=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2000/parse/quote.c,v retrieving revision 1.15 retrieving revision 1.25 diff -u -p -r1.15 -r1.25 --- OpenXM_contrib2/asir2000/parse/quote.c 2004/07/08 02:58:19 1.15 +++ OpenXM_contrib2/asir2000/parse/quote.c 2005/09/30 02:20:06 1.25 @@ -1,4 +1,4 @@ -/* $OpenXM: OpenXM_contrib2/asir2000/parse/quote.c,v 1.14 2004/07/07 07:40:19 noro Exp $ */ +/* $OpenXM: OpenXM_contrib2/asir2000/parse/quote.c,v 1.24 2005/09/28 08:40:31 noro Exp $ */ #include "ca.h" #include "parse.h" @@ -6,7 +6,9 @@ void addquote(VL vl,QUOTE a,QUOTE b,QUOTE *c) { FNODE fn; + QUOTE t; + objtoquote((Obj)a,&t); a = t; objtoquote((Obj)b,&t); b = t; fn = mkfnode(3,I_BOP,addfs,BDY(a),BDY(b)); MKQUOTE(*c,fn); } @@ -14,7 +16,9 @@ void addquote(VL vl,QUOTE a,QUOTE b,QUOTE *c) void subquote(VL vl,QUOTE a,QUOTE b,QUOTE *c) { FNODE fn; + QUOTE t; + objtoquote((Obj)a,&t); a = t; objtoquote((Obj)b,&t); b = t; fn = mkfnode(3,I_BOP,subfs,BDY(a),BDY(b)); MKQUOTE(*c,fn); } @@ -22,7 +26,9 @@ void subquote(VL vl,QUOTE a,QUOTE b,QUOTE *c) void mulquote(VL vl,QUOTE a,QUOTE b,QUOTE *c) { FNODE fn; + QUOTE t; + objtoquote((Obj)a,&t); a = t; objtoquote((Obj)b,&t); b = t; fn = mkfnode(3,I_BOP,mulfs,BDY(a),BDY(b)); MKQUOTE(*c,fn); } @@ -30,7 +36,9 @@ void mulquote(VL vl,QUOTE a,QUOTE b,QUOTE *c) void divquote(VL vl,QUOTE a,QUOTE b,QUOTE *c) { FNODE fn; + QUOTE t; + objtoquote((Obj)a,&t); a = t; objtoquote((Obj)b,&t); b = t; fn = mkfnode(3,I_BOP,divfs,BDY(a),BDY(b)); MKQUOTE(*c,fn); } @@ -38,9 +46,9 @@ void divquote(VL vl,QUOTE a,QUOTE b,QUOTE *c) void pwrquote(VL vl,QUOTE a,QUOTE b,QUOTE *c) { FNODE fn; + QUOTE t; - if ( !b || OID(b) != O_QUOTE ) - error("pwrquote : invalid argument"); + objtoquote((Obj)a,&t); a = t; objtoquote((Obj)b,&t); b = t; fn = mkfnode(3,I_BOP,pwrfs,BDY(a),BDY(b)); MKQUOTE(*c,fn); } @@ -48,8 +56,10 @@ void pwrquote(VL vl,QUOTE a,QUOTE b,QUOTE *c) void chsgnquote(QUOTE a,QUOTE *c) { FNODE fn; + QUOTE t; - fn = mkfnode(3,I_BOP,subfs,0,BDY(a)); + objtoquote((Obj)a,&t); a = t; + fn = mkfnode(1,I_MINUS,BDY(a)); MKQUOTE(*c,fn); } @@ -318,13 +328,12 @@ void vartoquote(V v,QUOTE *c) if ( x && OID(x)==O_P && !NEXT(DC(x)) && UNIQ(DEG(DC(x))) && UNIQ(COEF(DC(x))) ) { /* use a as is */ - u = a; } else { /* a => (a) */ - MKQUOTE(u,mkfnode(1,I_PAREN,BDY(a))); + MKQUOTE(u,mkfnode(1,I_PAREN,BDY(a))); a = u; } objtoquote(ad[1].arg,&b); - pwrquote(CO,u,b,c); + pwrquote(CO,a,b,c); } else { for ( i = 0; i < pf->argc; i++ ) if ( ad[i].d ) @@ -343,53 +352,57 @@ void vartoquote(V v,QUOTE *c) } } -typedef enum { - A_arg,A_arf,A_int,A_str,A_internal,A_node,A_notimpl,A_func,A_end -} farg_type; +/* + * A_arf : arithmetic function + * A_int : machine integer + * A_fnode : FNODE + * A_node : NODE with FNODE bodies + * A_internal : internal object + * A_str : string + * A_end : terminal + * A_func : FUNC + * A_notimpl : not implemented + */ -typedef struct fid_spec { - fid id; - farg_type type[10]; -} *fid_spec_p; - struct fid_spec fid_spec_tab[] = { - {I_BOP,A_arf,A_arg,A_arg,A_end}, - {I_COP,A_int,A_arg,A_arg,A_end}, - {I_AND,A_arg,A_arg,A_end}, - {I_OR,A_arg,A_arg,A_end}, - {I_NOT,A_arg,A_end}, - {I_CE,A_arg,A_arg,A_end}, - {I_PRESELF,A_arf,A_arg,A_end}, - {I_POSTSELF,A_arf,A_arg,A_end}, - {I_FUNC,A_func,A_arg,A_end}, - {I_FUNC_OPT,A_func,A_arg,A_arg,A_end}, - {I_IFUNC,A_arg,A_arg,A_end}, - {I_MAP,A_func,A_arg,A_end}, - {I_RECMAP,A_func,A_arg,A_end}, + {I_BOP,A_arf,A_fnode,A_fnode,A_end}, + {I_COP,A_int,A_fnode,A_fnode,A_end}, + {I_AND,A_fnode,A_fnode,A_end}, + {I_OR,A_fnode,A_fnode,A_end}, + {I_NOT,A_fnode,A_end}, + {I_CE,A_fnode,A_fnode,A_end}, + {I_PRESELF,A_arf,A_fnode,A_end}, + {I_POSTSELF,A_arf,A_fnode,A_end}, + {I_FUNC,A_func,A_fnode,A_end}, + {I_FUNC_OPT,A_func,A_fnode,A_fnode,A_end}, + {I_IFUNC,A_fnode,A_fnode,A_end}, + {I_MAP,A_func,A_fnode,A_end}, + {I_RECMAP,A_func,A_fnode,A_end}, {I_PFDERIV,A_notimpl,A_end}, {I_ANS,A_int,A_end}, {I_PVAR,A_int,A_node,A_end}, - {I_ASSPVAR,A_arg,A_arg,A_end}, + {I_ASSPVAR,A_fnode,A_fnode,A_end}, {I_FORMULA,A_internal,A_end}, {I_LIST,A_node,A_end}, {I_STR,A_str,A_end}, {I_NEWCOMP,A_int,A_end}, - {I_CAR,A_arg,A_end}, - {I_CDR,A_arg,A_end}, + {I_CAR,A_fnode,A_end}, + {I_CDR,A_fnode,A_end}, {I_CAST,A_notimpl,A_end}, - {I_INDEX,A_arg,A_node,A_end}, + {I_INDEX,A_fnode,A_node,A_end}, {I_EV,A_node,A_end}, - {I_TIMER,A_arg,A_arg,A_arg,A_end}, + {I_TIMER,A_fnode,A_fnode,A_fnode,A_end}, {I_GF2NGEN,A_end}, {I_GFPNGEN,A_end}, {I_GFSNGEN,A_end}, - {I_LOP,A_int,A_arg,A_arg,A_end}, - {I_OPT,A_str,A_arg,A_end}, + {I_LOP,A_int,A_fnode,A_fnode,A_end}, + {I_OPT,A_str,A_fnode,A_end}, {I_GETOPT,A_str,A_end}, - {I_POINT,A_arg,A_str,A_end}, - {I_PAREN,A_arg,A_end}, - {I_MINUS,A_arg,A_end}, - {I_NARYOP,A_notimpl,A_end} + {I_POINT,A_fnode,A_str,A_end}, + {I_PAREN,A_fnode,A_end}, + {I_MINUS,A_fnode,A_end}, + {I_NARYOP,A_arf,A_node,A_end}, + {I_CONS,A_node,A_fnode,A_end} }; #define N_FID_SPEC (sizeof(fid_spec_tab)/sizeof(struct fid_spec)) @@ -414,6 +427,22 @@ FNODE strip_paren(FNODE f) } } +NODE flatten_fnodenode(NODE n,char *opname); +FNODE flatten_fnode(FNODE f,char *opname); + +NODE flatten_fnodenode(NODE n,char *opname) +{ + NODE r0,r,t; + + r0 = 0; + for ( t = n; t; t = NEXT(t) ) { + NEXTNODE(r0,r); + BDY(r) = (pointer)flatten_fnode((FNODE)BDY(t),opname); + } + if ( r0 ) NEXT(r) = 0; + return r0; +} + FNODE flatten_fnode(FNODE f,char *opname) { fid_spec_p spec; @@ -433,9 +462,9 @@ FNODE flatten_fnode(FNODE f,char *opname) f2 = (pointer)flatten_fnode(FA2(f),opname); f2 = strip_paren(f2); if ( f1->id == I_BOP && !strcmp(((ARF)FA0(f1))->name,opname) ) { - /* [+ [+ A B] C] => [+ A [+ B C]] */ - return mkfnode(3,I_BOP,(ARF)FA0(f),FA1(f1), - mkfnode(3,I_BOP,(ARF)FA0(f),FA2(f1),f2)); + /* [op [op A B] C] => [op A [op B C]] */ + f2 = flatten_fnode(mkfnode(3,I_BOP,(ARF)FA0(f),FA2(f1),f2),opname); + return mkfnode(3,I_BOP,(ARF)FA0(f),FA1(f1),f2); } else return mkfnode(3,I_BOP,(ARF)FA0(f),f1,f2); } else { @@ -443,11 +472,101 @@ FNODE flatten_fnode(FNODE f,char *opname) for ( i = 0; type[i] != A_end; i++ ); NEWFNODE(r,i); ID(r) = f->id; for ( i = 0; type[i] != A_end; i++ ) { - if ( type[i] == A_arg ) + if ( type[i] == A_fnode ) r->arg[i] = (pointer)flatten_fnode(f->arg[i],opname); + else if ( type[i] == A_node ) + r->arg[i] = (pointer)flatten_fnodenode(f->arg[i],opname); else r->arg[i] = f->arg[i]; } return r; } +} + +/* comparison of QUOTE */ + +int compquote(VL vl,QUOTE q1,QUOTE q2) +{ + return compfnode(BDY(q1),BDY(q2)); +} + +/* comparison of QUOTEARG */ +/* XXX : executes a non-sense comparison for bodies */ + +int compqa(VL vl,QUOTEARG q1,QUOTEARG q2) +{ + if ( !q1 ) return q2?-1:0; + else if ( !q2 ) return 1; + else if ( OID(q1) > OID(q2) ) return 1; + else if ( OID(q1) < OID(q2) ) return -1; + else if ( q1->type > q2->type ) return 1; + else if ( q1->type < q2->type ) return -1; + else switch ( q1->type ) { + case A_func: + return strcmp(((FUNC)q1->body)->name,((FUNC)q2->body)->name); + case A_arf: + return strcmp(((ARF)q1->body)->name,((ARF)q2->body)->name); + default: + if ( (unsigned)q1->body > (unsigned)q2->body ) return 1; + else if ( (unsigned)q1->body < (unsigned)q2->body ) return -1; + else return 0; + } +} + +int compfnode(FNODE f1,FNODE f2) +{ + fid_spec_p spec; + int t,s1,s2,i; + NODE n1,n2; + + if ( !f1 ) return f2 ? -1 : 1; + else if ( !f2 ) return 1; + else if ( f1->id > f2->id ) return 1; + else if ( f1->id < f2->id ) return -1; + spec = fid_spec_tab+f1->id; + for ( i = 0; spec->type[i] != A_end; i++ ) { + switch ( spec->type[i] ) { + case A_fnode: + t = compfnode((FNODE)f1->arg[i],(FNODE)f2->arg[i]); + if ( t ) return t; + break; + case A_int: + s1 = (int)f1->arg[i]; + s2 = (int)f2->arg[i]; + if ( s1 > s2 ) return 1; + else if ( s1 < s2 ) return -1; + break; + case A_str: + t = strcmp((char *)f1->arg[i],(char *)f2->arg[i]); + if ( t ) return t; + break; + case A_internal: + t = arf_comp(CO,(Obj)f1->arg[i],(Obj)f2->arg[i]); + if ( t ) return t; + break; + case A_node: + n1 = (NODE)f1->arg[i]; + n2 = (NODE)f2->arg[i]; + for ( ; n1 && n2; n1 = NEXT(n1), n2 = NEXT(n2) ) { + t = compfnode(BDY(n1),BDY(n2)); + if ( t ) return t; + } + if ( n1 ) return 1; + else if ( n2 ) return -1; + break; + case A_arf: + t = strcmp(((ARF)f1->arg[i])->name,((ARF)f2->arg[i])->name); + if ( t ) return t; + break; + case A_func: + t = strcmp(((FUNC)f1->arg[i])->name,((FUNC)f2->arg[i])->name); + if ( t ) return t; + break; + case A_notimpl: + default: + error("compfnode : not implemented"); + break; + } + } + return 0; }