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