===================================================================
RCS file: /home/cvs/OpenXM_contrib2/asir2000/parse/eval.c,v
retrieving revision 1.55
retrieving revision 1.61
diff -u -p -r1.55 -r1.61
--- OpenXM_contrib2/asir2000/parse/eval.c	2005/12/02 07:13:19	1.55
+++ 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.54 2005/11/06 01:27:28 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:
@@ -511,6 +519,7 @@ FNODE partial_eval(FNODE f)
 	Obj obj;
 	QUOTE q;
 	pointer val;
+	FUNC func;
 
 	if ( !f )
 		return f;
@@ -542,13 +551,19 @@ FNODE partial_eval(FNODE f)
 			return mkfnode(3,f->id,a0,a1,a2);
 			break;
 
-		/* XXX : function is evaluated */
+		/* XXX : function is evaluated with QUOTE args */
 		case I_FUNC:
 			a1 = partial_eval((FNODE)FA1(f));
-			a1 =  mkfnode(2,f->id,FA0(f),a1);
-			obj = eval(a1);
-			objtoquote(obj,&q);
-			return BDY(q);
+			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:
@@ -583,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;
@@ -598,39 +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;
 
 		/* 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:
@@ -641,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;
 			}
@@ -653,13 +669,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;
@@ -709,6 +725,7 @@ pointer evalstat(SNODE f)
 		bp(f);
 	}
 	evalstatline = f->ln;
+	if ( !PVSS ) at_root = evalstatline;
 
 	switch ( f->id ) {
 		case S_BP:
@@ -822,8 +839,6 @@ pointer evalnode(NODE node)
 	return ( val );
 }
 
-extern FUNC cur_binf;
-extern NODE PVSS;
 
 LIST eval_arg(FNODE a,unsigned int quote)
 {
@@ -924,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