===================================================================
RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/print.c,v
retrieving revision 1.11
retrieving revision 1.24
diff -u -p -r1.11 -r1.24
--- OpenXM_contrib2/asir2000/builtin/print.c	2001/09/04 03:12:20	1.11
+++ OpenXM_contrib2/asir2000/builtin/print.c	2007/11/22 05:14:48	1.24
@@ -45,58 +45,107 @@
  * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
  * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
  *
- * $OpenXM: OpenXM_contrib2/asir2000/builtin/print.c,v 1.10 2001/09/04 02:45:32 noro Exp $ 
+ * $OpenXM: OpenXM_contrib2/asir2000/builtin/print.c,v 1.23 2007/11/07 19:26:17 ohara Exp $ 
 */
 #include "ca.h"
 #include "parse.h"
 
+void Pprintf();
 void Pprint();
 void Pquotetolist();
+void Pobjtoquote();
 void Peval_variables_in_quote();
 void Pset_print_function();
-FNODE eval_pvar_in_fnode();
 
 struct ftab print_tab[] = {
+	{"printf",Pprintf,-99999999},
 	{"print",Pprint,-2},
+	{"objtoquote",Pobjtoquote,1},
 	{"quotetolist",Pquotetolist,1},
 	{"eval_variables_in_quote",Peval_variables_in_quote,1},
 	{"set_print_function",Pset_print_function,-1},
 	{0,0,0},
 };
 
