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