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

Diff for /OpenXM_contrib2/asir2000/parse/eval.c between version 1.23 and 1.80

version 1.23, 2003/05/14 09:18:38 version 1.80, 2018/03/29 01:32:54
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/parse/eval.c,v 1.22 2003/05/14 07:08:48 noro Exp $   * $OpenXM: OpenXM_contrib2/asir2000/parse/eval.c,v 1.79 2018/03/28 05:27:22 noro Exp $
 */  */
 #include <ctype.h>  #include <ctype.h>
 #include "ca.h"  #include "ca.h"
 #include "al.h"  #include "al.h"
 #include "base.h"  #include "base.h"
 #include "parse.h"  #include "parse.h"
   #if defined(GC7)
   #include "gc.h"
   #endif
 #include <sys/types.h>  #include <sys/types.h>
 #include <sys/stat.h>  #include <sys/stat.h>
 #if defined(PARI)  
 #include "genpari.h"  
 #endif  
   
 extern JMP_BUF timer_env;  extern JMP_BUF timer_env;
   extern FUNC cur_binf;
   extern NODE PVSS;
   extern int evalef;
   
 int f_break,f_return,f_continue;  int f_break,f_return,f_continue;
 int evalstatline;  int evalstatline;
 int recv_intr;  int show_crossref;
   int at_root;
   void gen_searchf_searchonly(char *name,FUNC *r,int global);
   LIST eval_arg(FNODE a,unsigned int quote);
   
 pointer eval(FNODE f)  pointer eval(FNODE f)
 {  {
         LIST t;    LIST t;
         STRING str;    STRING str;
         pointer val = 0;    pointer val = 0;
         pointer a,a1,a2;    pointer a,a1,a2;
         NODE tn,ind;    NODE tn,tn1,ind,match;
         R u;    R u;
         DP dp;    DP dp;
         unsigned int pv;    unsigned int pv;
         int c;    int c,ret,pos;
         FNODE f1;    FNODE f1;
         UP2 up2;    UP2 up2;
         UP up;    UP up;
         UM um;    UM um;
         Obj obj;    Obj obj;
         GF2N gf2n;    GF2N gf2n;
         GFPN gfpn;    GFPN gfpn;
         GFSN gfsn;    GFSN gfsn;
     RANGE range;
     QUOTE expr,pattern;
     Q q;
   
 #if defined(VISUAL)  #if defined(VISUAL) || defined(__MINGW32__)
         if ( recv_intr ) {    check_intr();
 #include <signal.h>  
                 if ( recv_intr == 1 ) {  
                         recv_intr = 0;  
                         int_handler(SIGINT);  
                 } else {  
                         recv_intr = 0;  
                         ox_usr1_handler(0);  
                 }  
         }  
 #endif  #endif
         if ( !f )    if ( !f )
                 return ( 0 );      return ( 0 );
         switch ( f->id ) {    switch ( f->id ) {
                 case I_PAREN:      case I_PAREN:
                         val = eval((FNODE)(FA0(f)));        val = eval((FNODE)(FA0(f)));
                         break;        break;
                 case I_MINUS:      case I_MINUS:
                         a1 = eval((FNODE)(FA0(f)));        a1 = eval((FNODE)(FA0(f)));
                         arf_chsgn((Obj)a1,&obj);        arf_chsgn((Obj)a1,&obj);
                         val = (pointer)obj;        val = (pointer)obj;
                         break;        break;
                 case I_BOP:      case I_BOP:
                         a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));        a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
                         (*((ARF)FA0(f))->fp)(CO,a1,a2,&val);        (*((ARF)FA0(f))->fp)(CO,a1,a2,&val);
                         break;        break;
                 case I_COP:      case I_NARYOP:
                         a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));        tn = (NODE)FA1(f);
                         c = arf_comp(CO,a1,a2);        a = eval((FNODE)BDY(tn));
                         switch ( (cid)FA0(f) ) {        for ( tn = NEXT(tn); tn; tn = NEXT(tn) ) {
                                 case C_EQ:          a1 = eval((FNODE)BDY(tn));
                                         c = (c == 0); break;          (*((ARF)FA0(f))->fp)(CO,a,a1,&a2);
                                 case C_NE:          a = a2;
                                         c = (c != 0); break;        }
                                 case C_GT:        val = a;
                                         c = (c > 0); break;        break;
                                 case C_LT:      case I_COP:
                                         c = (c < 0); break;        a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
                                 case C_GE:        c = arf_comp(CO,a1,a2);
                                         c = (c >= 0); break;        switch ( (cid)FA0(f) ) {
                                 case C_LE:          case C_EQ:
                                         c = (c <= 0); break;            c = (c == 0); break;
                                 default:          case C_NE:
                                         c = 0; break;            c = (c != 0); break;
                         }          case C_GT:
                         if ( c )            c = (c > 0); break;
                                 val = (pointer)ONE;          case C_LT:
                         break;            c = (c < 0); break;
                 case I_AND:          case C_GE:
                         if ( eval((FNODE)FA0(f)) && eval((FNODE)FA1(f)) )            c = (c >= 0); break;
                                 val = (pointer)ONE;          case C_LE:
                         break;            c = (c <= 0); break;
                 case I_OR:          default:
                         if ( eval((FNODE)FA0(f)) || eval((FNODE)FA1(f)) )            c = 0; break;
                                 val = (pointer)ONE;        }
                         break;        if ( c )
                 case I_NOT:          val = (pointer)ONE;
                         if ( eval((FNODE)FA0(f)) )        break;
                                 val = 0;      case I_AND:
                         else        if ( eval((FNODE)FA0(f)) && eval((FNODE)FA1(f)) )
                                 val = (pointer)ONE;          val = (pointer)ONE;
                         break;        break;
                 case I_LOP:      case I_OR:
                         a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));        if ( eval((FNODE)FA0(f)) || eval((FNODE)FA1(f)) )
                         val = evall((lid)FA0(f),a1,a2);          val = (pointer)ONE;
                         break;        break;
                 case I_CE:      case I_NOT:
                         if ( eval((FNODE)FA0(f)) )        if ( eval((FNODE)FA0(f)) )
                                 val = eval((FNODE)FA1(f));          val = 0;
                         else        else
                                 val = eval((FNODE)FA2(f));          val = (pointer)ONE;
                         break;        break;
                 case I_EV:      case I_LOP:
                         evalnodebody((NODE)FA0(f),&tn); nodetod(tn,&dp); val = (pointer)dp;        a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
                         break;        val = evall((lid)FA0(f),a1,a2);
                 case I_FUNC:        break;
                         val = evalf((FUNC)FA0(f),(FNODE)FA1(f),0); break;      case I_CE:
                 case I_FUNC_OPT:        if ( eval((FNODE)FA0(f)) )
                         val = evalf((FUNC)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;          val = eval((FNODE)FA1(f));
                 case I_PFDERIV:        else
                         error("eval : not implemented yet");          val = eval((FNODE)FA2(f));
                         break;        break;
                 case I_MAP:      case I_EV:
                         val = evalmapf((FUNC)FA0(f),(FNODE)FA1(f)); break;        evalnodebody((NODE)FA0(f),&tn); nodetod(tn,&dp); val = (pointer)dp;
                 case I_RECMAP:        break;
                         val = eval_rec_mapf((FUNC)FA0(f),(FNODE)FA1(f)); break;      case I_EVM:
                 case I_IFUNC:        evalnodebody((NODE)FA0(f),&tn); pos = eval((FNODE)FA1(f)); nodetodpm(tn,pos,&dp); val = (pointer)dp;
                         val = evalif((FNODE)FA0(f),(FNODE)FA1(f)); break;        break;
 #if !defined(VISUAL)      case I_FUNC:
                 case I_TIMER:        val = evalf((FUNC)FA0(f),(FNODE)FA1(f),0); break;
                         {      case I_FUNC_OPT:
                                 int interval;        val = evalf((FUNC)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;
                                 Obj expired;      case I_FUNC_QARG:
         tn = BDY(eval_arg((FNODE)FA1(f),(unsigned int)0xffffffff));
         val = bevalf((FUNC)FA0(f),tn); break;
       case I_PFDERIV:
         val = evalf_deriv((FUNC)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;
       case I_MAP:
         val = evalmapf((FUNC)FA0(f),(FNODE)FA1(f)); break;
       case I_RECMAP:
         val = eval_rec_mapf((FUNC)FA0(f),(FNODE)FA1(f)); break;
       case I_IFUNC:
         val = evalif((FNODE)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;
   #if !defined(VISUAL) && !defined(__MINGW32__)
       case I_TIMER:
         {
           int interval;
           Obj expired;
   
                                 interval = QTOS((Q)eval((FNODE)FA0(f)));          interval = QTOS((Q)eval((FNODE)FA0(f)));
                                 expired = (Obj)eval((FNODE)FA2(f));          expired = (Obj)eval((FNODE)FA2(f));
                                 set_timer(interval);          set_timer(interval);
                                 savepvs();          savepvs();
                                 if ( !SETJMP(timer_env) )          if ( !SETJMP(timer_env) )
                                         val = eval((FNODE)FA1(f));            val = eval((FNODE)FA1(f));
                                 else {          else {
                                         val = (pointer)expired;            val = (pointer)expired;
                                         restorepvs();            restorepvs();
                                 }          }
                                 reset_timer();          reset_timer();
                         }        }
                         break;        break;
 #endif  #endif
                 case I_PRESELF:      case I_PRESELF:
                         f1 = (FNODE)FA1(f);        f1 = (FNODE)FA1(f);
                         if ( ID(f1) == I_PVAR ) {        if ( ID(f1) == I_PVAR ) {
                                 pv = (unsigned int)FA0(f1); ind = (NODE)FA1(f1); GETPV(pv,a);          pv = (unsigned int)FA0(f1); ind = (NODE)FA1(f1); GETPV(pv,a);
                                 if ( !ind ) {          if ( !ind ) {
                                         (*((ARF)FA0(f))->fp)(CO,a,ONE,&val); ASSPV(pv,val);            (*((ARF)FA0(f))->fp)(CO,a,ONE,&val); ASSPV(pv,val);
                                 } else if ( a ) {          } else if ( a ) {
                                         evalnodebody(ind,&tn); getarray(a,tn,(pointer *)&u);            evalnodebody(ind,&tn); getarray(a,tn,(pointer *)&u);
                                         (*((ARF)FA0(f))->fp)(CO,u,ONE,&val); putarray(a,tn,val);            (*((ARF)FA0(f))->fp)(CO,u,ONE,&val); putarray(a,tn,val);
                                 }          }
                         } else        } else
                                 error("++ : not implemented yet");          error("++ : not implemented yet");
                         break;        break;
                 case I_POSTSELF:      case I_POSTSELF:
                         f1 = (FNODE)FA1(f);        f1 = (FNODE)FA1(f);
                         if ( ID(f1) == I_PVAR ) {        if ( ID(f1) == I_PVAR ) {
                                 pv = (unsigned int)FA0(f1); ind = (NODE)FA1(f1); GETPV(pv,val);          pv = (unsigned int)FA0(f1); ind = (NODE)FA1(f1); GETPV(pv,val);
                                 if ( !ind ) {          if ( !ind ) {
                                         (*((ARF)FA0(f))->fp)(CO,val,ONE,&u); ASSPV(pv,u);            (*((ARF)FA0(f))->fp)(CO,val,ONE,&u); ASSPV(pv,u);
                                 } else if ( val ) {          } else if ( val ) {
                                         evalnodebody(ind,&tn); getarray(val,tn,&a);            evalnodebody(ind,&tn); getarray(val,tn,&a);
                                         (*((ARF)FA0(f))->fp)(CO,a,ONE,&u); putarray(val,tn,(pointer)u);            (*((ARF)FA0(f))->fp)(CO,a,ONE,&u); putarray(val,tn,(pointer)u);
                                         val = a;            val = a;
                                 }          }
                         } else        } else
                                 error("-- : not implemented yet");          error("-- : not implemented yet");
                         break;        break;
                 case I_PVAR:      case I_PVAR:
                         pv = (unsigned int)FA0(f); ind = (NODE)FA1(f); GETPV(pv,a);        pv = (unsigned int)FA0(f);
                         if ( !ind )        ind = (NODE)FA1(f);
                                 val = a;        GETPV(pv,a);
                         else {        if ( !ind )
                                 evalnodebody(ind,&tn); getarray(a,tn,&val);          val = a;
                         }        else {
                         break;          evalnodebody(ind,&tn); getarray(a,tn,&val);
                 case I_ASSPVAR:        }
                         f1 = (FNODE)FA0(f);        break;
                         if ( ID(f1) == I_PVAR ) {      case I_ASSPVAR:
                                 pv = (unsigned int)FA0(f1); ind = (NODE)FA1(f1);        f1 = (FNODE)FA0(f);
                                 if ( !ind ) {        if ( ID(f1) == I_PVAR ) {
                                         val = eval((FNODE)FA1(f)); ASSPV(pv,val);          pv = (unsigned int)FA0(f1); ind = (NODE)FA1(f1);
                                 } else {          if ( !ind ) {
                                         GETPV(pv,a);            val = eval((FNODE)FA1(f)); ASSPV(pv,val);
                                         evalnodebody(ind,&tn);          } else {
                                         putarray(a,tn,val = eval((FNODE)FA1(f)));            GETPV(pv,a);
                                 }            evalnodebody(ind,&tn);
                         } else if ( ID(f1) == I_POINT ) {            putarray(a,tn,val = eval((FNODE)FA1(f)));
                                 /* f1 <-> FA0(f1)->FA1(f1) */          }
                                 a = eval(FA0(f1));        } else if ( ID(f1) == I_POINT ) {
                                 assign_to_member(a,(char *)FA1(f1),val = eval((FNODE)FA1(f)));          /* f1 <-> FA0(f1)->FA1(f1) */
                         } else if ( ID(f1) == I_INDEX ) {          a = eval(FA0(f1));
                                 /* f1 <-> FA0(f1)[FA1(f1)] */          assign_to_member(a,(char *)FA1(f1),val = eval((FNODE)FA1(f)));
                                 a = eval((FNODE)FA0(f1)); ind = (NODE)FA1(f1);        } else if ( ID(f1) == I_INDEX ) {
                                 evalnodebody(ind,&tn);          /* f1 <-> FA0(f1)[FA1(f1)] */
                                 putarray(a,tn,val = eval((FNODE)FA1(f)));          a = eval((FNODE)FA0(f1)); ind = (NODE)FA1(f1);
                         } else {          evalnodebody(ind,&tn);
                                 error("eval : invalid assignment");          putarray(a,tn,val = eval((FNODE)FA1(f)));
                         }        } else {
                         break;          error("eval : invalid assignment");
                 case I_ANS:        }
                         if ( (pv =(int)FA0(f)) < (int)APVS->n )        break;
                                 val = APVS->va[pv].priv;      case I_ANS:
                         break;        if ( (pv =(int)FA0(f)) < (int)APVS->n )
                 case I_GF2NGEN:          val = APVS->va[pv].priv;
                         NEWUP2(up2,1);        break;
                         up2->w=1;      case I_GF2NGEN:
                         up2->b[0] = 2; /* @ */        NEWUP2(up2,1);
                         MKGF2N(up2,gf2n);        up2->w=1;
                         val = (pointer)gf2n;        up2->b[0] = 2; /* @ */
                         break;        MKGF2N(up2,gf2n);
                 case I_GFPNGEN:        val = (pointer)gf2n;
                         up = UPALLOC(1);        break;
                         DEG(up)=1;      case I_GFPNGEN:
                         COEF(up)[0] = 0;        up = UPALLOC(1);
                         COEF(up)[1] = (Num)ONELM;        DEG(up)=1;
                         MKGFPN(up,gfpn);        COEF(up)[0] = 0;
                         val = (pointer)gfpn;        COEF(up)[1] = (Num)ONELM;
                         break;        MKGFPN(up,gfpn);
                 case I_GFSNGEN:        val = (pointer)gfpn;
                         um = UMALLOC(1);        break;
                         DEG(um) = 1;      case I_GFSNGEN:
                         COEF(um)[0] = 0;        um = UMALLOC(1);
                         COEF(um)[1] = _onesf();        DEG(um) = 1;
                         MKGFSN(um,gfsn);        COEF(um)[0] = 0;
                         val = (pointer)gfsn;        COEF(um)[1] = _onesf();
                         break;        MKGFSN(um,gfsn);
                 case I_STR:        val = (pointer)gfsn;
                         MKSTR(str,FA0(f)); val = (pointer)str; break;        break;
                 case I_FORMULA:      case I_STR:
                          val = FA0(f); break;        MKSTR(str,FA0(f)); val = (pointer)str; break;
                 case I_LIST:      case I_FORMULA:
                         evalnodebody((NODE)FA0(f),&tn); MKLIST(t,tn); val = (pointer)t; break;        val = FA0(f);
                 case I_NEWCOMP:        break;
                         newstruct((int)FA0(f),(struct oCOMP **)&val); break;      case I_LIST:
                 case I_CAR:        evalnodebody((NODE)FA0(f),&tn); MKLIST(t,tn); val = (pointer)t; break;
                         if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )      case I_CONS:
                                 val = 0;        evalnodebody((NODE)FA0(f),&tn); a2 = eval(FA1(f));
                         else if ( !BDY((LIST)a) )        if ( !a2 || OID(a2) != O_LIST )
                                 val = a;            error("cons : invalid argument");
                         else        for ( tn1 = tn; NEXT(tn1); tn1 = NEXT(tn1) );
                                 val = (pointer)BDY(BDY((LIST)a));        NEXT(tn1) = BDY((LIST)a2);
                         break;        MKLIST(t,tn); val = (pointer)t;
                 case I_CDR:        break;
                         if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )      case I_NEWCOMP:
                                 val = 0;        newstruct((int)FA0(f),(struct oCOMP **)&val); break;
                         else if ( !BDY((LIST)a) )      case I_CAR:
                                 val = a;        if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )
                         else {          val = 0;
                                 MKLIST(t,NEXT(BDY((LIST)a))); val = (pointer)t;        else if ( !BDY((LIST)a) )
                         }          val = a;
                         break;        else
                 case I_PROC:          val = (pointer)BDY(BDY((LIST)a));
                         val = (pointer)FA0(f); break;        break;
                 case I_INDEX:      case I_CDR:
                         a = eval((FNODE)FA0(f)); ind = (NODE)FA1(f);        if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )
                         evalnodebody(ind,&tn); getarray(a,tn,&val);          val = 0;
                         break;        else if ( !BDY((LIST)a) )
                 case I_OPT:          val = a;
                         MKSTR(str,(char *)FA0(f));        else {
                         a = (pointer)eval(FA1(f));          MKLIST(t,NEXT(BDY((LIST)a))); val = (pointer)t;
                         tn = mknode(2,str,a);        }
                         MKLIST(t,tn); val = (pointer)t;        break;
                         break;      case I_INDEX:
                 case I_GETOPT:        a = eval((FNODE)FA0(f)); ind = (NODE)FA1(f);
                         val = (pointer)getopt_from_cpvs((char *)FA0(f));        evalnodebody(ind,&tn); getarray(a,tn,&val);
                         break;        break;
                 case I_POINT:      case I_OPT:
                         a = (pointer)eval(FA0(f));        MKSTR(str,(char *)FA0(f));
                         val = (pointer)memberofstruct(a,(char *)FA1(f));        a = (pointer)eval(FA1(f));
                         break;        tn = mknode(2,str,a);
                 default:        MKLIST(t,tn); val = (pointer)t;
                         error("eval : unknown id");        break;
                         break;      case I_GETOPT:
         }        val = (pointer)getopt_from_cpvs((char *)FA0(f));
         return ( val );        break;
       case I_POINT:
         a = (pointer)eval(FA0(f));
         val = (pointer)memberofstruct(a,(char *)FA1(f));
         break;
       default:
         error("eval : unknown id");
         break;
     }
     return ( val );
 }  }
   
   NODE fnode_to_nary_node(NODE);
   NODE fnode_to_bin_node(NODE,int);
   
   FNODE fnode_to_nary(FNODE f)
   {
     FNODE a0,a1,a2;
     NODE n,t,t0;
     pointer val;
     char *op;
   
     if ( !f )
       return f;
     switch ( f->id ) {
       case I_NARYOP:
           n = fnode_to_nary_node((NODE)FA1(f));
           return mkfnode(2,I_NARYOP,FA0(f),n);
   
       case I_BOP:
         a1 = fnode_to_nary((FNODE)FA1(f));
         a2 = fnode_to_nary((FNODE)FA2(f));
         op = ((ARF)FA0(f))->name;
         if ( !strcmp(op,"+") || !strcmp(op,"*") ) {
           if ( a1->id == I_NARYOP && !strcmp(op,((ARF)FA0(a1))->name) ) {
             for ( n = (NODE)FA1(a1); NEXT(n); n = NEXT(n) );
             if ( a2->id == I_NARYOP && !strcmp(op,((ARF)FA0(a2))->name) )
               NEXT(n) = (NODE)FA1(a2);
             else
               MKNODE(NEXT(n),a2,0);
             return a1;
           } else if ( a2->id == I_NARYOP && !strcmp(op,((ARF)FA0(a2))->name) ) {
             MKNODE(t,a1,(NODE)FA1(a2));
             return mkfnode(2,I_NARYOP,FA0(f),t);
           } else {
             t = mknode(2,a1,a2);
             return mkfnode(2,I_NARYOP,FA0(f),t);
           }
         } else
           return mkfnode(3,f->id,FA0(f),a1,a2);
   
       case I_NOT: case I_PAREN: case I_MINUS:
       case I_CAR: case I_CDR:
         a0 = fnode_to_nary((FNODE)FA0(f));
         return mkfnode(1,f->id,a0);
   
       case I_COP: case I_LOP:
         a1 = fnode_to_nary((FNODE)FA1(f));
         a2 = fnode_to_nary((FNODE)FA2(f));
         return mkfnode(3,f->id,FA0(f),a1,a2);
   
       case I_AND: case I_OR:
         a0 = fnode_to_nary((FNODE)FA0(f));
         a1 = fnode_to_nary((FNODE)FA1(f));
         return mkfnode(2,f->id,a0,a1);
   
       /* ternary operators */
       case I_CE:
         a0 = fnode_to_nary((FNODE)FA0(f));
         a1 = fnode_to_nary((FNODE)FA1(f));
         a2 = fnode_to_nary((FNODE)FA2(f));
         return mkfnode(3,f->id,a0,a1,a2);
         break;
   
       /* function */
       case I_FUNC:
         a1 = fnode_to_nary((FNODE)FA1(f));
         return mkfnode(2,f->id,FA0(f),a1);
   
       case I_LIST: case I_EV:
         n = fnode_to_nary_node((NODE)FA0(f));
         return mkfnode(1,f->id,n);
   
       case I_STR: case I_FORMULA: case I_PVAR:
         return f;
   
       default:
         error("fnode_to_nary : not implemented yet");
     }
   }
   
   FNODE fnode_to_bin(FNODE f,int dir)
   {
     FNODE a0,a1,a2;
     NODE n,t;
     pointer val;
     ARF fun;
     int len,i;
     FNODE *arg;
   
     if ( !f )
       return f;
     switch ( f->id ) {
       case I_NARYOP:
         fun = (ARF)FA0(f);
         len = length((NODE)FA1(f));
         if ( len==1 ) return BDY((NODE)(FA1(f)));
   
         arg = (FNODE *)ALLOCA(len*sizeof(FNODE));
         for ( i = 0, t = (NODE)FA1(f); i < len; i++, t = NEXT(t) )
           arg[i] = fnode_to_bin((FNODE)BDY(t),dir);
         if ( dir ) {
           a2 = mkfnode(3,I_BOP,fun,arg[len-2],arg[len-1]);
           for ( i = len-3; i >= 0; i-- )
             a2 = mkfnode(3,I_BOP,fun,arg[i],a2);
         } else {
           a2 = mkfnode(3,I_BOP,fun,arg[0],arg[1]);
           for ( i = 2; i < len; i++ )
             a2 = mkfnode(3,I_BOP,fun,a2,arg[i]);
         }
         return a2;
   
       case I_NOT: case I_PAREN: case I_MINUS:
       case I_CAR: case I_CDR:
         a0 = fnode_to_bin((FNODE)FA0(f),dir);
         return mkfnode(1,f->id,a0);
   
       case I_BOP: case I_COP: case I_LOP:
         a1 = fnode_to_bin((FNODE)FA1(f),dir);
         a2 = fnode_to_bin((FNODE)FA2(f),dir);
         return mkfnode(3,f->id,FA0(f),a1,a2);
   
       case I_AND: case I_OR:
         a0 = fnode_to_bin((FNODE)FA0(f),dir);
         a1 = fnode_to_bin((FNODE)FA1(f),dir);
         return mkfnode(2,f->id,a0,a1);
   
       /* ternary operators */
       case I_CE:
         a0 = fnode_to_bin((FNODE)FA0(f),dir);
         a1 = fnode_to_bin((FNODE)FA1(f),dir);
         a2 = fnode_to_bin((FNODE)FA2(f),dir);
         return mkfnode(3,f->id,a0,a1,a2);
         break;
   
       /* function */
       case I_FUNC:
         a1 = fnode_to_bin((FNODE)FA1(f),dir);
         return mkfnode(2,f->id,FA0(f),a1);
   
       case I_LIST: case I_EV:
         n = fnode_to_bin_node((NODE)FA0(f),dir);
         return mkfnode(1,f->id,n);
   
       case I_STR: case I_FORMULA: case I_PVAR:
         return f;
   
       default:
         error("fnode_to_bin : not implemented yet");
     }
   }
   
   NODE partial_eval_node(NODE n);
   FNODE partial_eval(FNODE f);
   
   FNODE partial_eval(FNODE f)
   {
     FNODE a0,a1,a2;
     NODE n;
     Obj obj;
     QUOTE q;
     pointer val;
     FUNC func;
   
     if ( !f )
       return f;
     switch ( f->id ) {
       case I_NOT: case I_PAREN: case I_MINUS:
       case I_CAR: case I_CDR:
         a0 = partial_eval((FNODE)FA0(f));
         return mkfnode(1,f->id,a0);
   
       case I_BOP: case I_COP: case I_LOP:
         a1 = partial_eval((FNODE)FA1(f));
         a2 = partial_eval((FNODE)FA2(f));
         return mkfnode(3,f->id,FA0(f),a1,a2);
   
       case I_NARYOP:
         n = partial_eval_node((NODE)FA1(f));
         return mkfnode(2,f->id,FA0(f),n);
   
       case I_AND: case I_OR:
         a0 = partial_eval((FNODE)FA0(f));
         a1 = partial_eval((FNODE)FA1(f));
         return mkfnode(2,f->id,a0,a1);
   
       /* ternary operators */
       case I_CE:
         a0 = partial_eval((FNODE)FA0(f));
         a1 = partial_eval((FNODE)FA1(f));
         a2 = partial_eval((FNODE)FA2(f));
         return mkfnode(3,f->id,a0,a1,a2);
         break;
   
       /* XXX : function is evaluated with QUOTE args */
       case I_FUNC:
         a1 = partial_eval((FNODE)FA1(f));
         func = (FUNC)FA0(f);
         if ( func->id == A_UNDEF || func->id != A_USR ) {
           a1 =  mkfnode(2,I_FUNC,func,a1);
           return a1;
         } else {
           n = BDY(eval_arg(a1,(unsigned int)0xffffffff));
           obj = bevalf(func,n);
           objtoquote(obj,&q);
           return BDY(q);
         }
         break;
   
       case I_LIST: case I_EV:
         n = partial_eval_node((NODE)FA0(f));
         return mkfnode(1,f->id,n);
   
       case I_STR: case I_FORMULA:
         return f;
   
       /* program variable */
       case I_PVAR:
         val = eval(f);
         if ( val && OID((Obj)val) == O_QUOTE )
           return partial_eval((FNODE)BDY((QUOTE)val));
         else
           return mkfnode(1,I_FORMULA,val);
   
       default:
         error("partial_eval : not implemented yet");
     }
   }
   
   NODE partial_eval_node(NODE n)
   {
     NODE r0,r,t;
   
     for ( r0 = 0, t = n; t; t = NEXT(t) ) {
       NEXTNODE(r0,r);
       BDY(r) = partial_eval((FNODE)BDY(t));
     }
     if ( r0 ) NEXT(r) = 0;
     return r0;
   }
   
   NODE rewrite_fnode_node(NODE n,NODE arg,int qarg);
   FNODE rewrite_fnode(FNODE f,NODE arg,int qarg);
   
   FNODE rewrite_fnode(FNODE f,NODE arg,int qarg)
   {
     FNODE a0,a1,a2,value;
     NODE n,t,pair;
     pointer val;
     int pv,ind;
   
     if ( !f )
       return f;
     switch ( f->id ) {
       case I_NOT: case I_PAREN: case I_MINUS:
       case I_CAR: case I_CDR:
         a0 = rewrite_fnode((FNODE)FA0(f),arg,qarg);
         return mkfnode(1,f->id,a0);
   
       case I_BOP: case I_COP: case I_LOP:
         a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg);
         a2 = rewrite_fnode((FNODE)FA2(f),arg,qarg);
         return mkfnode(3,f->id,FA0(f),a1,a2);
   
       case I_AND: case I_OR:
         a0 = rewrite_fnode((FNODE)FA0(f),arg,qarg);
         a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg);
         return mkfnode(2,f->id,a0,a1);
   
       /* ternary operators */
       case I_CE:
         a0 = rewrite_fnode((FNODE)FA0(f),arg,qarg);
         a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg);
         a2 = rewrite_fnode((FNODE)FA2(f),arg,qarg);
         return mkfnode(3,f->id,a0,a1,a2);
         break;
   
       /* nary operators */
       case I_NARYOP:
         n = rewrite_fnode_node((NODE)FA1(f),arg,qarg);
         return mkfnode(2,f->id,FA0(f),n);
   
       /* and function */
       case I_FUNC:
         a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg);
         return mkfnode(2,qarg?I_FUNC_QARG:f->id,FA0(f),a1);
   
       case I_LIST: case I_EV:
         n = rewrite_fnode_node((NODE)FA0(f),arg,qarg);
         return mkfnode(1,f->id,n);
   
       case I_STR: case I_FORMULA:
         return f;
   
       /* program variable */
       case I_PVAR:
         pv = (int)FA0(f);
         for ( t = arg; t; t = NEXT(t) ) {
           pair = (NODE)BDY(t);
           ind = (int)BDY(pair);
           value = (FNODE)BDY(NEXT(pair));
           if ( pv == ind )
             return value;
         }
         return f;
         break;
   
       default:
         error("rewrite_fnode : not implemented yet");
     }
   }
   
   NODE rewrite_fnode_node(NODE n,NODE arg,int qarg)
   {
     NODE r0,r,t;
   
     for ( r0 = 0, t = n; t; t = NEXT(t) ) {
       NEXTNODE(r0,r);
       BDY(r) = rewrite_fnode((FNODE)BDY(t),arg,qarg);
     }
     if ( r0 ) NEXT(r) = 0;
     return r0;
   }
   
   NODE fnode_to_nary_node(NODE n)
   {
     NODE r0,r,t;
   
     for ( r0 = 0, t = n; t; t = NEXT(t) ) {
       NEXTNODE(r0,r);
       BDY(r) = fnode_to_nary((FNODE)BDY(t));
     }
     if ( r0 ) NEXT(r) = 0;
     return r0;
   }
   
   NODE fnode_to_bin_node(NODE n,int dir)
   {
     NODE r0,r,t;
   
     for ( r0 = 0, t = n; t; t = NEXT(t) ) {
       NEXTNODE(r0,r);
       BDY(r) = fnode_to_bin((FNODE)BDY(t),dir);
     }
     if ( r0 ) NEXT(r) = 0;
     return r0;
   }
   
   V searchvar(char *name);
   
 pointer evalstat(SNODE f)  pointer evalstat(SNODE f)
 {  {
         pointer val = 0,t,s,s1;    pointer val = 0,t,s,s1;
         P u;    P u;
         NODE tn;    NODE tn;
         int i,ac;    int i,ac;
         V *a;    V v;
         char *buf;    V *a;
     char *buf;
     FUNC func;
   
         if ( !f )    if ( !f )
                 return ( 0 );      return ( 0 );
         if ( nextbp && nextbplevel <= 0 && f->id != S_CPLX ) {    if ( nextbp && nextbplevel <= 0 && f->id != S_CPLX ) {
                 nextbp = 0;      nextbp = 0;
                 bp(f);      bp(f);
         }    }
         evalstatline = f->ln;    evalstatline = f->ln;
     if ( !PVSS ) at_root = evalstatline;
   
         switch ( f->id ) {    switch ( f->id ) {
                 case S_BP:      case S_BP:
                         if ( !nextbp && (!FA1(f) || eval((FNODE)FA1(f))) ) {        if ( !nextbp && (!FA1(f) || eval((FNODE)FA1(f))) ) {
                                 if ( (FNODE)FA2(f) ) {          if ( (FNODE)FA2(f) ) {
 #if defined(PARI)            asir_out = stderr;
                                         pari_outfile = stderr;            printexpr(CO,eval((FNODE)FA2(f)));
 #endif            putc('\n',asir_out); fflush(asir_out);
                                         asir_out = stderr;            asir_out = stdout;
                                         printexpr(CO,eval((FNODE)FA2(f)));          } else {
                                         putc('\n',asir_out); fflush(asir_out);            nextbp = 1; nextbplevel = 0;
 #if defined(PARI)          }
                                         pari_outfile = stdout;        }
 #endif        val = evalstat((SNODE)FA0(f));
                                         asir_out = stdout;        break;
                                 } else {      case S_PFDEF:
                                         nextbp = 1; nextbplevel = 0;        ac = argc(FA1(f)); a = (V *)MALLOC(ac*sizeof(V));
                                 }        s = eval((FNODE)FA2(f));
                         }        buf = (char *)ALLOCA(BUFSIZ);
                         val = evalstat((SNODE)FA0(f));        for ( i = 0, tn = (NODE)FA1(f); tn; tn = NEXT(tn), i++ ) {
                         break;          t = eval((FNODE)tn->body); sprintf(buf,"_%s",NAME(VR((P)t)));
                 case S_PFDEF:          makevar(buf,&u); a[i] = VR(u);
                         ac = argc(FA1(f)); a = (V *)MALLOC(ac*sizeof(V));          substr(CO,0,(Obj)s,VR((P)t),(Obj)u,(Obj *)&s1); s = s1;
                         s = eval((FNODE)FA2(f));        }
                         buf = (char *)ALLOCA(BUFSIZ);        mkpf((char *)FA0(f),(Obj)s,ac,a,0,0,0,(PF *)&val); val = 0;
                         for ( i = 0, tn = (NODE)FA1(f); tn; tn = NEXT(tn), i++ ) {        v = searchvar((char *)FA0(f));
                                 t = eval((FNODE)tn->body); sprintf(buf,"_%s",NAME(VR((P)t)));        if ( v ) {
                                 makevar(buf,&u); a[i] = VR(u);          searchpf((char *)FA0(f),&func);
                                 substr(CO,0,(Obj)s,VR((P)t),(Obj)u,(Obj *)&s1); s = s1;          makesrvar(func,&u);
                         }        }
                         mkpf((char *)FA0(f),(Obj)s,ac,a,0,0,0,(PF *)&val); val = 0; break;        break;
                 case S_SINGLE:      case S_SINGLE:
                         val = eval((FNODE)FA0(f)); break;        val = eval((FNODE)FA0(f)); break;
                 case S_CPLX:      case S_CPLX:
                         for ( tn = (NODE)FA0(f); tn; tn = NEXT(tn) ) {        for ( tn = (NODE)FA0(f); tn; tn = NEXT(tn) ) {
                                 if ( BDY(tn) )          if ( BDY(tn) )
                                         val = evalstat((SNODE)BDY(tn));            val = evalstat((SNODE)BDY(tn));
                                 if ( f_break || f_return || f_continue )          if ( f_break || f_return || f_continue )
                                         break;            break;
                         }        }
                         break;        break;
                 case S_BREAK:      case S_BREAK:
                         if ( GPVS != CPVS )        if ( 1 || GPVS != CPVS )
                                 f_break = 1;          f_break = 1;
                         break;        break;
                 case S_CONTINUE:      case S_CONTINUE:
                         if ( GPVS != CPVS )        if ( 1 || GPVS != CPVS )
                                 f_continue = 1;          f_continue = 1;
                         break;        break;
                 case S_RETURN:      case S_RETURN:
                         if ( GPVS != CPVS ) {        if ( 1 || GPVS != CPVS ) {
                                 val = eval((FNODE)FA0(f)); f_return = 1;          val = eval((FNODE)FA0(f)); f_return = 1;
                         }        }
                         break;        break;
                 case S_IFELSE:      case S_IFELSE:
                         if ( evalnode((NODE)FA1(f)) )        if ( evalnode((NODE)FA1(f)) )
                                 val = evalstat((SNODE)FA2(f));          val = evalstat((SNODE)FA2(f));
                         else if ( FA3(f) )        else if ( FA3(f) )
                                 val = evalstat((SNODE)FA3(f));          val = evalstat((SNODE)FA3(f));
                         break;        break;
                 case S_FOR:      case S_FOR:
                         evalnode((NODE)FA1(f));        evalnode((NODE)FA1(f));
                         while ( 1 ) {        while ( 1 ) {
                                 if ( !evalnode((NODE)FA2(f)) )          if ( !evalnode((NODE)FA2(f)) )
                                         break;            break;
                                 val = evalstat((SNODE)FA4(f));          val = evalstat((SNODE)FA4(f));
                                 if ( f_break || f_return )          if ( f_break || f_return )
                                         break;            break;
                                 f_continue = 0;          f_continue = 0;
                                 evalnode((NODE)FA3(f));          evalnode((NODE)FA3(f));
                         }        }
                         f_break = 0; break;        f_break = 0; break;
                 case S_DO:      case S_DO:
                         while ( 1 ) {        while ( 1 ) {
                                 val = evalstat((SNODE)FA1(f));          val = evalstat((SNODE)FA1(f));
                                 if ( f_break || f_return )          if ( f_break || f_return )
                                         break;            break;
                                 f_continue = 0;          f_continue = 0;
                                 if ( !evalnode((NODE)FA2(f)) )          if ( !evalnode((NODE)FA2(f)) )
                                         break;            break;
                         }        }
                         f_break = 0; break;        f_break = 0; break;
                 default:      case S_MODULE:
                         error("evalstat : unknown id");        CUR_MODULE = (MODULE)FA0(f);
                         break;        if ( CUR_MODULE )
         }            MPVS = CUR_MODULE->pvs;
         return ( val );        else
             MPVS = 0;
         break;
       default:
         error("evalstat : unknown id");
         break;
     }
     return ( val );
 }  }
   
 pointer evalnode(NODE node)  pointer evalnode(NODE node)
 {  {
         NODE tn;    NODE tn;
         pointer val;    pointer val;
   
         for ( tn = node, val = 0; tn; tn = NEXT(tn) )    for ( tn = node, val = 0; tn; tn = NEXT(tn) )
                 if ( BDY(tn) )      if ( BDY(tn) )
                         val = eval((FNODE)BDY(tn));        val = eval((FNODE)BDY(tn));
         return ( val );    return ( val );
 }  }
   
 extern FUNC cur_binf;  
 extern NODE PVSS;  
   
   LIST eval_arg(FNODE a,unsigned int quote)
   {
     LIST l;
     FNODE fn;
     NODE n,n0,tn;
     QUOTE q;
     int i;
   
     for ( tn = (NODE)FA0(a), n0 = 0, i = 0; tn; tn = NEXT(tn), i++ ) {
       NEXTNODE(n0,n);
       if ( quote & (1<<i) ) {
         fn = (FNODE)(BDY(tn));
         if ( fn->id == I_FORMULA && FA0(fn)
           && OID((Obj)FA0(fn))== O_QUOTE )
            BDY(n) = FA0(fn);
         else {
           MKQUOTE(q,(FNODE)BDY(tn));
           BDY(n) = (pointer)q;
         }
       } else
         BDY(n) = eval((FNODE)BDY(tn));
     }
     if ( n0 ) NEXT(n) = 0;
     MKLIST(l,n0);
     return l;
   }
   
 pointer evalf(FUNC f,FNODE a,FNODE opt)  pointer evalf(FUNC f,FNODE a,FNODE opt)
 {  {
         LIST args;    LIST args;
         pointer val;    pointer val;
         int i,n,level;    int i,n,level;
         NODE tn,sn,opts,opt1;    NODE tn,sn,opts,opt1,dmy;
     VS pvs,prev_mpvs;        VS pvs,prev_mpvs;
         char errbuf[BUFSIZ];    char errbuf[BUFSIZ];
         static unsigned int stack_size;    static unsigned int stack_size;
         static void *stack_base;    static void *stack_base;
     FUNC f1;
   
         if ( f->id == A_UNDEF ) {    if ( f->id == A_UNDEF ) {
                 sprintf(errbuf,"evalf : %s undefined",NAME(f));      gen_searchf_searchonly(f->fullname,&f1,0);
                 error(errbuf);      if ( f1->id == A_UNDEF ) {
         }        sprintf(errbuf,"evalf : %s undefined",NAME(f));
         if ( f->id != A_PARI ) {        error(errbuf);
                 for ( i = 0, tn = a?(NODE)FA0(a):0; tn; i++, tn = NEXT(tn) );      } else
                 if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {        *f = *f1;
                         sprintf(errbuf,"evalf : argument mismatch in %s()",NAME(f));    }
                         error(errbuf);    if ( getsecuremode() && !PVSS && !f->secure ) {
                 }      sprintf(errbuf,"evalf : %s not permitted",NAME(f));
         }      error(errbuf);
         switch ( f->id ) {    }
                 case A_BIN:    if ( f->id != A_PARI ) {
                         if ( !n ) {      for ( i = 0, tn = a?(NODE)FA0(a):0; tn; i++, tn = NEXT(tn) );
                                 cur_binf = f;      if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
                                 (*f->f.binf)(&val);        sprintf(errbuf,"evalf : argument mismatch in %s()",NAME(f));
                         } else {        error(errbuf);
                                 args = (LIST)eval(a);      }
                                 cur_binf = f;    }
                                 (*f->f.binf)(args?BDY(args):0,&val);    switch ( f->id ) {
                         }      case A_BIN:
                         cur_binf = 0;        if ( opt ) {
                         break;          opts = BDY((LIST)eval(opt));
                 case A_PARI:          /* opts = ["opt1",arg1],... */
                         args = (LIST)eval(a);          opt1 = BDY((LIST)BDY(opts));
                         cur_binf = f;          if ( !strcmp(BDY((STRING)BDY(opt1)),"option_list") ) {
                         val = evalparif(f,args?BDY(args):0);            /*
                         cur_binf = 0;             * the special option specification:
                         break;             *  option_list=[["o1","a1"],...]
                 case A_USR:             */
                         /* stack check */            asir_assert(BDY(NEXT(opt1)),O_LIST,"evalf");
 #if !defined(VISUAL) && !defined(__CYGWIN__)            opts = BDY((LIST)BDY(NEXT(opt1)));
                         if ( !stack_size ) {          }
                                 struct rlimit rl;        } else
                                 getrlimit(RLIMIT_STACK,&rl);          opts = 0;
                                 stack_size = rl.rlim_cur;        if ( !n ) {
                         }          current_option = opts;
                         if ( !stack_base )          cur_binf = f;
                                 stack_base = (void *)GC_get_stack_base();          (*f->f.binf)(&val);
                         if ( (stack_base - (void *)&args) +0x100000 > stack_size )        } else {
                                 error("stack overflow");          args = (LIST)eval_arg(a,f->quote);
           current_option = opts;
           cur_binf = f;
           (*f->f.binf)(args?BDY(args):0,&val);
         }
         cur_binf = 0;
         break;
       case A_PARI:
         args = (LIST)eval(a);
         cur_binf = f;
         val = evalparif(f,args?BDY(args):0);
         cur_binf = 0;
         break;
       case A_USR:
         /* stack check */
   #if !defined(VISUAL) && !defined(__MINGW32__) && !defined(__CYGWIN__)
         if ( !stack_size ) {
           struct rlimit rl;
           getrlimit(RLIMIT_STACK,&rl);
           stack_size = rl.rlim_cur;
         }
               if ( !stack_base ) {
   #if defined(GC7)
                   stack_base = (void *)GC_get_main_stack_base();
   #else
                   stack_base = (void *)GC_get_stack_base();
 #endif  #endif
                         args = (LIST)eval(a);              }
                         if ( opt ) {        if ( (stack_base - (void *)&args) +0x100000 > stack_size )
                                 opts = BDY((LIST)eval(opt));          error("stack overflow");
                                 /* opts = ["opt1",arg1],... */  #endif
                                 opt1 = BDY((LIST)BDY(opts));        args = (LIST)eval_arg(a,f->quote);
                                 if ( !strcmp(BDY((STRING)BDY(opt1)),"option_list") ) {        if ( opt ) {
                                         /*          opts = BDY((LIST)eval(opt));
                                          * the special option specification:          /* opts = ["opt1",arg1],... */
                                          *  option_list=[["o1","a1"],...]          opt1 = BDY((LIST)BDY(opts));
                                          */          if ( !strcmp(BDY((STRING)BDY(opt1)),"option_list") ) {
                                         asir_assert(BDY(NEXT(opt1)),O_LIST,"evalf");            /*
                                         opts = BDY((LIST)BDY(NEXT(opt1)));             * the special option specification:
                                 }             *  option_list=[["o1","a1"],...]
                         } else             */
                                 opts = 0;            asir_assert(BDY(NEXT(opt1)),O_LIST,"evalf");
                 pvs = f->f.usrf->pvs;            opts = BDY((LIST)BDY(NEXT(opt1)));
                 if ( PVSS ) {          }
                         ((VS)BDY(PVSS))->at = evalstatline;        } else
                                 level = ((VS)BDY(PVSS))->level+1;          opts = 0;
                         } else          pvs = f->f.usrf->pvs;
                                 level = 1;          if ( PVSS ) {
                 MKNODE(tn,pvs,PVSS); PVSS = tn;              ((VS)BDY(PVSS))->at = evalstatline;
                 CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;          level = ((VS)BDY(PVSS))->level+1;
                 CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;        } else
                         CPVS->level = level;          level = 1;
                         CPVS->opt = opts;          MKNODE(tn,pvs,PVSS); PVSS = tn;
                 if ( CPVS->n ) {          CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
                         CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));          CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
                         bcopy((char *)pvs->va,(char *)CPVS->va,        CPVS->level = level;
                                         (int)(pvs->n*sizeof(struct oPV)));        CPVS->opt = opts;
                 }          if ( CPVS->n ) {
                 if ( nextbp )              CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
                         nextbplevel++;              bcopy((char *)pvs->va,(char *)CPVS->va,
                         for ( tn = f->f.usrf->args, sn = BDY(args);            (int)(pvs->n*sizeof(struct oPV)));
                                 sn; tn = NEXT(tn), sn = NEXT(sn) )          }
                                 ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));          if ( nextbp )
                         if ( f->f.usrf->module ) {              nextbplevel++;
                                 prev_mpvs = MPVS;        for ( tn = f->f.usrf->args, sn = BDY(args);
                                 MPVS = f->f.usrf->module->pvs;          sn; tn = NEXT(tn), sn = NEXT(sn) )
                                 val = evalstat((SNODE)BDY(f->f.usrf));          ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
                                 MPVS = prev_mpvs;        f_return = f_break = f_continue = 0;
                         } else        if ( f->f.usrf->module ) {
                                 val = evalstat((SNODE)BDY(f->f.usrf));          prev_mpvs = MPVS;
                         f_return = f_break = f_continue = 0; poppvs();          MPVS = f->f.usrf->module->pvs;
                         break;          val = evalstat((SNODE)BDY(f->f.usrf));
                 case A_PURE:          MPVS = prev_mpvs;
                         args = (LIST)eval(a);        } else
                         val = evalpf(f->f.puref,args?BDY(args):0);          val = evalstat((SNODE)BDY(f->f.usrf));
                         break;        f_return = f_break = f_continue = 0; poppvs();
                 default:        if ( PVSS )
                         sprintf(errbuf,"evalf : %s undefined",NAME(f));              evalstatline = ((VS)BDY(PVSS))->at;
                         error(errbuf);        break;
                         break;      case A_PURE:
         }        args = (LIST)eval(a);
         return val;        val = evalpf(f->f.puref,args?BDY(args):0,0);
         break;
       default:
         sprintf(errbuf,"evalf : %s undefined",NAME(f));
         error(errbuf);
         break;
     }
     return val;
 }  }
   
   pointer evalf_deriv(FUNC f,FNODE a,FNODE deriv)
   {
     LIST args,dargs;
     pointer val;
     char errbuf[BUFSIZ];
   
     switch ( f->id ) {
       case A_PURE:
         args = (LIST)eval(a);
         dargs = (LIST)eval(deriv);
         val = evalpf(f->f.puref,
           args?BDY(args):0,dargs?BDY(dargs):0);
         break;
       default:
         sprintf(errbuf,
           "evalf : %s is not a pure function",NAME(f));
         error(errbuf);
         break;
     }
     return val;
   }
   
 pointer evalmapf(FUNC f,FNODE a)  pointer evalmapf(FUNC f,FNODE a)
 {  {
         LIST args;    LIST args;
         NODE node,rest,t,n,r,r0;    NODE node,rest,t,n,r,r0;
         Obj head;    Obj head;
         VECT v,rv;    VECT v,rv;
         MAT m,rm;    MAT m,rm;
         LIST rl;    LIST rl;
         int len,row,col,i,j;    int len,row,col,i,j;
         pointer val;    pointer val;
   
         args = (LIST)eval(a);    args = (LIST)eval_arg(a,f->quote);
         node = BDY(args); head = (Obj)BDY(node); rest = NEXT(node);    node = BDY(args); head = (Obj)BDY(node); rest = NEXT(node);
         if ( !head ) {    if ( !head ) {
                 val = bevalf(f,node);      val = bevalf(f,node);
                 return val;      return val;
         }    }
         switch ( OID(head) ) {    switch ( OID(head) ) {
                 case O_VECT:      case O_VECT:
                         v = (VECT)head; len = v->len; MKVECT(rv,len);        v = (VECT)head; len = v->len; MKVECT(rv,len);
                         for ( i = 0; i < len; i++ ) {        for ( i = 0; i < len; i++ ) {
                                 MKNODE(t,BDY(v)[i],rest); BDY(rv)[i] = bevalf(f,t);          MKNODE(t,BDY(v)[i],rest); BDY(rv)[i] = bevalf(f,t);
                         }        }
                         val = (pointer)rv;        val = (pointer)rv;
                         break;        break;
                 case O_MAT:      case O_MAT:
                         m = (MAT)head; row = m->row; col = m->col; MKMAT(rm,row,col);        m = (MAT)head; row = m->row; col = m->col; MKMAT(rm,row,col);
                         for ( i = 0; i < row; i++ )        for ( i = 0; i < row; i++ )
                                 for ( j = 0; j < col; j++ ) {          for ( j = 0; j < col; j++ ) {
                                         MKNODE(t,BDY(m)[i][j],rest); BDY(rm)[i][j] = bevalf(f,t);            MKNODE(t,BDY(m)[i][j],rest); BDY(rm)[i][j] = bevalf(f,t);
                                 }          }
                         val = (pointer)rm;        val = (pointer)rm;
                         break;        break;
                 case O_LIST:      case O_LIST:
                         n = BDY((LIST)head);        n = BDY((LIST)head);
                         for ( r0 = r = 0; n; n = NEXT(n) ) {        for ( r0 = r = 0; n; n = NEXT(n) ) {
                                 NEXTNODE(r0,r); MKNODE(t,BDY(n),rest); BDY(r) = bevalf(f,t);          NEXTNODE(r0,r); MKNODE(t,BDY(n),rest); BDY(r) = bevalf(f,t);
                         }        }
                         if ( r0 )        if ( r0 )
                                 NEXT(r) = 0;          NEXT(r) = 0;
                         MKLIST(rl,r0);        MKLIST(rl,r0);
                         val = (pointer)rl;        val = (pointer)rl;
                         break;        break;
                 default:      default:
                         val = bevalf(f,node);        val = bevalf(f,node);
                         break;        break;
         }    }
         return val;    return val;
 }  }
   
 pointer eval_rec_mapf(FUNC f,FNODE a)  pointer eval_rec_mapf(FUNC f,FNODE a)
 {  {
         LIST args;    LIST args;
   
         args = (LIST)eval(a);    args = (LIST)eval_arg(a,f->quote);
         return beval_rec_mapf(f,BDY(args));    return beval_rec_mapf(f,BDY(args));
 }  }
   
 pointer beval_rec_mapf(FUNC f,NODE node)  pointer beval_rec_mapf(FUNC f,NODE node)
 {  {
         NODE rest,t,n,r,r0;    NODE rest,t,n,r,r0;
         Obj head;    Obj head;
         VECT v,rv;    VECT v,rv;
         MAT m,rm;    MAT m,rm;
         LIST rl;    LIST rl;
         int len,row,col,i,j;    int len,row,col,i,j;
         pointer val;    pointer val;
   
         head = (Obj)BDY(node); rest = NEXT(node);    head = (Obj)BDY(node); rest = NEXT(node);
         if ( !head ) {    if ( !head ) {
                 val = bevalf(f,node);      val = bevalf(f,node);
                 return val;      return val;
         }    }
         switch ( OID(head) ) {    switch ( OID(head) ) {
                 case O_VECT:      case O_VECT:
                         v = (VECT)head; len = v->len; MKVECT(rv,len);        v = (VECT)head; len = v->len; MKVECT(rv,len);
                         for ( i = 0; i < len; i++ ) {        for ( i = 0; i < len; i++ ) {
                                 MKNODE(t,BDY(v)[i],rest); BDY(rv)[i] = beval_rec_mapf(f,t);          MKNODE(t,BDY(v)[i],rest); BDY(rv)[i] = beval_rec_mapf(f,t);
                         }        }
                         val = (pointer)rv;        val = (pointer)rv;
                         break;        break;
                 case O_MAT:      case O_MAT:
                         m = (MAT)head; row = m->row; col = m->col; MKMAT(rm,row,col);        m = (MAT)head; row = m->row; col = m->col; MKMAT(rm,row,col);
                         for ( i = 0; i < row; i++ )        for ( i = 0; i < row; i++ )
                                 for ( j = 0; j < col; j++ ) {          for ( j = 0; j < col; j++ ) {
                                         MKNODE(t,BDY(m)[i][j],rest);            MKNODE(t,BDY(m)[i][j],rest);
                                         BDY(rm)[i][j] = beval_rec_mapf(f,t);            BDY(rm)[i][j] = beval_rec_mapf(f,t);
                                 }          }
                         val = (pointer)rm;        val = (pointer)rm;
                         break;        break;
                 case O_LIST:      case O_LIST:
                         n = BDY((LIST)head);        n = BDY((LIST)head);
                         for ( r0 = r = 0; n; n = NEXT(n) ) {        for ( r0 = r = 0; n; n = NEXT(n) ) {
                                 NEXTNODE(r0,r); MKNODE(t,BDY(n),rest);          NEXTNODE(r0,r); MKNODE(t,BDY(n),rest);
                                 BDY(r) = beval_rec_mapf(f,t);          BDY(r) = beval_rec_mapf(f,t);
                         }        }
                         if ( r0 )        if ( r0 )
                                 NEXT(r) = 0;          NEXT(r) = 0;
                         MKLIST(rl,r0);        MKLIST(rl,r0);
                         val = (pointer)rl;        val = (pointer)rl;
                         break;        break;
                 default:      default:
                         val = bevalf(f,node);        val = bevalf(f,node);
                         break;        break;
         }    }
         return val;    return val;
 }  }
   
 pointer bevalf(FUNC f,NODE a)  pointer bevalf(FUNC f,NODE a)
 {  {
         pointer val;    pointer val;
         int i,n;    int i,n;
         NODE tn,sn;    NODE tn,sn;
     VS pvs;    VS pvs,prev_mpvs;
         char errbuf[BUFSIZ];    char errbuf[BUFSIZ];
   
         if ( f->id == A_UNDEF ) {    if ( f->id == A_UNDEF ) {
                 sprintf(errbuf,"bevalf : %s undefined",NAME(f));      sprintf(errbuf,"bevalf : %s undefined",NAME(f));
                 error(errbuf);      error(errbuf);
         }    }
         if ( f->id != A_PARI ) {    if ( getsecuremode() && !PVSS && !f->secure ) {
                 for ( i = 0, tn = a; tn; i++, tn = NEXT(tn) );      sprintf(errbuf,"bevalf : %s not permitted",NAME(f));
                 if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {      error(errbuf);
                         sprintf(errbuf,"bevalf : argument mismatch in %s()",NAME(f));    }
                         error(errbuf);    if ( f->id != A_PARI ) {
                 }      for ( i = 0, tn = a; tn; i++, tn = NEXT(tn) );
         }      if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
         switch ( f->id ) {        sprintf(errbuf,"bevalf : argument mismatch in %s()",NAME(f));
                 case A_BIN:        error(errbuf);
                         if ( !n ) {      }
                                 cur_binf = f;    }
                                 (*f->f.binf)(&val);    switch ( f->id ) {
                         } else {      case A_BIN:
                                 cur_binf = f;        current_option = 0;
                                 (*f->f.binf)(a,&val);        if ( !n ) {
                         }          cur_binf = f;
                         cur_binf = 0;          (*f->f.binf)(&val);
                         break;        } else {
                 case A_PARI:          cur_binf = f;
                         cur_binf = f;          (*f->f.binf)(a,&val);
                         val = evalparif(f,a);        }
                         cur_binf = 0;        cur_binf = 0;
                         break;        break;
                 case A_USR:      case A_PARI:
                 pvs = f->f.usrf->pvs;        cur_binf = f;
                 if ( PVSS )        val = evalparif(f,a);
                         ((VS)BDY(PVSS))->at = evalstatline;        cur_binf = 0;
                 MKNODE(tn,pvs,PVSS); PVSS = tn;        break;
                 CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;      case A_USR:
                 CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;          pvs = f->f.usrf->pvs;
                         CPVS->opt = 0;          if ( PVSS )
                 if ( CPVS->n ) {              ((VS)BDY(PVSS))->at = evalstatline;
                         CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));          MKNODE(tn,pvs,PVSS); PVSS = tn;
                         bcopy((char *)pvs->va,(char *)CPVS->va,          CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
                                         (int)(pvs->n*sizeof(struct oPV)));          CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
                 }        CPVS->opt = 0;
                 if ( nextbp )          if ( CPVS->n ) {
                         nextbplevel++;              CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
                         for ( tn = f->f.usrf->args, sn = a;              bcopy((char *)pvs->va,(char *)CPVS->va,
                                 sn; tn = NEXT(tn), sn = NEXT(sn) )            (int)(pvs->n*sizeof(struct oPV)));
                                 ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));          }
                         val = evalstat((SNODE)BDY(f->f.usrf));          if ( nextbp )
                         f_return = f_break = f_continue = 0; poppvs();              nextbplevel++;
                         break;        for ( tn = f->f.usrf->args, sn = a;
                 case A_PURE:          sn; tn = NEXT(tn), sn = NEXT(sn) )
                         val = evalpf(f->f.puref,a);          ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
                         break;        f_return = f_break = f_continue = 0;
                 default:        if ( f->f.usrf->module ) {
                         sprintf(errbuf,"bevalf : %s undefined",NAME(f));          prev_mpvs = MPVS;
                         error(errbuf);          MPVS = f->f.usrf->module->pvs;
                         break;          val = evalstat((SNODE)BDY(f->f.usrf));
         }          MPVS = prev_mpvs;
         return val;        } else
           val = evalstat((SNODE)BDY(f->f.usrf));
         f_return = f_break = f_continue = 0; poppvs();
         break;
       case A_PURE:
         val = evalpf(f->f.puref,a,0);
         break;
       default:
         sprintf(errbuf,"bevalf : %s undefined",NAME(f));
         error(errbuf);
         break;
     }
     return val;
 }  }
   
 pointer evalif(FNODE f,FNODE a)  pointer bevalf_with_opts(FUNC f,NODE a,NODE opts)
 {  {
         Obj g;    pointer val;
     int i,n;
     NODE tn,sn;
     VS pvs,prev_mpvs;
     char errbuf[BUFSIZ];
   
         g = (Obj)eval(f);    if ( f->id == A_UNDEF ) {
         if ( g && (OID(g) == O_P) && (VR((P)g)->attr == (pointer)V_SR) )      sprintf(errbuf,"bevalf : %s undefined",NAME(f));
                 return evalf((FUNC)VR((P)g)->priv,a,0);      error(errbuf);
         else {    }
                 error("invalid function pointer");    if ( getsecuremode() && !PVSS && !f->secure ) {
                 /* NOTREACHED */      sprintf(errbuf,"bevalf : %s not permitted",NAME(f));
                 return (pointer)-1;      error(errbuf);
         }    }
     if ( f->id != A_PARI ) {
       for ( i = 0, tn = a; tn; i++, tn = NEXT(tn) );
       if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
         sprintf(errbuf,"bevalf : argument mismatch in %s()",NAME(f));
         error(errbuf);
       }
     }
     switch ( f->id ) {
       case A_BIN:
         current_option = opts;
         if ( !n ) {
           cur_binf = f;
           (*f->f.binf)(&val);
         } else {
           cur_binf = f;
           (*f->f.binf)(a,&val);
         }
         cur_binf = 0;
         break;
       case A_PARI:
         cur_binf = f;
         val = evalparif(f,a);
         cur_binf = 0;
         break;
       case A_USR:
           pvs = f->f.usrf->pvs;
           if ( PVSS )
               ((VS)BDY(PVSS))->at = evalstatline;
           MKNODE(tn,pvs,PVSS); PVSS = tn;
           CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
           CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
         CPVS->opt = opts;
           if ( CPVS->n ) {
               CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
               bcopy((char *)pvs->va,(char *)CPVS->va,
             (int)(pvs->n*sizeof(struct oPV)));
           }
           if ( nextbp )
               nextbplevel++;
         for ( tn = f->f.usrf->args, sn = a;
           sn; tn = NEXT(tn), sn = NEXT(sn) )
           ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
         f_return = f_break = f_continue = 0;
         if ( f->f.usrf->module ) {
           prev_mpvs = MPVS;
           MPVS = f->f.usrf->module->pvs;
           val = evalstat((SNODE)BDY(f->f.usrf));
           MPVS = prev_mpvs;
         } else
           val = evalstat((SNODE)BDY(f->f.usrf));
         f_return = f_break = f_continue = 0; poppvs();
         break;
       case A_PURE:
         val = evalpf(f->f.puref,a,0);
         break;
       default:
         sprintf(errbuf,"bevalf : %s undefined",NAME(f));
         error(errbuf);
         break;
     }
     return val;
 }  }
   
 pointer evalpf(PF pf,NODE args)  pointer evalif(FNODE f,FNODE a,FNODE opt)
 {  {
         Obj s,s1;    Obj g;
         int i;    QUOTE q;
         NODE node;    FNODE t;
         PFINS ins;    LIST l;
         PFAD ad;  
     g = (Obj)eval(f);
         if ( !pf->body ) {    if ( g && (OID(g) == O_P) && (VR((P)g)->attr == (pointer)V_SR) )
                 ins = (PFINS)CALLOC(1,sizeof(PF)+pf->argc*sizeof(struct oPFAD));      return evalf((FUNC)VR((P)g)->priv,a,opt);
                 ins->pf = pf;    else if ( g && OID(g) == O_QUOTEARG && ((QUOTEARG)g)->type == A_func ) {
                 for ( i = 0, node = args, ad = ins->ad;      t = mkfnode(2,I_FUNC,((QUOTEARG)g)->body,a);
                         node; node = NEXT(node), i++ ) {      MKQUOTE(q,t);
                         ad[i].d = 0; ad[i].arg = (Obj)node->body;      return q;
                 }    } else {
                 simplify_ins(ins,&s);      error("invalid function pointer");
         } else {      /* NOTREACHED */
                 for ( i = 0, s = pf->body, node = args;      return (pointer)-1;
                         node; node = NEXT(node), i++ ) {    }
                         substr(CO,0,s,pf->args[i],(Obj)node->body,&s1); s = s1;  
                 }  
         }  
         return (pointer)s;  
 }  }
   
   pointer evalpf(PF pf,NODE args,NODE dargs)
   {
     Obj s,s1;
     int i,di,j;
     NODE node,dnode;
     PFINS ins;
     PFAD ad;
   
     if ( !pf->body ) {
       ins = (PFINS)CALLOC(1,sizeof(PF)+pf->argc*sizeof(struct oPFAD));
       ins->pf = pf;
       for ( i = 0, node = args, dnode = dargs, ad = ins->ad;
         node; i++ ) {
         ad[i].arg = (Obj)node->body;
         if ( !dnode ) ad[i].d = 0;
         else
           ad[i].d = QTOS((Q)dnode->body);
         node = NEXT(node);
         if ( dnode ) dnode = NEXT(dnode);
       }
       simplify_ins(ins,&s);
     } else {
       s = pf->body;
       if ( dargs ) {
         for ( i = 0, dnode = dargs; dnode; dnode = NEXT(dnode), i++ ) {
           di = QTOS((Q)dnode->body);
           for ( j = 0; j < di; j++ ) {
             derivr(CO,s,pf->args[i],&s1); s = s1;
           }
         }
       }
       for ( i = 0, node = args; node; node = NEXT(node), i++ ) {
         substr(CO,0,s,pf->args[i],(Obj)node->body,&s1); s = s1;
       }
     }
     return (pointer)s;
   }
   
 void evalnodebody(NODE sn,NODE *dnp)  void evalnodebody(NODE sn,NODE *dnp)
 {  {
         NODE n,n0,tn;    NODE n,n0,tn;
         int line;    int line;
   
         if ( !sn ) {    if ( !sn ) {
                 *dnp = 0;      *dnp = 0;
                 return;      return;
         }    }
         line = evalstatline;    line = evalstatline;
         for ( tn = sn, n0 = 0; tn; tn = NEXT(tn) ) {    for ( tn = sn, n0 = 0; tn; tn = NEXT(tn) ) {
                 NEXTNODE(n0,n);      NEXTNODE(n0,n);
                 BDY(n) = eval((FNODE)BDY(tn));      BDY(n) = eval((FNODE)BDY(tn));
                 evalstatline = line;      evalstatline = line;
         }    }
         NEXT(n) = 0; *dnp = n0;    NEXT(n) = 0; *dnp = n0;
 }  }
   
 MODULE searchmodule(char *name)  MODULE searchmodule(char *name)
 {  {
         MODULE mod;    MODULE mod;
         NODE m;    NODE m;
   
         for ( m = MODULE_LIST; m; m = NEXT(m) ) {    for ( m = MODULE_LIST; m; m = NEXT(m) ) {
                 mod = (MODULE)BDY(m);      mod = (MODULE)BDY(m);
                 if ( !strcmp(mod->name,name) )      if ( !strcmp(mod->name,name) )
                         return mod;        return mod;
         }    }
         return 0;    return 0;
 }  }
   /*
    * xxx.yyy() is searched in the flist
    * of the module xxx.
    * yyy() is searched in the global flist.
    */
   
 void searchuf(char *name,FUNC *r)  void searchuf(char *name,FUNC *r)
 {  {
         MODULE mod;    MODULE mod;
         char *name0,*dot;    char *name0,*dot;
   
         if ( dot = strchr(name,'.') ) {    if ( dot = strchr(name,'.') ) {
                 name0 = (char *)ALLOCA(strlen(name)+1);      name0 = (char *)ALLOCA(strlen(name)+1);
                 strcpy(name0,name);      strcpy(name0,name);
                 dot = strchr(name0,'.');      dot = strchr(name0,'.');
                 *dot = 0;      *dot = 0;
                 mod = searchmodule(name0);      mod = searchmodule(name0);
                 if ( mod )      if ( mod )
                         searchf(mod->usrf_list,dot+1,r);        searchf(mod->usrf_list,dot+1,r);
         } else    } else
                 searchf(usrf,name,r);      searchf(usrf,name,r);
 }  }
   
 void gen_searchf(char *name,FUNC *r)  void gen_searchf(char *name,FUNC *r)
 {  {
         FUNC val = 0;    FUNC val = 0;
     int global = 0;
     if ( *name == ':' ) {
       global = 1;
       name += 2;
     }
     if ( CUR_MODULE && !global )
       searchf(CUR_MODULE->usrf_list,name,&val);
     if ( !val )
       searchf(sysf,name,&val);
     if ( !val )
       searchf(ubinf,name,&val);
     if ( !val )
       searchpf(name,&val);
     if ( !val )
       searchuf(name,&val);
     if ( !val )
       appenduf(name,&val);
     *r = val;
   }
   
         if ( CUR_MODULE )  void gen_searchf_searchonly(char *name,FUNC *r,int global)
                 searchf(CUR_MODULE->usrf_list,name,&val);  {
         if ( !val )    FUNC val = 0;
                 searchf(sysf,name,&val);    if ( *name == ':' ) {
         if ( !val )      global = 1;
                 searchf(ubinf,name,&val);      name += 2;
         if ( !val )    }
                 searchpf(name,&val);    if ( CUR_MODULE && !global )
         if ( !val )      searchf(CUR_MODULE->usrf_list,name,&val);
                 searchuf(name,&val);    if ( !val )
         if ( !val )      searchf(sysf,name,&val);
                 appenduf(name,&val);    if ( !val )
         *r = val;      searchf(ubinf,name,&val);
     if ( !val )
       searchpf(name,&val);
     if ( !val )
       searchuf(name,&val);
     *r = val;
 }  }
   
 void searchf(NODE fn,char *name,FUNC *r)  void searchf(NODE fn,char *name,FUNC *r)
 {  {
         NODE tn;    NODE tn;
   
         for ( tn = fn;    for ( tn = fn;
                 tn && strcmp(NAME((FUNC)BDY(tn)),name); tn = NEXT(tn) );      tn && strcmp(NAME((FUNC)BDY(tn)),name); tn = NEXT(tn) );
                 if ( tn ) {      if ( tn ) {
                         *r = (FUNC)BDY(tn);        *r = (FUNC)BDY(tn);
                         return;        return;
                 }      }
         *r = 0;    *r = 0;
 }  }
   
 MODULE mkmodule(char *);  MODULE mkmodule(char *);
   
 void appenduf(char *name,FUNC *r)  void appenduf(char *name,FUNC *r)
 {  {
         NODE tn;    NODE tn;
         FUNC f;    FUNC f;
         int len;    int len;
         MODULE mod;    MODULE mod;
         char *modname,*fname,*dot;    char *modname,*fname,*dot;
   
         f=(FUNC)MALLOC(sizeof(struct oFUNC));    f=(FUNC)MALLOC(sizeof(struct oFUNC));
         f->id = A_UNDEF; f->argc = 0; f->f.binf = 0;    f->id = A_UNDEF; f->argc = 0; f->f.binf = 0;
         if ( dot = strchr(name,'.') ) {    if ( dot = strchr(name,'.') ) {
                 /* undefined function in undefined module */      /* undefined function in a module */
                 len = dot-name;      len = dot-name;
                 modname = (char *)MALLOC_ATOMIC(len+1);      modname = (char *)MALLOC_ATOMIC(len+1);
                 strncpy(modname,name,len); modname[len] = 0;      strncpy(modname,name,len); modname[len] = 0;
                 mod = mkmodule(modname);      fname = (char *)MALLOC_ATOMIC(strlen(name)-len+1);
                 fname = (char *)MALLOC_ATOMIC(strlen(name)-len+1);      strcpy(fname,dot+1);
                 strcpy(fname,dot+1);      f->name = fname;
                 f->name = fname;      f->fullname = name;
                 MKNODE(mod->usrf_list,f,0);      mod = searchmodule(modname);
         } else {      if ( !mod )
                 f->name = name;        mod = mkmodule(modname);
                 if ( CUR_MODULE ) {      MKNODE(tn,f,mod->usrf_list); mod->usrf_list = tn;
                         MKNODE(tn,f,CUR_MODULE->usrf_list); CUR_MODULE->usrf_list = tn;    } else {
                 } else {      f->name = name;
                         MKNODE(tn,f,usrf); usrf = tn;      f->fullname = name;
                 }      MKNODE(tn,f,usrf); usrf = tn;
         }    }
         *r = f;    *r = f;
 }  }
   
   void appenduf_local(char *name,FUNC *r)
   {
     NODE tn;
     FUNC f;
     MODULE mod;
   
     for ( tn = CUR_MODULE->usrf_list; tn; tn = NEXT(tn) )
       if ( !strcmp(((FUNC)BDY(tn))->name,name) )
         break;
     if ( tn )
       return;
   
     f=(FUNC)MALLOC(sizeof(struct oFUNC));
     f->id = A_UNDEF; f->argc = 0; f->f.binf = 0;
     f->name = name;
     f->fullname =
       (char *)MALLOC_ATOMIC(strlen(CUR_MODULE->name)+strlen(name)+1);
     sprintf(f->fullname,"%s.%s",CUR_MODULE->name,name);
     MKNODE(tn,f,CUR_MODULE->usrf_list); CUR_MODULE->usrf_list = tn;
     *r = f;
   }
   
   void appenduflist(NODE n)
   {
     NODE tn;
     FUNC f;
   
     for ( tn = n; tn; tn = NEXT(tn) )
       appenduf_local((char *)BDY(tn),&f);
   }
   
 void mkparif(char *name,FUNC *r)  void mkparif(char *name,FUNC *r)
 {  {
         FUNC f;    FUNC f;
   
         *r = f =(FUNC)MALLOC(sizeof(struct oFUNC));    *r = f =(FUNC)MALLOC(sizeof(struct oFUNC));
         f->name = name; f->id = A_PARI; f->argc = 0; f->f.binf = 0;    f->name = name; f->id = A_PARI; f->argc = 0; f->f.binf = 0;
     f->fullname = name;
 }  }
   
 void mkuf(char *name,char *fname,NODE args,SNODE body,int startl,int endl,char *desc,MODULE module)  void mkuf(char *name,char *fname,NODE args,SNODE body,int startl,int endl,char *desc,MODULE module)
 {  {
         FUNC f;    FUNC f;
         USRF t;    USRF t;
         NODE usrf_list,sn,tn;    NODE usrf_list,sn,tn;
         FNODE fn;    FNODE fn;
         char *longname;    char *longname;
         int argc;    int argc;
   
         if ( !module ) {    if ( getsecuremode() ) {
                 searchf(sysf,name,&f);      error("defining function is not permitted in the secure mode");
                 if ( f ) {    }
                         fprintf(stderr,"def : builtin function %s() cannot be redefined.\n",name);    if ( *name == ':' )
                         CPVS = GPVS; return;      name += 2;
                 }    if ( !module ) {
         }      searchf(sysf,name,&f);
         for ( argc = 0, sn = args; sn; argc++, sn = NEXT(sn) ) {      if ( f ) {
                 fn = (FNODE)BDY(sn);        fprintf(stderr,"def : builtin function %s() cannot be redefined.\n",name);
                 if ( !fn || ID(fn) != I_PVAR ) {        CPVS = GPVS; return;
                         fprintf(stderr,"illegal argument in %s()\n",name);      }
                         CPVS = GPVS; return;    }
                 }    for ( argc = 0, sn = args; sn; argc++, sn = NEXT(sn) ) {
         }      fn = (FNODE)BDY(sn);
         usrf_list = module ? module->usrf_list : usrf;      if ( !fn || ID(fn) != I_PVAR ) {
         for ( sn = usrf_list; sn && strcmp(NAME((FUNC)BDY(sn)),name); sn = NEXT(sn) );        fprintf(stderr,"illegal  argument in %s()\n",name);
         if ( sn )        CPVS = GPVS; return;
                 f = (FUNC)BDY(sn);      }
         else {    }
                 f=(FUNC)MALLOC(sizeof(struct oFUNC));    usrf_list = module ? module->usrf_list : usrf;
                 f->name = name;    for ( sn = usrf_list; sn && strcmp(NAME((FUNC)BDY(sn)),name); sn = NEXT(sn) );
                 MKNODE(tn,f,usrf_list); usrf_list = tn;    if ( sn )
                 if ( module )      f = (FUNC)BDY(sn);
                         module->usrf_list = usrf_list;    else {
                 else      f=(FUNC)MALLOC(sizeof(struct oFUNC));
                         usrf = usrf_list;      f->name = name;
         }      MKNODE(tn,f,usrf_list); usrf_list = tn;
         if ( Verbose && f->id != A_UNDEF ) {      if ( module ) {
                 if ( module )        f->fullname =
                         fprintf(stderr,"Warning : %s.%s() redefined.\n",module->name,name);          (char *)MALLOC_ATOMIC(strlen(f->name)+strlen(module->name)+1);
                 else        sprintf(f->fullname,"%s.%s",module->name,f->name);
                         fprintf(stderr,"Warning : %s() redefined.\n",name);        module->usrf_list = usrf_list;
         }      } else {
         t=(USRF)MALLOC(sizeof(struct oUSRF));        f->fullname = f->name;
         t->args=args; BDY(t)=body; t->pvs = CPVS; t->fname = fname;        usrf = usrf_list;
         t->startl = startl; t->endl = endl; t->module = module;      }
         t->desc = desc;    }
         f->id = A_USR; f->argc = argc; f->f.usrf = t;    if ( Verbose && f->id != A_UNDEF ) {
         CPVS = GPVS;      if ( module )
         clearbp(f);        fprintf(stderr,"Warning : %s.%s() redefined.\n",module->name,name);
       else
         fprintf(stderr,"Warning : %s() redefined.\n",name);
     }
     t=(USRF)MALLOC(sizeof(struct oUSRF));
     t->args=args; BDY(t)=body; t->pvs = CPVS; t->fname = fname;
     t->startl = startl; t->endl = endl; t->module = module;
     t->desc = desc;
     f->id = A_USR; f->argc = argc; f->f.usrf = t;
     CPVS = GPVS;
     CUR_FUNC = 0;
     clearbp(f);
 }  }
   
 /*  /*
         retrieve value of an option whose key matches 'key'    retrieve value of an option whose key matches 'key'
         CVS->opt is a list(node) of key-value pair (list)    CVS->opt is a list(node) of key-value pair (list)
         CVS->opt = BDY([[key,value],[key,value],...])    CVS->opt = BDY([[key,value],[key,value],...])
 */  */
   
 Obj getopt_from_cpvs(char *key)  Obj getopt_from_cpvs(char *key)
 {  {
         NODE opts,opt;    NODE opts,opt;
         LIST r;    LIST r;
         extern Obj VOIDobj;    extern Obj VOIDobj;
   
         opts = CPVS->opt;    opts = CPVS->opt;
         if ( !key ) {    if ( !key ) {
                 MKLIST(r,opts);      MKLIST(r,opts);
                 return (Obj)r;      return (Obj)r;
         } else {    } else {
                 for ( ; opts; opts = NEXT(opts) ) {      for ( ; opts; opts = NEXT(opts) ) {
                         asir_assert(BDY(opts),O_LIST,"getopt_from_cvps");        asir_assert(BDY(opts),O_LIST,"getopt_from_cvps");
                         opt = BDY((LIST)BDY(opts));        opt = BDY((LIST)BDY(opts));
                         if ( !strcmp(key,BDY((STRING)BDY(opt))) )        if ( !strcmp(key,BDY((STRING)BDY(opt))) )
                                 return (Obj)BDY(NEXT(opt));          return (Obj)BDY(NEXT(opt));
                 }      }
                 return VOIDobj;      return VOIDobj;
         }    }
   
 }  }
   
 extern NODE MODULE_LIST;  
   
 MODULE mkmodule(char *name)  MODULE mkmodule(char *name)
 {  {
         MODULE mod;    MODULE mod;
         NODE m;    NODE m;
         int len;    int len;
         VS mpvs;    VS mpvs;
   
         for ( m = MODULE_LIST; m; m = NEXT(m) ) {    for ( m = MODULE_LIST; m; m = NEXT(m) ) {
                 mod = (MODULE)m->body;      mod = (MODULE)m->body;
                 if ( !strcmp(mod->name,name) )      if ( !strcmp(mod->name,name) )
                         break;        break;
         }    }
         if ( m )    if ( m )
                 return mod;      return mod;
         else {    else {
                 mod = (MODULE)MALLOC(sizeof(struct oMODULE));      mod = (MODULE)MALLOC(sizeof(struct oMODULE));
                 len = strlen(name);      len = strlen(name);
                 mod->name = (char *)MALLOC_ATOMIC(len+1);      mod->name = (char *)MALLOC_ATOMIC(len+1);
                 strcpy(mod->name,name);      strcpy(mod->name,name);
                 mod->pvs = mpvs = (VS)MALLOC(sizeof(struct oVS));      mod->pvs = mpvs = (VS)MALLOC(sizeof(struct oVS));
                 reallocarray((char **)&mpvs->va,(int *)&mpvs->asize,      asir_reallocarray((char **)&mpvs->va,(int *)&mpvs->asize,
                         (int *)&mpvs->n,(int)sizeof(struct oPV));        (int *)&mpvs->n,(int)sizeof(struct oPV));
                 mod->usrf_list = 0;      mod->usrf_list = 0;
                 MKNODE(m,mod,MODULE_LIST);      MKNODE(m,mod,MODULE_LIST);
                 MODULE_LIST = m;      MODULE_LIST = m;
                 return mod;      return mod;
         }    }
 }  }
   
 int afo(SNODE a1) {  void print_crossref(FUNC f)
         printf("afo\n");  {
     FUNC r;
     if ( show_crossref && CUR_FUNC ) {
     searchuf(f->fullname,&r);
     if (r != NULL) {
       fprintf(asir_out,"%s() at line %d in %s()\n",
           f->fullname, asir_infile->ln, CUR_FUNC);
     }
     }
 }  }
Legend:
Removed from v.1.23  
changed lines
  Added in v.1.80
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>