=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2000/parse/eval.c,v retrieving revision 1.48 retrieving revision 1.72 diff -u -p -r1.48 -r1.72 --- OpenXM_contrib2/asir2000/parse/eval.c 2005/09/30 01:35:25 1.48 +++ OpenXM_contrib2/asir2000/parse/eval.c 2015/08/06 10:01:53 1.72 @@ -45,26 +45,30 @@ * 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.71 2015/08/04 06:20:45 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) -#include "genpari.h" -#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; -void gen_searchf_searchonly(char *name,FUNC *r); +int at_root; +void gen_searchf_searchonly(char *name,FUNC *r,int global); +LIST eval_arg(FNODE a,unsigned int quote); pointer eval(FNODE f) { @@ -88,7 +92,7 @@ pointer eval(FNODE f) RANGE range; QUOTE expr,pattern; -#if defined(VISUAL) +#if defined(VISUAL) || defined(__MINGW32__) || defined(__MINGW64__) if ( recv_intr ) { #include if ( recv_intr == 1 ) { @@ -178,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: @@ -185,8 +192,8 @@ 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; -#if !defined(VISUAL) + val = evalif((FNODE)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break; +#if !defined(VISUAL) && !defined(__MINGW32__) && !defined(__MINGW64__) case I_TIMER: { int interval; @@ -351,10 +358,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 +372,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 +399,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 +452,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 +470,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 +515,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 +533,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 +550,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 +597,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,20 +724,15 @@ pointer evalstat(SNODE f) bp(f); } evalstatline = f->ln; + if ( !PVSS ) at_root = evalstatline; switch ( f->id ) { case S_BP: if ( !nextbp && (!FA1(f) || eval((FNODE)FA1(f))) ) { if ( (FNODE)FA2(f) ) { -#if defined(PARI) - pari_outfile = stderr; -#endif asir_out = stderr; printexpr(CO,eval((FNODE)FA2(f))); putc('\n',asir_out); fflush(asir_out); -#if defined(PARI) - pari_outfile = stdout; -#endif asir_out = stdout; } else { nextbp = 1; nextbplevel = 0; @@ -728,8 +832,6 @@ pointer evalnode(NODE node) return ( val ); } -extern FUNC cur_binf; -extern NODE PVSS; LIST eval_arg(FNODE a,unsigned int quote) { @@ -771,7 +873,7 @@ pointer evalf(FUNC f,FNODE a,FNODE opt) FUNC f1; if ( f->id == A_UNDEF ) { - gen_searchf_searchonly(f->fullname,&f1); + gen_searchf_searchonly(f->fullname,&f1,0); if ( f1->id == A_UNDEF ) { sprintf(errbuf,"evalf : %s undefined",NAME(f)); error(errbuf); @@ -806,6 +908,7 @@ pointer evalf(FUNC f,FNODE a,FNODE opt) } else opts = 0; if ( !n ) { + current_option = opts; cur_binf = f; (*f->f.binf)(&val); } else { @@ -824,14 +927,19 @@ pointer evalf(FUNC f,FNODE a,FNODE opt) break; case A_USR: /* stack check */ -#if !defined(VISUAL) && !defined(__CYGWIN__) +#if !defined(VISUAL) && !defined(__MINGW32__) && !defined(__MINGW64__) && !defined(__CYGWIN__) if ( !stack_size ) { struct rlimit rl; 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) + stack_base = (void *)GC_get_main_stack_base(); +#else + stack_base = (void *)GC_get_stack_base(); +#endif + } if ( (stack_base - (void *)&args) +0x100000 > stack_size ) error("stack overflow"); #endif @@ -871,6 +979,7 @@ pointer evalf(FUNC f,FNODE a,FNODE opt) for ( tn = f->f.usrf->args, sn = BDY(args); sn; tn = NEXT(tn), sn = NEXT(sn) ) ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn)); + f_return = f_break = f_continue = 0; if ( f->f.usrf->module ) { prev_mpvs = MPVS; MPVS = f->f.usrf->module->pvs; @@ -879,6 +988,8 @@ pointer evalf(FUNC f,FNODE a,FNODE opt) } else val = evalstat((SNODE)BDY(f->f.usrf)); f_return = f_break = f_continue = 0; poppvs(); + if ( PVSS ) + evalstatline = ((VS)BDY(PVSS))->at; break; case A_PURE: args = (LIST)eval(a); @@ -1047,6 +1158,7 @@ pointer bevalf(FUNC f,NODE a) } switch ( f->id ) { case A_BIN: + current_option = 0; if ( !n ) { cur_binf = f; (*f->f.binf)(&val); @@ -1079,6 +1191,7 @@ pointer bevalf(FUNC f,NODE a) for ( tn = f->f.usrf->args, sn = a; sn; tn = NEXT(tn), sn = NEXT(sn) ) ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn)); + f_return = f_break = f_continue = 0; if ( f->f.usrf->module ) { prev_mpvs = MPVS; MPVS = f->f.usrf->module->pvs; @@ -1099,17 +1212,99 @@ pointer bevalf(FUNC f,NODE a) return val; } -pointer evalif(FNODE f,FNODE a) +pointer bevalf_with_opts(FUNC f,NODE a,NODE opts) { + pointer val; + int i,n; + NODE tn,sn; + VS pvs,prev_mpvs; + char errbuf[BUFSIZ]; + + if ( f->id == A_UNDEF ) { + sprintf(errbuf,"bevalf : %s undefined",NAME(f)); + error(errbuf); + } + if ( getsecuremode() && !PVSS && !f->secure ) { + sprintf(errbuf,"bevalf : %s not permitted",NAME(f)); + error(errbuf); + } + if ( f->id != A_PARI ) { + for ( i = 0, tn = a; tn; i++, tn = NEXT(tn) ); + if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) { + sprintf(errbuf,"bevalf : argument mismatch in %s()",NAME(f)); + error(errbuf); + } + } + switch ( f->id ) { + case A_BIN: + current_option = opts; + if ( !n ) { + cur_binf = f; + (*f->f.binf)(&val); + } else { + cur_binf = f; + (*f->f.binf)(a,&val); + } + cur_binf = 0; + break; + case A_PARI: + cur_binf = f; + val = evalparif(f,a); + cur_binf = 0; + break; + case A_USR: + pvs = f->f.usrf->pvs; + if ( PVSS ) + ((VS)BDY(PVSS))->at = evalstatline; + MKNODE(tn,pvs,PVSS); PVSS = tn; + CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS; + CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n; + CPVS->opt = opts; + if ( CPVS->n ) { + CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV)); + bcopy((char *)pvs->va,(char *)CPVS->va, + (int)(pvs->n*sizeof(struct oPV))); + } + if ( nextbp ) + nextbplevel++; + for ( tn = f->f.usrf->args, sn = a; + sn; tn = NEXT(tn), sn = NEXT(sn) ) + ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn)); + f_return = f_break = f_continue = 0; + if ( f->f.usrf->module ) { + prev_mpvs = MPVS; + MPVS = f->f.usrf->module->pvs; + val = evalstat((SNODE)BDY(f->f.usrf)); + MPVS = prev_mpvs; + } else + val = evalstat((SNODE)BDY(f->f.usrf)); + f_return = f_break = f_continue = 0; poppvs(); + break; + case A_PURE: + val = evalpf(f->f.puref,a,0); + break; + default: + sprintf(errbuf,"bevalf : %s undefined",NAME(f)); + error(errbuf); + break; + } + return val; +} + +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 +1315,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 +1334,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 ( dargs ) { + 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; } } @@ -1223,10 +1426,9 @@ void gen_searchf(char *name,FUNC *r) *r = val; } -void gen_searchf_searchonly(char *name,FUNC *r) +void gen_searchf_searchonly(char *name,FUNC *r,int global) { FUNC val = 0; - int global = 0; if ( *name == ':' ) { global = 1; name += 2;