===================================================================
RCS file: /home/cvs/OpenXM_contrib2/asir2000/parse/eval.c,v
retrieving revision 1.57
retrieving revision 1.78
diff -u -p -r1.57 -r1.78
--- OpenXM_contrib2/asir2000/parse/eval.c	2005/12/10 14:14:15	1.57
+++ OpenXM_contrib2/asir2000/parse/eval.c	2018/03/27 06:29:19	1.78
@@ -45,26 +45,29 @@
  * 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.56 2005/12/09 08:10:44 noro Exp $ 
+ * $OpenXM: OpenXM_contrib2/asir2000/parse/eval.c,v 1.77 2017/08/31 02:36:21 noro Exp $ 
 */
 #include <ctype.h>
 #include "ca.h"
 #include "al.h"
 #include "base.h"
 #include "parse.h"
+#if defined(GC7)
+#include "gc.h"
+#endif
 #include <sys/types.h>
 #include <sys/stat.h>
-#if defined(PARI)
-#include "genpari.h"
-#endif
 
 extern JMP_BUF timer_env;
+extern FUNC cur_binf;
+extern NODE PVSS;
+extern int evalef;
 
 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)
@@ -77,7 +80,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;
@@ -89,17 +92,8 @@ pointer eval(FNODE f)
 	RANGE range;
 	QUOTE expr,pattern;
 
-#if defined(VISUAL)
-	if ( recv_intr ) {
-#include <signal.h>
-		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 );
@@ -175,6 +169,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:
@@ -189,8 +186,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;
@@ -301,7 +298,8 @@ pointer eval(FNODE f)
 		case I_STR:
 			MKSTR(str,FA0(f)); val = (pointer)str; break;
 		case I_FORMULA:
-			 val = FA0(f); break;
+			val = FA0(f); 
+			break;
 		case I_LIST:
 			evalnodebody((NODE)FA0(f),&tn); MKLIST(t,tn); val = (pointer)t; break;
 		case I_CONS:
@@ -547,15 +545,16 @@ FNODE partial_eval(FNODE f)
 			return mkfnode(3,f->id,a0,a1,a2);
 			break;
 
-		/* XXX : function is evaluated */
-		case I_FUNC: case I_FUNC_QARG:
+		/* XXX : function is evaluated with QUOTE args */
+		case I_FUNC:
 			a1 = partial_eval((FNODE)FA1(f));
 			func = (FUNC)FA0(f);
-			a1 =  mkfnode(2,I_FUNC,func,a1);
-			if ( f->id == I_FUNC_QARG || func->id == A_UNDEF )
+			if ( func->id == A_UNDEF || func->id != A_USR ) {
+				a1 =  mkfnode(2,I_FUNC,func,a1);
 				return a1;
-			else {
-				obj = eval(a1);
+			} else {
+				n = BDY(eval_arg(a1,(unsigned int)0xffffffff));
+				obj = bevalf(func,n);
 				objtoquote(obj,&q);
 				return BDY(q);
 			}
@@ -720,20 +719,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; 
@@ -833,8 +827,6 @@ pointer evalnode(NODE node)
 	return ( val );
 }
 
-extern FUNC cur_binf;
-extern NODE PVSS;
 
 LIST eval_arg(FNODE a,unsigned int quote)
 {
@@ -876,7 +868,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);
@@ -911,6 +903,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 {
@@ -929,14 +922,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
@@ -976,6 +974,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;
@@ -984,6 +983,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);
@@ -1152,6 +1153,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);
@@ -1184,6 +1186,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;
@@ -1204,8 +1207,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;
@@ -1213,7 +1295,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);
@@ -1248,7 +1330,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++ ) {
@@ -1339,10 +1421,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;
@@ -1556,7 +1637,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);