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