=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2000/parse/eval.c,v retrieving revision 1.46 retrieving revision 1.62 diff -u -p -r1.46 -r1.62 --- OpenXM_contrib2/asir2000/parse/eval.c 2005/09/28 08:08:34 1.46 +++ OpenXM_contrib2/asir2000/parse/eval.c 2007/12/20 03:31:01 1.62 @@ -45,13 +45,16 @@ * 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.45 2005/09/27 03:00:21 noro Exp $ + * $OpenXM: OpenXM_contrib2/asir2000/parse/eval.c,v 1.61 2007/11/15 06:24:59 ohara Exp $ */ #include #include "ca.h" #include "al.h" #include "base.h" #include "parse.h" +#if defined(GC7) +#include "gc.h" +#endif #include #include #if defined(PARI) @@ -59,12 +62,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 +79,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; @@ -178,6 +185,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: @@ -300,6 +310,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: @@ -343,35 +361,38 @@ pointer eval(FNODE f) return ( val ); } -NODE quote_bin_to_nary_node(NODE); -NODE quote_nary_to_bin_node(NODE,int); +NODE fnode_to_nary_node(NODE); +NODE fnode_to_bin_node(NODE,int); -FNODE quote_bin_to_nary(FNODE f) +FNODE fnode_to_nary(FNODE f) { FNODE a0,a1,a2; - NODE n,t; + 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 = quote_bin_to_nary((FNODE)FA1(f)); - a2 = quote_bin_to_nary((FNODE)FA2(f)); + 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 ( t = (NODE)FA1(a1); NEXT(t); t = NEXT(t)); + for ( n = (NODE)FA1(a1); NEXT(n); n = NEXT(n) ); if ( a2->id == I_NARYOP && !strcmp(op,((ARF)FA0(a2))->name) ) - NEXT(t) = (NODE)FA1(a2); + NEXT(n) = (NODE)FA1(a2); else - MKNODE(NEXT(t),a2,0); + 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)); - FA1(a2) = (pointer)t; - return a2; + return mkfnode(2,I_NARYOP,FA0(f),t); } else { t = mknode(2,a1,a2); return mkfnode(2,I_NARYOP,FA0(f),t); @@ -381,45 +402,45 @@ FNODE quote_bin_to_nary(FNODE f) case I_NOT: case I_PAREN: case I_MINUS: case I_CAR: case I_CDR: - a0 = quote_bin_to_nary((FNODE)FA0(f)); + a0 = fnode_to_nary((FNODE)FA0(f)); return mkfnode(1,f->id,a0); case I_COP: case I_LOP: - a1 = quote_bin_to_nary((FNODE)FA1(f)); - a2 = quote_bin_to_nary((FNODE)FA2(f)); + 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 = quote_bin_to_nary((FNODE)FA0(f)); - a1 = quote_bin_to_nary((FNODE)FA1(f)); + 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 = quote_bin_to_nary((FNODE)FA0(f)); - a1 = quote_bin_to_nary((FNODE)FA1(f)); - a2 = quote_bin_to_nary((FNODE)FA2(f)); + 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 = quote_bin_to_nary((FNODE)FA1(f)); + a1 = fnode_to_nary((FNODE)FA1(f)); return mkfnode(2,f->id,FA0(f),a1); case I_LIST: case I_EV: - n = quote_bin_to_nary_node((NODE)FA0(f)); + 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("quote_bin_to_nary : not implemented yet"); + error("fnode_to_nary : not implemented yet"); } } -FNODE quote_nary_to_bin(FNODE f,int dir) +FNODE fnode_to_bin(FNODE f,int dir) { FNODE a0,a1,a2; NODE n,t; @@ -434,9 +455,11 @@ FNODE quote_nary_to_bin(FNODE f,int dir) 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] = quote_nary_to_bin((FNODE)BDY(t),dir); + 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-- ) @@ -450,41 +473,41 @@ FNODE quote_nary_to_bin(FNODE f,int dir) case I_NOT: case I_PAREN: case I_MINUS: case I_CAR: case I_CDR: - a0 = quote_nary_to_bin((FNODE)FA0(f),dir); + a0 = fnode_to_bin((FNODE)FA0(f),dir); return mkfnode(1,f->id,a0); case I_BOP: case I_COP: case I_LOP: - a1 = quote_nary_to_bin((FNODE)FA1(f),dir); - a2 = quote_nary_to_bin((FNODE)FA2(f),dir); + 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 = quote_nary_to_bin((FNODE)FA0(f),dir); - a1 = quote_nary_to_bin((FNODE)FA1(f),dir); + 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 = quote_nary_to_bin((FNODE)FA0(f),dir); - a1 = quote_nary_to_bin((FNODE)FA1(f),dir); - a2 = quote_nary_to_bin((FNODE)FA2(f),dir); + 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 = quote_nary_to_bin((FNODE)FA1(f),dir); + a1 = fnode_to_bin((FNODE)FA1(f),dir); return mkfnode(2,f->id,FA0(f),a1); case I_LIST: case I_EV: - n = quote_nary_to_bin_node((NODE)FA0(f),dir); + 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("quote_nary_to_bin : not implemented yet"); + error("fnode_to_bin : not implemented yet"); } } @@ -495,7 +518,10 @@ FNODE partial_eval(FNODE f) { FNODE a0,a1,a2; NODE n; + Obj obj; + QUOTE q; pointer val; + FUNC func; if ( !f ) return f; @@ -510,6 +536,10 @@ FNODE partial_eval(FNODE 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)); @@ -523,10 +553,20 @@ FNODE partial_eval(FNODE f) return mkfnode(3,f->id,a0,a1,a2); break; - /* function */ + /* XXX : function is evaluated with QUOTE args */ case I_FUNC: a1 = partial_eval((FNODE)FA1(f)); - return mkfnode(2,f->id,FA0(f),a1); + 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)); @@ -560,30 +600,113 @@ NODE partial_eval_node(NODE n) return r0; } -NODE quote_bin_to_nary_node(NODE n) +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) = quote_bin_to_nary((FNODE)BDY(t)); + BDY(r) = rewrite_fnode((FNODE)BDY(t),arg,qarg); } if ( r0 ) NEXT(r) = 0; return r0; } -NODE quote_nary_to_bin_node(NODE n,int dir) +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) = quote_nary_to_bin((FNODE)BDY(t),dir); + 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) @@ -604,6 +727,7 @@ pointer evalstat(SNODE f) bp(f); } evalstatline = f->ln; + if ( !PVSS ) at_root = evalstatline; switch ( f->id ) { case S_BP: @@ -717,8 +841,6 @@ pointer evalnode(NODE node) return ( val ); } -extern FUNC cur_binf; -extern NODE PVSS; LIST eval_arg(FNODE a,unsigned int quote) { @@ -819,8 +941,15 @@ pointer evalf(FUNC f,FNODE a,FNODE opt) getrlimit(RLIMIT_STACK,&rl); stack_size = rl.rlim_cur; } - if ( !stack_base ) - stack_base = (void *)GC_get_stack_base(); + if ( !stack_base ) { +#if defined(GC7) + struct GC_stack_base sb; + GC_get_stack_base(&sb); + stack_base = (void *)sb.mem_base; +#else + stack_base = (void *)GC_get_stack_base(); +#endif + } if ( (stack_base - (void *)&args) +0x100000 > stack_size ) error("stack overflow"); #endif @@ -1091,14 +1220,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 */ @@ -1109,7 +1241,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; @@ -1128,8 +1260,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; } }