-void Pprint(arg,rp)
-NODE arg;
-pointer *rp;
+extern int I_am_server;
+
+int wfep_mode;
+
+void Pprintf(NODE arg,pointer *rp)
 {
-	printexpr(CO,ARG0(arg)); 
-	if ( argc(arg) == 2 )
-		switch ( QTOS((Q)ARG1(arg)) ) {
-			case 0:
-				break;
-			case 2:
-				fflush(asir_out); break;
-				break;
-			case 1: default:
-				putc('\n',asir_out); break;
+	STRING s;
+	if ( arg ) {
+		Psprintf(arg,&s);
+		/* engine for wfep */
+		if ( wfep_mode ) {
+			print_to_wfep(s);
+		}else {
+			printexpr(CO,s);
+			fflush(asir_out);
 		}
-	else
-		putc('\n',asir_out);
+	}
 	*rp = 0;
+	return;
 }
 
-void fnodetotree();
+void Pprint(NODE arg,pointer *rp)
+{
+	Obj obj;
+	STRING nl;
+	Q opt;
 
-void Pquotetolist(arg,rp)
-NODE arg;
-Obj *rp;
+	/* engine for wfep */
+	if ( wfep_mode ) {
+		if ( arg ) {
+			print_to_wfep((Obj)ARG0(arg));
+			if ( !NEXT(arg) || ARG1(arg) ) {
+				MKSTR(nl,"\r\n");
+				print_to_wfep((Obj)nl);
+			}
+		}
+		*rp = 0;
+		return;
+	}
+	if ( arg ) {
+		obj = (Obj)ARG0(arg);
+		if ( NEXT(arg) ) {
+			opt = (Q)ARG1(arg);
+			if ( INT(opt) ) {
+				printexpr(CO,obj);
+				switch ( QTOS(opt) ) {
+					case 0:
+						break;
+					case 2:
+						fflush(asir_out); break;
+						break;
+					case 1: default:
+						putc('\n',asir_out); break;
+				}
+			} else
+				error("print : invalid argument");
+		} else {
+			printexpr(CO,obj);
+			putc('\n',asir_out);
+		}
+	}
+	/* XXX : if ox_asir, we have to fflush always */
+	if ( I_am_server )
+		fflush(asir_out);
+	*rp = 0;
+}
+
+void Pobjtoquote(NODE arg,QUOTE *rp)
 {
+	objtoquote(ARG0(arg),rp);
+}
+
+void Pquotetolist(NODE arg,LIST *rp)
+{
 	asir_assert(ARG0(arg),O_QUOTE,"quotetolist");	
 	fnodetotree((FNODE)BDY((QUOTE)(ARG0(arg))),rp);
 }
 
-void Peval_variables_in_quote(arg,rp)
-NODE arg;
-QUOTE *rp;
+void Peval_variables_in_quote(NODE arg,QUOTE *rp)
 {
 	FNODE fn;
 
@@ -107,26 +156,22 @@ QUOTE *rp;
 
 /* fnode -> [tag,name,arg0,arg1,...] */
 
-void fnodetotree(f,rp)
-FNODE f;
-Obj *rp;
+void fnodetotree(FNODE f,LIST *rp)
 {
-	Obj a1,a2,a3;
+	LIST a1,a2,a3;
 	NODE n,t,t0;
 	STRING head,op,str;
-	LIST r,arg;
 	char *opname;
 
 	if ( !f ) {
 		MKSTR(head,"internal");
 		n = mknode(2,head,0);
-		MKLIST(r,n);
-		*rp = (Obj)r;
+		MKLIST(*rp,n);
 		return;
 	}
 	switch ( f->id ) {
 		/* unary operators */
-		case I_NOT: case I_PAREN:
+		case I_NOT: case I_PAREN: case I_MINUS:
 			MKSTR(head,"u_op");
 			switch ( f->id ) {
 				case I_NOT:
@@ -135,11 +180,13 @@ Obj *rp;
 				case I_PAREN:
 					MKSTR(op,"()");
 					break;
+				case I_MINUS:
+					MKSTR(op,"-");
+					break;
 			}
 			fnodetotree((FNODE)FA0(f),&a1);
 			n = mknode(3,head,op,a1);
-			MKLIST(r,n);
-			*rp = (Obj)r;
+			MKLIST(*rp,n);
 			break;
 
 		/* binary operators */
@@ -191,8 +238,7 @@ Obj *rp;
 							MKSTR(head,"u_op");
 							MKSTR(op,opname);
 							n = mknode(3,head,op,a1);
-							MKLIST(r,n);
-							*rp = (Obj)r;
+							MKLIST(*rp,n);
 							return;
 					}
 					MKSTR(op,opname); break;
@@ -204,10 +250,24 @@ Obj *rp;
 					MKSTR(op,"||"); break;
 			}
 			n = mknode(4,head,op,a1,a2);
-			MKLIST(r,n);
-			*rp = (Obj)r;
+			MKLIST(*rp,n);
 			break;
 
+		case I_NARYOP: 
+			/* head */
+			MKSTR(head,"n_op");
+			n = (NODE)FA1(f);
+			for ( t0 = 0; n; n = NEXT(n) ) {
+				NEXTNODE(t0,t);
+				fnodetotree((FNODE)BDY(n),&a1);
+				BDY(t) = (pointer)a1;
+			}
+			MKSTR(op,((ARF)FA0(f))->name);
+			MKNODE(t,op,t0);
+			MKNODE(n,head,t);
+			MKLIST(*rp,n);
+			break;
+
 		/* ternary operators */
 		case I_CE:
 			MKSTR(head,"t_op");
@@ -216,8 +276,7 @@ Obj *rp;
 			fnodetotree((FNODE)FA1(f),&a2);
 			fnodetotree((FNODE)FA2(f),&a3);
 			n = mknode(5,head,op,a1,a2,a3);
-			MKLIST(r,n);
-			*rp = (Obj)r;
+			MKLIST(*rp,n);
 			break;
 
 		/* lists */
@@ -225,58 +284,55 @@ Obj *rp;
 			n = (NODE)FA0(f);
 			for ( t0 = 0; n; n = NEXT(n) ) {
 				NEXTNODE(t0,t);
-				fnodetotree(BDY(n),&BDY(t));
+				fnodetotree((FNODE)BDY(n),&a1);
+				BDY(t) = (pointer)a1;
 			}
 			if ( t0 )
 				NEXT(t) = 0;
 			MKSTR(head,"list");
 			MKNODE(n,head,t0);
-			MKLIST(r,n);
-			*rp = (Obj)r;
+			MKLIST(*rp,n);
 			break;
 
 		/* function */
-		case I_FUNC: case I_CAR: case I_CDR: case I_EV:
+		case I_FUNC: case I_FUNC_QARG: case I_CAR: case I_CDR: case I_EV:
 			MKSTR(head,"function");
 			switch ( f->id ) {
-				case I_FUNC:
-					MKSTR(op,((FUNC)FA0(f))->name);
-					fnodetotree((FNODE)FA1(f),&arg);
+				case I_FUNC: case I_FUNC_QARG:
+					MKSTR(op,((FUNC)FA0(f))->fullname);
+					fnodetotree((FNODE)FA1(f),&a1);
 					break;
 				case I_CAR:
 					MKSTR(op,"car");
-					fnodetotree((FNODE)FA0(f),&arg);
+					fnodetotree((FNODE)FA0(f),&a1);
 					break;
 				case I_CDR:
 					MKSTR(op,"cdr");
-					fnodetotree((FNODE)FA0(f),&arg);
+					fnodetotree((FNODE)FA0(f),&a1);
 					break;
 				case I_EV:
 					/* exponent vector; should be treated as function call */
 					MKSTR(op,"exponent_vector");
-					fnodetotree(mkfnode(1,I_LIST,FA0(f)),&arg);
+					fnodetotree(mkfnode(1,I_LIST,FA0(f)),&a1);
 					break;
 			}
-			t0 = NEXT(BDY(arg)); /* XXX : skip the headers */
+			t0 = NEXT(BDY(a1)); /* XXX : skip the headers */
 			MKNODE(t,op,t0);
 			MKNODE(n,head,t);
-			MKLIST(r,n);
-			*rp = (Obj)r;
+			MKLIST(*rp,n);
 			break;
 
 		case I_STR:
 			MKSTR(head,"internal");
 			MKSTR(str,FA0(f));
 			n = mknode(2,head,str);
-			MKLIST(r,n);
-			*rp = (Obj)r;
+			MKLIST(*rp,n);
 			break;
 
 		case I_FORMULA:
 			MKSTR(head,"internal");
 			n = mknode(2,head,FA0(f));
-			MKLIST(r,n);
-			*rp = (Obj)r;
+			MKLIST(*rp,n);
 			break;
 
 		case I_PVAR:
@@ -286,8 +342,7 @@ Obj *rp;
 			GETPVNAME(FA0(f),opname);
 			MKSTR(op,opname);
 			n = mknode(2,head,op);
-			MKLIST(r,n);
-			*rp = (Obj)r;
+			MKLIST(*rp,n);
 			break;
 
 		default:
@@ -295,8 +350,7 @@ Obj *rp;
 	}
 }
 
