=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2000/parse/eval.c,v retrieving revision 1.60 retrieving revision 1.77 diff -u -p -r1.60 -r1.77 --- OpenXM_contrib2/asir2000/parse/eval.c 2006/02/25 06:33:31 1.60 +++ OpenXM_contrib2/asir2000/parse/eval.c 2017/08/31 02:36:21 1.77 @@ -45,18 +45,18 @@ * 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.59 2005/12/11 07:21:43 noro Exp $ + * $OpenXM: OpenXM_contrib2/asir2000/parse/eval.c,v 1.76 2017/02/07 08:30:31 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; @@ -64,10 +64,9 @@ 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); +void gen_searchf_searchonly(char *name,FUNC *r,int global); LIST eval_arg(FNODE a,unsigned int quote); pointer eval(FNODE f) @@ -80,7 +79,7 @@ pointer eval(FNODE f) R u; DP dp; unsigned int pv; - int c,ret; + int c,ret,pos; FNODE f1; UP2 up2; UP up; @@ -92,17 +91,8 @@ pointer eval(FNODE f) RANGE range; QUOTE expr,pattern; -#if defined(VISUAL) - if ( recv_intr ) { -#include - if ( recv_intr == 1 ) { - recv_intr = 0; - int_handler(SIGINT); - } else { - recv_intr = 0; - ox_usr1_handler(0); - } - } +#if defined(VISUAL) || defined(__MINGW32__) + check_intr(); #endif if ( !f ) return ( 0 ); @@ -178,6 +168,9 @@ pointer eval(FNODE f) case I_EV: evalnodebody((NODE)FA0(f),&tn); nodetod(tn,&dp); val = (pointer)dp; break; + case I_EVM: + evalnodebody((NODE)FA0(f),&tn); pos = eval((FNODE)FA1(f)); nodetodpm(tn,pos,&dp); val = (pointer)dp; + break; case I_FUNC: val = evalf((FUNC)FA0(f),(FNODE)FA1(f),0); break; case I_FUNC_OPT: @@ -192,8 +185,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__) case I_TIMER: { int interval; @@ -730,15 +723,9 @@ pointer evalstat(SNODE f) 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; @@ -879,7 +866,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); @@ -914,6 +901,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 { @@ -932,14 +920,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(__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 @@ -979,6 +972,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; @@ -987,6 +981,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); @@ -1155,6 +1151,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); @@ -1187,6 +1184,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; @@ -1207,8 +1205,87 @@ 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; @@ -1216,7 +1293,7 @@ pointer evalif(FNODE f,FNODE a) 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); MKQUOTE(q,t); @@ -1251,7 +1328,7 @@ pointer evalpf(PF pf,NODE args,NODE dargs) simplify_ins(ins,&s); } else { s = pf->body; - if ( dnode ) { + if ( dargs ) { for ( i = 0, dnode = dargs; dnode; dnode = NEXT(dnode), i++ ) { di = QTOS((Q)dnode->body); for ( j = 0; j < di; j++ ) { @@ -1342,10 +1419,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; @@ -1559,7 +1635,7 @@ MODULE mkmodule(char *name) mod->name = (char *)MALLOC_ATOMIC(len+1); strcpy(mod->name,name); mod->pvs = mpvs = (VS)MALLOC(sizeof(struct oVS)); - reallocarray((char **)&mpvs->va,(int *)&mpvs->asize, + asir_reallocarray((char **)&mpvs->va,(int *)&mpvs->asize, (int *)&mpvs->n,(int)sizeof(struct oPV)); mod->usrf_list = 0; MKNODE(m,mod,MODULE_LIST);