[BACK]Return to print.c CVS log [TXT][DIR] Up to [local] / OpenXM_contrib2 / asir2000 / builtin

Diff for /OpenXM_contrib2/asir2000/builtin/print.c between version 1.17 and 1.27

version 1.17, 2004/05/14 09:20:56 version 1.27, 2018/03/29 01:32:50
Line 45 
Line 45 
  * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,   * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
  * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.   * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
  *   *
  * $OpenXM: OpenXM_contrib2/asir2000/builtin/print.c,v 1.16 2004/03/03 01:16:28 noro Exp $   * $OpenXM: OpenXM_contrib2/asir2000/builtin/print.c,v 1.26 2015/03/15 19:31:30 ohara Exp $
 */  */
 #include "ca.h"  #include "ca.h"
 #include "parse.h"  #include "parse.h"
   
   void Psprintf(NODE,STRING *);
   
   void Pprintf();
 void Pprint();  void Pprint();
 void Pquotetolist();  void Pquotetolist();
 void Pobjtoquote();  void Pobjtoquote();
Line 57  void Peval_variables_in_quote();
Line 60  void Peval_variables_in_quote();
 void Pset_print_function();  void Pset_print_function();
   
 struct ftab print_tab[] = {  struct ftab print_tab[] = {
         {"print",Pprint,-2},    {"printf",Pprintf,-99999999},
         {"objtoquote",Pobjtoquote,1},    {"print",Pprint,-2},
         {"quotetolist",Pquotetolist,1},    {"objtoquote",Pobjtoquote,1},
         {"eval_variables_in_quote",Peval_variables_in_quote,1},    {"quotetolist",Pquotetolist,1},
         {"set_print_function",Pset_print_function,-1},    {"eval_variables_in_quote",Peval_variables_in_quote,1},
         {0,0,0},    {"set_print_function",Pset_print_function,-1},
     {0,0,0},
 };  };
   
   extern int I_am_server;
   
   int wfep_mode;
   
   void Pprintf(NODE arg,pointer *rp)
   {
     STRING s;
     if ( arg ) {
       Psprintf(arg,&s);
       /* engine for wfep */
       if ( wfep_mode ) {
         print_to_wfep(s);
       }else {
         printexpr(CO,s);
         fflush(asir_out);
       }
     }
     *rp = 0;
     return;
   }
   
 void Pprint(NODE arg,pointer *rp)  void Pprint(NODE arg,pointer *rp)
 {  {
         Obj obj;    Obj obj;
         Q opt;    STRING nl;
     Q opt;
   
         if ( arg ) {    /* engine for wfep */
                 obj = (Obj)ARG0(arg);    if ( wfep_mode ) {
                 if ( NEXT(arg) ) {      if ( arg ) {
                         opt = (Q)ARG1(arg);        print_to_wfep((Obj)ARG0(arg));
                         if ( INT(opt) ) {        if ( !NEXT(arg) || ARG1(arg) ) {
                                 printexpr(CO,obj);          MKSTR(nl,"\r\n");
                                 switch ( QTOS(opt) ) {          print_to_wfep((Obj)nl);
                                         case 0:        }
                                                 break;      }
                                         case 2:      *rp = 0;
                                                 fflush(asir_out); break;      return;
                                                 break;    }
                                         case 1: default:    if ( arg ) {
                                                 putc('\n',asir_out); break;      obj = (Obj)ARG0(arg);
                                 }      if ( NEXT(arg) ) {
                         } else        opt = (Q)ARG1(arg);
                                 error("print : invalid argument");        if ( INT(opt) ) {
                 } else {          printexpr(CO,obj);
                         printexpr(CO,obj);          switch ( QTOS(opt) ) {
                         putc('\n',asir_out);            case 0:
                 }              break;
         }            case 2:
         *rp = 0;              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)  void Pobjtoquote(NODE arg,QUOTE *rp)
 {  {
         objtoquote(ARG0(arg),rp);    objtoquote(ARG0(arg),rp);
 }  }
   
 void Pquotetolist(NODE arg,LIST *rp)  void Pquotetolist(NODE arg,LIST *rp)
 {  {
         asir_assert(ARG0(arg),O_QUOTE,"quotetolist");    asir_assert(ARG0(arg),O_QUOTE,"quotetolist");
         fnodetotree((FNODE)BDY((QUOTE)(ARG0(arg))),rp);    fnodetotree((FNODE)BDY((QUOTE)(ARG0(arg))),rp);
 }  }
   
 void Peval_variables_in_quote(NODE arg,QUOTE *rp)  void Peval_variables_in_quote(NODE arg,QUOTE *rp)
 {  {
         FNODE fn;    FNODE fn;
   
         asir_assert(ARG0(arg),O_QUOTE,"eval_variables_in_quote");    asir_assert(ARG0(arg),O_QUOTE,"eval_variables_in_quote");
         fn = eval_pvar_in_fnode((FNODE)BDY((QUOTE)(ARG0(arg))));    fn = eval_pvar_in_fnode((FNODE)BDY((QUOTE)(ARG0(arg))));
         MKQUOTE(*rp,fn);    MKQUOTE(*rp,fn);
 }  }
   
 /* fnode -> [tag,name,arg0,arg1,...] */  /* fnode -> [tag,name,arg0,arg1,...] */
   
 void fnodetotree(FNODE f,LIST *rp)  void fnodetotree(FNODE f,LIST *rp)
 {  {
         LIST a1,a2,a3;    LIST a1,a2,a3;
         NODE n,t,t0;    NODE n,t,t0;
         STRING head,op,str;    STRING head,op,str;
         char *opname;    char *opname;
   
         if ( !f ) {    if ( !f ) {
                 MKSTR(head,"internal");      MKSTR(head,"internal");
                 n = mknode(2,head,0);      n = mknode(2,head,NULLP);
                 MKLIST(*rp,n);      MKLIST(*rp,n);
                 return;      return;
         }    }
         switch ( f->id ) {    switch ( f->id ) {
                 /* unary operators */      /* unary operators */
                 case I_NOT: case I_PAREN: case I_MINUS:      case I_NOT: case I_PAREN: case I_MINUS:
                         MKSTR(head,"u_op");        MKSTR(head,"u_op");
                         switch ( f->id ) {        switch ( f->id ) {
                                 case I_NOT:          case I_NOT:
                                         MKSTR(op,"!");            MKSTR(op,"!");
                                         break;            break;
                                 case I_PAREN:          case I_PAREN:
                                         MKSTR(op,"()");            MKSTR(op,"()");
                                         break;            break;
                                 case I_MINUS:          case I_MINUS:
                                         MKSTR(op,"-");            MKSTR(op,"-");
                                         break;            break;
                         }        }
                         fnodetotree((FNODE)FA0(f),&a1);        fnodetotree((FNODE)FA0(f),&a1);
                         n = mknode(3,head,op,a1);        n = mknode(3,head,op,a1);
                         MKLIST(*rp,n);        MKLIST(*rp,n);
                         break;        break;
   
                 /* binary operators */      /* binary operators */
                 case I_BOP: case I_COP: case I_LOP: case I_AND: case I_OR:      case I_BOP: case I_COP: case I_LOP: case I_AND: case I_OR:
                         /* head */        /* head */
                         MKSTR(head,"b_op");        MKSTR(head,"b_op");
   
                         /* arg list */        /* arg list */
                         switch ( f->id ) {        switch ( f->id ) {
                                 case I_AND: case I_OR:          case I_AND: case I_OR:
                                         fnodetotree((FNODE)FA0(f),&a1);            fnodetotree((FNODE)FA0(f),&a1);
                                         fnodetotree((FNODE)FA1(f),&a2);            fnodetotree((FNODE)FA1(f),&a2);
                                         break;            break;
                                 default:          default:
                                         fnodetotree((FNODE)FA1(f),&a1);            fnodetotree((FNODE)FA1(f),&a1);
                                         fnodetotree((FNODE)FA2(f),&a2);            fnodetotree((FNODE)FA2(f),&a2);
                                         break;            break;
                         }        }
   
                         /* op */        /* op */
                         switch ( f->id ) {        switch ( f->id ) {
                                 case I_BOP:          case I_BOP:
                                         MKSTR(op,((ARF)FA0(f))->name); break;            MKSTR(op,((ARF)FA0(f))->name); break;
   
                                 case I_COP:          case I_COP:
                                         switch( (cid)FA0(f) ) {            switch( (cid)FA0(f) ) {
                                                 case C_EQ: opname = "=="; break;              case C_EQ: opname = "=="; break;
                                                 case C_NE: opname = "!="; break;              case C_NE: opname = "!="; break;
                                                 case C_GT: opname = ">"; break;              case C_GT: opname = ">"; break;
                                                 case C_LT: opname = "<"; break;              case C_LT: opname = "<"; break;
                                                 case C_GE: opname = ">="; break;              case C_GE: opname = ">="; break;
                                                 case C_LE: opname = "<="; break;              case C_LE: opname = "<="; break;
                                         }            }
                                         MKSTR(op,opname); break;            MKSTR(op,opname); break;
   
                                 case I_LOP:          case I_LOP:
                                         switch( (lid)FA0(f) ) {            switch( (lid)FA0(f) ) {
                                                 case L_EQ: opname = "@=="; break;              case L_EQ: opname = "@=="; break;
                                                 case L_NE: opname = "@!="; break;              case L_NE: opname = "@!="; break;
                                                 case L_GT: opname = "@>"; break;              case L_GT: opname = "@>"; break;
                                                 case L_LT: opname = "@<"; break;              case L_LT: opname = "@<"; break;
                                                 case L_GE: opname = "@>="; break;              case L_GE: opname = "@>="; break;
                                                 case L_LE: opname = "@<="; break;              case L_LE: opname = "@<="; break;
                                                 case L_AND: opname = "@&&"; break;              case L_AND: opname = "@&&"; break;
                                                 case L_OR: opname = "@||"; break;              case L_OR: opname = "@||"; break;
   
                                                 case L_NOT: opname = "@!";              case L_NOT: opname = "@!";
                                                         /* XXX : L_NOT is a unary operator */                /* XXX : L_NOT is a unary operator */
                                                         MKSTR(head,"u_op");                MKSTR(head,"u_op");
                                                         MKSTR(op,opname);                MKSTR(op,opname);
                                                         n = mknode(3,head,op,a1);                n = mknode(3,head,op,a1);
                                                         MKLIST(*rp,n);                MKLIST(*rp,n);
                                                         return;                return;
                                         }            }
                                         MKSTR(op,opname); break;            MKSTR(op,opname); break;
   
                                 case I_AND:          case I_AND:
                                         MKSTR(op,"&&"); break;            MKSTR(op,"&&"); break;
   
                                 case I_OR:          case I_OR:
                                         MKSTR(op,"||"); break;            MKSTR(op,"||"); break;
                         }        }
                         n = mknode(4,head,op,a1,a2);        n = mknode(4,head,op,a1,a2);
                         MKLIST(*rp,n);        MKLIST(*rp,n);
                         break;        break;
   
                 /* ternary operators */      case I_NARYOP:
                 case I_CE:        /* head */
                         MKSTR(head,"t_op");        MKSTR(head,"n_op");
                         MKSTR(op,"?:");        n = (NODE)FA1(f);
                         fnodetotree((FNODE)FA0(f),&a1);        for ( t0 = 0; n; n = NEXT(n) ) {
                         fnodetotree((FNODE)FA1(f),&a2);          NEXTNODE(t0,t);
                         fnodetotree((FNODE)FA2(f),&a3);          fnodetotree((FNODE)BDY(n),&a1);
                         n = mknode(5,head,op,a1,a2,a3);          BDY(t) = (pointer)a1;
                         MKLIST(*rp,n);        }
                         break;        MKSTR(op,((ARF)FA0(f))->name);
         MKNODE(t,op,t0);
         MKNODE(n,head,t);
         MKLIST(*rp,n);
         break;
   
                 /* lists */      /* ternary operators */
                 case I_LIST:      case I_CE:
                         n = (NODE)FA0(f);        MKSTR(head,"t_op");
                         for ( t0 = 0; n; n = NEXT(n) ) {        MKSTR(op,"?:");
                                 NEXTNODE(t0,t);        fnodetotree((FNODE)FA0(f),&a1);
                                 fnodetotree((FNODE)BDY(n),&a1);        fnodetotree((FNODE)FA1(f),&a2);
                                 BDY(t) = (pointer)a1;        fnodetotree((FNODE)FA2(f),&a3);
                         }        n = mknode(5,head,op,a1,a2,a3);
                         if ( t0 )        MKLIST(*rp,n);
                                 NEXT(t) = 0;        break;
                         MKSTR(head,"list");  
                         MKNODE(n,head,t0);  
                         MKLIST(*rp,n);  
                         break;  
   
                 /* function */      /* lists */
                 case I_FUNC: case I_CAR: case I_CDR: case I_EV:      case I_LIST:
                         MKSTR(head,"function");        n = (NODE)FA0(f);
                         switch ( f->id ) {        for ( t0 = 0; n; n = NEXT(n) ) {
                                 case I_FUNC:          NEXTNODE(t0,t);
                                         MKSTR(op,((FUNC)FA0(f))->name);          fnodetotree((FNODE)BDY(n),&a1);
                                         fnodetotree((FNODE)FA1(f),&a1);          BDY(t) = (pointer)a1;
                                         break;        }
                                 case I_CAR:        if ( t0 )
                                         MKSTR(op,"car");          NEXT(t) = 0;
                                         fnodetotree((FNODE)FA0(f),&a1);        MKSTR(head,"list");
                                         break;        MKNODE(n,head,t0);
                                 case I_CDR:        MKLIST(*rp,n);
                                         MKSTR(op,"cdr");        break;
                                         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)),&a1);  
                                         break;  
                         }  
                         t0 = NEXT(BDY(a1)); /* XXX : skip the headers */  
                         MKNODE(t,op,t0);  
                         MKNODE(n,head,t);  
                         MKLIST(*rp,n);  
                         break;  
   
                 case I_STR:      /* function */
                         MKSTR(head,"internal");      case I_FUNC: case I_FUNC_QARG: case I_CAR: case I_CDR: case I_EV:
                         MKSTR(str,FA0(f));        MKSTR(head,"function");
                         n = mknode(2,head,str);        switch ( f->id ) {
                         MKLIST(*rp,n);          case I_FUNC: case I_FUNC_QARG:
                         break;            MKSTR(op,((FUNC)FA0(f))->fullname);
             fnodetotree((FNODE)FA1(f),&a1);
             break;
           case I_CAR:
             MKSTR(op,"car");
             fnodetotree((FNODE)FA0(f),&a1);
             break;
           case I_CDR:
             MKSTR(op,"cdr");
             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)),&a1);
             break;
         }
         t0 = NEXT(BDY(a1)); /* XXX : skip the headers */
         MKNODE(t,op,t0);
         MKNODE(n,head,t);
         MKLIST(*rp,n);
         break;
   
                 case I_FORMULA:      case I_STR:
                         MKSTR(head,"internal");        MKSTR(head,"internal");
                         n = mknode(2,head,FA0(f));        MKSTR(str,FA0(f));
                         MKLIST(*rp,n);        n = mknode(2,head,str);
                         break;        MKLIST(*rp,n);
         break;
   
                 case I_PVAR:      case I_FORMULA:
                         if ( FA1(f) )        MKSTR(head,"internal");
                                 error("fnodetotree : not implemented yet");        n = mknode(2,head,FA0(f));
                         MKSTR(head,"variable");        MKLIST(*rp,n);
                         GETPVNAME(FA0(f),opname);        break;
                         MKSTR(op,opname);  
                         n = mknode(2,head,op);  
                         MKLIST(*rp,n);  
                         break;  
   
                 default:      case I_PVAR:
                         error("fnodetotree : not implemented yet");        if ( FA1(f) )
         }          error("fnodetotree : not implemented yet");
         MKSTR(head,"variable");
         GETPVNAME(FA0(f),opname);
         MKSTR(op,opname);
         n = mknode(2,head,op);
         MKLIST(*rp,n);
         break;
   
       default:
         error("fnodetotree : not implemented yet");
     }
 }  }
   
 FNODE eval_pvar_in_fnode(FNODE f)  FNODE eval_pvar_in_fnode(FNODE f)
 {  {
         FNODE a1,a2,a3;    FNODE a1,a2,a3;
         pointer r;    pointer r;
         NODE n,t,t0;    NODE n,t,t0;
         QUOTE q;    QUOTE q;
   
         if ( !f )    if ( !f )
                 return 0;      return 0;
   
         switch ( f->id ) {    switch ( f->id ) {
                 /* unary operators */      /* unary operators */
                 case I_NOT: case I_PAREN: case I_MINUS:      case I_NOT: case I_PAREN: case I_MINUS:
                         a1 = eval_pvar_in_fnode((FNODE)FA0(f));        a1 = eval_pvar_in_fnode((FNODE)FA0(f));
                         return mkfnode(1,f->id,a1);        return mkfnode(1,f->id,a1);
   
                 /* binary operators */      /* binary operators */
                 case I_AND: case I_OR:      case I_AND: case I_OR:
                         a1 = eval_pvar_in_fnode((FNODE)FA0(f));        a1 = eval_pvar_in_fnode((FNODE)FA0(f));
                         a2 = eval_pvar_in_fnode((FNODE)FA1(f));        a2 = eval_pvar_in_fnode((FNODE)FA1(f));
                         return mkfnode(3,f->id,a1,a2);        return mkfnode(3,f->id,a1,a2);
   
                 case I_BOP: case I_COP: case I_LOP:      case I_BOP: case I_COP: case I_LOP:
                         a1 = eval_pvar_in_fnode((FNODE)FA1(f));        a1 = eval_pvar_in_fnode((FNODE)FA1(f));
                         a2 = eval_pvar_in_fnode((FNODE)FA2(f));        a2 = eval_pvar_in_fnode((FNODE)FA2(f));
                         return mkfnode(4,f->id,FA0(f),a1,a2);        return mkfnode(4,f->id,FA0(f),a1,a2);
   
                 /* ternary operators */      /* ternary operators */
                 case I_CE:      case I_CE:
                         a1 = eval_pvar_in_fnode((FNODE)FA0(f));        a1 = eval_pvar_in_fnode((FNODE)FA0(f));
                         a2 = eval_pvar_in_fnode((FNODE)FA1(f));        a2 = eval_pvar_in_fnode((FNODE)FA1(f));
                         a3 = eval_pvar_in_fnode((FNODE)FA2(f));        a3 = eval_pvar_in_fnode((FNODE)FA2(f));
                         return mkfnode(5,f->id,a1,a2,a3);        return mkfnode(5,f->id,a1,a2,a3);
   
                 /* lists */      /* lists */
                 case I_LIST:      case I_LIST:
                         n = (NODE)FA0(f);        n = (NODE)FA0(f);
                         for ( t0 = 0; n; n = NEXT(n) ) {        for ( t0 = 0; n; n = NEXT(n) ) {
                                 NEXTNODE(t0,t);          NEXTNODE(t0,t);
                                 BDY(t) = (pointer)eval_pvar_in_fnode(BDY(n));          BDY(t) = (pointer)eval_pvar_in_fnode(BDY(n));
                         }        }
                         if ( t0 )        if ( t0 )
                                 NEXT(t) = 0;          NEXT(t) = 0;
                         return mkfnode(1,f->id,t0);        return mkfnode(1,f->id,t0);
   
                 /* function */      /* function */
                 case I_FUNC:      case I_FUNC:
                         a1 = eval_pvar_in_fnode((FNODE)FA1(f));        a1 = eval_pvar_in_fnode((FNODE)FA1(f));
                         return mkfnode(2,f->id,FA0(f),a1);        return mkfnode(2,f->id,FA0(f),a1);
                         break;        break;
                 case I_CAR: case I_CDR:      case I_CAR: case I_CDR:
                         a1 = eval_pvar_in_fnode((FNODE)FA0(f));        a1 = eval_pvar_in_fnode((FNODE)FA0(f));
                         return mkfnode(1,f->id,a1);        return mkfnode(1,f->id,a1);
                 case I_EV:      case I_EV:
                         /* exponent vector */        /* exponent vector */
                         a1 = eval_pvar_in_fnode(mkfnode(1,I_LIST,FA0(f)));        a1 = eval_pvar_in_fnode(mkfnode(1,I_LIST,FA0(f)));
                         return mkfnode(1,f->id,a1);        return mkfnode(1,f->id,a1);
   
                 case I_STR: case I_FORMULA:      case I_STR: case I_FORMULA:
                         return f;        return f;
   
                 case I_PVAR: case I_INDEX:      case I_PVAR: case I_INDEX:
                 case I_POSTSELF: case I_PRESELF:      case I_POSTSELF: case I_PRESELF:
                         r = eval(f);        r = eval(f);
                         objtoquote(r,&q);        objtoquote(r,&q);
                         return BDY(q);        return BDY(q);
   
                 default:      default:
                         error("eval_pvar_in_fnode : not implemented yet");        error("eval_pvar_in_fnode : not implemented yet");
                         /* NOTREACHED */        /* NOTREACHED */
                         return 0;        return 0;
         }    }
 }  }
   
 FNODE subst_in_fnode(FNODE f,V v,FNODE g)  FNODE subst_in_fnode(FNODE f,V v,FNODE g)
 {  {
         FNODE a1,a2,a3;    FNODE a1,a2,a3;
         DCP dc;    DCP dc;
         V vf;    V vf;
         NODE n,t,t0;    NODE n,t,t0;
         Obj obj;    Obj obj;
   
         if ( !f )    if ( !f )
                 return 0;      return 0;
   
         switch ( f->id ) {    switch ( f->id ) {
                 /* unary operators */      /* unary operators */
                 case I_NOT: case I_PAREN: case I_MINUS:      case I_NOT: case I_PAREN: case I_MINUS:
                         a1 = subst_in_fnode((FNODE)FA0(f),v,g);        a1 = subst_in_fnode((FNODE)FA0(f),v,g);
                         return mkfnode(1,f->id,a1);        return mkfnode(1,f->id,a1);
   
                 /* binary operators */      /* binary operators */
                 case I_AND: case I_OR:      case I_AND: case I_OR:
                         a1 = subst_in_fnode((FNODE)FA0(f),v,g);        a1 = subst_in_fnode((FNODE)FA0(f),v,g);
                         a2 = subst_in_fnode((FNODE)FA1(f),v,g);        a2 = subst_in_fnode((FNODE)FA1(f),v,g);
                         return mkfnode(3,f->id,a1,a2);        return mkfnode(3,f->id,a1,a2);
   
                 case I_BOP: case I_COP: case I_LOP:      case I_BOP: case I_COP: case I_LOP:
                         a1 = subst_in_fnode((FNODE)FA1(f),v,g);        a1 = subst_in_fnode((FNODE)FA1(f),v,g);
                         a2 = subst_in_fnode((FNODE)FA2(f),v,g);        a2 = subst_in_fnode((FNODE)FA2(f),v,g);
                         return mkfnode(4,f->id,FA0(f),a1,a2);        return mkfnode(4,f->id,FA0(f),a1,a2);
   
                 /* ternary operators */      /* ternary operators */
                 case I_CE:      case I_CE:
                         a1 = subst_in_fnode((FNODE)FA0(f),v,g);        a1 = subst_in_fnode((FNODE)FA0(f),v,g);
                         a2 = subst_in_fnode((FNODE)FA1(f),v,g);        a2 = subst_in_fnode((FNODE)FA1(f),v,g);
                         a3 = subst_in_fnode((FNODE)FA2(f),v,g);        a3 = subst_in_fnode((FNODE)FA2(f),v,g);
                         return mkfnode(5,f->id,a1,a2,a3);        return mkfnode(5,f->id,a1,a2,a3);
   
                 /* lists */      /* lists */
                 case I_LIST:      case I_LIST:
                         n = (NODE)FA0(f);        n = (NODE)FA0(f);
                         for ( t0 = 0; n; n = NEXT(n) ) {        for ( t0 = 0; n; n = NEXT(n) ) {
                                 NEXTNODE(t0,t);          NEXTNODE(t0,t);
                                 BDY(t) = (pointer)subst_in_fnode(BDY(n),v,g);          BDY(t) = (pointer)subst_in_fnode(BDY(n),v,g);
                         }        }
                         if ( t0 )        if ( t0 )
                                 NEXT(t) = 0;          NEXT(t) = 0;
                         return mkfnode(1,f->id,t0);        return mkfnode(1,f->id,t0);
   
                 /* function */      /* function */
                 case I_FUNC:      case I_FUNC:
                         a1 = subst_in_fnode((FNODE)FA1(f),v,g);        a1 = subst_in_fnode((FNODE)FA1(f),v,g);
                         return mkfnode(2,f->id,FA0(f),a1);        return mkfnode(2,f->id,FA0(f),a1);
                         break;        break;
                 case I_CAR: case I_CDR:      case I_CAR: case I_CDR:
                         a1 = subst_in_fnode((FNODE)FA0(f),v,g);        a1 = subst_in_fnode((FNODE)FA0(f),v,g);
                         return mkfnode(1,f->id,a1);        return mkfnode(1,f->id,a1);
                 case I_EV:      case I_EV:
                         /* exponent vector */        /* exponent vector */
                         a1 = subst_in_fnode(mkfnode(1,I_LIST,FA0(f)),v,g);        a1 = subst_in_fnode(mkfnode(1,I_LIST,FA0(f)),v,g);
                         return mkfnode(1,f->id,a1);        return mkfnode(1,f->id,a1);
   
                 case I_STR:      case I_STR:
                         return f;        return f;
   
                 case I_FORMULA:      case I_FORMULA:
                         obj = (Obj)FA0(f);        obj = (Obj)FA0(f);
                         if ( !obj )        if ( !obj )
                                 return f;          return f;
   
                         switch ( OID(obj) ) {        switch ( OID(obj) ) {
                                 case O_N:          case O_N:
                                         return f;            return f;
                                 case O_P:          case O_P:
                                         vf = VR((P)obj);            vf = VR((P)obj);
                                         dc = DC((P)obj);            dc = DC((P)obj);
                                         if ( vf != v )            if ( vf != v )
                                                 return f;              return f;
                                         else if ( UNIQ(DEG(dc)) && UNIQ((Q)COEF(dc)) )            else if ( UNIQ(DEG(dc)) && UNIQ((Q)COEF(dc)) )
                                                 return g;              return g;
                                         else break;            else break;
                                 default:          default:
                                         break;            break;
                         }        }
   
                 default:      default:
                         error("subst_in_fnode : not implemented yet");        error("subst_in_fnode : not implemented yet");
                         /* NOTREACHED */        /* NOTREACHED */
                         return 0;        return 0;
         }    }
 }  }
   
 /* not completed yet */  /* not completed yet */
