=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2000/parse/eval.c,v retrieving revision 1.44 retrieving revision 1.60 diff -u -p -r1.44 -r1.60 --- OpenXM_contrib2/asir2000/parse/eval.c 2005/09/21 23:39:32 1.44 +++ OpenXM_contrib2/asir2000/parse/eval.c 2006/02/25 06:33:31 1.60 @@ -45,7 +45,7 @@ * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE, * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE. * - * $OpenXM: OpenXM_contrib2/asir2000/parse/eval.c,v 1.43 2005/09/14 02:48:38 noro Exp $ + * $OpenXM: OpenXM_contrib2/asir2000/parse/eval.c,v 1.59 2005/12/11 07:21:43 noro Exp $ */ #include #include "ca.h" @@ -59,12 +59,16 @@ #endif extern JMP_BUF timer_env; +extern FUNC cur_binf; +extern NODE PVSS; int f_break,f_return,f_continue; int evalstatline; int recv_intr; int show_crossref; +int at_root; void gen_searchf_searchonly(char *name,FUNC *r); +LIST eval_arg(FNODE a,unsigned int quote); pointer eval(FNODE f) { @@ -72,7 +76,7 @@ pointer eval(FNODE f) STRING str; pointer val = 0; pointer a,a1,a2; - NODE tn,ind,match; + NODE tn,tn1,ind,match; R u; DP dp; unsigned int pv; @@ -115,6 +119,16 @@ pointer eval(FNODE f) a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f)); (*((ARF)FA0(f))->fp)(CO,a1,a2,&val); break; + case I_NARYOP: + tn = (NODE)FA1(f); + a = eval((FNODE)BDY(tn)); + for ( tn = NEXT(tn); tn; tn = NEXT(tn) ) { + a1 = eval((FNODE)BDY(tn)); + (*((ARF)FA0(f))->fp)(CO,a,a1,&a2); + a = a2; + } + val = a; + break; case I_COP: a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f)); c = arf_comp(CO,a1,a2); @@ -168,6 +182,9 @@ pointer eval(FNODE f) val = evalf((FUNC)FA0(f),(FNODE)FA1(f),0); break; case I_FUNC_OPT: val = evalf((FUNC)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break; + case I_FUNC_QARG: + tn = BDY(eval_arg((FNODE)FA1(f),(unsigned int)0xffffffff)); + val = bevalf((FUNC)FA0(f),tn); break; case I_PFDERIV: val = evalf_deriv((FUNC)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break; case I_MAP: @@ -290,6 +307,14 @@ pointer eval(FNODE f) val = FA0(f); break; case I_LIST: evalnodebody((NODE)FA0(f),&tn); MKLIST(t,tn); val = (pointer)t; break; + case I_CONS: + evalnodebody((NODE)FA0(f),&tn); a2 = eval(FA1(f)); + if ( !a2 || OID(a2) != O_LIST ) + error("cons : invalid argument"); + for ( tn1 = tn; NEXT(tn1); tn1 = NEXT(tn1) ); + NEXT(tn1) = BDY((LIST)a2); + MKLIST(t,tn); val = (pointer)t; + break; case I_NEWCOMP: newstruct((int)FA0(f),(struct oCOMP **)&val); break; case I_CAR: @@ -333,6 +358,352 @@ pointer eval(FNODE f) return ( val ); } +NODE fnode_to_nary_node(NODE); +NODE fnode_to_bin_node(NODE,int); + +FNODE fnode_to_nary(FNODE f) +{ + FNODE a0,a1,a2; + NODE n,t,t0; + pointer val; + char *op; + + if ( !f ) + return f; + switch ( f->id ) { + case I_NARYOP: + n = fnode_to_nary_node((NODE)FA1(f)); + return mkfnode(2,I_NARYOP,FA0(f),n); + + case I_BOP: + a1 = fnode_to_nary((FNODE)FA1(f)); + a2 = fnode_to_nary((FNODE)FA2(f)); + op = ((ARF)FA0(f))->name; + if ( !strcmp(op,"+") || !strcmp(op,"*") ) { + if ( a1->id == I_NARYOP && !strcmp(op,((ARF)FA0(a1))->name) ) { + for ( n = (NODE)FA1(a1); NEXT(n); n = NEXT(n) ); + if ( a2->id == I_NARYOP && !strcmp(op,((ARF)FA0(a2))->name) ) + NEXT(n) = (NODE)FA1(a2); + else + MKNODE(NEXT(n),a2,0); + return a1; + } else if ( a2->id == I_NARYOP && !strcmp(op,((ARF)FA0(a2))->name) ) { + MKNODE(t,a1,(NODE)FA1(a2)); + return mkfnode(2,I_NARYOP,FA0(f),t); + } else { + t = mknode(2,a1,a2); + return mkfnode(2,I_NARYOP,FA0(f),t); + } + } else + return mkfnode(3,f->id,FA0(f),a1,a2); + + case I_NOT: case I_PAREN: case I_MINUS: + case I_CAR: case I_CDR: + a0 = fnode_to_nary((FNODE)FA0(f)); + return mkfnode(1,f->id,a0); + + case I_COP: case I_LOP: + a1 = fnode_to_nary((FNODE)FA1(f)); + a2 = fnode_to_nary((FNODE)FA2(f)); + return mkfnode(3,f->id,FA0(f),a1,a2); + + case I_AND: case I_OR: + a0 = fnode_to_nary((FNODE)FA0(f)); + a1 = fnode_to_nary((FNODE)FA1(f)); + return mkfnode(2,f->id,a0,a1); + + /* ternary operators */ + case I_CE: + a0 = fnode_to_nary((FNODE)FA0(f)); + a1 = fnode_to_nary((FNODE)FA1(f)); + a2 = fnode_to_nary((FNODE)FA2(f)); + return mkfnode(3,f->id,a0,a1,a2); + break; + + /* function */ + case I_FUNC: + a1 = fnode_to_nary((FNODE)FA1(f)); + return mkfnode(2,f->id,FA0(f),a1); + + case I_LIST: case I_EV: + n = fnode_to_nary_node((NODE)FA0(f)); + return mkfnode(1,f->id,n); + + case I_STR: case I_FORMULA: case I_PVAR: + return f; + + default: + error("fnode_to_nary : not implemented yet"); + } +} + +FNODE fnode_to_bin(FNODE f,int dir) +{ + FNODE a0,a1,a2; + NODE n,t; + pointer val; + ARF fun; + int len,i; + FNODE *arg; + + if ( !f ) + return f; + switch ( f->id ) { + case I_NARYOP: + fun = (ARF)FA0(f); + len = length((NODE)FA1(f)); + if ( len==1 ) return BDY((NODE)(FA1(f))); + + arg = (FNODE *)ALLOCA(len*sizeof(FNODE)); + for ( i = 0, t = (NODE)FA1(f); i < len; i++, t = NEXT(t) ) + arg[i] = fnode_to_bin((FNODE)BDY(t),dir); + if ( dir ) { + a2 = mkfnode(3,I_BOP,fun,arg[len-2],arg[len-1]); + for ( i = len-3; i >= 0; i-- ) + a2 = mkfnode(3,I_BOP,fun,arg[i],a2); + } else { + a2 = mkfnode(3,I_BOP,fun,arg[0],arg[1]); + for ( i = 2; i < len; i++ ) + a2 = mkfnode(3,I_BOP,fun,a2,arg[i]); + } + return a2; + + case I_NOT: case I_PAREN: case I_MINUS: + case I_CAR: case I_CDR: + a0 = fnode_to_bin((FNODE)FA0(f),dir); + return mkfnode(1,f->id,a0); + + case I_BOP: case I_COP: case I_LOP: + a1 = fnode_to_bin((FNODE)FA1(f),dir); + a2 = fnode_to_bin((FNODE)FA2(f),dir); + return mkfnode(3,f->id,FA0(f),a1,a2); + + case I_AND: case I_OR: + a0 = fnode_to_bin((FNODE)FA0(f),dir); + a1 = fnode_to_bin((FNODE)FA1(f),dir); + return mkfnode(2,f->id,a0,a1); + + /* ternary operators */ + case I_CE: + a0 = fnode_to_bin((FNODE)FA0(f),dir); + a1 = fnode_to_bin((FNODE)FA1(f),dir); + a2 = fnode_to_bin((FNODE)FA2(f),dir); + return mkfnode(3,f->id,a0,a1,a2); + break; + + /* function */ + case I_FUNC: + a1 = fnode_to_bin((FNODE)FA1(f),dir); + return mkfnode(2,f->id,FA0(f),a1); + + case I_LIST: case I_EV: + n = fnode_to_bin_node((NODE)FA0(f),dir); + return mkfnode(1,f->id,n); + + case I_STR: case I_FORMULA: case I_PVAR: + return f; + + default: + error("fnode_to_bin : not implemented yet"); + } +} + +NODE partial_eval_node(NODE n); +FNODE partial_eval(FNODE f); + +FNODE partial_eval(FNODE f) +{ + FNODE a0,a1,a2; + NODE n; + Obj obj; + QUOTE q; + pointer val; + FUNC func; + + if ( !f ) + return f; + switch ( f->id ) { + case I_NOT: case I_PAREN: case I_MINUS: + case I_CAR: case I_CDR: + a0 = partial_eval((FNODE)FA0(f)); + return mkfnode(1,f->id,a0); + + case I_BOP: case I_COP: case I_LOP: + a1 = partial_eval((FNODE)FA1(f)); + a2 = partial_eval((FNODE)FA2(f)); + return mkfnode(3,f->id,FA0(f),a1,a2); + + case I_NARYOP: + n = partial_eval_node((NODE)FA1(f)); + return mkfnode(2,f->id,FA0(f),n); + + case I_AND: case I_OR: + a0 = partial_eval((FNODE)FA0(f)); + a1 = partial_eval((FNODE)FA1(f)); + return mkfnode(2,f->id,a0,a1); + + /* ternary operators */ + case I_CE: + a0 = partial_eval((FNODE)FA0(f)); + a1 = partial_eval((FNODE)FA1(f)); + a2 = partial_eval((FNODE)FA2(f)); + return mkfnode(3,f->id,a0,a1,a2); + break; + + /* XXX : function is evaluated with QUOTE args */ + case I_FUNC: + a1 = partial_eval((FNODE)FA1(f)); + func = (FUNC)FA0(f); + if ( func->id == A_UNDEF || func->id != A_USR ) { + a1 = mkfnode(2,I_FUNC,func,a1); + return a1; + } else { + n = BDY(eval_arg(a1,(unsigned int)0xffffffff)); + obj = bevalf(func,n); + objtoquote(obj,&q); + return BDY(q); + } + break; + + case I_LIST: case I_EV: + n = partial_eval_node((NODE)FA0(f)); + return mkfnode(1,f->id,n); + + case I_STR: case I_FORMULA: + return f; + + /* program variable */ + case I_PVAR: + val = eval(f); + if ( val && OID((Obj)val) == O_QUOTE ) + return partial_eval((FNODE)BDY((QUOTE)val)); + else + return mkfnode(1,I_FORMULA,val); + + default: + error("partial_eval : not implemented yet"); + } +} + +NODE partial_eval_node(NODE n) +{ + NODE r0,r,t; + + for ( r0 = 0, t = n; t; t = NEXT(t) ) { + NEXTNODE(r0,r); + BDY(r) = partial_eval((FNODE)BDY(t)); + } + if ( r0 ) NEXT(r) = 0; + return r0; +} + +NODE rewrite_fnode_node(NODE n,NODE arg,int qarg); +FNODE rewrite_fnode(FNODE f,NODE arg,int qarg); + +FNODE rewrite_fnode(FNODE f,NODE arg,int qarg) +{ + FNODE a0,a1,a2,value; + NODE n,t,pair; + pointer val; + int pv,ind; + + if ( !f ) + return f; + switch ( f->id ) { + case I_NOT: case I_PAREN: case I_MINUS: + case I_CAR: case I_CDR: + a0 = rewrite_fnode((FNODE)FA0(f),arg,qarg); + return mkfnode(1,f->id,a0); + + case I_BOP: case I_COP: case I_LOP: + a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg); + a2 = rewrite_fnode((FNODE)FA2(f),arg,qarg); + return mkfnode(3,f->id,FA0(f),a1,a2); + + case I_AND: case I_OR: + a0 = rewrite_fnode((FNODE)FA0(f),arg,qarg); + a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg); + return mkfnode(2,f->id,a0,a1); + + /* ternary operators */ + case I_CE: + a0 = rewrite_fnode((FNODE)FA0(f),arg,qarg); + a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg); + a2 = rewrite_fnode((FNODE)FA2(f),arg,qarg); + return mkfnode(3,f->id,a0,a1,a2); + break; + + /* nary operators */ + case I_NARYOP: + n = rewrite_fnode_node((NODE)FA1(f),arg,qarg); + return mkfnode(2,f->id,FA0(f),n); + + /* and function */ + case I_FUNC: + a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg); + return mkfnode(2,qarg?I_FUNC_QARG:f->id,FA0(f),a1); + + case I_LIST: case I_EV: + n = rewrite_fnode_node((NODE)FA0(f),arg,qarg); + return mkfnode(1,f->id,n); + + case I_STR: case I_FORMULA: + return f; + + /* program variable */ + case I_PVAR: + pv = (int)FA0(f); + for ( t = arg; t; t = NEXT(t) ) { + pair = (NODE)BDY(t); + ind = (int)BDY(pair); + value = (FNODE)BDY(NEXT(pair)); + if ( pv == ind ) + return value; + } + return f; + break; + + default: + error("rewrite_fnode : not implemented yet"); + } +} + +NODE rewrite_fnode_node(NODE n,NODE arg,int qarg) +{ + NODE r0,r,t; + + for ( r0 = 0, t = n; t; t = NEXT(t) ) { + NEXTNODE(r0,r); + BDY(r) = rewrite_fnode((FNODE)BDY(t),arg,qarg); + } + if ( r0 ) NEXT(r) = 0; + return r0; +} + +NODE fnode_to_nary_node(NODE n) +{ + NODE r0,r,t; + + for ( r0 = 0, t = n; t; t = NEXT(t) ) { + NEXTNODE(r0,r); + BDY(r) = fnode_to_nary((FNODE)BDY(t)); + } + if ( r0 ) NEXT(r) = 0; + return r0; +} + +NODE fnode_to_bin_node(NODE n,int dir) +{ + NODE r0,r,t; + + for ( r0 = 0, t = n; t; t = NEXT(t) ) { + NEXTNODE(r0,r); + BDY(r) = fnode_to_bin((FNODE)BDY(t),dir); + } + if ( r0 ) NEXT(r) = 0; + return r0; +} + V searchvar(char *name); pointer evalstat(SNODE f) @@ -353,6 +724,7 @@ pointer evalstat(SNODE f) bp(f); } evalstatline = f->ln; + if ( !PVSS ) at_root = evalstatline; switch ( f->id ) { case S_BP: @@ -466,8 +838,6 @@ pointer evalnode(NODE node) return ( val ); } -extern FUNC cur_binf; -extern NODE PVSS; LIST eval_arg(FNODE a,unsigned int quote) { @@ -840,14 +1210,17 @@ pointer bevalf(FUNC f,NODE a) pointer evalif(FNODE f,FNODE a) { Obj g; + QUOTE q; FNODE t; + LIST l; g = (Obj)eval(f); if ( g && (OID(g) == O_P) && (VR((P)g)->attr == (pointer)V_SR) ) return evalf((FUNC)VR((P)g)->priv,a,0); else if ( g && OID(g) == O_QUOTEARG && ((QUOTEARG)g)->type == A_func ) { t = mkfnode(2,I_FUNC,((QUOTEARG)g)->body,a); - return eval(t); + MKQUOTE(q,t); + return q; } else { error("invalid function pointer"); /* NOTREACHED */ @@ -858,7 +1231,7 @@ pointer evalif(FNODE f,FNODE a) pointer evalpf(PF pf,NODE args,NODE dargs) { Obj s,s1; - int i; + int i,di,j; NODE node,dnode; PFINS ins; PFAD ad; @@ -877,8 +1250,16 @@ pointer evalpf(PF pf,NODE args,NODE dargs) } simplify_ins(ins,&s); } else { - for ( i = 0, s = pf->body, node = args; - node; node = NEXT(node), i++ ) { + s = pf->body; + if ( dnode ) { + for ( i = 0, dnode = dargs; dnode; dnode = NEXT(dnode), i++ ) { + di = QTOS((Q)dnode->body); + for ( j = 0; j < di; j++ ) { + derivr(CO,s,pf->args[i],&s1); s = s1; + } + } + } + for ( i = 0, node = args; node; node = NEXT(node), i++ ) { substr(CO,0,s,pf->args[i],(Obj)node->body,&s1); s = s1; } }