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