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