Line 467  char *get_attribute(char *key,LIST attr)
Line 523  char *get_attribute(char *key,LIST attr)
   
 void treetofnode(Obj obj,FNODE *f)  void treetofnode(Obj obj,FNODE *f)
 {  {
         NODE n;    NODE n;
         LIST attr;    LIST attr;
         char *prop;    char *prop;
   
         if ( obj || OID(obj) != O_LIST ) {    if ( obj || OID(obj) != O_LIST ) {
                 /* internal object */      /* internal object */
                 *f = mkfnode(1,I_FORMULA,obj);      *f = mkfnode(1,I_FORMULA,obj);
         } else {    } else {
                 /* [attr(list),name(string),args(node)] */      /* [attr(list),name(string),args(node)] */
                 n = BDY((LIST)obj);      n = BDY((LIST)obj);
                 attr = (LIST)BDY(n); n = NEXT(n);      attr = (LIST)BDY(n); n = NEXT(n);
                 prop = get_attribute("asir",attr);      prop = get_attribute("asir",attr);
                 if ( !strcmp(prop,"u_op") ) {      if ( !strcmp(prop,"u_op") ) {
                 } else if ( !strcmp(prop,"b_op") ) {      } else if ( !strcmp(prop,"b_op") ) {
                 } else if ( !strcmp(prop,"t_op") ) {      } else if ( !strcmp(prop,"t_op") ) {
                 } else if ( !strcmp(prop,"function") ) {      } else if ( !strcmp(prop,"function") ) {
                 }      }
                         /* default will be set to P_FUNC */        /* default will be set to P_FUNC */
         }    }
 }  }
 #endif  #endif
   
Line 493  FUNC user_print_function;
Line 549  FUNC user_print_function;
   
 void Pset_print_function(NODE arg,pointer *rp)  void Pset_print_function(NODE arg,pointer *rp)
 {  {
         if ( !arg )    if ( !arg )
                 user_print_function = 0;      user_print_function = 0;
         else {    else {
                 gen_searchf(BDY((STRING)ARG0(arg)),&user_print_function);      gen_searchf(BDY((STRING)ARG0(arg)),&user_print_function);
         }    }
         *rp = 0;    *rp = 0;
 }  }
Legend:
Removed from v.1.17  
changed lines
  Added in v.1.27
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>