===================================================================
RCS file: /home/cvs/OpenXM_contrib2/asir2000/parse/eval.c,v
retrieving revision 1.50
retrieving revision 1.61
diff -u -p -r1.50 -r1.61
--- OpenXM_contrib2/asir2000/parse/eval.c	2005/10/05 09:39:13	1.50
+++ OpenXM_contrib2/asir2000/parse/eval.c	2007/11/15 06:24:59	1.61
@@ -45,13 +45,14 @@
  * 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.49 2005/10/05 07:38:08 noro Exp $ 
+ * $OpenXM: OpenXM_contrib2/asir2000/parse/eval.c,v 1.60 2006/02/25 06:33:31 noro Exp $ 
 */
 #include <ctype.h>
 #include "ca.h"
 #include "al.h"
 #include "base.h"
 #include "parse.h"
+#include "gc.h"
 #include <sys/types.h>
 #include <sys/stat.h>
 #if defined(PARI)
@@ -59,12 +60,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 +183,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:
@@ -351,10 +359,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 +373,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 +400,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 +453,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 +471,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 +516,10 @@ FNODE partial_eval(FNODE f)
 {
 	FNODE a0,a1,a2;
 	NODE n;
+	Obj obj;
+	QUOTE q;
 	pointer val;
+	FUNC func;
 
 	if ( !f )
 		return f;
@@ -538,10 +551,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));
@@ -575,10 +598,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;
@@ -590,34 +613,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;
 
-		/* function */
+		/* 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);
-			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:
@@ -628,7 +656,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;
 			}
@@ -640,37 +669,37 @@ 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;
 }
 
-NODE quote_to_nary_node(NODE n)
+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_nary((FNODE)BDY(t));
+		BDY(r) = fnode_to_nary((FNODE)BDY(t));
 	}
 	if ( r0 ) NEXT(r) = 0;
 	return r0;
 }
 
-NODE quote_to_bin_node(NODE n,int dir)
+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) = quote_to_bin((FNODE)BDY(t),dir);
+		BDY(r) = fnode_to_bin((FNODE)BDY(t),dir);
 	}
 	if ( r0 ) NEXT(r) = 0;
 	return r0;
@@ -696,6 +725,7 @@ pointer evalstat(SNODE f)
 		bp(f);
 	}
 	evalstatline = f->ln;
+	if ( !PVSS ) at_root = evalstatline;
 
 	switch ( f->id ) {
 		case S_BP:
@@ -809,8 +839,6 @@ pointer evalnode(NODE node)
 	return ( val );
 }
 
-extern FUNC cur_binf;
-extern NODE PVSS;
 
 LIST eval_arg(FNODE a,unsigned int quote)
 {
@@ -911,8 +939,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
@@ -1204,7 +1239,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;
@@ -1223,8 +1258,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;
 		}
 	}