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