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