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