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