-FNODE eval_pvar_in_fnode(f)
-FNODE f;
+FNODE eval_pvar_in_fnode(FNODE f)
 {
 	FNODE a1,a2,a3;
 	pointer r;
@@ -308,7 +362,7 @@ FNODE f;
 
 	switch ( f->id ) {
 		/* unary operators */
-		case I_NOT: case I_PAREN:
+		case I_NOT: case I_PAREN: case I_MINUS:
 			a1 = eval_pvar_in_fnode((FNODE)FA0(f));
 			return mkfnode(1,f->id,a1);
 
@@ -365,17 +419,107 @@ FNODE f;
 
 		default:
 			error("eval_pvar_in_fnode : not implemented yet");
+			/* NOTREACHED */
+			return 0;
 	}
 }
 
-char *get_attribute(key,attr)
-char *key;
-LIST attr;
+FNODE subst_in_fnode(FNODE f,V v,FNODE g)
+{
+	FNODE a1,a2,a3;
+	DCP dc;
+	V vf;
+	NODE n,t,t0;
+	Obj obj;
+
+	if ( !f )
+		return 0;
+
+	switch ( f->id ) {
+		/* unary operators */
+		case I_NOT: case I_PAREN: case I_MINUS:
+			a1 = subst_in_fnode((FNODE)FA0(f),v,g);
+			return mkfnode(1,f->id,a1);
+
+		/* binary operators */
+		case I_AND: case I_OR:
+			a1 = subst_in_fnode((FNODE)FA0(f),v,g);
+			a2 = subst_in_fnode((FNODE)FA1(f),v,g);
+			return mkfnode(3,f->id,a1,a2);
+
+		case I_BOP: case I_COP: case I_LOP: 
+			a1 = subst_in_fnode((FNODE)FA1(f),v,g);
+			a2 = subst_in_fnode((FNODE)FA2(f),v,g);
+			return mkfnode(4,f->id,FA0(f),a1,a2);
+
+		/* ternary operators */
+		case I_CE:
+			a1 = subst_in_fnode((FNODE)FA0(f),v,g);
+			a2 = subst_in_fnode((FNODE)FA1(f),v,g);
+			a3 = subst_in_fnode((FNODE)FA2(f),v,g);
+			return mkfnode(5,f->id,a1,a2,a3);
+
+		/* lists */
+		case I_LIST:
+			n = (NODE)FA0(f);
+			for ( t0 = 0; n; n = NEXT(n) ) {
+				NEXTNODE(t0,t);
+				BDY(t) = (pointer)subst_in_fnode(BDY(n),v,g);
+			}
+			if ( t0 )
+				NEXT(t) = 0;
+			return mkfnode(1,f->id,t0);
+
+		/* function */
+		case I_FUNC:
+			a1 = subst_in_fnode((FNODE)FA1(f),v,g);
+			return mkfnode(2,f->id,FA0(f),a1);
+			break;
+		case I_CAR: case I_CDR:
+			a1 = subst_in_fnode((FNODE)FA0(f),v,g);
+			return mkfnode(1,f->id,a1);
+		case I_EV:
+			/* exponent vector */
+			a1 = subst_in_fnode(mkfnode(1,I_LIST,FA0(f)),v,g);
+			return mkfnode(1,f->id,a1);
+
+		case I_STR:
+			return f;
+
+		case I_FORMULA:
+			obj = (Obj)FA0(f);
+			if ( !obj )
+				return f;
+
+			switch ( OID(obj) ) {
+				case O_N:
+					return f;
+				case O_P:
+					vf = VR((P)obj);
+					dc = DC((P)obj);
+					if ( vf != v )
+						return f;
+					else if ( UNIQ(DEG(dc)) && UNIQ((Q)COEF(dc)) )
+						return g;	
+					else break;
+				default:
+					break;
+			}
+
+		default:
+			error("subst_in_fnode : not implemented yet");
+			/* NOTREACHED */
+			return 0;
+	}
+}
+
+/* not completed yet */
+
+#if 0
+char *get_attribute(char *key,LIST attr)
 {}
 
-void treetofnode(obj,f)
-Obj obj;
-FNODE *f;
+void treetofnode(Obj obj,FNODE *f)
 {
 	NODE n;
 	LIST attr;
@@ -397,12 +541,11 @@ FNODE *f;
 			/* default will be set to P_FUNC */
 	}
 }
+#endif
 
 FUNC user_print_function;
 
-void Pset_print_function(arg,rp)
-NODE arg;
-pointer *rp;
+void Pset_print_function(NODE arg,pointer *rp)
 {
 	if ( !arg )
 		user_print_function = 0;