![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to strobj.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2000 / builtin|
Return to strobj.c CVS log | Up to [local] / OpenXM_contrib2 / asir2000 / builtin |
1.6 noro 1: /*
2: * Copyright (c) 1994-2000 FUJITSU LABORATORIES LIMITED
3: * All rights reserved.
4: *
5: * FUJITSU LABORATORIES LIMITED ("FLL") hereby grants you a limited,
6: * non-exclusive and royalty-free license to use, copy, modify and
7: * redistribute, solely for non-commercial and non-profit purposes, the
8: * computer program, "Risa/Asir" ("SOFTWARE"), subject to the terms and
9: * conditions of this Agreement. For the avoidance of doubt, you acquire
10: * only a limited right to use the SOFTWARE hereunder, and FLL or any
11: * third party developer retains all rights, including but not limited to
12: * copyrights, in and to the SOFTWARE.
13: *
14: * (1) FLL does not grant you a license in any way for commercial
15: * purposes. You may use the SOFTWARE only for non-commercial and
16: * non-profit purposes only, such as academic, research and internal
17: * business use.
18: * (2) The SOFTWARE is protected by the Copyright Law of Japan and
19: * international copyright treaties. If you make copies of the SOFTWARE,
20: * with or without modification, as permitted hereunder, you shall affix
21: * to all such copies of the SOFTWARE the above copyright notice.
22: * (3) An explicit reference to this SOFTWARE and its copyright owner
23: * shall be made on your publication or presentation in any form of the
24: * results obtained by use of the SOFTWARE.
25: * (4) In the event that you modify the SOFTWARE, you shall notify FLL by
1.7 noro 26: * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.6 noro 27: * for such modification or the source code of the modified part of the
28: * SOFTWARE.
29: *
30: * THE SOFTWARE IS PROVIDED AS IS WITHOUT ANY WARRANTY OF ANY KIND. FLL
31: * MAKES ABSOLUTELY NO WARRANTIES, EXPRESSED, IMPLIED OR STATUTORY, AND
32: * EXPRESSLY DISCLAIMS ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS
33: * FOR A PARTICULAR PURPOSE OR NONINFRINGEMENT OF THIRD PARTIES'
34: * RIGHTS. NO FLL DEALER, AGENT, EMPLOYEES IS AUTHORIZED TO MAKE ANY
35: * MODIFICATIONS, EXTENSIONS, OR ADDITIONS TO THIS WARRANTY.
36: * UNDER NO CIRCUMSTANCES AND UNDER NO LEGAL THEORY, TORT, CONTRACT,
37: * OR OTHERWISE, SHALL FLL BE LIABLE TO YOU OR ANY OTHER PERSON FOR ANY
38: * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, PUNITIVE OR CONSEQUENTIAL
39: * DAMAGES OF ANY CHARACTER, INCLUDING, WITHOUT LIMITATION, DAMAGES
40: * ARISING OUT OF OR RELATING TO THE SOFTWARE OR THIS AGREEMENT, DAMAGES
41: * FOR LOSS OF GOODWILL, WORK STOPPAGE, OR LOSS OF DATA, OR FOR ANY
42: * DAMAGES, EVEN IF FLL SHALL HAVE BEEN INFORMED OF THE POSSIBILITY OF
43: * SUCH DAMAGES, OR FOR ANY CLAIM BY ANY OTHER PARTY. EVEN IF A PART
44: * OF THE SOFTWARE HAS BEEN DEVELOPED BY A THIRD PARTY, THE THIRD PARTY
45: * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
46: * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
47: *
1.39 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/strobj.c,v 1.38 2004/03/11 03:39:39 noro Exp $
1.6 noro 49: */
1.1 noro 50: #include "ca.h"
51: #include "parse.h"
52: #include "ctype.h"
1.10 ohara 53: #if defined(PARI)
1.1 noro 54: #include "genpari.h"
1.11 saito 55: # if !(PARI_VERSION_CODE > 131588)
1.1 noro 56: extern jmp_buf environnement;
1.11 saito 57: # endif
1.1 noro 58: #endif
1.5 noro 59: #include <string.h>
60:
1.18 noro 61: struct TeXSymbol {
62: char *text;
63: char *symbol;
64: };
65:
1.1 noro 66: extern char *parse_strp;
67:
68: void Prtostr(), Pstrtov(), Peval_str();
1.3 noro 69: void Pstrtoascii(), Pasciitostr();
1.5 noro 70: void Pstr_len(), Pstr_chr(), Psub_str();
1.14 noro 71: void Pwrite_to_tb();
72: void Ptb_to_string();
73: void Pclear_tb();
74: void Pstring_to_tb();
75: void Pquotetotex_tb();
76: void Pquotetotex();
1.24 noro 77: void Pquotetotex_env();
1.14 noro 78: void fnodetotex_tb(FNODE f,TB tb);
79: char *symbol_name(char *name);
1.28 noro 80: char *conv_rule(char *name);
1.38 noro 81: char *conv_subs(char *name);
1.28 noro 82: char *call_convfunc(char *name);
1.14 noro 83: void tb_to_string(TB tb,STRING *rp);
84: void fnodenodetotex_tb(NODE n,TB tb);
85: void fargstotex_tb(char *opname,FNODE f,TB tb);
1.35 noro 86: int top_is_minus(FNODE f);
1.1 noro 87:
88: struct ftab str_tab[] = {
89: {"rtostr",Prtostr,1},
90: {"strtov",Pstrtov,1},
91: {"eval_str",Peval_str,1},
1.3 noro 92: {"strtoascii",Pstrtoascii,1},
93: {"asciitostr",Pasciitostr,1},
1.5 noro 94: {"str_len",Pstr_len,1},
95: {"str_chr",Pstr_chr,3},
96: {"sub_str",Psub_str,3},
1.14 noro 97: {"write_to_tb",Pwrite_to_tb,2},
98: {"clear_tb",Pclear_tb,1},
99: {"tb_to_string",Ptb_to_string,1},
100: {"string_to_tb",Pstring_to_tb,1},
101: {"quotetotex_tb",Pquotetotex_tb,2},
102: {"quotetotex",Pquotetotex,1},
1.24 noro 103: {"quotetotex_env",Pquotetotex_env,-99999999},
1.1 noro 104: {0,0,0},
105: };
1.13 noro 106:
1.14 noro 107: void write_tb(char *s,TB tb)
108: {
109: if ( tb->next == tb->size ) {
110: tb->size *= 2;
111: tb->body = (char **)REALLOC(tb->body,tb->size*sizeof(char *));
112: }
113: tb->body[tb->next] = s;
114: tb->next++;
115: }
1.13 noro 116:
1.18 noro 117: int register_symbol_table(Obj arg);
118: int register_conv_rule(Obj arg);
1.38 noro 119: int register_conv_func(Obj arg);
1.23 noro 120: int register_dp_vars(Obj arg);
1.25 noro 121: int register_dp_vars_prefix(Obj arg);
1.31 noro 122: int register_dp_vars_hweyl(Obj arg);
1.27 noro 123: int register_show_lt(Obj arg);
1.18 noro 124: static struct TeXSymbol *user_texsymbol;
1.23 noro 125: static char **dp_vars;
1.25 noro 126: static int dp_vars_len;
127: static char *dp_vars_prefix;
1.27 noro 128: static int show_lt;
1.26 noro 129: static FUNC convfunc;
1.27 noro 130: static int is_lt;
1.28 noro 131: static int conv_flag;
1.31 noro 132: static int dp_vars_hweyl;
1.28 noro 133:
1.38 noro 134: #define CONV_TABLE (1U<<0)
135: #define CONV_SUBS (1U<<1)
136: #define CONV_DMODE (1U<<2)
1.18 noro 137:
138: static struct {
139: char *name;
140: Obj value;
141: int (*reg)();
142: } qtot_env[] = {
143: {"symbol_table",0,register_symbol_table},
144: {"conv_rule",0,register_conv_rule},
1.38 noro 145: {"conv_func",0,register_conv_func},
1.23 noro 146: {"dp_vars",0,register_dp_vars},
1.25 noro 147: {"dp_vars_prefix",0,register_dp_vars_prefix},
1.31 noro 148: {"dp_vars_hweyl",0,register_dp_vars_hweyl},
1.27 noro 149: {"show_lt",0,register_show_lt},
1.18 noro 150: {0,0,0},
151: };
152:
1.20 noro 153: #define PARTIAL "\\partial"
1.28 noro 154:
155: char *conv_rule(char *name)
156: {
157: char *body,*r;
158:
1.38 noro 159: if ( convfunc )
160: name = call_convfunc(name);
1.28 noro 161: if ( conv_flag & CONV_DMODE ) {
162: if ( *name == 'd' ) {
1.38 noro 163: body = conv_flag&CONV_SUBS?conv_subs(name+1):symbol_name(name+1);
1.39 ! noro 164: if ( !body ) {
! 165: r = MALLOC_ATOMIC((strlen(PARTIAL)+1)*sizeof(char));
! 166: strcpy(r,PARTIAL);
! 167: } else {
! 168: r = MALLOC_ATOMIC((strlen(PARTIAL)+strlen(body)+5)
! 169: *sizeof(char));
! 170: sprintf(r,strlen(body)==1?"{%s}_%s":"{%s}_{%s}",PARTIAL,body);
! 171: }
1.28 noro 172: return r;
1.38 noro 173: } else
174: return conv_flag&CONV_SUBS?conv_subs(name):symbol_name(name);
175: } else
176: return conv_flag&CONV_SUBS?conv_subs(name):symbol_name(name);
1.28 noro 177: }
178:
1.38 noro 179: char *conv_subs(char *name)
1.19 noro 180: {
1.29 noro 181: int i,j,k,len,clen,slen,start,level;
1.32 noro 182: char *buf,*head,*r,*h,*brace;
1.28 noro 183: char **subs;
184:
185: len = strlen(name);
1.37 noro 186: if ( !len ) return 0;
1.28 noro 187: subs = (char **)ALLOCA(len*sizeof(char* ));
1.32 noro 188: for ( i = 0, j = 0, start = i; ; j++ ) {
1.33 noro 189: while ( (i < len) &&
190: (name[i] == ' ' || name[i] == '_' || name[i] == ',') ) i++;
1.32 noro 191: start = i;
1.28 noro 192: if ( i == len ) break;
1.29 noro 193: if ( name[i] == '{' ) {
194: for ( level = 1, i++; i < len && level; i++ ) {
195: if ( name[i] == '{' ) level++;
196: else if ( name[i] == '}' ) level--;
197: }
1.32 noro 198: slen = i-start;
1.37 noro 199: if ( slen >= 3 ) {
200: brace = (char *)ALLOCA((slen+1)*sizeof(char));
201: strncpy(brace,name+start+1,slen-2);
202: brace[slen-2] = 0;
1.38 noro 203: buf = conv_subs(brace);
1.37 noro 204: subs[j] = (char *)ALLOCA((strlen(buf)+3)*sizeof(char));
1.38 noro 205: if ( strlen(buf) == 1 )
206: strcpy(subs[j],buf);
207: else
208: sprintf(subs[j],"{%s}",buf);
1.37 noro 209: } else
210: subs[j] = "{}";
1.32 noro 211: } else {
212: if ( isdigit(name[i]) )
213: while ( i < len && isdigit(name[i]) ) i++;
214: else
215: while ( i < len && (isalpha(name[i]) || name[i] == '\\') ) i++;
216: slen = i-start;
217: buf = (char *)ALLOCA((slen+1)*sizeof(char));
218: strncpy(buf,name+start,slen); buf[slen] = 0;
219: subs[j] = symbol_name(buf);
220: }
1.28 noro 221: }
1.32 noro 222: for ( k = 0, clen = 0; k < j; k++ ) clen += strlen(subs[k]);
223: /* {subs(0)}_{{subs(1)},...,{subs(j-1)}} => {}:j+1 _:1 ,:j-2 */
224: h = r = MALLOC_ATOMIC((clen+(j+1)*2+1+(j-2)+1)*sizeof(char));
225: if ( j == 1 )
226: sprintf(h,"{%s}",subs[0]);
1.28 noro 227: else {
1.38 noro 228: sprintf(h,"{%s}_{%s",subs[0],subs[1]);
1.28 noro 229: h += strlen(h);
1.32 noro 230: for ( k = 2; k < j; k++ ) {
1.38 noro 231: sprintf(h,",%s",subs[k]);
1.28 noro 232: h += strlen(h);
1.19 noro 233: }
1.28 noro 234: strcpy(h,"}");
1.20 noro 235: }
236: return r;
1.19 noro 237: }
238:
1.26 noro 239: char *call_convfunc(char *name)
240: {
241: STRING str,r;
242: NODE arg;
243:
244: MKSTR(str,name);
245: arg = mknode(1,str);
246: r = (STRING)bevalf(convfunc,arg);
247: if ( !r || OID(r) != O_STR )
248: error("call_convfunc : invalid result");
249: return BDY(r);
250: }
251:
1.18 noro 252: int register_symbol_table(Obj arg)
253: {
254: NODE n,t;
255: Obj b;
256: STRING a0,a1;
257: struct TeXSymbol *uts;
258: int i,len;
259:
260: /* check */
261: if ( !arg ) {
262: user_texsymbol = 0;
263: return 1;
264: }
265: if ( OID(arg) != O_LIST ) return 0;
266:
267: n = BDY((LIST)arg);
268: len = length(n);
269: uts = (struct TeXSymbol *)MALLOC((len+1)*sizeof(struct TeXSymbol));
270: for ( i = 0; n; n = NEXT(n), i++ ) {
271: b = (Obj)BDY(n);
272: if ( !b || OID(b) != O_LIST ) return 0;
273: t = BDY((LIST)b);
274: if ( !t || !NEXT(t) ) return 0;
275: a0 = (STRING)BDY(t);
276: a1 = (STRING)BDY(NEXT(t));
1.23 noro 277: if ( !a0 ) return 0;
278: if ( OID(a0) == O_STR )
279: uts[i].text = BDY(a0);
280: else if ( OID(a0) == O_P )
281: uts[i].text = NAME(VR((P)a0));
282: else
283: return 0;
284: if ( !a1 ) return 0;
285: if ( OID(a1) == O_STR )
286: uts[i].symbol = BDY(a1);
287: else if ( OID(a1) == O_P )
288: uts[i].symbol = NAME(VR((P)a1));
289: else
290: return 0;
1.18 noro 291: }
292: uts[i].text = 0;
293: uts[i].symbol = 0;
294: user_texsymbol = uts;
295: return 1;
296: }
297:
1.31 noro 298: int register_dp_vars_hweyl(Obj arg)
299: {
300: if ( INT(arg) ) {
301: dp_vars_hweyl = QTOS((Q)arg);
302: return 1;
303: } else return 0;
304: }
305:
1.27 noro 306: int register_show_lt(Obj arg)
307: {
308: if ( INT(arg) ) {
309: show_lt = QTOS((Q)arg);
310: return 1;
311: } else return 0;
312: }
1.26 noro 313:
1.18 noro 314: int register_conv_rule(Obj arg)
315: {
1.19 noro 316: if ( INT(arg) ) {
1.28 noro 317: conv_flag = QTOS((Q)arg);
318: convfunc = 0;
319: return 1;
1.38 noro 320: } else return 0;
321: }
322:
323: int register_conv_func(Obj arg)
324: {
325: if ( OID(arg) == O_P && (int)(VR((P)arg))->attr == V_SR ) {
1.26 noro 326: convfunc = (FUNC)(VR((P)arg)->priv);
327: /* f must be a function which takes single argument */
328: return 1;
1.19 noro 329: } else return 0;
1.18 noro 330: }
331:
1.23 noro 332: int register_dp_vars(Obj arg)
333: {
334: int l,i;
335: char **r;
336: NODE n;
337: STRING a;
338:
339: if ( !arg ) {
340: dp_vars = 0;
341: dp_vars_len = 0;
1.25 noro 342: return 1;
1.23 noro 343: } else if ( OID(arg) != O_LIST )
344: return 0;
345: else {
346: n = BDY((LIST)arg);
347: l = length(n);
348: r = (char **)MALLOC_ATOMIC(l*sizeof(char *));
349: for ( i = 0; i < l; i++, n = NEXT(n) ) {
350: a = (STRING)BDY(n);
351: if ( !a ) return 0;
352: if ( OID(a) == O_STR )
353: r[i] = BDY(a);
354: else if ( OID(a) == O_P )
355: r[i] = NAME(VR((P)a));
356: else
357: return 0;
358: }
359: dp_vars = r;
360: dp_vars_len = l;
361: return 1;
362: }
363: }
364:
1.25 noro 365: int register_dp_vars_prefix(Obj arg)
366: {
367: if ( !arg ) {
368: dp_vars_prefix = 0;
369: return 1;
370: } else if ( OID(arg) == O_STR ) {
371: dp_vars_prefix = BDY((STRING)arg);
372: return 1;
373: } else if ( OID(arg) == O_P ) {
374: dp_vars_prefix = NAME(VR((P)arg));
375: return 1;
376: } else return 0;
377: }
378:
1.24 noro 379: void Pquotetotex_env(NODE arg,Obj *rp)
1.18 noro 380: {
381: int ac,i;
382: char *name;
383: NODE n,n0;
384: STRING s;
385: LIST l;
386:
387: ac = argc(arg);
388: if ( !ac ) {
389: n0 = 0;
390: for ( i = 0; qtot_env[i].name; i++ ) {
391: NEXTNODE(n0,n); MKSTR(s,qtot_env[i].name); BDY(n) = (pointer)s;
392: NEXTNODE(n0,n); BDY(n) = (Q)qtot_env[i].value;
393: }
394: NEXT(n) = 0;
395: MKLIST(l,n0);
396: *rp = (Obj)l;
1.34 noro 397: } else if ( ac == 1 && !ARG0(arg) ) {
398: /* set to default */
399: for ( i = 0; qtot_env[i].name; i++ )
400: qtot_env[i].value = 0;
401: *rp = 0;
1.18 noro 402: } else if ( ac == 1 || ac == 2 ) {
1.24 noro 403: asir_assert(ARG0(arg),O_STR,"quotetotex_env");
1.18 noro 404: name = BDY((STRING)ARG0(arg));
405: for ( i = 0; qtot_env[i].name; i++ )
406: if ( !strcmp(qtot_env[i].name,name) ) {
407: if ( ac == 2 ) {
408: if ( (qtot_env[i].reg)((Obj)ARG1(arg)) )
409: qtot_env[i].value = (Obj)ARG1(arg);
410: else
1.24 noro 411: error("quotetotex_env : invalid argument");
1.18 noro 412: }
413: *rp = qtot_env[i].value;
414: return;
415: }
416: *rp = 0;
417: } else
418: *rp = 0;
419: }
420:
1.14 noro 421: void Pwrite_to_tb(NODE arg,Q *rp)
1.13 noro 422: {
423: int i;
1.16 noro 424: Obj obj;
425: TB tb;
1.13 noro 426:
1.14 noro 427: asir_assert(ARG1(arg),O_TB,"write_to_tb");
1.16 noro 428: obj = ARG0(arg);
429: if ( !obj )
430: write_tb("",ARG1(arg));
431: else if ( OID(obj) == O_STR )
432: write_tb(BDY((STRING)obj),ARG1(arg));
433: else if ( OID(obj) == O_TB ) {
434: tb = (TB)obj;
435: for ( i = 0; i < tb->next; i++ )
436: write_tb(tb->body[i],ARG1(arg));
437: }
1.14 noro 438: *rp = 0;
1.13 noro 439: }
440:
1.14 noro 441: void Pquotetotex(NODE arg,STRING *rp)
1.13 noro 442: {
1.14 noro 443: TB tb;
1.13 noro 444:
1.14 noro 445: NEWTB(tb);
1.27 noro 446: /* XXX for DP */
447: is_lt = 1;
1.14 noro 448: fnodetotex_tb(BDY((QUOTE)ARG0(arg)),tb);
449: tb_to_string(tb,rp);
1.13 noro 450: }
451:
1.14 noro 452: void Pquotetotex_tb(NODE arg,Q *rp)
1.13 noro 453: {
454: int i;
1.14 noro 455: TB tb;
1.13 noro 456:
1.14 noro 457: asir_assert(ARG1(arg),O_TB,"quotetotex_tb");
1.27 noro 458: /* XXX for DP */
459: is_lt = 1;
1.14 noro 460: fnodetotex_tb(BDY((QUOTE)ARG0(arg)),ARG1(arg));
1.13 noro 461: *rp = 0;
462: }
463:
1.14 noro 464: void Pstring_to_tb(NODE arg,TB *rp)
465: {
466: TB tb;
467:
468: asir_assert(ARG0(arg),O_STR,"string_to_tb");
469: NEWTB(tb);
470: tb->body[0] = BDY((STRING)ARG0(arg));
471: tb->next++;
472: *rp = tb;
473: }
474:
475: void Ptb_to_string(NODE arg,STRING *rp)
476: {
477: TB tb;
478:
479: asir_assert(ARG0(arg),O_TB,"tb_to_string");
480: tb = (TB)ARG0(arg);
481: tb_to_string(tb,rp);
482: }
483:
484: void tb_to_string(TB tb,STRING *rp)
1.13 noro 485: {
1.14 noro 486: int j,len;
1.13 noro 487: char *all,*p,*q;
488:
1.14 noro 489: for ( j = 0, len = 0; j < tb->next; j++ )
490: len += strlen(tb->body[j]);
491: all = (char *)MALLOC_ATOMIC((len+1)*sizeof(char));
492: for ( j = 0, p = all; j < tb->next; j++ )
493: for ( q = tb->body[j]; *q; *p++ = *q++ );
494: *p = 0;
495: MKSTR(*rp,all);
496: }
497:
498: void Pclear_tb(NODE arg,Q *rp)
499: {
500: TB tb;
501: int j;
502:
503: asir_assert(ARG0(arg),O_TB,"clear_tb");
504: tb = (TB)ARG0(arg);
505: for ( j = 0; j < tb->next; j++ )
506: tb->body[j] = 0;
507: tb->next = 0;
508: *rp = 0;
1.13 noro 509: }
1.5 noro 510:
511: void Pstr_len(arg,rp)
512: NODE arg;
513: Q *rp;
514: {
1.16 noro 515: Obj obj;
516: TB tb;
517: int r,i;
1.5 noro 518:
1.16 noro 519: obj = (Obj)ARG0(arg);
520: if ( !obj || (OID(obj) != O_STR && OID(obj) != O_TB) )
521: error("str_len : invalid argument");
522: if ( OID(obj) == O_STR)
523: r = strlen(BDY((STRING)obj));
524: else if ( OID(obj) == O_TB ) {
525: tb = (TB)obj;
526: for ( r = i = 0; i < tb->next; i++ )
527: r += strlen(tb->body[i]);
528: }
1.5 noro 529: STOQ(r,*rp);
530: }
531:
532: void Pstr_chr(arg,rp)
533: NODE arg;
534: Q *rp;
535: {
536: STRING str,terminator;
537: Q start;
538: char *p,*ind;
539: int chr,spos,r;
540:
541: str = (STRING)ARG0(arg);
542: start = (Q)ARG1(arg);
543: terminator = (STRING)ARG2(arg);
544: asir_assert(str,O_STR,"str_chr");
545: asir_assert(start,O_N,"str_chr");
546: asir_assert(terminator,O_STR,"str_chr");
547: p = BDY(str);
548: spos = QTOS(start);
549: chr = BDY(terminator)[0];
1.8 noro 550: if ( spos > (int)strlen(p) )
1.5 noro 551: r = -1;
552: else {
553: ind = strchr(p+spos,chr);
554: if ( ind )
555: r = ind-p;
556: else
557: r = -1;
558: }
559: STOQ(r,*rp);
560: }
561:
562: void Psub_str(arg,rp)
563: NODE arg;
564: STRING *rp;
565: {
566: STRING str;
567: Q head,tail;
568: char *p,*r;
569: int spos,epos,len;
570:
571: str = (STRING)ARG0(arg);
572: head = (Q)ARG1(arg);
573: tail = (Q)ARG2(arg);
574: asir_assert(str,O_STR,"sub_str");
575: asir_assert(head,O_N,"sub_str");
576: asir_assert(tail,O_N,"sub_str");
577: p = BDY(str);
578: spos = QTOS(head);
579: epos = QTOS(tail);
580: len = strlen(p);
581: if ( (spos >= len) || (epos < spos) ) {
582: *rp = 0; return;
583: }
584: if ( epos >= len )
585: epos = len-1;
586: len = epos-spos+1;
587: r = (char *)MALLOC(len+1);
588: strncpy(r,p+spos,len);
589: r[len] = 0;
590: MKSTR(*rp,r);
591: }
1.3 noro 592:
593: void Pstrtoascii(arg,rp)
594: NODE arg;
595: LIST *rp;
596: {
597: STRING str;
598: unsigned char *p;
599: int len,i;
600: NODE n,n1;
601: Q q;
602:
603: str = (STRING)ARG0(arg);
604: asir_assert(str,O_STR,"strtoascii");
605: p = BDY(str);
606: len = strlen(p);
607: for ( i = len-1, n = 0; i >= 0; i-- ) {
608: UTOQ((unsigned int)p[i],q);
609: MKNODE(n1,q,n);
610: n = n1;
611: }
612: MKLIST(*rp,n);
613: }
614:
615: void Pasciitostr(arg,rp)
616: NODE arg;
617: STRING *rp;
618: {
619: LIST list;
620: unsigned char *p;
621: int len,i,j;
622: NODE n;
623: Q q;
624:
625: list = (LIST)ARG0(arg);
626: asir_assert(list,O_LIST,"asciitostr");
627: n = BDY(list);
628: len = length(n);
629: p = MALLOC_ATOMIC(len+1);
630: for ( i = 0; i < len; i++, n = NEXT(n) ) {
631: q = (Q)BDY(n);
632: asir_assert(q,O_N,"asciitostr");
633: j = QTOS(q);
1.4 noro 634: if ( j >= 256 || j <= 0 )
1.3 noro 635: error("asciitostr : argument out of range");
636: p[i] = j;
637: }
638: p[i] = 0;
639: MKSTR(*rp,(char *)p);
640: }
1.1 noro 641:
642: void Peval_str(arg,rp)
643: NODE arg;
644: Obj *rp;
645: {
646: FNODE fnode;
647: char *cmd;
1.10 ohara 648: #if defined(PARI)
1.8 noro 649: void recover(int);
650:
1.1 noro 651: recover(0);
1.11 saito 652: # if !(PARI_VERSION_CODE > 131588)
1.1 noro 653: if ( setjmp(environnement) ) {
654: avma = top; recover(1);
655: resetenv("");
656: }
1.11 saito 657: # endif
1.1 noro 658: #endif
659: cmd = BDY((STRING)ARG0(arg));
1.9 noro 660: exprparse_create_var(0,cmd,&fnode);
1.1 noro 661: *rp = eval(fnode);
662: }
663:
664: void Prtostr(arg,rp)
665: NODE arg;
666: STRING *rp;
667: {
668: char *b;
669: int len;
670:
1.2 noro 671: len = estimate_length(CO,ARG0(arg));
1.12 noro 672: b = (char *)MALLOC_ATOMIC(len+1);
1.1 noro 673: soutput_init(b);
674: sprintexpr(CO,ARG0(arg));
675: MKSTR(*rp,b);
676: }
677:
678: void Pstrtov(arg,rp)
679: NODE arg;
680: P *rp;
681: {
1.8 noro 682: char *p;
1.1 noro 683:
684: p = BDY((STRING)ARG0(arg));
685: #if 0
686: if ( !islower(*p) )
687: *rp = 0;
688: else {
689: for ( t = p+1; t && (isalnum(*t) || *t == '_'); t++ );
690: if ( *t )
691: *rp = 0;
692: else
693: makevar(p,rp);
694: }
695: #else
696: makevar(p,rp);
697: #endif
1.14 noro 698: }
699:
1.15 noro 700: static struct TeXSymbol texsymbol[] = {
701: {"sin","\\sin"},
702: {"cos","\\cos"},
703: {"tan","\\tan"},
704: {"sinh","\\sinh"},
705: {"cosh","\\cosh"},
706: {"tanh","\\tanh"},
707: {"exp","\\exp"},
708: {"log","\\log"},
709:
710: /* Greek Letters (lower case) */
711: {"alpha","\\alpha"},
712: {"beta","\\beta"},
713: {"gamma","\\gamma"},
714: {"delta","\\delta"},
715: {"epsilon","\\epsilon"},
716: {"varepsilon","\\varepsilon"},
717: {"zeta","\\zeta"},
718: {"eta","\\eta"},
719: {"theta","\\theta"},
720: {"vartheta","\\vartheta"},
721: {"iota","\\iota"},
722: {"kappa","\\kappa"},
723: {"lambda","\\lambda"},
724: {"mu","\\mu"},
725: {"nu","\\nu"},
726: {"xi","\\xi"},
727: {"pi","\\pi"},
728: {"varpi","\\varpi"},
729: {"rho","\\rho"},
730: {"sigma","\\sigma"},
731: {"varsigma","\\varsigma"},
732: {"tau","\\tau"},
733: {"upsilon","\\upsilon"},
734: {"phi","\\phi"},
735: {"varphi","\\varphi"},
736: {"chi","\\chi"},
737: {"omega","\\omega"},
738:
739: /* Greek Letters, (upper case) */
740: {"ggamma","\\Gamma"},
741: {"ddelta","\\Delta"},
742: {"ttheta","\\Theta"},
743: {"llambda","\\Lambda"},
744: {"xxi","\\Xi"},
745: {"ppi","\\Pi"},
746: {"ssigma","\\Sigma"},
747: {"uupsilon","\\Upsilon"},
748: {"pphi","\\Phi"},
749: {"ppsi","\\Psi"},
750: {"oomega","\\Omega"},
751:
752: /* Our own mathematical functions */
753: {"algebra_tensor","\\otimes"},
754: {"base_where","{\\rm \\ where \\ }"},
755: /* Mathematical constants */
756: {"c_pi","\\pi"},
757: {"c_i","\\sqrt{-1}"},
758:
759: /* Temporary */
760: {0,0}
761: };
762:
1.14 noro 763: char *symbol_name(char *name)
764: {
1.15 noro 765: int i;
766:
1.38 noro 767: if ( !(conv_flag & CONV_TABLE) )
768: return name;
769:
1.18 noro 770: if ( user_texsymbol )
771: for ( i = 0; user_texsymbol[i].text; i++ )
772: if ( !strcmp(user_texsymbol[i].text,name) )
773: return user_texsymbol[i].symbol;
1.15 noro 774: for ( i = 0; texsymbol[i].text; i++ )
775: if ( !strcmp(texsymbol[i].text,name) )
776: return texsymbol[i].symbol;
1.28 noro 777: return name;
1.14 noro 778: }
779:
780: void fnodetotex_tb(FNODE f,TB tb)
781: {
782: NODE n,t,t0;
1.38 noro 783: char vname[BUFSIZ],prefix[BUFSIZ];
784: char *opname,*vname_conv,*prefix_conv;
1.14 noro 785: Obj obj;
1.31 noro 786: int i,len,allzero,elen,elen2;
1.17 noro 787: FNODE fi,f2;
1.14 noro 788:
789: write_tb(" ",tb);
790: if ( !f ) {
791: write_tb("0",tb);
792: return;
793: }
794: switch ( f->id ) {
795: /* unary operators */
1.23 noro 796: case I_NOT:
797: write_tb("\\neg (",tb);
798: fnodetotex_tb((FNODE)FA0(f),tb);
799: write_tb(")",tb);
800: break;
801: case I_PAREN:
802: write_tb("(",tb);
803: fnodetotex_tb((FNODE)FA0(f),tb);
804: write_tb(")",tb);
805: break;
806: case I_MINUS:
807: write_tb("-",tb);
808: fnodetotex_tb((FNODE)FA0(f),tb);
809: break;
810:
811: /* binary operators */
812: /* arg list */
813: /* I_AND, I_OR => FA0(f), FA1(f) */
814: /* otherwise => FA1(f), FA2(f) */
815: case I_BOP:
816: opname = ((ARF)FA0(f))->name;
817: if ( !strcmp(opname,"+") ) {
818: fnodetotex_tb((FNODE)FA1(f),tb);
1.35 noro 819: if ( !top_is_minus((FNODE)FA2(f)) ) write_tb(opname,tb);
1.23 noro 820: fnodetotex_tb((FNODE)FA2(f),tb);
821: } else if ( !strcmp(opname,"-") ) {
822: if ( FA1(f) ) fnodetotex_tb((FNODE)FA1(f),tb);
823: write_tb(opname,tb);
824: fnodetotex_tb((FNODE)FA2(f),tb);
825: } else if ( !strcmp(opname,"*") ) {
826: fnodetotex_tb((FNODE)FA1(f),tb);
827: write_tb(" ",tb);
828: /* XXX special care for DP */
829: f2 = (FNODE)FA2(f);
830: if ( f2->id == I_EV ) {
831: n = (NODE)FA0(f2);
832: for ( i = 0; n; n = NEXT(n), i++ ) {
833: fi = (FNODE)BDY(n);
834: if ( fi->id != I_FORMULA || FA0(fi) )
835: break;
836: }
837: if ( n )
838: fnodetotex_tb((FNODE)FA2(f),tb);
839: } else
840: fnodetotex_tb((FNODE)FA2(f),tb);
841: } else if ( !strcmp(opname,"/") ) {
842: write_tb("\\frac{",tb);
843: fnodetotex_tb((FNODE)FA1(f),tb);
844: write_tb("} {",tb);
845: fnodetotex_tb((FNODE)FA2(f),tb);
846: write_tb("}",tb);
847: } else if ( !strcmp(opname,"^") ) {
848: fnodetotex_tb((FNODE)FA1(f),tb);
849: write_tb("^{",tb);
850: fnodetotex_tb((FNODE)FA2(f),tb);
851: write_tb("} ",tb);
852: } else if ( !strcmp(opname,"%") ) {
853: fnodetotex_tb((FNODE)FA1(f),tb);
854: write_tb(" {\\rm mod}\\, ",tb);
855: fnodetotex_tb((FNODE)FA2(f),tb);
856: } else
857: error("invalid binary operator");
858: break;
859:
860: case I_COP:
861: switch( (cid)FA0(f) ) {
862: case C_EQ:
863: fnodetotex_tb((FNODE)FA1(f),tb);
864: write_tb(" = ",tb);
865: fnodetotex_tb((FNODE)FA2(f),tb);
866: break;
867: case C_NE:
868: fnodetotex_tb((FNODE)FA1(f),tb);
869: write_tb(" \\neq ",tb);
870: fnodetotex_tb((FNODE)FA2(f),tb);
871: break;
872: case C_GT:
873: fnodetotex_tb((FNODE)FA1(f),tb);
874: write_tb(" \\gt ",tb);
875: fnodetotex_tb((FNODE)FA2(f),tb);
876: break;
877: case C_LT:
878: fnodetotex_tb((FNODE)FA1(f),tb);
879: write_tb(" \\lt ",tb);
880: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 881: break;
1.23 noro 882: case C_GE:
883: fnodetotex_tb((FNODE)FA1(f),tb);
884: write_tb(" \\geq ",tb);
885: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 886: break;
1.23 noro 887: case C_LE:
888: fnodetotex_tb((FNODE)FA1(f),tb);
889: write_tb(" \\leq ",tb);
890: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 891: break;
892: }
893: break;
894:
1.23 noro 895: case I_LOP:
896: switch( (lid)FA0(f) ) {
897: case L_EQ:
898: fnodetotex_tb((FNODE)FA1(f),tb);
899: write_tb(" = ",tb);
900: fnodetotex_tb((FNODE)FA2(f),tb);
901: break;
902: case L_NE:
903: fnodetotex_tb((FNODE)FA1(f),tb);
904: write_tb(" \\neq ",tb);
905: fnodetotex_tb((FNODE)FA2(f),tb);
906: break;
907: case L_GT:
908: fnodetotex_tb((FNODE)FA1(f),tb);
909: write_tb(" \\gt ",tb);
910: fnodetotex_tb((FNODE)FA2(f),tb);
911: break;
912: case L_LT:
913: fnodetotex_tb((FNODE)FA1(f),tb);
914: write_tb(" \\lt ",tb);
915: fnodetotex_tb((FNODE)FA2(f),tb);
916: break;
917: case L_GE:
918: fnodetotex_tb((FNODE)FA1(f),tb);
919: write_tb(" \\geq ",tb);
920: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 921: break;
1.23 noro 922: case L_LE:
923: fnodetotex_tb((FNODE)FA1(f),tb);
924: write_tb(" \\leq ",tb);
925: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 926: break;
1.23 noro 927: case L_AND:
928: fnodetotex_tb((FNODE)FA1(f),tb);
1.14 noro 929: write_tb(" {\\rm \\ and\\ } ",tb);
1.23 noro 930: fnodetotex_tb((FNODE)FA2(f),tb);
931: break;
932: case L_OR:
1.14 noro 933: fnodetotex_tb((FNODE)FA1(f),tb);
1.23 noro 934: write_tb(" {\\rm \\ or\\ } ",tb);
935: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 936: break;
1.23 noro 937: case L_NOT:
938: /* XXX : L_NOT is a unary operator */
939: write_tb("\\neg (",tb);
1.14 noro 940: fnodetotex_tb((FNODE)FA1(f),tb);
1.23 noro 941: write_tb(")",tb);
942: return;
1.14 noro 943: }
944: break;
945:
1.23 noro 946: case I_AND:
947: fnodetotex_tb((FNODE)FA0(f),tb);
948: write_tb(" {\\rm \\ and\\ } ",tb);
949: fnodetotex_tb((FNODE)FA1(f),tb);
950: break;
951:
952: case I_OR:
953: fnodetotex_tb((FNODE)FA0(f),tb);
954: write_tb(" {\\rm \\ or\\ } ",tb);
955: fnodetotex_tb((FNODE)FA1(f),tb);
956: break;
957:
1.14 noro 958: /* ternary operators */
959: case I_CE:
960: error("fnodetotex_tb : not implemented yet");
961: break;
962:
963: /* lists */
964: case I_LIST:
965: write_tb(" [ ",tb);
966: n = (NODE)FA0(f);
967: fnodenodetotex_tb(n,tb);
968: write_tb("]",tb);
969: break;
970:
971: /* function */
1.23 noro 972: case I_FUNC:
1.28 noro 973: opname = conv_rule(((FUNC)FA0(f))->name);
1.23 noro 974: write_tb(opname,tb);
975: write_tb("(",tb);
976: fargstotex_tb(opname,FA1(f),tb);
977: write_tb(")",tb);
978: break;
979:
980: /* XXX */
981: case I_CAR:
1.28 noro 982: opname = conv_rule("car");
1.23 noro 983: write_tb(opname,tb);
984: write_tb("(",tb);
985: fargstotex_tb(opname,FA0(f),tb);
986: write_tb(")",tb);
987: break;
988:
989: case I_CDR:
1.28 noro 990: opname = conv_rule("cdr");
1.23 noro 991: write_tb(opname,tb);
992: write_tb("(",tb);
993: fargstotex_tb(opname,FA0(f),tb);
994: write_tb(")",tb);
995: break;
996:
997: /* exponent vector */
998: case I_EV:
999: n = (NODE)FA0(f);
1.31 noro 1000: if ( dp_vars_hweyl ) {
1001: elen = length(n);
1002: elen2 = elen>>1;
1003: elen = elen2<<1;
1004: }
1.23 noro 1005: allzero = 1;
1.27 noro 1006: if ( show_lt && is_lt )
1007: write_tb("\\underline{",tb);
1.23 noro 1008: for ( t0 = 0, i = 0; n; n = NEXT(n), i++ ) {
1009: fi = (FNODE)BDY(n);
1010: if ( fi->id == I_FORMULA && !FA0(fi) ) continue;
1011: allzero = 0;
1.38 noro 1012: if ( dp_vars && i < dp_vars_len ) {
1013: strcpy(vname,dp_vars[i]);
1014: vname_conv = conv_rule(vname);
1015: } else {
1016: if ( dp_vars_hweyl ) {
1017: if ( i < elen2 )
1018: strcpy(prefix,dp_vars_prefix?dp_vars_prefix:"x");
1019: else if ( i < elen )
1020: strcpy(prefix,"\\partial");
1.31 noro 1021: else
1.38 noro 1022: strcpy(prefix,"h");
1023: } else
1024: strcpy(prefix,dp_vars_prefix?dp_vars_prefix:"x");
1025: prefix_conv = conv_rule(prefix);
1026: vname_conv = (char *)ALLOCA(strlen(prefix_conv)+50);
1027: if ( i < 10 )
1028: sprintf(vname_conv,"%s_%d",prefix_conv,i);
1.31 noro 1029: else
1.38 noro 1030: sprintf(vname_conv,"%s_{%d}",prefix_conv,i);
1031: }
1.23 noro 1032: if ( fi->id == I_FORMULA && UNIQ(FA0(fi)) ) {
1033: len = strlen(vname_conv);
1034: opname = MALLOC_ATOMIC(len+2);
1035: sprintf(opname,"%s ",vname_conv);
1.14 noro 1036: write_tb(opname,tb);
1.23 noro 1037: } else {
1038: len = strlen(vname_conv);
1039: /* 2: ^{ */
1040: opname = MALLOC_ATOMIC(len+1+2);
1041: sprintf(opname,"%s^{",vname_conv);
1.14 noro 1042: write_tb(opname,tb);
1.23 noro 1043: fnodetotex_tb((FNODE)BDY(n),tb);
1044: write_tb("} ",tb);
1045: }
1.14 noro 1046: }
1.23 noro 1047: /* XXX */
1048: if ( allzero )
1049: write_tb(" 1 ",tb);
1.27 noro 1050: if ( show_lt && is_lt ) {
1051: write_tb("}",tb);
1052: is_lt = 0;
1053: }
1.14 noro 1054: break;
1055:
1.23 noro 1056: /* string */
1.14 noro 1057: case I_STR:
1058: write_tb((char *)FA0(f),tb);
1059: break;
1060:
1.23 noro 1061: /* internal object */
1.14 noro 1062: case I_FORMULA:
1063: obj = (Obj)FA0(f);
1064: if ( obj && OID(obj) == O_P ) {
1.28 noro 1065: opname = conv_rule(VR((P)obj)->name);
1.14 noro 1066: } else {
1067: len = estimate_length(CO,obj);
1068: opname = (char *)MALLOC_ATOMIC(len+1);
1069: soutput_init(opname);
1070: sprintexpr(CO,obj);
1071: }
1072: write_tb(opname,tb);
1073: break;
1074:
1.23 noro 1075: /* program variable */
1.14 noro 1076: case I_PVAR:
1077: if ( FA1(f) )
1078: error("fnodetotex_tb : not implemented yet");
1079: GETPVNAME(FA0(f),opname);
1080: write_tb(opname,tb);
1081: break;
1082:
1083: default:
1084: error("fnodetotex_tb : not implemented yet");
1085: }
1086: }
1087:
1088: void fnodenodetotex_tb(NODE n,TB tb)
1089: {
1090: for ( ; n; n = NEXT(n) ) {
1.27 noro 1091: is_lt = 1;
1.14 noro 1092: fnodetotex_tb((FNODE)BDY(n),tb);
1093: if ( NEXT(n) ) write_tb(", ",tb);
1094: }
1095: }
1096:
1097: void fargstotex_tb(char *name,FNODE f,TB tb)
1098: {
1099: NODE n;
1100:
1101: if ( !strcmp(name,"matrix") ) {
1102: error("fargstotex_tb : not implemented yet");
1103: } else if ( !strcmp(name,"vector") ) {
1104: error("fargstotex_tb : not implemented yet");
1105: } else {
1106: if ( f->id == I_LIST ) {
1107: n = (NODE)FA0(f);
1108: fnodenodetotex_tb(n,tb);
1109: } else
1110: fnodetotex_tb(f,tb);
1.35 noro 1111: }
1112: }
1113:
1114: int top_is_minus(FNODE f)
1115: {
1116: char *opname;
1117: int len;
1118: Obj obj;
1119:
1120: if ( !f )
1121: return 0;
1122: switch ( f->id ) {
1123: case I_MINUS:
1124: return 1;
1125: case I_BOP:
1126: opname = ((ARF)FA0(f))->name;
1127: switch ( opname[0] ) {
1128: case '+': case '*': case '/': case '^': case '%':
1129: return top_is_minus((FNODE)FA1(f));
1130: case '-':
1131: if ( FA1(f) )
1132: return top_is_minus((FNODE)FA1(f));
1133: else
1134: return 1;
1135: default:
1136: return 0;
1137: }
1138: break;
1139: case I_COP:
1140: return top_is_minus((FNODE)FA1(f));
1141: case I_LOP:
1142: if ( (lid)FA0(f) == L_NOT ) return 0;
1143: else return top_is_minus((FNODE)FA1(f));
1144: case I_AND: case I_OR:
1145: return top_is_minus((FNODE)FA0(f));
1146: case I_FORMULA:
1147: obj = (Obj)FA0(f);
1.36 noro 1148: if ( !obj )
1149: return 0;
1150: else {
1151: switch ( OID(obj) ) {
1152: case O_N:
1153: return mmono((P)obj);
1154: case O_P:
1155: /* must be a variable */
1156: opname = conv_rule(VR((P)obj)->name);
1157: return opname[0]=='-';
1158: default:
1159: /* ??? */
1160: len = estimate_length(CO,obj);
1161: opname = (char *)MALLOC_ATOMIC(len+1);
1162: soutput_init(opname);
1163: sprintexpr(CO,obj);
1164: return opname[0]=='-';
1165: }
1.35 noro 1166: }
1167: default:
1168: return 0;
1.14 noro 1169: }
1.1 noro 1170: }