![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to print.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 print.c CVS log | Up to [local] / OpenXM_contrib2 / asir2000 / builtin |
1.2 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.3 noro 26: * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
1.2 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.22 ! noro 48: * $OpenXM: OpenXM_contrib2/asir2000/builtin/print.c,v 1.21 2006/02/01 07:29:29 noro Exp $
1.2 noro 49: */
1.1 noro 50: #include "ca.h"
51: #include "parse.h"
52:
53: void Pprint();
1.4 noro 54: void Pquotetolist();
1.16 noro 55: void Pobjtoquote();
1.9 noro 56: void Peval_variables_in_quote();
1.11 noro 57: void Pset_print_function();
1.1 noro 58:
59: struct ftab print_tab[] = {
60: {"print",Pprint,-2},
1.16 noro 61: {"objtoquote",Pobjtoquote,1},
1.4 noro 62: {"quotetolist",Pquotetolist,1},
1.9 noro 63: {"eval_variables_in_quote",Peval_variables_in_quote,1},
1.11 noro 64: {"set_print_function",Pset_print_function,-1},
1.1 noro 65: {0,0,0},
66: };
67:
1.21 noro 68: extern int I_am_server;
69:
1.22 ! noro 70: int wfep_mode;
! 71:
1.14 noro 72: void Pprint(NODE arg,pointer *rp)
1.1 noro 73: {
1.15 noro 74: Obj obj;
1.22 ! noro 75: STRING nl;
1.17 noro 76: Q opt;
1.15 noro 77:
1.22 ! noro 78: /* engine for wfep */
! 79: if ( wfep_mode ) {
! 80: if ( arg ) {
! 81: print_to_wfep((Obj)ARG0(arg));
! 82: if ( !NEXT(arg) || ARG1(arg) ) {
! 83: MKSTR(nl,"\r\n");
! 84: print_to_wfep((Obj)nl);
! 85: }
! 86: }
! 87: *rp = 0;
! 88: return;
! 89: }
1.15 noro 90: if ( arg ) {
91: obj = (Obj)ARG0(arg);
92: if ( NEXT(arg) ) {
1.17 noro 93: opt = (Q)ARG1(arg);
1.15 noro 94: if ( INT(opt) ) {
95: printexpr(CO,obj);
1.17 noro 96: switch ( QTOS(opt) ) {
1.15 noro 97: case 0:
98: break;
99: case 2:
100: fflush(asir_out); break;
101: break;
102: case 1: default:
103: putc('\n',asir_out); break;
104: }
105: } else
106: error("print : invalid argument");
107: } else {
108: printexpr(CO,obj);
109: putc('\n',asir_out);
1.1 noro 110: }
1.15 noro 111: }
1.21 noro 112: /* XXX : if ox_asir, we have to fflush always */
113: if ( I_am_server )
114: fflush(asir_out);
1.1 noro 115: *rp = 0;
1.16 noro 116: }
117:
118: void Pobjtoquote(NODE arg,QUOTE *rp)
119: {
120: objtoquote(ARG0(arg),rp);
1.4 noro 121: }
122:
1.14 noro 123: void Pquotetolist(NODE arg,LIST *rp)
1.4 noro 124: {
125: asir_assert(ARG0(arg),O_QUOTE,"quotetolist");
126: fnodetotree((FNODE)BDY((QUOTE)(ARG0(arg))),rp);
127: }
128:
1.14 noro 129: void Peval_variables_in_quote(NODE arg,QUOTE *rp)
1.9 noro 130: {
131: FNODE fn;
132:
133: asir_assert(ARG0(arg),O_QUOTE,"eval_variables_in_quote");
134: fn = eval_pvar_in_fnode((FNODE)BDY((QUOTE)(ARG0(arg))));
135: MKQUOTE(*rp,fn);
136: }
137:
1.7 noro 138: /* fnode -> [tag,name,arg0,arg1,...] */
139:
1.14 noro 140: void fnodetotree(FNODE f,LIST *rp)
1.4 noro 141: {
1.14 noro 142: LIST a1,a2,a3;
1.4 noro 143: NODE n,t,t0;
1.7 noro 144: STRING head,op,str;
1.4 noro 145: char *opname;
146:
147: if ( !f ) {
1.7 noro 148: MKSTR(head,"internal");
149: n = mknode(2,head,0);
1.14 noro 150: MKLIST(*rp,n);
1.4 noro 151: return;
152: }
153: switch ( f->id ) {
1.7 noro 154: /* unary operators */
1.13 noro 155: case I_NOT: case I_PAREN: case I_MINUS:
1.7 noro 156: MKSTR(head,"u_op");
157: switch ( f->id ) {
158: case I_NOT:
159: MKSTR(op,"!");
160: break;
161: case I_PAREN:
162: MKSTR(op,"()");
163: break;
1.13 noro 164: case I_MINUS:
165: MKSTR(op,"-");
166: break;
1.7 noro 167: }
168: fnodetotree((FNODE)FA0(f),&a1);
169: n = mknode(3,head,op,a1);
1.14 noro 170: MKLIST(*rp,n);
1.7 noro 171: break;
172:
173: /* binary operators */
174: case I_BOP: case I_COP: case I_LOP: case I_AND: case I_OR:
175: /* head */
176: MKSTR(head,"b_op");
177:
1.4 noro 178: /* arg list */
1.7 noro 179: switch ( f->id ) {
180: case I_AND: case I_OR:
181: fnodetotree((FNODE)FA0(f),&a1);
182: fnodetotree((FNODE)FA1(f),&a2);
183: break;
184: default:
185: fnodetotree((FNODE)FA1(f),&a1);
186: fnodetotree((FNODE)FA2(f),&a2);
187: break;
188: }
1.4 noro 189:
1.7 noro 190: /* op */
1.4 noro 191: switch ( f->id ) {
192: case I_BOP:
1.7 noro 193: MKSTR(op,((ARF)FA0(f))->name); break;
194:
1.4 noro 195: case I_COP:
196: switch( (cid)FA0(f) ) {
197: case C_EQ: opname = "=="; break;
198: case C_NE: opname = "!="; break;
199: case C_GT: opname = ">"; break;
200: case C_LT: opname = "<"; break;
201: case C_GE: opname = ">="; break;
202: case C_LE: opname = "<="; break;
203: }
1.7 noro 204: MKSTR(op,opname); break;
205:
1.4 noro 206: case I_LOP:
207: switch( (lid)FA0(f) ) {
208: case L_EQ: opname = "@=="; break;
209: case L_NE: opname = "@!="; break;
210: case L_GT: opname = "@>"; break;
211: case L_LT: opname = "@<"; break;
212: case L_GE: opname = "@>="; break;
213: case L_LE: opname = "@<="; break;
214: case L_AND: opname = "@&&"; break;
215: case L_OR: opname = "@||"; break;
1.7 noro 216:
217: case L_NOT: opname = "@!";
218: /* XXX : L_NOT is a unary operator */
219: MKSTR(head,"u_op");
220: MKSTR(op,opname);
221: n = mknode(3,head,op,a1);
1.14 noro 222: MKLIST(*rp,n);
1.7 noro 223: return;
1.4 noro 224: }
1.7 noro 225: MKSTR(op,opname); break;
226:
227: case I_AND:
228: MKSTR(op,"&&"); break;
229:
230: case I_OR:
231: MKSTR(op,"||"); break;
1.4 noro 232: }
1.7 noro 233: n = mknode(4,head,op,a1,a2);
1.19 noro 234: MKLIST(*rp,n);
235: break;
236:
237: case I_NARYOP:
238: /* head */
239: MKSTR(head,"n_op");
240: n = (NODE)FA1(f);
241: for ( t0 = 0; n; n = NEXT(n) ) {
242: NEXTNODE(t0,t);
243: fnodetotree((FNODE)BDY(n),&a1);
244: BDY(t) = (pointer)a1;
245: }
246: MKSTR(op,((ARF)FA0(f))->name);
247: MKNODE(t,op,t0);
248: MKNODE(n,head,t);
1.14 noro 249: MKLIST(*rp,n);
1.4 noro 250: break;
1.7 noro 251:
252: /* ternary operators */
1.4 noro 253: case I_CE:
1.7 noro 254: MKSTR(head,"t_op");
255: MKSTR(op,"?:");
1.4 noro 256: fnodetotree((FNODE)FA0(f),&a1);
257: fnodetotree((FNODE)FA1(f),&a2);
1.7 noro 258: fnodetotree((FNODE)FA2(f),&a3);
259: n = mknode(5,head,op,a1,a2,a3);
1.14 noro 260: MKLIST(*rp,n);
1.4 noro 261: break;
1.7 noro 262:
263: /* lists */
1.8 noro 264: case I_LIST:
1.4 noro 265: n = (NODE)FA0(f);
266: for ( t0 = 0; n; n = NEXT(n) ) {
267: NEXTNODE(t0,t);
1.14 noro 268: fnodetotree((FNODE)BDY(n),&a1);
269: BDY(t) = (pointer)a1;
1.4 noro 270: }
271: if ( t0 )
272: NEXT(t) = 0;
1.8 noro 273: MKSTR(head,"list");
1.7 noro 274: MKNODE(n,head,t0);
1.14 noro 275: MKLIST(*rp,n);
1.4 noro 276: break;
1.7 noro 277:
278: /* function */
1.20 noro 279: case I_FUNC: case I_FUNC_QARG: case I_CAR: case I_CDR: case I_EV:
1.7 noro 280: MKSTR(head,"function");
281: switch ( f->id ) {
1.20 noro 282: case I_FUNC: case I_FUNC_QARG:
1.18 noro 283: MKSTR(op,((FUNC)FA0(f))->fullname);
1.14 noro 284: fnodetotree((FNODE)FA1(f),&a1);
1.7 noro 285: break;
286: case I_CAR:
287: MKSTR(op,"car");
1.14 noro 288: fnodetotree((FNODE)FA0(f),&a1);
1.7 noro 289: break;
290: case I_CDR:
291: MKSTR(op,"cdr");
1.14 noro 292: fnodetotree((FNODE)FA0(f),&a1);
1.7 noro 293: break;
1.8 noro 294: case I_EV:
295: /* exponent vector; should be treated as function call */
296: MKSTR(op,"exponent_vector");
1.14 noro 297: fnodetotree(mkfnode(1,I_LIST,FA0(f)),&a1);
1.8 noro 298: break;
1.7 noro 299: }
1.14 noro 300: t0 = NEXT(BDY(a1)); /* XXX : skip the headers */
1.7 noro 301: MKNODE(t,op,t0);
302: MKNODE(n,head,t);
1.14 noro 303: MKLIST(*rp,n);
1.4 noro 304: break;
1.7 noro 305:
306: case I_STR:
307: MKSTR(head,"internal");
308: MKSTR(str,FA0(f));
309: n = mknode(2,head,str);
1.14 noro 310: MKLIST(*rp,n);
1.4 noro 311: break;
1.7 noro 312:
313: case I_FORMULA:
314: MKSTR(head,"internal");
315: n = mknode(2,head,FA0(f));
1.14 noro 316: MKLIST(*rp,n);
1.4 noro 317: break;
1.9 noro 318:
319: case I_PVAR:
1.10 noro 320: if ( FA1(f) )
321: error("fnodetotree : not implemented yet");
1.9 noro 322: MKSTR(head,"variable");
323: GETPVNAME(FA0(f),opname);
324: MKSTR(op,opname);
325: n = mknode(2,head,op);
1.14 noro 326: MKLIST(*rp,n);
1.9 noro 327: break;
328:
1.4 noro 329: default:
330: error("fnodetotree : not implemented yet");
1.9 noro 331: }
332: }
333:
1.14 noro 334: FNODE eval_pvar_in_fnode(FNODE f)
1.9 noro 335: {
336: FNODE a1,a2,a3;
337: pointer r;
338: NODE n,t,t0;
1.10 noro 339: QUOTE q;
1.9 noro 340:
341: if ( !f )
342: return 0;
343:
344: switch ( f->id ) {
345: /* unary operators */
1.13 noro 346: case I_NOT: case I_PAREN: case I_MINUS:
1.9 noro 347: a1 = eval_pvar_in_fnode((FNODE)FA0(f));
348: return mkfnode(1,f->id,a1);
349:
350: /* binary operators */
351: case I_AND: case I_OR:
352: a1 = eval_pvar_in_fnode((FNODE)FA0(f));
353: a2 = eval_pvar_in_fnode((FNODE)FA1(f));
354: return mkfnode(3,f->id,a1,a2);
355:
356: case I_BOP: case I_COP: case I_LOP:
357: a1 = eval_pvar_in_fnode((FNODE)FA1(f));
358: a2 = eval_pvar_in_fnode((FNODE)FA2(f));
359: return mkfnode(4,f->id,FA0(f),a1,a2);
360:
361: /* ternary operators */
362: case I_CE:
363: a1 = eval_pvar_in_fnode((FNODE)FA0(f));
364: a2 = eval_pvar_in_fnode((FNODE)FA1(f));
365: a3 = eval_pvar_in_fnode((FNODE)FA2(f));
366: return mkfnode(5,f->id,a1,a2,a3);
367:
368: /* lists */
369: case I_LIST:
370: n = (NODE)FA0(f);
371: for ( t0 = 0; n; n = NEXT(n) ) {
372: NEXTNODE(t0,t);
373: BDY(t) = (pointer)eval_pvar_in_fnode(BDY(n));
374: }
375: if ( t0 )
376: NEXT(t) = 0;
377: return mkfnode(1,f->id,t0);
378:
379: /* function */
380: case I_FUNC:
381: a1 = eval_pvar_in_fnode((FNODE)FA1(f));
382: return mkfnode(2,f->id,FA0(f),a1);
383: break;
384: case I_CAR: case I_CDR:
385: a1 = eval_pvar_in_fnode((FNODE)FA0(f));
386: return mkfnode(1,f->id,a1);
387: case I_EV:
388: /* exponent vector */
389: a1 = eval_pvar_in_fnode(mkfnode(1,I_LIST,FA0(f)));
390: return mkfnode(1,f->id,a1);
391:
392: case I_STR: case I_FORMULA:
393: return f;
394:
395: case I_PVAR: case I_INDEX:
396: case I_POSTSELF: case I_PRESELF:
397: r = eval(f);
1.10 noro 398: objtoquote(r,&q);
399: return BDY(q);
1.9 noro 400:
401: default:
402: error("eval_pvar_in_fnode : not implemented yet");
1.14 noro 403: /* NOTREACHED */
404: return 0;
1.12 noro 405: }
406: }
407:
1.14 noro 408: FNODE subst_in_fnode(FNODE f,V v,FNODE g)
1.12 noro 409: {
410: FNODE a1,a2,a3;
411: DCP dc;
412: V vf;
413: NODE n,t,t0;
414: Obj obj;
415:
416: if ( !f )
417: return 0;
418:
419: switch ( f->id ) {
420: /* unary operators */
1.13 noro 421: case I_NOT: case I_PAREN: case I_MINUS:
1.12 noro 422: a1 = subst_in_fnode((FNODE)FA0(f),v,g);
423: return mkfnode(1,f->id,a1);
424:
425: /* binary operators */
426: case I_AND: case I_OR:
427: a1 = subst_in_fnode((FNODE)FA0(f),v,g);
428: a2 = subst_in_fnode((FNODE)FA1(f),v,g);
429: return mkfnode(3,f->id,a1,a2);
430:
431: case I_BOP: case I_COP: case I_LOP:
432: a1 = subst_in_fnode((FNODE)FA1(f),v,g);
433: a2 = subst_in_fnode((FNODE)FA2(f),v,g);
434: return mkfnode(4,f->id,FA0(f),a1,a2);
435:
436: /* ternary operators */
437: case I_CE:
438: a1 = subst_in_fnode((FNODE)FA0(f),v,g);
439: a2 = subst_in_fnode((FNODE)FA1(f),v,g);
440: a3 = subst_in_fnode((FNODE)FA2(f),v,g);
441: return mkfnode(5,f->id,a1,a2,a3);
442:
443: /* lists */
444: case I_LIST:
445: n = (NODE)FA0(f);
446: for ( t0 = 0; n; n = NEXT(n) ) {
447: NEXTNODE(t0,t);
448: BDY(t) = (pointer)subst_in_fnode(BDY(n),v,g);
449: }
450: if ( t0 )
451: NEXT(t) = 0;
452: return mkfnode(1,f->id,t0);
453:
454: /* function */
455: case I_FUNC:
456: a1 = subst_in_fnode((FNODE)FA1(f),v,g);
457: return mkfnode(2,f->id,FA0(f),a1);
458: break;
459: case I_CAR: case I_CDR:
460: a1 = subst_in_fnode((FNODE)FA0(f),v,g);
461: return mkfnode(1,f->id,a1);
462: case I_EV:
463: /* exponent vector */
464: a1 = subst_in_fnode(mkfnode(1,I_LIST,FA0(f)),v,g);
465: return mkfnode(1,f->id,a1);
466:
467: case I_STR:
468: return f;
469:
470: case I_FORMULA:
471: obj = (Obj)FA0(f);
472: if ( !obj )
473: return f;
474:
475: switch ( OID(obj) ) {
476: case O_N:
477: return f;
478: case O_P:
479: vf = VR((P)obj);
480: dc = DC((P)obj);
481: if ( vf != v )
482: return f;
483: else if ( UNIQ(DEG(dc)) && UNIQ((Q)COEF(dc)) )
484: return g;
485: else break;
486: default:
487: break;
488: }
489:
490: default:
491: error("subst_in_fnode : not implemented yet");
1.14 noro 492: /* NOTREACHED */
493: return 0;
1.4 noro 494: }
1.1 noro 495: }
1.8 noro 496:
1.14 noro 497: /* not completed yet */
498:
499: #if 0
500: char *get_attribute(char *key,LIST attr)
1.8 noro 501: {}
502:
1.14 noro 503: void treetofnode(Obj obj,FNODE *f)
1.8 noro 504: {
505: NODE n;
506: LIST attr;
507: char *prop;
508:
509: if ( obj || OID(obj) != O_LIST ) {
510: /* internal object */
511: *f = mkfnode(1,I_FORMULA,obj);
512: } else {
513: /* [attr(list),name(string),args(node)] */
514: n = BDY((LIST)obj);
515: attr = (LIST)BDY(n); n = NEXT(n);
516: prop = get_attribute("asir",attr);
517: if ( !strcmp(prop,"u_op") ) {
518: } else if ( !strcmp(prop,"b_op") ) {
519: } else if ( !strcmp(prop,"t_op") ) {
520: } else if ( !strcmp(prop,"function") ) {
521: }
522: /* default will be set to P_FUNC */
523: }
524: }
1.14 noro 525: #endif
1.8 noro 526:
1.11 noro 527: FUNC user_print_function;
528:
1.14 noro 529: void Pset_print_function(NODE arg,pointer *rp)
1.11 noro 530: {
531: if ( !arg )
532: user_print_function = 0;
533: else {
534: gen_searchf(BDY((STRING)ARG0(arg)),&user_print_function);
535: }
536: *rp = 0;
537: }