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