===================================================================
RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/print.c,v
retrieving revision 1.9
retrieving revision 1.12
diff -u -p -r1.9 -r1.12
--- OpenXM_contrib2/asir2000/builtin/print.c	2001/09/03 08:52:38	1.9
+++ OpenXM_contrib2/asir2000/builtin/print.c	2001/09/05 04:43:58	1.12
@@ -45,7 +45,7 @@
  * 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.8 2001/08/31 09:17:12 noro Exp $ 
+ * $OpenXM: OpenXM_contrib2/asir2000/builtin/print.c,v 1.11 2001/09/04 03:12:20 noro Exp $ 
 */
 #include "ca.h"
 #include "parse.h"
@@ -53,12 +53,15 @@
 void Pprint();
 void Pquotetolist();
 void Peval_variables_in_quote();
+void Pset_print_function();
 FNODE eval_pvar_in_fnode();
+FNODE subst_in_fnode();
 
 struct ftab print_tab[] = {
 	{"print",Pprint,-2},
 	{"quotetolist",Pquotetolist,1},
 	{"eval_variables_in_quote",Peval_variables_in_quote,1},
+	{"set_print_function",Pset_print_function,-1},
 	{0,0,0},
 };
 
@@ -278,6 +281,8 @@ Obj *rp;
 			break;
 
 		case I_PVAR:
+			if ( FA1(f) )
+				error("fnodetotree : not implemented yet");
 			MKSTR(head,"variable");
 			GETPVNAME(FA0(f),opname);
 			MKSTR(op,opname);
@@ -297,6 +302,7 @@ FNODE f;
 	FNODE a1,a2,a3;
 	pointer r;
 	NODE n,t,t0;
+	QUOTE q;
 
 	if ( !f )
 		return 0;
@@ -355,13 +361,106 @@ FNODE f;
 		case I_PVAR: case I_INDEX:
 		case I_POSTSELF: case I_PRESELF:
 			r = eval(f);
-			return mkfnode(1,I_FORMULA,r);
+			objtoquote(r,&q);
+			return BDY(q);
 
 		default:
 			error("eval_pvar_in_fnode : not implemented yet");
 	}
 }
 
+FNODE subst_in_fnode(f,v,g)
+FNODE f;
+V v;
+FNODE g;
+{
+	FNODE a1,a2,a3;
+	DCP dc;
+	pointer r;
+	V vf;
+	NODE n,t,t0;
+	QUOTE q;
+	Obj obj;
+
+	if ( !f )
+		return 0;
+
+	switch ( f->id ) {
+		/* unary operators */
+		case I_NOT: case I_PAREN:
+			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");
+	}
+}
+
 char *get_attribute(key,attr)
 char *key;
 LIST attr;
@@ -392,3 +491,16 @@ FNODE *f;
 	}
 }
 
+FUNC user_print_function;
+
+void Pset_print_function(arg,rp)
+NODE arg;
+pointer *rp;
+{
+	if ( !arg )
+		user_print_function = 0;		
+	else {
+		gen_searchf(BDY((STRING)ARG0(arg)),&user_print_function);
+	}
+	*rp = 0;
+}