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