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