=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2000/parse/eval.c,v retrieving revision 1.48 retrieving revision 1.63 diff -u -p -r1.48 -r1.63 --- OpenXM_contrib2/asir2000/parse/eval.c 2005/09/30 01:35:25 1.48 +++ OpenXM_contrib2/asir2000/parse/eval.c 2008/09/01 06:20:33 1.63 @@ -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.47 2005/09/29 08:55:26 noro Exp $ + * $OpenXM: OpenXM_contrib2/asir2000/parse/eval.c,v 1.62 2007/12/20 03:31:01 noro 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) { @@ -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: @@ -185,7 +195,7 @@ pointer eval(FNODE f) case I_RECMAP: val = eval_rec_mapf((FUNC)FA0(f),(FNODE)FA1(f)); break; case I_IFUNC: - val = evalif((FNODE)FA0(f),(FNODE)FA1(f)); break; + val = evalif((FNODE)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break; #if !defined(VISUAL) case I_TIMER: { @@ -351,10 +361,10 @@ pointer eval(FNODE f) return ( val ); } -NODE quote_to_nary_node(NODE); -NODE quote_to_bin_node(NODE,int); +NODE fnode_to_nary_node(NODE); +NODE fnode_to_bin_node(NODE,int); -FNODE quote_to_nary(FNODE f) +FNODE fnode_to_nary(FNODE f) { FNODE a0,a1,a2; NODE n,t,t0; @@ -365,12 +375,12 @@ FNODE quote_to_nary(FNODE f) return f; switch ( f->id ) { case I_NARYOP: - n = quote_to_nary_node((NODE)FA1(f)); + n = fnode_to_nary_node((NODE)FA1(f)); return mkfnode(2,I_NARYOP,FA0(f),n); case I_BOP: - a1 = quote_to_nary((FNODE)FA1(f)); - a2 = quote_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) ) { @@ -392,45 +402,45 @@ FNODE quote_to_nary(FNODE f) case I_NOT: case I_PAREN: case I_MINUS: case I_CAR: case I_CDR: - a0 = quote_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_to_nary((FNODE)FA1(f)); - a2 = quote_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_to_nary((FNODE)FA0(f)); - a1 = quote_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_to_nary((FNODE)FA0(f)); - a1 = quote_to_nary((FNODE)FA1(f)); - a2 = quote_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_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_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_to_nary : not implemented yet"); + error("fnode_to_nary : not implemented yet"); } } -FNODE quote_to_bin(FNODE f,int dir) +FNODE fnode_to_bin(FNODE f,int dir) { FNODE a0,a1,a2; NODE n,t; @@ -445,9 +455,11 @@ FNODE quote_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_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-- ) @@ -461,41 +473,41 @@ FNODE quote_to_bin(FNODE f,int dir) case I_NOT: case I_PAREN: case I_MINUS: case I_CAR: case I_CDR: - a0 = quote_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_to_bin((FNODE)FA1(f),dir); - a2 = quote_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_to_bin((FNODE)FA0(f),dir); - a1 = quote_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_to_bin((FNODE)FA0(f),dir); - a1 = quote_to_bin((FNODE)FA1(f),dir); - a2 = quote_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_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_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_to_bin : not implemented yet"); + error("fnode_to_bin : not implemented yet"); } } @@ -506,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; @@ -521,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)); @@ -534,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)); @@ -571,30 +600,113 @@ NODE partial_eval_node(NODE n) return r0; } -NODE quote_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_to_nary((FNODE)BDY(t)); + BDY(r) = rewrite_fnode((FNODE)BDY(t),arg,qarg); } if ( r0 ) NEXT(r) = 0; return r0; } -NODE quote_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_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) @@ -615,6 +727,7 @@ pointer evalstat(SNODE f) bp(f); } evalstatline = f->ln; + if ( !PVSS ) at_root = evalstatline; switch ( f->id ) { case S_BP: @@ -728,8 +841,6 @@ pointer evalnode(NODE node) return ( val ); } -extern FUNC cur_binf; -extern NODE PVSS; LIST eval_arg(FNODE a,unsigned int quote) { @@ -830,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 @@ -1099,17 +1217,20 @@ pointer bevalf(FUNC f,NODE a) return val; } -pointer evalif(FNODE f,FNODE a) +pointer evalif(FNODE f,FNODE a,FNODE opt) { 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); + return evalf((FUNC)VR((P)g)->priv,a,opt); 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 */ @@ -1120,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; @@ -1139,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; } }