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