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