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