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