[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.4 and 1.27

version 1.4, 2001/08/06 01:48:32 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.3 2000/08/22 05:03:59 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 Peval_variables_in_quote();
   void Pset_print_function();
   
 struct ftab print_tab[] = {  struct ftab print_tab[] = {
         {"print",Pprint,-2},    {"printf",Pprintf,-99999999},
         {"quotetolist",Pquotetolist,1},    {"print",Pprint,-2},
         {0,0,0},    {"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)  extern int I_am_server;
 NODE arg;  
 pointer *rp;  int wfep_mode;
   
   void Pprintf(NODE arg,pointer *rp)
 {  {
         printexpr(CO,ARG0(arg));    STRING s;
         if ( argc(arg) == 2 )    if ( arg ) {
                 switch ( QTOS((Q)ARG1(arg)) ) {      Psprintf(arg,&s);
                         case 0:      /* engine for wfep */
                                 break;      if ( wfep_mode ) {
                         case 2:        print_to_wfep(s);
                                 fflush(asir_out); break;      }else {
                                 break;        printexpr(CO,s);
                         case 1: default:        fflush(asir_out);
                                 putc('\n',asir_out); break;      }
                 }    }
         else    *rp = 0;
                 putc('\n',asir_out);    return;
         *rp = 0;  
 }  }
   
 void fnodetotree();  void Pprint(NODE arg,pointer *rp)
   {
     Obj obj;
     STRING nl;
     Q opt;
   
 void Pquotetolist(arg,rp)    /* engine for wfep */
 NODE arg;    if ( wfep_mode ) {
 Obj *rp;      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)
 {  {
         asir_assert(ARG0(arg),O_QUOTE,"quotetolist");    objtoquote(ARG0(arg),rp);
         fnodetotree((FNODE)BDY((QUOTE)(ARG0(arg))),rp);  
 }  }
   
 void fnodetotree(f,rp)  void Pquotetolist(NODE arg,LIST *rp)
 FNODE f;  
 Obj *rp;  
 {  {
         Obj a1,a2;    asir_assert(ARG0(arg),O_QUOTE,"quotetolist");
         NODE n,t,t0;    fnodetotree((FNODE)BDY((QUOTE)(ARG0(arg))),rp);
         STRING head;  }
         LIST r,arg;  
         char *opname;  
   
         if ( !f ) {  void Peval_variables_in_quote(NODE arg,QUOTE *rp)
                 *rp = 0;  {
                 return;    FNODE fn;
         }  
         switch ( f->id ) {  
                 case I_BOP: case I_COP: I_LOP:  
                         /* arg list */  
                         fnodetotree((FNODE)FA1(f),&a1);  
                         fnodetotree((FNODE)FA2(f),&a2);  
                         n = mknode(2,a1,a2); MKLIST(arg,n);  
   
                         /* head */    asir_assert(ARG0(arg),O_QUOTE,"eval_variables_in_quote");
                         switch ( f->id ) {    fn = eval_pvar_in_fnode((FNODE)BDY((QUOTE)(ARG0(arg))));
                                 case I_BOP:    MKQUOTE(*rp,fn);
                                         MKSTR(head,((ARF)FA0(f))->name); break;  }
                                 case I_COP:  
                                         switch( (cid)FA0(f) ) {  /* fnode -> [tag,name,arg0,arg1,...] */
                                                 case C_EQ: opname = "=="; break;  
                                                 case C_NE: opname = "!="; break;  void fnodetotree(FNODE f,LIST *rp)
                                                 case C_GT: opname = ">"; break;  {
                                                 case C_LT: opname = "<"; break;    LIST a1,a2,a3;
                                                 case C_GE: opname = ">="; break;    NODE n,t,t0;
                                                 case C_LE: opname = "<="; break;    STRING head,op,str;
                                         }    char *opname;
                                         MKSTR(head,opname); break;  
                                 case I_LOP:    if ( !f ) {
                                         switch( (lid)FA0(f) ) {      MKSTR(head,"internal");
                                                 case L_EQ: opname = "@=="; break;      n = mknode(2,head,NULLP);
                                                 case L_NE: opname = "@!="; break;      MKLIST(*rp,n);
                                                 case L_GT: opname = "@>"; break;      return;
                                                 case L_LT: opname = "@<"; break;    }
                                                 case L_GE: opname = "@>="; break;    switch ( f->id ) {
                                                 case L_LE: opname = "@<="; break;      /* unary operators */
                                                 case L_AND: opname = "@&&"; break;      case I_NOT: case I_PAREN: case I_MINUS:
                                                 case L_OR: opname = "@||"; break;        MKSTR(head,"u_op");
                                                 case L_NOT: opname = "@!"; break;        switch ( f->id ) {
                                         }          case I_NOT:
                                         MKSTR(head,opname); break;            MKSTR(op,"!");
                         }            break;
                         n = mknode(2,head,arg);          case I_PAREN:
                         MKLIST(r,n);            MKSTR(op,"()");
                         *rp = (Obj)r;            break;
                         break;          case I_MINUS:
                 case I_AND:            MKSTR(op,"-");
                         fnodetotree((FNODE)FA0(f),&a1);            break;
                         fnodetotree((FNODE)FA1(f),&a2);        }
                         n = mknode(2,a1,a2); MKLIST(arg,n);        fnodetotree((FNODE)FA0(f),&a1);
                         MKSTR(head,"&&");        n = mknode(3,head,op,a1);
                         n = mknode(2,head,arg);        MKLIST(*rp,n);
                         MKLIST(r,n);        break;
                         *rp = (Obj)r;  
                         break;      /* binary operators */
                 case I_OR:      case I_BOP: case I_COP: case I_LOP: case I_AND: case I_OR:
                         fnodetotree((FNODE)FA0(f),&a1);        /* head */
                         fnodetotree((FNODE)FA1(f),&a2);        MKSTR(head,"b_op");
                         n = mknode(2,a1,a2); MKLIST(arg,n);  
                         MKSTR(head,"||");        /* arg list */
                         n = mknode(2,head,arg);        switch ( f->id ) {
                         MKLIST(r,n);          case I_AND: case I_OR:
                         *rp = (Obj)r;            fnodetotree((FNODE)FA0(f),&a1);
                         break;            fnodetotree((FNODE)FA1(f),&a2);
                 case I_NOT:            break;
                         fnodetotree((FNODE)FA0(f),&a1);          default:
                         n = mknode(1,a1); MKLIST(arg,n);            fnodetotree((FNODE)FA1(f),&a1);
                         MKSTR(head,"!");            fnodetotree((FNODE)FA2(f),&a2);
                         n = mknode(2,head,arg);            break;
                         MKLIST(r,n);        }
                         *rp = (Obj)r;  
                         break;        /* op */
                 case I_CE:        switch ( f->id ) {
                         fnodetotree((FNODE)FA0(f),&a1);          case I_BOP:
                         fnodetotree((FNODE)FA1(f),&a2);            MKSTR(op,((ARF)FA0(f))->name); break;
                         n = mknode(2,a1,a2); MKLIST(arg,n);  
                         MKSTR(head,"?:");          case I_COP:
                         n = mknode(2,head,arg);            switch( (cid)FA0(f) ) {
                         MKLIST(r,n);              case C_EQ: opname = "=="; break;
                         *rp = (Obj)r;              case C_NE: opname = "!="; break;
                         break;              case C_GT: opname = ">"; break;
                 case I_EV: case I_LIST:              case C_LT: opname = "<"; break;
                         n = (NODE)FA0(f);              case C_GE: opname = ">="; break;
                         for ( t0 = 0; n; n = NEXT(n) ) {              case C_LE: opname = "<="; break;
                                 NEXTNODE(t0,t);            }
                                 fnodetotree(BDY(n),&BDY(t));            MKSTR(op,opname); break;
                         }  
                         if ( t0 )          case I_LOP:
                                 NEXT(t) = 0;            switch( (lid)FA0(f) ) {
                         MKLIST(arg,t0);              case L_EQ: opname = "@=="; break;
                         switch ( f->id ) {              case L_NE: opname = "@!="; break;
                                 case I_LIST:              case L_GT: opname = "@>"; break;
                                         *rp = (Obj)arg; break;              case L_LT: opname = "@<"; break;
                                 case I_EV:              case L_GE: opname = "@>="; break;
                                         MKSTR(head,"exponent_vector");              case L_LE: opname = "@<="; break;
                                         n = mknode(2,head,arg);              case L_AND: opname = "@&&"; break;
                                         MKLIST(r,n);              case L_OR: opname = "@||"; break;
                                         *rp = (Obj)r;  
                                         break;              case L_NOT: opname = "@!";
                         }                /* XXX : L_NOT is a unary operator */
                         break;                MKSTR(head,"u_op");
                 case I_FUNC:                MKSTR(op,opname);
                         fnodetotree((FNODE)FA1(f),&arg);                n = mknode(3,head,op,a1);
                         MKSTR(head,((FUNC)FA0(f))->name);                MKLIST(*rp,n);
                         n = mknode(2,head,arg);                return;
                         MKLIST(r,n);            }
                         *rp = (Obj)r;            MKSTR(op,opname); break;
                         break;  
                 case I_CAR:          case I_AND:
                         fnodetotree((FNODE)FA0(f),&arg);            MKSTR(op,"&&"); break;
                         MKSTR(head,"car");  
                         n = mknode(2,head,arg);          case I_OR:
                         MKLIST(r,n);            MKSTR(op,"||"); break;
                         *rp = (Obj)r;        }
                         break;        n = mknode(4,head,op,a1,a2);
                 case I_CDR:        MKLIST(*rp,n);
                         fnodetotree((FNODE)FA0(f),&arg);        break;
                         MKSTR(head,"cdr");  
                         n = mknode(2,head,arg);      case I_NARYOP:
                         MKLIST(r,n);        /* head */
                         *rp = (Obj)r;        MKSTR(head,"n_op");
                         break;        n = (NODE)FA1(f);
                 case I_FORMULA:        for ( t0 = 0; n; n = NEXT(n) ) {
                         *rp = (Obj)FA0(f);          NEXTNODE(t0,t);
                         break;          fnodetotree((FNODE)BDY(n),&a1);
                 default:          BDY(t) = (pointer)a1;
                         error("fnodetotree : not implemented yet");        }
         }        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");
         MKSTR(op,"?:");
         fnodetotree((FNODE)FA0(f),&a1);
         fnodetotree((FNODE)FA1(f),&a2);
         fnodetotree((FNODE)FA2(f),&a3);
         n = mknode(5,head,op,a1,a2,a3);
         MKLIST(*rp,n);
         break;
   
       /* lists */
       case I_LIST:
         n = (NODE)FA0(f);
         for ( t0 = 0; n; n = NEXT(n) ) {
           NEXTNODE(t0,t);
           fnodetotree((FNODE)BDY(n),&a1);
           BDY(t) = (pointer)a1;
         }
         if ( t0 )
           NEXT(t) = 0;
         MKSTR(head,"list");
         MKNODE(n,head,t0);
         MKLIST(*rp,n);
         break;
   
       /* function */
       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: 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),&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_STR:
         MKSTR(head,"internal");
         MKSTR(str,FA0(f));
         n = mknode(2,head,str);
         MKLIST(*rp,n);
         break;
   
       case I_FORMULA:
         MKSTR(head,"internal");
         n = mknode(2,head,FA0(f));
         MKLIST(*rp,n);
         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(*rp,n);
         break;
   
       default:
         error("fnodetotree : not implemented yet");
     }
   }
   
   FNODE eval_pvar_in_fnode(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");
         /* NOTREACHED */
         return 0;
     }
   }
   
   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 obj,FNODE *f)
   {
     NODE n;
     LIST attr;
     char *prop;
   
     if ( obj || OID(obj) != O_LIST ) {
       /* internal object */
       *f = mkfnode(1,I_FORMULA,obj);
     } else {
       /* [attr(list),name(string),args(node)] */
       n = BDY((LIST)obj);
       attr = (LIST)BDY(n); n = NEXT(n);
       prop = get_attribute("asir",attr);
       if ( !strcmp(prop,"u_op") ) {
       } else if ( !strcmp(prop,"b_op") ) {
       } else if ( !strcmp(prop,"t_op") ) {
       } else if ( !strcmp(prop,"function") ) {
       }
         /* default will be set to P_FUNC */
     }
   }
   #endif
   
   FUNC user_print_function;
   
   void Pset_print_function(NODE arg,pointer *rp)
   {
     if ( !arg )
       user_print_function = 0;
     else {
       gen_searchf(BDY((STRING)ARG0(arg)),&user_print_function);
     }
     *rp = 0;
 }  }
Legend:
Removed from v.1.4  
changed lines
  Added in v.1.27
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>