=================================================================== RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/print.c,v retrieving revision 1.8 retrieving revision 1.13 diff -u -p -r1.8 -r1.13 --- OpenXM_contrib2/asir2000/builtin/print.c 2001/08/31 09:17:12 1.8 +++ OpenXM_contrib2/asir2000/builtin/print.c 2001/09/05 09:01:27 1.13 @@ -45,17 +45,23 @@ * 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.7 2001/08/22 04:20:45 noro Exp $ + * $OpenXM: OpenXM_contrib2/asir2000/builtin/print.c,v 1.12 2001/09/05 04:43:58 noro Exp $ */ #include "ca.h" #include "parse.h" 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}, }; @@ -89,6 +95,17 @@ Obj *rp; fnodetotree((FNODE)BDY((QUOTE)(ARG0(arg))),rp); } +void Peval_variables_in_quote(arg,rp) +NODE arg; +QUOTE *rp; +{ + FNODE fn; + + asir_assert(ARG0(arg),O_QUOTE,"eval_variables_in_quote"); + fn = eval_pvar_in_fnode((FNODE)BDY((QUOTE)(ARG0(arg)))); + MKQUOTE(*rp,fn); +} + /* fnode -> [tag,name,arg0,arg1,...] */ void fnodetotree(f,rp) @@ -110,7 +127,7 @@ Obj *rp; } 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: @@ -119,6 +136,9 @@ 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); @@ -262,11 +282,188 @@ Obj *rp; MKLIST(r,n); *rp = (Obj)r; break; + + case I_PVAR: + if ( FA1(f) ) + error("fnodetotree : not implemented yet"); + MKSTR(head,"variable"); + GETPVNAME(FA0(f),opname); + MKSTR(op,opname); + n = mknode(2,head,op); + MKLIST(r,n); + *rp = (Obj)r; + break; + default: error("fnodetotree : not implemented yet"); } } +FNODE eval_pvar_in_fnode(f) +FNODE f; +{ + FNODE a1,a2,a3; + pointer r; + NODE n,t,t0; + QUOTE q; + + if ( !f ) + return 0; + + switch ( f->id ) { + /* unary operators */ + case I_NOT: case I_PAREN: case I_MINUS: + a1 = eval_pvar_in_fnode((FNODE)FA0(f)); + return mkfnode(1,f->id,a1); + + /* binary operators */ + case I_AND: case I_OR: + a1 = eval_pvar_in_fnode((FNODE)FA0(f)); + a2 = eval_pvar_in_fnode((FNODE)FA1(f)); + return mkfnode(3,f->id,a1,a2); + + case I_BOP: case I_COP: case I_LOP: + a1 = eval_pvar_in_fnode((FNODE)FA1(f)); + a2 = eval_pvar_in_fnode((FNODE)FA2(f)); + return mkfnode(4,f->id,FA0(f),a1,a2); + + /* ternary operators */ + case I_CE: + a1 = eval_pvar_in_fnode((FNODE)FA0(f)); + a2 = eval_pvar_in_fnode((FNODE)FA1(f)); + a3 = eval_pvar_in_fnode((FNODE)FA2(f)); + 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)eval_pvar_in_fnode(BDY(n)); + } + if ( t0 ) + NEXT(t) = 0; + return mkfnode(1,f->id,t0); + + /* function */ + case I_FUNC: + a1 = eval_pvar_in_fnode((FNODE)FA1(f)); + return mkfnode(2,f->id,FA0(f),a1); + break; + case I_CAR: case I_CDR: + a1 = eval_pvar_in_fnode((FNODE)FA0(f)); + return mkfnode(1,f->id,a1); + case I_EV: + /* exponent vector */ + a1 = eval_pvar_in_fnode(mkfnode(1,I_LIST,FA0(f))); + return mkfnode(1,f->id,a1); + + case I_STR: case I_FORMULA: + return f; + + case I_PVAR: case I_INDEX: + case I_POSTSELF: case I_PRESELF: + r = eval(f); + 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: 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"); + } +} + char *get_attribute(key,attr) char *key; LIST attr; @@ -297,3 +494,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; +}