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