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

version 1.2, 2000/08/21 08:31:21 version 1.27, 2018/03/29 01:32:50
Line 23 
Line 23 
  * shall be made on your publication or presentation in any form of the   * shall be made on your publication or presentation in any form of the
  * results obtained by use of the SOFTWARE.   * results obtained by use of the SOFTWARE.
  * (4) In the event that you modify the SOFTWARE, you shall notify FLL by   * (4) In the event that you modify the SOFTWARE, you shall notify FLL by
  * e-mail at risa-admin@flab.fujitsu.co.jp of the detailed specification   * e-mail at risa-admin@sec.flab.fujitsu.co.jp of the detailed specification
  * for such modification or the source code of the modified part of the   * for such modification or the source code of the modified part of the
  * SOFTWARE.   * SOFTWARE.
  *   *
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.1.1.1 1999/12/03 07:39:07 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 Pobjtoquote();
   void Peval_variables_in_quote();
   void Pset_print_function();
   
 struct ftab print_tab[] = {  struct ftab print_tab[] = {
         {"print",Pprint,-2},    {"printf",Pprintf,-99999999},
         {0,0,0},    {"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)  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 Pprint(NODE arg,pointer *rp)
   {
     Obj obj;
     STRING nl;
     Q opt;
   
     /* 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(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(FNODE f,LIST *rp)
   {
     LIST a1,a2,a3;
     NODE n,t,t0;
     STRING head,op,str;
     char *opname;
   
     if ( !f ) {
       MKSTR(head,"internal");
       n = mknode(2,head,NULLP);
       MKLIST(*rp,n);
       return;
     }
     switch ( f->id ) {
       /* unary operators */
       case I_NOT: case I_PAREN: case I_MINUS:
         MKSTR(head,"u_op");
         switch ( f->id ) {
           case I_NOT:
             MKSTR(op,"!");
             break;
           case I_PAREN:
             MKSTR(op,"()");
             break;
           case I_MINUS:
             MKSTR(op,"-");
             break;
         }
         fnodetotree((FNODE)FA0(f),&a1);
         n = mknode(3,head,op,a1);
         MKLIST(*rp,n);
         break;
   
       /* binary operators */
       case I_BOP: case I_COP: case I_LOP: case I_AND: case I_OR:
         /* head */
         MKSTR(head,"b_op");
   
         /* arg list */
         switch ( f->id ) {
           case I_AND: case I_OR:
             fnodetotree((FNODE)FA0(f),&a1);
             fnodetotree((FNODE)FA1(f),&a2);
             break;
           default:
             fnodetotree((FNODE)FA1(f),&a1);
             fnodetotree((FNODE)FA2(f),&a2);
             break;
         }
   
         /* op */
         switch ( f->id ) {
           case I_BOP:
             MKSTR(op,((ARF)FA0(f))->name); break;
   
           case I_COP:
             switch( (cid)FA0(f) ) {
               case C_EQ: opname = "=="; break;
               case C_NE: opname = "!="; break;
               case C_GT: opname = ">"; break;
               case C_LT: opname = "<"; break;
               case C_GE: opname = ">="; break;
               case C_LE: opname = "<="; break;
             }
             MKSTR(op,opname); break;
   
           case I_LOP:
             switch( (lid)FA0(f) ) {
               case L_EQ: opname = "@=="; break;
               case L_NE: opname = "@!="; break;
               case L_GT: opname = "@>"; break;
               case L_LT: opname = "@<"; break;
               case L_GE: opname = "@>="; break;
               case L_LE: opname = "@<="; break;
               case L_AND: opname = "@&&"; break;
               case L_OR: opname = "@||"; break;
   
               case L_NOT: opname = "@!";
                 /* XXX : L_NOT is a unary operator */
                 MKSTR(head,"u_op");
                 MKSTR(op,opname);
                 n = mknode(3,head,op,a1);
                 MKLIST(*rp,n);
                 return;
             }
             MKSTR(op,opname); break;
   
           case I_AND:
             MKSTR(op,"&&"); break;
   
           case I_OR:
             MKSTR(op,"||"); break;
         }
         n = mknode(4,head,op,a1,a2);
         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");
         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.2  
changed lines
  Added in v.1.27
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>