===================================================================
RCS file: /home/cvs/OpenXM_contrib2/asir2000/parse/eval.c,v
retrieving revision 1.53
retrieving revision 1.73
diff -u -p -r1.53 -r1.73
--- OpenXM_contrib2/asir2000/parse/eval.c	2005/10/19 14:09:13	1.53
+++ OpenXM_contrib2/asir2000/parse/eval.c	2015/08/08 14:19:42	1.73
@@ -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.52 2005/10/19 04:52:59 noro Exp $ 
+ * $OpenXM: OpenXM_contrib2/asir2000/parse/eval.c,v 1.72 2015/08/06 10:01:53 fujimoto 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;
 
 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 <signal.h>
 		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;
@@ -508,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;
@@ -540,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));
@@ -577,10 +597,10 @@ NODE partial_eval_node(NODE n)
 	return r0;
 }
 
-NODE rewrite_fnode_node(NODE n,NODE arg);
-FNODE rewrite_fnode(FNODE f,NODE arg);
+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)
+FNODE rewrite_fnode(FNODE f,NODE arg,int qarg)
 {
 	FNODE a0,a1,a2,value;
 	NODE n,t,pair;
@@ -592,39 +612,39 @@ FNODE rewrite_fnode(FNODE f,NODE arg)
 	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);
+			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);
-			a2 = rewrite_fnode((FNODE)FA2(f),arg);
+			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);
-			a1 = rewrite_fnode((FNODE)FA1(f),arg);
+			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);
-			a1 = rewrite_fnode((FNODE)FA1(f),arg);
-			a2 = rewrite_fnode((FNODE)FA2(f),arg);
+			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);
+			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);
-			return mkfnode(2,f->id,FA0(f),a1);
+			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);
+			n = rewrite_fnode_node((NODE)FA0(f),arg,qarg);
 			return mkfnode(1,f->id,n);
 
 		case I_STR: case I_FORMULA:
@@ -635,7 +655,8 @@ FNODE rewrite_fnode(FNODE f,NODE arg)
 			pv = (int)FA0(f);
 			for ( t = arg; t; t = NEXT(t) ) {
 				pair = (NODE)BDY(t);
-				ind = (int)BDY(pair); value = (FNODE)BDY(NEXT(pair));
+				ind = (int)BDY(pair);
+				value = (FNODE)BDY(NEXT(pair));
 				if ( pv == ind )
 					return value;
 			}
@@ -647,13 +668,13 @@ FNODE rewrite_fnode(FNODE f,NODE arg)
 	}
 }
 
-NODE rewrite_fnode_node(NODE n,NODE arg)
+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) = rewrite_fnode((FNODE)BDY(t),arg);
+		BDY(r) = rewrite_fnode((FNODE)BDY(t),arg,qarg);
 	}
 	if ( r0 ) NEXT(r) = 0;
 	return r0;
@@ -703,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; 
@@ -816,8 +832,6 @@ pointer evalnode(NODE node)
 	return ( val );
 }
 
-extern FUNC cur_binf;
-extern NODE PVSS;
 
 LIST eval_arg(FNODE a,unsigned int quote)
 {
@@ -859,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);
@@ -894,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 {
@@ -912,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
@@ -959,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;
@@ -967,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);
@@ -1135,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);
@@ -1167,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;
@@ -1187,8 +1212,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;
@@ -1196,7 +1300,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);
@@ -1211,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;
@@ -1230,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;
 		}
 	}
@@ -1314,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;
@@ -1481,6 +1592,9 @@ void mkuf(char *name,char *fname,NODE args,SNODE body,
 	CPVS = GPVS;
 	CUR_FUNC = 0;
 	clearbp(f);
+#if defined(__MINGW32__) || defined(__MINGW64__)
+	fflush(stderr);
+#endif
 }
 
 /*