![[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.36 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/strobj.c,v 1.35 2004/03/10 05:27:03 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);
81: char *conv_subscript(char *name);
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.23 noro 119: int register_dp_vars(Obj arg);
1.25 noro 120: int register_dp_vars_prefix(Obj arg);
1.31 noro 121: int register_dp_vars_hweyl(Obj arg);
1.27 noro 122: int register_show_lt(Obj arg);
1.18 noro 123: static struct TeXSymbol *user_texsymbol;
1.23 noro 124: static char **dp_vars;
1.25 noro 125: static int dp_vars_len;
126: static char *dp_vars_prefix;
1.27 noro 127: static int show_lt;
1.26 noro 128: static FUNC convfunc;
1.27 noro 129: static int is_lt;
1.28 noro 130: static int conv_flag;
1.31 noro 131: static int dp_vars_hweyl;
1.28 noro 132:
133: #define CONV_SUBSCRIPT (1U<<0)
134: #define CONV_DMODE (1U<<1)
135: #define CONV_USERFUNC (1U<<31)
1.18 noro 136:
137: static struct {
138: char *name;
139: Obj value;
140: int (*reg)();
141: } qtot_env[] = {
142: {"symbol_table",0,register_symbol_table},
143: {"conv_rule",0,register_conv_rule},
1.23 noro 144: {"dp_vars",0,register_dp_vars},
1.25 noro 145: {"dp_vars_prefix",0,register_dp_vars_prefix},
1.31 noro 146: {"dp_vars_hweyl",0,register_dp_vars_hweyl},
1.27 noro 147: {"show_lt",0,register_show_lt},
1.18 noro 148: {0,0,0},
149: };
150:
1.20 noro 151: #define PARTIAL "\\partial"
1.28 noro 152:
153: char *conv_rule(char *name)
154: {
155: char *body,*r;
156:
157: if ( conv_flag & CONV_DMODE ) {
158: if ( *name == 'd' ) {
159: if ( conv_flag & CONV_SUBSCRIPT )
160: body = conv_subscript(name+1);
161: else
162: body = name+1;
163: r = MALLOC_ATOMIC((strlen(PARTIAL)+strlen(body)+5)*sizeof(char));
164: sprintf(r,"{%s}_{%s}",PARTIAL,body);
165: return r;
166: } else {
167: if ( conv_flag & CONV_SUBSCRIPT )
168: body = conv_subscript(name);
169: else
170: body = name;
171: }
172: } else if ( conv_flag & CONV_SUBSCRIPT )
173: return conv_subscript(name);
174: else if ( conv_flag & CONV_USERFUNC && convfunc )
175: return call_convfunc(name);
176: else
177: return name;
178: }
179:
180: char *conv_subscript(char *name)
1.19 noro 181: {
1.29 noro 182: int i,j,k,len,clen,slen,start,level;
1.32 noro 183: char *buf,*head,*r,*h,*brace;
1.28 noro 184: char **subs;
185:
186: len = strlen(name);
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;
199: brace = (char *)ALLOCA((slen+1)*sizeof(char));
200: strncpy(brace,name+start+1,slen-2);
201: brace[slen-2] = 0;
202: buf = conv_subscript(brace);
203: subs[j] = (char *)ALLOCA((strlen(buf)+3)*sizeof(char));
204: sprintf(subs[j],"{%s}",buf);
205: } else {
206: if ( isdigit(name[i]) )
207: while ( i < len && isdigit(name[i]) ) i++;
208: else
209: while ( i < len && (isalpha(name[i]) || name[i] == '\\') ) i++;
210: slen = i-start;
211: buf = (char *)ALLOCA((slen+1)*sizeof(char));
212: strncpy(buf,name+start,slen); buf[slen] = 0;
213: subs[j] = symbol_name(buf);
214: }
1.28 noro 215: }
1.32 noro 216: for ( k = 0, clen = 0; k < j; k++ ) clen += strlen(subs[k]);
217: /* {subs(0)}_{{subs(1)},...,{subs(j-1)}} => {}:j+1 _:1 ,:j-2 */
218: h = r = MALLOC_ATOMIC((clen+(j+1)*2+1+(j-2)+1)*sizeof(char));
219: if ( j == 1 )
220: sprintf(h,"{%s}",subs[0]);
1.28 noro 221: else {
1.32 noro 222: sprintf(h,"{%s}_{{%s}",subs[0],subs[1]);
1.28 noro 223: h += strlen(h);
1.32 noro 224: for ( k = 2; k < j; k++ ) {
1.28 noro 225: sprintf(h,",{%s}",subs[k]);
226: h += strlen(h);
1.19 noro 227: }
1.28 noro 228: strcpy(h,"}");
1.20 noro 229: }
230: return r;
1.19 noro 231: }
232:
1.26 noro 233: char *call_convfunc(char *name)
234: {
235: STRING str,r;
236: NODE arg;
237:
238: MKSTR(str,name);
239: arg = mknode(1,str);
240: r = (STRING)bevalf(convfunc,arg);
241: if ( !r || OID(r) != O_STR )
242: error("call_convfunc : invalid result");
243: return BDY(r);
244: }
245:
1.18 noro 246: int register_symbol_table(Obj arg)
247: {
248: NODE n,t;
249: Obj b;
250: STRING a0,a1;
251: struct TeXSymbol *uts;
252: int i,len;
253:
254: /* check */
255: if ( !arg ) {
256: user_texsymbol = 0;
257: return 1;
258: }
259: if ( OID(arg) != O_LIST ) return 0;
260:
261: n = BDY((LIST)arg);
262: len = length(n);
263: uts = (struct TeXSymbol *)MALLOC((len+1)*sizeof(struct TeXSymbol));
264: for ( i = 0; n; n = NEXT(n), i++ ) {
265: b = (Obj)BDY(n);
266: if ( !b || OID(b) != O_LIST ) return 0;
267: t = BDY((LIST)b);
268: if ( !t || !NEXT(t) ) return 0;
269: a0 = (STRING)BDY(t);
270: a1 = (STRING)BDY(NEXT(t));
1.23 noro 271: if ( !a0 ) return 0;
272: if ( OID(a0) == O_STR )
273: uts[i].text = BDY(a0);
274: else if ( OID(a0) == O_P )
275: uts[i].text = NAME(VR((P)a0));
276: else
277: return 0;
278: if ( !a1 ) return 0;
279: if ( OID(a1) == O_STR )
280: uts[i].symbol = BDY(a1);
281: else if ( OID(a1) == O_P )
282: uts[i].symbol = NAME(VR((P)a1));
283: else
284: return 0;
1.18 noro 285: }
286: uts[i].text = 0;
287: uts[i].symbol = 0;
288: user_texsymbol = uts;
289: return 1;
290: }
291:
1.31 noro 292: int register_dp_vars_hweyl(Obj arg)
293: {
294: if ( INT(arg) ) {
295: dp_vars_hweyl = QTOS((Q)arg);
296: return 1;
297: } else return 0;
298: }
299:
1.27 noro 300: int register_show_lt(Obj arg)
301: {
302: if ( INT(arg) ) {
303: show_lt = QTOS((Q)arg);
304: return 1;
305: } else return 0;
306: }
1.26 noro 307:
1.18 noro 308: int register_conv_rule(Obj arg)
309: {
1.19 noro 310: if ( INT(arg) ) {
1.28 noro 311: conv_flag = QTOS((Q)arg);
312: convfunc = 0;
313: return 1;
1.26 noro 314: } else if ( OID(arg) == O_P &&
315: (int)(VR((P)arg))->attr == V_SR ) {
1.28 noro 316: conv_flag = CONV_USERFUNC;
1.26 noro 317: convfunc = (FUNC)(VR((P)arg)->priv);
318: /* f must be a function which takes single argument */
319: return 1;
1.19 noro 320: } else return 0;
1.18 noro 321: }
322:
1.23 noro 323: int register_dp_vars(Obj arg)
324: {
325: int l,i;
326: char **r;
327: NODE n;
328: STRING a;
329:
330: if ( !arg ) {
331: dp_vars = 0;
332: dp_vars_len = 0;
1.25 noro 333: return 1;
1.23 noro 334: } else if ( OID(arg) != O_LIST )
335: return 0;
336: else {
337: n = BDY((LIST)arg);
338: l = length(n);
339: r = (char **)MALLOC_ATOMIC(l*sizeof(char *));
340: for ( i = 0; i < l; i++, n = NEXT(n) ) {
341: a = (STRING)BDY(n);
342: if ( !a ) return 0;
343: if ( OID(a) == O_STR )
344: r[i] = BDY(a);
345: else if ( OID(a) == O_P )
346: r[i] = NAME(VR((P)a));
347: else
348: return 0;
349: }
350: dp_vars = r;
351: dp_vars_len = l;
352: return 1;
353: }
354: }
355:
1.25 noro 356: int register_dp_vars_prefix(Obj arg)
357: {
358: if ( !arg ) {
359: dp_vars_prefix = 0;
360: return 1;
361: } else if ( OID(arg) == O_STR ) {
362: dp_vars_prefix = BDY((STRING)arg);
363: return 1;
364: } else if ( OID(arg) == O_P ) {
365: dp_vars_prefix = NAME(VR((P)arg));
366: return 1;
367: } else return 0;
368: }
369:
1.24 noro 370: void Pquotetotex_env(NODE arg,Obj *rp)
1.18 noro 371: {
372: int ac,i;
373: char *name;
374: NODE n,n0;
375: STRING s;
376: LIST l;
377:
378: ac = argc(arg);
379: if ( !ac ) {
380: n0 = 0;
381: for ( i = 0; qtot_env[i].name; i++ ) {
382: NEXTNODE(n0,n); MKSTR(s,qtot_env[i].name); BDY(n) = (pointer)s;
383: NEXTNODE(n0,n); BDY(n) = (Q)qtot_env[i].value;
384: }
385: NEXT(n) = 0;
386: MKLIST(l,n0);
387: *rp = (Obj)l;
1.34 noro 388: } else if ( ac == 1 && !ARG0(arg) ) {
389: /* set to default */
390: for ( i = 0; qtot_env[i].name; i++ )
391: qtot_env[i].value = 0;
392: *rp = 0;
1.18 noro 393: } else if ( ac == 1 || ac == 2 ) {
1.24 noro 394: asir_assert(ARG0(arg),O_STR,"quotetotex_env");
1.18 noro 395: name = BDY((STRING)ARG0(arg));
396: for ( i = 0; qtot_env[i].name; i++ )
397: if ( !strcmp(qtot_env[i].name,name) ) {
398: if ( ac == 2 ) {
399: if ( (qtot_env[i].reg)((Obj)ARG1(arg)) )
400: qtot_env[i].value = (Obj)ARG1(arg);
401: else
1.24 noro 402: error("quotetotex_env : invalid argument");
1.18 noro 403: }
404: *rp = qtot_env[i].value;
405: return;
406: }
407: *rp = 0;
408: } else
409: *rp = 0;
410: }
411:
1.14 noro 412: void Pwrite_to_tb(NODE arg,Q *rp)
1.13 noro 413: {
414: int i;
1.16 noro 415: Obj obj;
416: TB tb;
1.13 noro 417:
1.14 noro 418: asir_assert(ARG1(arg),O_TB,"write_to_tb");
1.16 noro 419: obj = ARG0(arg);
420: if ( !obj )
421: write_tb("",ARG1(arg));
422: else if ( OID(obj) == O_STR )
423: write_tb(BDY((STRING)obj),ARG1(arg));
424: else if ( OID(obj) == O_TB ) {
425: tb = (TB)obj;
426: for ( i = 0; i < tb->next; i++ )
427: write_tb(tb->body[i],ARG1(arg));
428: }
1.14 noro 429: *rp = 0;
1.13 noro 430: }
431:
1.14 noro 432: void Pquotetotex(NODE arg,STRING *rp)
1.13 noro 433: {
1.14 noro 434: TB tb;
1.13 noro 435:
1.14 noro 436: NEWTB(tb);
1.27 noro 437: /* XXX for DP */
438: is_lt = 1;
1.14 noro 439: fnodetotex_tb(BDY((QUOTE)ARG0(arg)),tb);
440: tb_to_string(tb,rp);
1.13 noro 441: }
442:
1.14 noro 443: void Pquotetotex_tb(NODE arg,Q *rp)
1.13 noro 444: {
445: int i;
1.14 noro 446: TB tb;
1.13 noro 447:
1.14 noro 448: asir_assert(ARG1(arg),O_TB,"quotetotex_tb");
1.27 noro 449: /* XXX for DP */
450: is_lt = 1;
1.14 noro 451: fnodetotex_tb(BDY((QUOTE)ARG0(arg)),ARG1(arg));
1.13 noro 452: *rp = 0;
453: }
454:
1.14 noro 455: void Pstring_to_tb(NODE arg,TB *rp)
456: {
457: TB tb;
458:
459: asir_assert(ARG0(arg),O_STR,"string_to_tb");
460: NEWTB(tb);
461: tb->body[0] = BDY((STRING)ARG0(arg));
462: tb->next++;
463: *rp = tb;
464: }
465:
466: void Ptb_to_string(NODE arg,STRING *rp)
467: {
468: TB tb;
469:
470: asir_assert(ARG0(arg),O_TB,"tb_to_string");
471: tb = (TB)ARG0(arg);
472: tb_to_string(tb,rp);
473: }
474:
475: void tb_to_string(TB tb,STRING *rp)
1.13 noro 476: {
1.14 noro 477: int j,len;
1.13 noro 478: char *all,*p,*q;
479:
1.14 noro 480: for ( j = 0, len = 0; j < tb->next; j++ )
481: len += strlen(tb->body[j]);
482: all = (char *)MALLOC_ATOMIC((len+1)*sizeof(char));
483: for ( j = 0, p = all; j < tb->next; j++ )
484: for ( q = tb->body[j]; *q; *p++ = *q++ );
485: *p = 0;
486: MKSTR(*rp,all);
487: }
488:
489: void Pclear_tb(NODE arg,Q *rp)
490: {
491: TB tb;
492: int j;
493:
494: asir_assert(ARG0(arg),O_TB,"clear_tb");
495: tb = (TB)ARG0(arg);
496: for ( j = 0; j < tb->next; j++ )
497: tb->body[j] = 0;
498: tb->next = 0;
499: *rp = 0;
1.13 noro 500: }
1.5 noro 501:
502: void Pstr_len(arg,rp)
503: NODE arg;
504: Q *rp;
505: {
1.16 noro 506: Obj obj;
507: TB tb;
508: int r,i;
1.5 noro 509:
1.16 noro 510: obj = (Obj)ARG0(arg);
511: if ( !obj || (OID(obj) != O_STR && OID(obj) != O_TB) )
512: error("str_len : invalid argument");
513: if ( OID(obj) == O_STR)
514: r = strlen(BDY((STRING)obj));
515: else if ( OID(obj) == O_TB ) {
516: tb = (TB)obj;
517: for ( r = i = 0; i < tb->next; i++ )
518: r += strlen(tb->body[i]);
519: }
1.5 noro 520: STOQ(r,*rp);
521: }
522:
523: void Pstr_chr(arg,rp)
524: NODE arg;
525: Q *rp;
526: {
527: STRING str,terminator;
528: Q start;
529: char *p,*ind;
530: int chr,spos,r;
531:
532: str = (STRING)ARG0(arg);
533: start = (Q)ARG1(arg);
534: terminator = (STRING)ARG2(arg);
535: asir_assert(str,O_STR,"str_chr");
536: asir_assert(start,O_N,"str_chr");
537: asir_assert(terminator,O_STR,"str_chr");
538: p = BDY(str);
539: spos = QTOS(start);
540: chr = BDY(terminator)[0];
1.8 noro 541: if ( spos > (int)strlen(p) )
1.5 noro 542: r = -1;
543: else {
544: ind = strchr(p+spos,chr);
545: if ( ind )
546: r = ind-p;
547: else
548: r = -1;
549: }
550: STOQ(r,*rp);
551: }
552:
553: void Psub_str(arg,rp)
554: NODE arg;
555: STRING *rp;
556: {
557: STRING str;
558: Q head,tail;
559: char *p,*r;
560: int spos,epos,len;
561:
562: str = (STRING)ARG0(arg);
563: head = (Q)ARG1(arg);
564: tail = (Q)ARG2(arg);
565: asir_assert(str,O_STR,"sub_str");
566: asir_assert(head,O_N,"sub_str");
567: asir_assert(tail,O_N,"sub_str");
568: p = BDY(str);
569: spos = QTOS(head);
570: epos = QTOS(tail);
571: len = strlen(p);
572: if ( (spos >= len) || (epos < spos) ) {
573: *rp = 0; return;
574: }
575: if ( epos >= len )
576: epos = len-1;
577: len = epos-spos+1;
578: r = (char *)MALLOC(len+1);
579: strncpy(r,p+spos,len);
580: r[len] = 0;
581: MKSTR(*rp,r);
582: }
1.3 noro 583:
584: void Pstrtoascii(arg,rp)
585: NODE arg;
586: LIST *rp;
587: {
588: STRING str;
589: unsigned char *p;
590: int len,i;
591: NODE n,n1;
592: Q q;
593:
594: str = (STRING)ARG0(arg);
595: asir_assert(str,O_STR,"strtoascii");
596: p = BDY(str);
597: len = strlen(p);
598: for ( i = len-1, n = 0; i >= 0; i-- ) {
599: UTOQ((unsigned int)p[i],q);
600: MKNODE(n1,q,n);
601: n = n1;
602: }
603: MKLIST(*rp,n);
604: }
605:
606: void Pasciitostr(arg,rp)
607: NODE arg;
608: STRING *rp;
609: {
610: LIST list;
611: unsigned char *p;
612: int len,i,j;
613: NODE n;
614: Q q;
615:
616: list = (LIST)ARG0(arg);
617: asir_assert(list,O_LIST,"asciitostr");
618: n = BDY(list);
619: len = length(n);
620: p = MALLOC_ATOMIC(len+1);
621: for ( i = 0; i < len; i++, n = NEXT(n) ) {
622: q = (Q)BDY(n);
623: asir_assert(q,O_N,"asciitostr");
624: j = QTOS(q);
1.4 noro 625: if ( j >= 256 || j <= 0 )
1.3 noro 626: error("asciitostr : argument out of range");
627: p[i] = j;
628: }
629: p[i] = 0;
630: MKSTR(*rp,(char *)p);
631: }
1.1 noro 632:
633: void Peval_str(arg,rp)
634: NODE arg;
635: Obj *rp;
636: {
637: FNODE fnode;
638: char *cmd;
1.10 ohara 639: #if defined(PARI)
1.8 noro 640: void recover(int);
641:
1.1 noro 642: recover(0);
1.11 saito 643: # if !(PARI_VERSION_CODE > 131588)
1.1 noro 644: if ( setjmp(environnement) ) {
645: avma = top; recover(1);
646: resetenv("");
647: }
1.11 saito 648: # endif
1.1 noro 649: #endif
650: cmd = BDY((STRING)ARG0(arg));
1.9 noro 651: exprparse_create_var(0,cmd,&fnode);
1.1 noro 652: *rp = eval(fnode);
653: }
654:
655: void Prtostr(arg,rp)
656: NODE arg;
657: STRING *rp;
658: {
659: char *b;
660: int len;
661:
1.2 noro 662: len = estimate_length(CO,ARG0(arg));
1.12 noro 663: b = (char *)MALLOC_ATOMIC(len+1);
1.1 noro 664: soutput_init(b);
665: sprintexpr(CO,ARG0(arg));
666: MKSTR(*rp,b);
667: }
668:
669: void Pstrtov(arg,rp)
670: NODE arg;
671: P *rp;
672: {
1.8 noro 673: char *p;
1.1 noro 674:
675: p = BDY((STRING)ARG0(arg));
676: #if 0
677: if ( !islower(*p) )
678: *rp = 0;
679: else {
680: for ( t = p+1; t && (isalnum(*t) || *t == '_'); t++ );
681: if ( *t )
682: *rp = 0;
683: else
684: makevar(p,rp);
685: }
686: #else
687: makevar(p,rp);
688: #endif
1.14 noro 689: }
690:
1.15 noro 691: static struct TeXSymbol texsymbol[] = {
692: {"sin","\\sin"},
693: {"cos","\\cos"},
694: {"tan","\\tan"},
695: {"sinh","\\sinh"},
696: {"cosh","\\cosh"},
697: {"tanh","\\tanh"},
698: {"exp","\\exp"},
699: {"log","\\log"},
700:
701: /* Greek Letters (lower case) */
702: {"alpha","\\alpha"},
703: {"beta","\\beta"},
704: {"gamma","\\gamma"},
705: {"delta","\\delta"},
706: {"epsilon","\\epsilon"},
707: {"varepsilon","\\varepsilon"},
708: {"zeta","\\zeta"},
709: {"eta","\\eta"},
710: {"theta","\\theta"},
711: {"vartheta","\\vartheta"},
712: {"iota","\\iota"},
713: {"kappa","\\kappa"},
714: {"lambda","\\lambda"},
715: {"mu","\\mu"},
716: {"nu","\\nu"},
717: {"xi","\\xi"},
718: {"pi","\\pi"},
719: {"varpi","\\varpi"},
720: {"rho","\\rho"},
721: {"sigma","\\sigma"},
722: {"varsigma","\\varsigma"},
723: {"tau","\\tau"},
724: {"upsilon","\\upsilon"},
725: {"phi","\\phi"},
726: {"varphi","\\varphi"},
727: {"chi","\\chi"},
728: {"omega","\\omega"},
729:
730: /* Greek Letters, (upper case) */
731: {"ggamma","\\Gamma"},
732: {"ddelta","\\Delta"},
733: {"ttheta","\\Theta"},
734: {"llambda","\\Lambda"},
735: {"xxi","\\Xi"},
736: {"ppi","\\Pi"},
737: {"ssigma","\\Sigma"},
738: {"uupsilon","\\Upsilon"},
739: {"pphi","\\Phi"},
740: {"ppsi","\\Psi"},
741: {"oomega","\\Omega"},
742:
743: /* Our own mathematical functions */
744: {"algebra_tensor","\\otimes"},
745: {"base_where","{\\rm \\ where \\ }"},
746: /* Mathematical constants */
747: {"c_pi","\\pi"},
748: {"c_i","\\sqrt{-1}"},
749:
750: /* Temporary */
751: {0,0}
752: };
753:
1.14 noro 754: char *symbol_name(char *name)
755: {
1.15 noro 756: int i;
757:
1.18 noro 758: if ( user_texsymbol )
759: for ( i = 0; user_texsymbol[i].text; i++ )
760: if ( !strcmp(user_texsymbol[i].text,name) )
761: return user_texsymbol[i].symbol;
1.15 noro 762: for ( i = 0; texsymbol[i].text; i++ )
763: if ( !strcmp(texsymbol[i].text,name) )
764: return texsymbol[i].symbol;
1.28 noro 765: return name;
1.14 noro 766: }
767:
768: void fnodetotex_tb(FNODE f,TB tb)
769: {
770: NODE n,t,t0;
771: char vname[BUFSIZ];
1.23 noro 772: char *opname,*vname_conv;
1.14 noro 773: Obj obj;
1.31 noro 774: int i,len,allzero,elen,elen2;
1.17 noro 775: FNODE fi,f2;
1.14 noro 776:
777: write_tb(" ",tb);
778: if ( !f ) {
779: write_tb("0",tb);
780: return;
781: }
782: switch ( f->id ) {
783: /* unary operators */
1.23 noro 784: case I_NOT:
785: write_tb("\\neg (",tb);
786: fnodetotex_tb((FNODE)FA0(f),tb);
787: write_tb(")",tb);
788: break;
789: case I_PAREN:
790: write_tb("(",tb);
791: fnodetotex_tb((FNODE)FA0(f),tb);
792: write_tb(")",tb);
793: break;
794: case I_MINUS:
795: write_tb("-",tb);
796: fnodetotex_tb((FNODE)FA0(f),tb);
797: break;
798:
799: /* binary operators */
800: /* arg list */
801: /* I_AND, I_OR => FA0(f), FA1(f) */
802: /* otherwise => FA1(f), FA2(f) */
803: case I_BOP:
804: opname = ((ARF)FA0(f))->name;
805: if ( !strcmp(opname,"+") ) {
806: fnodetotex_tb((FNODE)FA1(f),tb);
1.35 noro 807: if ( !top_is_minus((FNODE)FA2(f)) ) write_tb(opname,tb);
1.23 noro 808: fnodetotex_tb((FNODE)FA2(f),tb);
809: } else if ( !strcmp(opname,"-") ) {
810: if ( FA1(f) ) fnodetotex_tb((FNODE)FA1(f),tb);
811: write_tb(opname,tb);
812: fnodetotex_tb((FNODE)FA2(f),tb);
813: } else if ( !strcmp(opname,"*") ) {
814: fnodetotex_tb((FNODE)FA1(f),tb);
815: write_tb(" ",tb);
816: /* XXX special care for DP */
817: f2 = (FNODE)FA2(f);
818: if ( f2->id == I_EV ) {
819: n = (NODE)FA0(f2);
820: for ( i = 0; n; n = NEXT(n), i++ ) {
821: fi = (FNODE)BDY(n);
822: if ( fi->id != I_FORMULA || FA0(fi) )
823: break;
824: }
825: if ( n )
826: fnodetotex_tb((FNODE)FA2(f),tb);
827: } else
828: fnodetotex_tb((FNODE)FA2(f),tb);
829: } else if ( !strcmp(opname,"/") ) {
830: write_tb("\\frac{",tb);
831: fnodetotex_tb((FNODE)FA1(f),tb);
832: write_tb("} {",tb);
833: fnodetotex_tb((FNODE)FA2(f),tb);
834: write_tb("}",tb);
835: } else if ( !strcmp(opname,"^") ) {
836: fnodetotex_tb((FNODE)FA1(f),tb);
837: write_tb("^{",tb);
838: fnodetotex_tb((FNODE)FA2(f),tb);
839: write_tb("} ",tb);
840: } else if ( !strcmp(opname,"%") ) {
841: fnodetotex_tb((FNODE)FA1(f),tb);
842: write_tb(" {\\rm mod}\\, ",tb);
843: fnodetotex_tb((FNODE)FA2(f),tb);
844: } else
845: error("invalid binary operator");
846: break;
847:
848: case I_COP:
849: switch( (cid)FA0(f) ) {
850: case C_EQ:
851: fnodetotex_tb((FNODE)FA1(f),tb);
852: write_tb(" = ",tb);
853: fnodetotex_tb((FNODE)FA2(f),tb);
854: break;
855: case C_NE:
856: fnodetotex_tb((FNODE)FA1(f),tb);
857: write_tb(" \\neq ",tb);
858: fnodetotex_tb((FNODE)FA2(f),tb);
859: break;
860: case C_GT:
861: fnodetotex_tb((FNODE)FA1(f),tb);
862: write_tb(" \\gt ",tb);
863: fnodetotex_tb((FNODE)FA2(f),tb);
864: break;
865: case C_LT:
866: fnodetotex_tb((FNODE)FA1(f),tb);
867: write_tb(" \\lt ",tb);
868: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 869: break;
1.23 noro 870: case C_GE:
871: fnodetotex_tb((FNODE)FA1(f),tb);
872: write_tb(" \\geq ",tb);
873: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 874: break;
1.23 noro 875: case C_LE:
876: fnodetotex_tb((FNODE)FA1(f),tb);
877: write_tb(" \\leq ",tb);
878: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 879: break;
880: }
881: break;
882:
1.23 noro 883: case I_LOP:
884: switch( (lid)FA0(f) ) {
885: case L_EQ:
886: fnodetotex_tb((FNODE)FA1(f),tb);
887: write_tb(" = ",tb);
888: fnodetotex_tb((FNODE)FA2(f),tb);
889: break;
890: case L_NE:
891: fnodetotex_tb((FNODE)FA1(f),tb);
892: write_tb(" \\neq ",tb);
893: fnodetotex_tb((FNODE)FA2(f),tb);
894: break;
895: case L_GT:
896: fnodetotex_tb((FNODE)FA1(f),tb);
897: write_tb(" \\gt ",tb);
898: fnodetotex_tb((FNODE)FA2(f),tb);
899: break;
900: case L_LT:
901: fnodetotex_tb((FNODE)FA1(f),tb);
902: write_tb(" \\lt ",tb);
903: fnodetotex_tb((FNODE)FA2(f),tb);
904: break;
905: case L_GE:
906: fnodetotex_tb((FNODE)FA1(f),tb);
907: write_tb(" \\geq ",tb);
908: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 909: break;
1.23 noro 910: case L_LE:
911: fnodetotex_tb((FNODE)FA1(f),tb);
912: write_tb(" \\leq ",tb);
913: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 914: break;
1.23 noro 915: case L_AND:
916: fnodetotex_tb((FNODE)FA1(f),tb);
1.14 noro 917: write_tb(" {\\rm \\ and\\ } ",tb);
1.23 noro 918: fnodetotex_tb((FNODE)FA2(f),tb);
919: break;
920: case L_OR:
1.14 noro 921: fnodetotex_tb((FNODE)FA1(f),tb);
1.23 noro 922: write_tb(" {\\rm \\ or\\ } ",tb);
923: fnodetotex_tb((FNODE)FA2(f),tb);
1.14 noro 924: break;
1.23 noro 925: case L_NOT:
926: /* XXX : L_NOT is a unary operator */
927: write_tb("\\neg (",tb);
1.14 noro 928: fnodetotex_tb((FNODE)FA1(f),tb);
1.23 noro 929: write_tb(")",tb);
930: return;
1.14 noro 931: }
932: break;
933:
1.23 noro 934: case I_AND:
935: fnodetotex_tb((FNODE)FA0(f),tb);
936: write_tb(" {\\rm \\ and\\ } ",tb);
937: fnodetotex_tb((FNODE)FA1(f),tb);
938: break;
939:
940: case I_OR:
941: fnodetotex_tb((FNODE)FA0(f),tb);
942: write_tb(" {\\rm \\ or\\ } ",tb);
943: fnodetotex_tb((FNODE)FA1(f),tb);
944: break;
945:
1.14 noro 946: /* ternary operators */
947: case I_CE:
948: error("fnodetotex_tb : not implemented yet");
949: break;
950:
951: /* lists */
952: case I_LIST:
953: write_tb(" [ ",tb);
954: n = (NODE)FA0(f);
955: fnodenodetotex_tb(n,tb);
956: write_tb("]",tb);
957: break;
958:
959: /* function */
1.23 noro 960: case I_FUNC:
1.28 noro 961: opname = conv_rule(((FUNC)FA0(f))->name);
1.23 noro 962: write_tb(opname,tb);
963: write_tb("(",tb);
964: fargstotex_tb(opname,FA1(f),tb);
965: write_tb(")",tb);
966: break;
967:
968: /* XXX */
969: case I_CAR:
1.28 noro 970: opname = conv_rule("car");
1.23 noro 971: write_tb(opname,tb);
972: write_tb("(",tb);
973: fargstotex_tb(opname,FA0(f),tb);
974: write_tb(")",tb);
975: break;
976:
977: case I_CDR:
1.28 noro 978: opname = conv_rule("cdr");
1.23 noro 979: write_tb(opname,tb);
980: write_tb("(",tb);
981: fargstotex_tb(opname,FA0(f),tb);
982: write_tb(")",tb);
983: break;
984:
985: /* exponent vector */
986: case I_EV:
987: n = (NODE)FA0(f);
1.31 noro 988: if ( dp_vars_hweyl ) {
989: elen = length(n);
990: elen2 = elen>>1;
991: elen = elen2<<1;
992: }
1.23 noro 993: allzero = 1;
1.27 noro 994: if ( show_lt && is_lt )
995: write_tb("\\underline{",tb);
1.23 noro 996: for ( t0 = 0, i = 0; n; n = NEXT(n), i++ ) {
997: fi = (FNODE)BDY(n);
998: if ( fi->id == I_FORMULA && !FA0(fi) ) continue;
999: allzero = 0;
1.31 noro 1000: if ( dp_vars_hweyl ) {
1001: if ( i < elen2 )
1002: if ( dp_vars_prefix )
1003: sprintf(vname,"%s_{%d}",dp_vars_prefix,i);
1004: else
1005: sprintf(vname,"x_{%d}",i);
1006: else if ( i < elen )
1007: sprintf(vname,"{\\partial}_{%d}",i-elen2);
1008: else
1009: strcpy(vname,"h");
1010: } else if ( dp_vars && i < dp_vars_len )
1.23 noro 1011: strcpy(vname,dp_vars[i]);
1.25 noro 1012: else if ( dp_vars_prefix )
1013: sprintf(vname,"%s_{%d}",dp_vars_prefix,i);
1.23 noro 1014: else
1015: sprintf(vname,"x_{%d}",i);
1.28 noro 1016: vname_conv = conv_rule(vname);
1.23 noro 1017: if ( fi->id == I_FORMULA && UNIQ(FA0(fi)) ) {
1018: len = strlen(vname_conv);
1019: opname = MALLOC_ATOMIC(len+2);
1020: sprintf(opname,"%s ",vname_conv);
1.14 noro 1021: write_tb(opname,tb);
1.23 noro 1022: } else {
1023: len = strlen(vname_conv);
1024: /* 2: ^{ */
1025: opname = MALLOC_ATOMIC(len+1+2);
1026: sprintf(opname,"%s^{",vname_conv);
1.14 noro 1027: write_tb(opname,tb);
1.23 noro 1028: fnodetotex_tb((FNODE)BDY(n),tb);
1029: write_tb("} ",tb);
1030: }
1.14 noro 1031: }
1.23 noro 1032: /* XXX */
1033: if ( allzero )
1034: write_tb(" 1 ",tb);
1.27 noro 1035: if ( show_lt && is_lt ) {
1036: write_tb("}",tb);
1037: is_lt = 0;
1038: }
1.14 noro 1039: break;
1040:
1.23 noro 1041: /* string */
1.14 noro 1042: case I_STR:
1043: write_tb((char *)FA0(f),tb);
1044: break;
1045:
1.23 noro 1046: /* internal object */
1.14 noro 1047: case I_FORMULA:
1048: obj = (Obj)FA0(f);
1049: if ( obj && OID(obj) == O_P ) {
1.28 noro 1050: opname = conv_rule(VR((P)obj)->name);
1.14 noro 1051: } else {
1052: len = estimate_length(CO,obj);
1053: opname = (char *)MALLOC_ATOMIC(len+1);
1054: soutput_init(opname);
1055: sprintexpr(CO,obj);
1056: }
1057: write_tb(opname,tb);
1058: break;
1059:
1.23 noro 1060: /* program variable */
1.14 noro 1061: case I_PVAR:
1062: if ( FA1(f) )
1063: error("fnodetotex_tb : not implemented yet");
1064: GETPVNAME(FA0(f),opname);
1065: write_tb(opname,tb);
1066: break;
1067:
1068: default:
1069: error("fnodetotex_tb : not implemented yet");
1070: }
1071: }
1072:
1073: void fnodenodetotex_tb(NODE n,TB tb)
1074: {
1075: for ( ; n; n = NEXT(n) ) {
1.27 noro 1076: is_lt = 1;
1.14 noro 1077: fnodetotex_tb((FNODE)BDY(n),tb);
1078: if ( NEXT(n) ) write_tb(", ",tb);
1079: }
1080: }
1081:
1082: void fargstotex_tb(char *name,FNODE f,TB tb)
1083: {
1084: NODE n;
1085:
1086: if ( !strcmp(name,"matrix") ) {
1087: error("fargstotex_tb : not implemented yet");
1088: } else if ( !strcmp(name,"vector") ) {
1089: error("fargstotex_tb : not implemented yet");
1090: } else {
1091: if ( f->id == I_LIST ) {
1092: n = (NODE)FA0(f);
1093: fnodenodetotex_tb(n,tb);
1094: } else
1095: fnodetotex_tb(f,tb);
1.35 noro 1096: }
1097: }
1098:
1099: int top_is_minus(FNODE f)
1100: {
1101: char *opname;
1102: int len;
1103: Obj obj;
1104:
1105: if ( !f )
1106: return 0;
1107: switch ( f->id ) {
1108: case I_MINUS:
1109: return 1;
1110: case I_BOP:
1111: opname = ((ARF)FA0(f))->name;
1112: switch ( opname[0] ) {
1113: case '+': case '*': case '/': case '^': case '%':
1114: return top_is_minus((FNODE)FA1(f));
1115: case '-':
1116: if ( FA1(f) )
1117: return top_is_minus((FNODE)FA1(f));
1118: else
1119: return 1;
1120: default:
1121: return 0;
1122: }
1123: break;
1124: case I_COP:
1125: return top_is_minus((FNODE)FA1(f));
1126: case I_LOP:
1127: if ( (lid)FA0(f) == L_NOT ) return 0;
1128: else return top_is_minus((FNODE)FA1(f));
1129: case I_AND: case I_OR:
1130: return top_is_minus((FNODE)FA0(f));
1131: case I_FORMULA:
1132: obj = (Obj)FA0(f);
1.36 ! noro 1133: if ( !obj )
! 1134: return 0;
! 1135: else {
! 1136: switch ( OID(obj) ) {
! 1137: case O_N:
! 1138: return mmono((P)obj);
! 1139: case O_P:
! 1140: /* must be a variable */
! 1141: opname = conv_rule(VR((P)obj)->name);
! 1142: return opname[0]=='-';
! 1143: default:
! 1144: /* ??? */
! 1145: len = estimate_length(CO,obj);
! 1146: opname = (char *)MALLOC_ATOMIC(len+1);
! 1147: soutput_init(opname);
! 1148: sprintexpr(CO,obj);
! 1149: return opname[0]=='-';
! 1150: }
1.35 noro 1151: }
1152: default:
1153: return 0;
1.14 noro 1154: }
1.1 noro 1155: }