[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.79 and 1.80

version 1.79, 2018/03/28 05:27:22 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.78 2018/03/27 06:29:19 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"
Line 72  LIST eval_arg(FNODE a,unsigned int quote);
Line 72  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,tn1,ind,match;    NODE tn,tn1,ind,match;
         R u;    R u;
         DP dp;    DP dp;
         unsigned int pv;    unsigned int pv;
         int c,ret,pos;    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;    RANGE range;
         QUOTE expr,pattern;    QUOTE expr,pattern;
         Q q;    Q q;
   
 #if defined(VISUAL) || defined(__MINGW32__)  #if defined(VISUAL) || defined(__MINGW32__)
         check_intr();    check_intr();
 #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_NARYOP:      case I_NARYOP:
                         tn = (NODE)FA1(f);        tn = (NODE)FA1(f);
                         a = eval((FNODE)BDY(tn));        a = eval((FNODE)BDY(tn));
                         for ( tn = NEXT(tn); tn; tn = NEXT(tn) ) {        for ( tn = NEXT(tn); tn; tn = NEXT(tn) ) {
                                 a1 = eval((FNODE)BDY(tn));          a1 = eval((FNODE)BDY(tn));
                                 (*((ARF)FA0(f))->fp)(CO,a,a1,&a2);          (*((ARF)FA0(f))->fp)(CO,a,a1,&a2);
                                 a = a2;          a = a2;
                         }        }
                         val = a;        val = a;
                         break;        break;
                 case I_COP:      case I_COP:
                         a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));        a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
                         c = arf_comp(CO,a1,a2);        c = arf_comp(CO,a1,a2);
                         switch ( (cid)FA0(f) ) {        switch ( (cid)FA0(f) ) {
                                 case C_EQ:          case C_EQ:
                                         c = (c == 0); break;            c = (c == 0); break;
                                 case C_NE:          case C_NE:
                                         c = (c != 0); break;            c = (c != 0); break;
                                 case C_GT:          case C_GT:
                                         c = (c > 0); break;            c = (c > 0); break;
                                 case C_LT:          case C_LT:
                                         c = (c < 0); break;            c = (c < 0); break;
                                 case C_GE:          case C_GE:
                                         c = (c >= 0); break;            c = (c >= 0); break;
                                 case C_LE:          case C_LE:
                                         c = (c <= 0); break;            c = (c <= 0); break;
                                 default:          default:
                                         c = 0; break;            c = 0; break;
                         }        }
                         if ( c )        if ( c )
                                 val = (pointer)ONE;          val = (pointer)ONE;
                         break;        break;
                 case I_AND:      case I_AND:
                         if ( eval((FNODE)FA0(f)) && eval((FNODE)FA1(f)) )        if ( eval((FNODE)FA0(f)) && eval((FNODE)FA1(f)) )
                                 val = (pointer)ONE;          val = (pointer)ONE;
                         break;        break;
                 case I_OR:      case I_OR:
                         if ( eval((FNODE)FA0(f)) || eval((FNODE)FA1(f)) )        if ( eval((FNODE)FA0(f)) || eval((FNODE)FA1(f)) )
                                 val = (pointer)ONE;          val = (pointer)ONE;
                         break;        break;
                 case I_NOT:      case I_NOT:
                         if ( eval((FNODE)FA0(f)) )        if ( eval((FNODE)FA0(f)) )
                                 val = 0;          val = 0;
                         else        else
                                 val = (pointer)ONE;          val = (pointer)ONE;
                         break;        break;
                 case I_LOP:      case I_LOP:
                         a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));        a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
                         val = evall((lid)FA0(f),a1,a2);        val = evall((lid)FA0(f),a1,a2);
                         break;        break;
                 case I_CE:      case I_CE:
                         if ( eval((FNODE)FA0(f)) )        if ( eval((FNODE)FA0(f)) )
                                 val = eval((FNODE)FA1(f));          val = eval((FNODE)FA1(f));
                         else        else
                                 val = eval((FNODE)FA2(f));          val = eval((FNODE)FA2(f));
                         break;        break;
                 case I_EV:      case I_EV:
                         evalnodebody((NODE)FA0(f),&tn); nodetod(tn,&dp); val = (pointer)dp;        evalnodebody((NODE)FA0(f),&tn); nodetod(tn,&dp); val = (pointer)dp;
                         break;        break;
                 case I_EVM:      case I_EVM:
                         evalnodebody((NODE)FA0(f),&tn); pos = eval((FNODE)FA1(f)); nodetodpm(tn,pos,&dp); val = (pointer)dp;        evalnodebody((NODE)FA0(f),&tn); pos = eval((FNODE)FA1(f)); nodetodpm(tn,pos,&dp); val = (pointer)dp;
                         break;        break;
                 case I_FUNC:      case I_FUNC:
                         val = evalf((FUNC)FA0(f),(FNODE)FA1(f),0); break;        val = evalf((FUNC)FA0(f),(FNODE)FA1(f),0); break;
                 case I_FUNC_OPT:      case I_FUNC_OPT:
                         val = evalf((FUNC)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;        val = evalf((FUNC)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;
                 case I_FUNC_QARG:      case I_FUNC_QARG:
                         tn = BDY(eval_arg((FNODE)FA1(f),(unsigned int)0xffffffff));        tn = BDY(eval_arg((FNODE)FA1(f),(unsigned int)0xffffffff));
                         val = bevalf((FUNC)FA0(f),tn); break;        val = bevalf((FUNC)FA0(f),tn); break;
                 case I_PFDERIV:      case I_PFDERIV:
                         val = evalf_deriv((FUNC)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;        val = evalf_deriv((FUNC)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;
                 case I_MAP:      case I_MAP:
                         val = evalmapf((FUNC)FA0(f),(FNODE)FA1(f)); break;        val = evalmapf((FUNC)FA0(f),(FNODE)FA1(f)); break;
                 case I_RECMAP:      case I_RECMAP:
                         val = eval_rec_mapf((FUNC)FA0(f),(FNODE)FA1(f)); break;        val = eval_rec_mapf((FUNC)FA0(f),(FNODE)FA1(f)); break;
                 case I_IFUNC:      case I_IFUNC:
                         val = evalif((FNODE)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;        val = evalif((FNODE)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;
 #if !defined(VISUAL) && !defined(__MINGW32__)  #if !defined(VISUAL) && !defined(__MINGW32__)
                 case I_TIMER:      case I_TIMER:
                         {        {
                                 int interval;          int interval;
                                 Obj expired;          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);        pv = (unsigned int)FA0(f);
                         ind = (NODE)FA1(f);        ind = (NODE)FA1(f);
                         GETPV(pv,a);        GETPV(pv,a);
                         if ( !ind )        if ( !ind )
                                 val = a;          val = a;
                         else {        else {
                                 evalnodebody(ind,&tn); getarray(a,tn,&val);          evalnodebody(ind,&tn); getarray(a,tn,&val);
                         }        }
                         break;        break;
                 case I_ASSPVAR:      case I_ASSPVAR:
                         f1 = (FNODE)FA0(f);        f1 = (FNODE)FA0(f);
                         if ( ID(f1) == I_PVAR ) {        if ( ID(f1) == I_PVAR ) {
                                 pv = (unsigned int)FA0(f1); ind = (NODE)FA1(f1);          pv = (unsigned int)FA0(f1); ind = (NODE)FA1(f1);
                                 if ( !ind ) {          if ( !ind ) {
                                         val = eval((FNODE)FA1(f)); ASSPV(pv,val);            val = eval((FNODE)FA1(f)); ASSPV(pv,val);
                                 } else {          } else {
                                         GETPV(pv,a);            GETPV(pv,a);
                                         evalnodebody(ind,&tn);            evalnodebody(ind,&tn);
                                         putarray(a,tn,val = eval((FNODE)FA1(f)));            putarray(a,tn,val = eval((FNODE)FA1(f)));
                                 }          }
                         } else if ( ID(f1) == I_POINT ) {        } else if ( ID(f1) == I_POINT ) {
                                 /* f1 <-> FA0(f1)->FA1(f1) */          /* f1 <-> FA0(f1)->FA1(f1) */
                                 a = eval(FA0(f1));          a = eval(FA0(f1));
                                 assign_to_member(a,(char *)FA1(f1),val = eval((FNODE)FA1(f)));          assign_to_member(a,(char *)FA1(f1),val = eval((FNODE)FA1(f)));
                         } else if ( ID(f1) == I_INDEX ) {        } else if ( ID(f1) == I_INDEX ) {
                                 /* f1 <-> FA0(f1)[FA1(f1)] */          /* f1 <-> FA0(f1)[FA1(f1)] */
                                 a = eval((FNODE)FA0(f1)); ind = (NODE)FA1(f1);          a = eval((FNODE)FA0(f1)); ind = (NODE)FA1(f1);
                                 evalnodebody(ind,&tn);          evalnodebody(ind,&tn);
                                 putarray(a,tn,val = eval((FNODE)FA1(f)));          putarray(a,tn,val = eval((FNODE)FA1(f)));
                         } else {        } else {
                                 error("eval : invalid assignment");          error("eval : invalid assignment");
                         }        }
                         break;        break;
                 case I_ANS:      case I_ANS:
                         if ( (pv =(int)FA0(f)) < (int)APVS->n )        if ( (pv =(int)FA0(f)) < (int)APVS->n )
                                 val = APVS->va[pv].priv;          val = APVS->va[pv].priv;
                         break;        break;
                 case I_GF2NGEN:      case I_GF2NGEN:
                         NEWUP2(up2,1);        NEWUP2(up2,1);
                         up2->w=1;        up2->w=1;
                         up2->b[0] = 2; /* @ */        up2->b[0] = 2; /* @ */
                         MKGF2N(up2,gf2n);        MKGF2N(up2,gf2n);
                         val = (pointer)gf2n;        val = (pointer)gf2n;
                         break;        break;
                 case I_GFPNGEN:      case I_GFPNGEN:
                         up = UPALLOC(1);        up = UPALLOC(1);
                         DEG(up)=1;        DEG(up)=1;
                         COEF(up)[0] = 0;        COEF(up)[0] = 0;
                         COEF(up)[1] = (Num)ONELM;        COEF(up)[1] = (Num)ONELM;
                         MKGFPN(up,gfpn);        MKGFPN(up,gfpn);
                         val = (pointer)gfpn;        val = (pointer)gfpn;
                         break;        break;
                 case I_GFSNGEN:      case I_GFSNGEN:
                         um = UMALLOC(1);        um = UMALLOC(1);
                         DEG(um) = 1;        DEG(um) = 1;
                         COEF(um)[0] = 0;        COEF(um)[0] = 0;
                         COEF(um)[1] = _onesf();        COEF(um)[1] = _onesf();
                         MKGFSN(um,gfsn);        MKGFSN(um,gfsn);
                         val = (pointer)gfsn;        val = (pointer)gfsn;
                         break;        break;
                 case I_STR:      case I_STR:
                         MKSTR(str,FA0(f)); val = (pointer)str; break;        MKSTR(str,FA0(f)); val = (pointer)str; break;
                 case I_FORMULA:      case I_FORMULA:
                         val = FA0(f);        val = FA0(f);
                         break;        break;
                 case I_LIST:      case I_LIST:
                         evalnodebody((NODE)FA0(f),&tn); MKLIST(t,tn); val = (pointer)t; break;        evalnodebody((NODE)FA0(f),&tn); MKLIST(t,tn); val = (pointer)t; break;
                 case I_CONS:      case I_CONS:
                         evalnodebody((NODE)FA0(f),&tn); a2 = eval(FA1(f));        evalnodebody((NODE)FA0(f),&tn); a2 = eval(FA1(f));
                         if ( !a2 || OID(a2) != O_LIST )        if ( !a2 || OID(a2) != O_LIST )
                                         error("cons : invalid argument");            error("cons : invalid argument");
                         for ( tn1 = tn; NEXT(tn1); tn1 = NEXT(tn1) );        for ( tn1 = tn; NEXT(tn1); tn1 = NEXT(tn1) );
                         NEXT(tn1) = BDY((LIST)a2);        NEXT(tn1) = BDY((LIST)a2);
                         MKLIST(t,tn); val = (pointer)t;        MKLIST(t,tn); val = (pointer)t;
                         break;        break;
                 case I_NEWCOMP:      case I_NEWCOMP:
                         newstruct((int)FA0(f),(struct oCOMP **)&val); break;        newstruct((int)FA0(f),(struct oCOMP **)&val); break;
                 case I_CAR:      case I_CAR:
                         if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )        if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )
                                 val = 0;          val = 0;
                         else if ( !BDY((LIST)a) )        else if ( !BDY((LIST)a) )
                                 val = a;          val = a;
                         else        else
                                 val = (pointer)BDY(BDY((LIST)a));          val = (pointer)BDY(BDY((LIST)a));
                         break;        break;
                 case I_CDR:      case I_CDR:
                         if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )        if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )
                                 val = 0;          val = 0;
                         else if ( !BDY((LIST)a) )        else if ( !BDY((LIST)a) )
                                 val = a;          val = a;
                         else {        else {
                                 MKLIST(t,NEXT(BDY((LIST)a))); val = (pointer)t;          MKLIST(t,NEXT(BDY((LIST)a))); val = (pointer)t;
                         }        }
                         break;        break;
                 case I_INDEX:      case I_INDEX:
                         a = eval((FNODE)FA0(f)); ind = (NODE)FA1(f);        a = eval((FNODE)FA0(f)); ind = (NODE)FA1(f);
                         evalnodebody(ind,&tn); getarray(a,tn,&val);        evalnodebody(ind,&tn); getarray(a,tn,&val);
                         break;        break;
                 case I_OPT:      case I_OPT:
                         MKSTR(str,(char *)FA0(f));        MKSTR(str,(char *)FA0(f));
                         a = (pointer)eval(FA1(f));        a = (pointer)eval(FA1(f));
                         tn = mknode(2,str,a);        tn = mknode(2,str,a);
                         MKLIST(t,tn); val = (pointer)t;        MKLIST(t,tn); val = (pointer)t;
                         break;        break;
                 case I_GETOPT:      case I_GETOPT:
                         val = (pointer)getopt_from_cpvs((char *)FA0(f));        val = (pointer)getopt_from_cpvs((char *)FA0(f));
                         break;        break;
                 case I_POINT:      case I_POINT:
                         a = (pointer)eval(FA0(f));        a = (pointer)eval(FA0(f));
                         val = (pointer)memberofstruct(a,(char *)FA1(f));        val = (pointer)memberofstruct(a,(char *)FA1(f));
                         break;        break;
                 default:      default:
                         error("eval : unknown id");        error("eval : unknown id");
                         break;        break;
         }    }
         return ( val );    return ( val );
 }  }
   
 NODE fnode_to_nary_node(NODE);  NODE fnode_to_nary_node(NODE);
Line 359  NODE fnode_to_bin_node(NODE,int);
Line 359  NODE fnode_to_bin_node(NODE,int);
   
 FNODE fnode_to_nary(FNODE f)  FNODE fnode_to_nary(FNODE f)
 {  {
         FNODE a0,a1,a2;    FNODE a0,a1,a2;
         NODE n,t,t0;    NODE n,t,t0;
         pointer val;    pointer val;
         char *op;    char *op;
   
         if ( !f )    if ( !f )
                 return f;      return f;
         switch ( f->id ) {    switch ( f->id ) {
                 case I_NARYOP:      case I_NARYOP:
                                 n = fnode_to_nary_node((NODE)FA1(f));          n = fnode_to_nary_node((NODE)FA1(f));
                                 return mkfnode(2,I_NARYOP,FA0(f),n);          return mkfnode(2,I_NARYOP,FA0(f),n);
   
                 case I_BOP:      case I_BOP:
                         a1 = fnode_to_nary((FNODE)FA1(f));        a1 = fnode_to_nary((FNODE)FA1(f));
                         a2 = fnode_to_nary((FNODE)FA2(f));        a2 = fnode_to_nary((FNODE)FA2(f));
                         op = ((ARF)FA0(f))->name;        op = ((ARF)FA0(f))->name;
                         if ( !strcmp(op,"+") || !strcmp(op,"*") ) {        if ( !strcmp(op,"+") || !strcmp(op,"*") ) {
                                 if ( a1->id == I_NARYOP && !strcmp(op,((ARF)FA0(a1))->name) ) {          if ( a1->id == I_NARYOP && !strcmp(op,((ARF)FA0(a1))->name) ) {
                                         for ( n = (NODE)FA1(a1); NEXT(n); n = NEXT(n) );            for ( n = (NODE)FA1(a1); NEXT(n); n = NEXT(n) );
                                         if ( a2->id == I_NARYOP && !strcmp(op,((ARF)FA0(a2))->name) )            if ( a2->id == I_NARYOP && !strcmp(op,((ARF)FA0(a2))->name) )
                                                 NEXT(n) = (NODE)FA1(a2);              NEXT(n) = (NODE)FA1(a2);
                                         else            else
                                                 MKNODE(NEXT(n),a2,0);              MKNODE(NEXT(n),a2,0);
                                         return a1;            return a1;
                                 } else if ( a2->id == I_NARYOP && !strcmp(op,((ARF)FA0(a2))->name) ) {          } else if ( a2->id == I_NARYOP && !strcmp(op,((ARF)FA0(a2))->name) ) {
                                         MKNODE(t,a1,(NODE)FA1(a2));            MKNODE(t,a1,(NODE)FA1(a2));
                                         return mkfnode(2,I_NARYOP,FA0(f),t);            return mkfnode(2,I_NARYOP,FA0(f),t);
                                 } else {          } else {
                                         t = mknode(2,a1,a2);            t = mknode(2,a1,a2);
                                         return mkfnode(2,I_NARYOP,FA0(f),t);            return mkfnode(2,I_NARYOP,FA0(f),t);
                                 }          }
                         } else        } else
                                 return mkfnode(3,f->id,FA0(f),a1,a2);          return mkfnode(3,f->id,FA0(f),a1,a2);
   
                 case I_NOT: case I_PAREN: case I_MINUS:      case I_NOT: case I_PAREN: case I_MINUS:
                 case I_CAR: case I_CDR:      case I_CAR: case I_CDR:
                         a0 = fnode_to_nary((FNODE)FA0(f));        a0 = fnode_to_nary((FNODE)FA0(f));
                         return mkfnode(1,f->id,a0);        return mkfnode(1,f->id,a0);
   
                 case I_COP: case I_LOP:      case I_COP: case I_LOP:
                         a1 = fnode_to_nary((FNODE)FA1(f));        a1 = fnode_to_nary((FNODE)FA1(f));
                         a2 = fnode_to_nary((FNODE)FA2(f));        a2 = fnode_to_nary((FNODE)FA2(f));
                         return mkfnode(3,f->id,FA0(f),a1,a2);        return mkfnode(3,f->id,FA0(f),a1,a2);
   
                 case I_AND: case I_OR:      case I_AND: case I_OR:
                         a0 = fnode_to_nary((FNODE)FA0(f));        a0 = fnode_to_nary((FNODE)FA0(f));
                         a1 = fnode_to_nary((FNODE)FA1(f));        a1 = fnode_to_nary((FNODE)FA1(f));
                         return mkfnode(2,f->id,a0,a1);        return mkfnode(2,f->id,a0,a1);
   
                 /* ternary operators */      /* ternary operators */
                 case I_CE:      case I_CE:
                         a0 = fnode_to_nary((FNODE)FA0(f));        a0 = fnode_to_nary((FNODE)FA0(f));
                         a1 = fnode_to_nary((FNODE)FA1(f));        a1 = fnode_to_nary((FNODE)FA1(f));
                         a2 = fnode_to_nary((FNODE)FA2(f));        a2 = fnode_to_nary((FNODE)FA2(f));
                         return mkfnode(3,f->id,a0,a1,a2);        return mkfnode(3,f->id,a0,a1,a2);
                         break;        break;
   
                 /* function */      /* function */
                 case I_FUNC:      case I_FUNC:
                         a1 = fnode_to_nary((FNODE)FA1(f));        a1 = fnode_to_nary((FNODE)FA1(f));
                         return mkfnode(2,f->id,FA0(f),a1);        return mkfnode(2,f->id,FA0(f),a1);
   
                 case I_LIST: case I_EV:      case I_LIST: case I_EV:
                         n = fnode_to_nary_node((NODE)FA0(f));        n = fnode_to_nary_node((NODE)FA0(f));
                         return mkfnode(1,f->id,n);        return mkfnode(1,f->id,n);
   
                 case I_STR: case I_FORMULA: case I_PVAR:      case I_STR: case I_FORMULA: case I_PVAR:
                         return f;        return f;
   
                 default:      default:
                         error("fnode_to_nary : not implemented yet");        error("fnode_to_nary : not implemented yet");
         }    }
 }  }
   
 FNODE fnode_to_bin(FNODE f,int dir)  FNODE fnode_to_bin(FNODE f,int dir)
 {  {
         FNODE a0,a1,a2;    FNODE a0,a1,a2;
         NODE n,t;    NODE n,t;
         pointer val;    pointer val;
         ARF fun;    ARF fun;
         int len,i;    int len,i;
         FNODE *arg;    FNODE *arg;
   
         if ( !f )    if ( !f )
                 return f;      return f;
         switch ( f->id ) {    switch ( f->id ) {
                 case I_NARYOP:      case I_NARYOP:
                         fun = (ARF)FA0(f);        fun = (ARF)FA0(f);
                         len = length((NODE)FA1(f));        len = length((NODE)FA1(f));
                         if ( len==1 ) return BDY((NODE)(FA1(f)));        if ( len==1 ) return BDY((NODE)(FA1(f)));
   
                         arg = (FNODE *)ALLOCA(len*sizeof(FNODE));        arg = (FNODE *)ALLOCA(len*sizeof(FNODE));
                         for ( i = 0, t = (NODE)FA1(f); i < len; i++, t = NEXT(t) )        for ( i = 0, t = (NODE)FA1(f); i < len; i++, t = NEXT(t) )
                                 arg[i] = fnode_to_bin((FNODE)BDY(t),dir);          arg[i] = fnode_to_bin((FNODE)BDY(t),dir);
                         if ( dir ) {        if ( dir ) {
                                 a2 = mkfnode(3,I_BOP,fun,arg[len-2],arg[len-1]);          a2 = mkfnode(3,I_BOP,fun,arg[len-2],arg[len-1]);
                                 for ( i = len-3; i >= 0; i-- )          for ( i = len-3; i >= 0; i-- )
                                         a2 = mkfnode(3,I_BOP,fun,arg[i],a2);            a2 = mkfnode(3,I_BOP,fun,arg[i],a2);
                         } else {        } else {
                                 a2 = mkfnode(3,I_BOP,fun,arg[0],arg[1]);          a2 = mkfnode(3,I_BOP,fun,arg[0],arg[1]);
                                 for ( i = 2; i < len; i++ )          for ( i = 2; i < len; i++ )
                                         a2 = mkfnode(3,I_BOP,fun,a2,arg[i]);            a2 = mkfnode(3,I_BOP,fun,a2,arg[i]);
                         }        }
                         return a2;        return a2;
   
                 case I_NOT: case I_PAREN: case I_MINUS:      case I_NOT: case I_PAREN: case I_MINUS:
                 case I_CAR: case I_CDR:      case I_CAR: case I_CDR:
                         a0 = fnode_to_bin((FNODE)FA0(f),dir);        a0 = fnode_to_bin((FNODE)FA0(f),dir);
                         return mkfnode(1,f->id,a0);        return mkfnode(1,f->id,a0);
   
                 case I_BOP: case I_COP: case I_LOP:      case I_BOP: case I_COP: case I_LOP:
                         a1 = fnode_to_bin((FNODE)FA1(f),dir);        a1 = fnode_to_bin((FNODE)FA1(f),dir);
                         a2 = fnode_to_bin((FNODE)FA2(f),dir);        a2 = fnode_to_bin((FNODE)FA2(f),dir);
                         return mkfnode(3,f->id,FA0(f),a1,a2);        return mkfnode(3,f->id,FA0(f),a1,a2);
   
                 case I_AND: case I_OR:      case I_AND: case I_OR:
                         a0 = fnode_to_bin((FNODE)FA0(f),dir);        a0 = fnode_to_bin((FNODE)FA0(f),dir);
                         a1 = fnode_to_bin((FNODE)FA1(f),dir);        a1 = fnode_to_bin((FNODE)FA1(f),dir);
                         return mkfnode(2,f->id,a0,a1);        return mkfnode(2,f->id,a0,a1);
   
                 /* ternary operators */      /* ternary operators */
                 case I_CE:      case I_CE:
                         a0 = fnode_to_bin((FNODE)FA0(f),dir);        a0 = fnode_to_bin((FNODE)FA0(f),dir);
                         a1 = fnode_to_bin((FNODE)FA1(f),dir);        a1 = fnode_to_bin((FNODE)FA1(f),dir);
                         a2 = fnode_to_bin((FNODE)FA2(f),dir);        a2 = fnode_to_bin((FNODE)FA2(f),dir);
                         return mkfnode(3,f->id,a0,a1,a2);        return mkfnode(3,f->id,a0,a1,a2);
                         break;        break;
   
                 /* function */      /* function */
                 case I_FUNC:      case I_FUNC:
                         a1 = fnode_to_bin((FNODE)FA1(f),dir);        a1 = fnode_to_bin((FNODE)FA1(f),dir);
                         return mkfnode(2,f->id,FA0(f),a1);        return mkfnode(2,f->id,FA0(f),a1);
   
                 case I_LIST: case I_EV:      case I_LIST: case I_EV:
                         n = fnode_to_bin_node((NODE)FA0(f),dir);        n = fnode_to_bin_node((NODE)FA0(f),dir);
                         return mkfnode(1,f->id,n);        return mkfnode(1,f->id,n);
   
                 case I_STR: case I_FORMULA: case I_PVAR:      case I_STR: case I_FORMULA: case I_PVAR:
                         return f;        return f;
   
                 default:      default:
                         error("fnode_to_bin : not implemented yet");        error("fnode_to_bin : not implemented yet");
         }    }
 }  }
   
 NODE partial_eval_node(NODE n);  NODE partial_eval_node(NODE n);
Line 509  FNODE partial_eval(FNODE f);
Line 509  FNODE partial_eval(FNODE f);
   
 FNODE partial_eval(FNODE f)  FNODE partial_eval(FNODE f)
 {  {
         FNODE a0,a1,a2;    FNODE a0,a1,a2;
         NODE n;    NODE n;
         Obj obj;    Obj obj;
         QUOTE q;    QUOTE q;
         pointer val;    pointer val;
         FUNC func;    FUNC func;
   
         if ( !f )    if ( !f )
                 return f;      return f;
         switch ( f->id ) {    switch ( f->id ) {
                 case I_NOT: case I_PAREN: case I_MINUS:      case I_NOT: case I_PAREN: case I_MINUS:
                 case I_CAR: case I_CDR:      case I_CAR: case I_CDR:
                         a0 = partial_eval((FNODE)FA0(f));        a0 = partial_eval((FNODE)FA0(f));
                         return mkfnode(1,f->id,a0);        return mkfnode(1,f->id,a0);
   
                 case I_BOP: case I_COP: case I_LOP:      case I_BOP: case I_COP: case I_LOP:
                         a1 = partial_eval((FNODE)FA1(f));        a1 = partial_eval((FNODE)FA1(f));
                         a2 = partial_eval((FNODE)FA2(f));        a2 = partial_eval((FNODE)FA2(f));
                         return mkfnode(3,f->id,FA0(f),a1,a2);        return mkfnode(3,f->id,FA0(f),a1,a2);
   
                 case I_NARYOP:      case I_NARYOP:
                         n = partial_eval_node((NODE)FA1(f));        n = partial_eval_node((NODE)FA1(f));
                         return mkfnode(2,f->id,FA0(f),n);        return mkfnode(2,f->id,FA0(f),n);
   
                 case I_AND: case I_OR:      case I_AND: case I_OR:
                         a0 = partial_eval((FNODE)FA0(f));        a0 = partial_eval((FNODE)FA0(f));
                         a1 = partial_eval((FNODE)FA1(f));        a1 = partial_eval((FNODE)FA1(f));
                         return mkfnode(2,f->id,a0,a1);        return mkfnode(2,f->id,a0,a1);
   
                 /* ternary operators */      /* ternary operators */
                 case I_CE:      case I_CE:
                         a0 = partial_eval((FNODE)FA0(f));        a0 = partial_eval((FNODE)FA0(f));
                         a1 = partial_eval((FNODE)FA1(f));        a1 = partial_eval((FNODE)FA1(f));
                         a2 = partial_eval((FNODE)FA2(f));        a2 = partial_eval((FNODE)FA2(f));
                         return mkfnode(3,f->id,a0,a1,a2);        return mkfnode(3,f->id,a0,a1,a2);
                         break;        break;
   
                 /* XXX : function is evaluated with QUOTE args */      /* XXX : function is evaluated with QUOTE args */
                 case I_FUNC:      case I_FUNC:
                         a1 = partial_eval((FNODE)FA1(f));        a1 = partial_eval((FNODE)FA1(f));
                         func = (FUNC)FA0(f);        func = (FUNC)FA0(f);
                         if ( func->id == A_UNDEF || func->id != A_USR ) {        if ( func->id == A_UNDEF || func->id != A_USR ) {
                                 a1 =  mkfnode(2,I_FUNC,func,a1);          a1 =  mkfnode(2,I_FUNC,func,a1);
                                 return a1;          return a1;
                         } else {        } else {
                                 n = BDY(eval_arg(a1,(unsigned int)0xffffffff));          n = BDY(eval_arg(a1,(unsigned int)0xffffffff));
                                 obj = bevalf(func,n);          obj = bevalf(func,n);
                                 objtoquote(obj,&q);          objtoquote(obj,&q);
                                 return BDY(q);          return BDY(q);
                         }        }
                         break;        break;
   
                 case I_LIST: case I_EV:      case I_LIST: case I_EV:
                         n = partial_eval_node((NODE)FA0(f));        n = partial_eval_node((NODE)FA0(f));
                         return mkfnode(1,f->id,n);        return mkfnode(1,f->id,n);
   
                 case I_STR: case I_FORMULA:      case I_STR: case I_FORMULA:
                         return f;        return f;
   
                 /* program variable */      /* program variable */
                 case I_PVAR:      case I_PVAR:
                         val = eval(f);        val = eval(f);
                         if ( val && OID((Obj)val) == O_QUOTE )        if ( val && OID((Obj)val) == O_QUOTE )
                                 return partial_eval((FNODE)BDY((QUOTE)val));          return partial_eval((FNODE)BDY((QUOTE)val));
                         else        else
                                 return mkfnode(1,I_FORMULA,val);          return mkfnode(1,I_FORMULA,val);
   
                 default:      default:
                         error("partial_eval : not implemented yet");        error("partial_eval : not implemented yet");
         }    }
 }  }
   
 NODE partial_eval_node(NODE n)  NODE partial_eval_node(NODE n)
 {  {
         NODE r0,r,t;    NODE r0,r,t;
   
         for ( r0 = 0, t = n; t; t = NEXT(t) ) {    for ( r0 = 0, t = n; t; t = NEXT(t) ) {
                 NEXTNODE(r0,r);      NEXTNODE(r0,r);
                 BDY(r) = partial_eval((FNODE)BDY(t));      BDY(r) = partial_eval((FNODE)BDY(t));
         }    }
         if ( r0 ) NEXT(r) = 0;    if ( r0 ) NEXT(r) = 0;
         return r0;    return r0;
 }  }
   
 NODE rewrite_fnode_node(NODE n,NODE arg,int qarg);  NODE rewrite_fnode_node(NODE n,NODE arg,int qarg);
Line 598  FNODE rewrite_fnode(FNODE f,NODE arg,int qarg);
Line 598  FNODE rewrite_fnode(FNODE f,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;    FNODE a0,a1,a2,value;
         NODE n,t,pair;    NODE n,t,pair;
         pointer val;    pointer val;
         int pv,ind;    int pv,ind;
   
         if ( !f )    if ( !f )
                 return f;      return f;
         switch ( f->id ) {    switch ( f->id ) {
                 case I_NOT: case I_PAREN: case I_MINUS:      case I_NOT: case I_PAREN: case I_MINUS:
                 case I_CAR: case I_CDR:      case I_CAR: case I_CDR:
                         a0 = rewrite_fnode((FNODE)FA0(f),arg,qarg);        a0 = rewrite_fnode((FNODE)FA0(f),arg,qarg);
                         return mkfnode(1,f->id,a0);        return mkfnode(1,f->id,a0);
   
                 case I_BOP: case I_COP: case I_LOP:      case I_BOP: case I_COP: case I_LOP:
                         a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg);        a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg);
                         a2 = rewrite_fnode((FNODE)FA2(f),arg,qarg);        a2 = rewrite_fnode((FNODE)FA2(f),arg,qarg);
                         return mkfnode(3,f->id,FA0(f),a1,a2);        return mkfnode(3,f->id,FA0(f),a1,a2);
   
                 case I_AND: case I_OR:      case I_AND: case I_OR:
                         a0 = rewrite_fnode((FNODE)FA0(f),arg,qarg);        a0 = rewrite_fnode((FNODE)FA0(f),arg,qarg);
                         a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg);        a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg);
                         return mkfnode(2,f->id,a0,a1);        return mkfnode(2,f->id,a0,a1);
   
                 /* ternary operators */      /* ternary operators */
                 case I_CE:      case I_CE:
                         a0 = rewrite_fnode((FNODE)FA0(f),arg,qarg);        a0 = rewrite_fnode((FNODE)FA0(f),arg,qarg);
                         a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg);        a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg);
                         a2 = rewrite_fnode((FNODE)FA2(f),arg,qarg);        a2 = rewrite_fnode((FNODE)FA2(f),arg,qarg);
                         return mkfnode(3,f->id,a0,a1,a2);        return mkfnode(3,f->id,a0,a1,a2);
                         break;        break;
   
                 /* nary operators */      /* nary operators */
                 case I_NARYOP:      case I_NARYOP:
                         n = rewrite_fnode_node((NODE)FA1(f),arg,qarg);        n = rewrite_fnode_node((NODE)FA1(f),arg,qarg);
                         return mkfnode(2,f->id,FA0(f),n);        return mkfnode(2,f->id,FA0(f),n);
   
                 /* and function */      /* and function */
                 case I_FUNC:      case I_FUNC:
                         a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg);        a1 = rewrite_fnode((FNODE)FA1(f),arg,qarg);
                         return mkfnode(2,qarg?I_FUNC_QARG:f->id,FA0(f),a1);        return mkfnode(2,qarg?I_FUNC_QARG:f->id,FA0(f),a1);
   
                 case I_LIST: case I_EV:      case I_LIST: case I_EV:
                         n = rewrite_fnode_node((NODE)FA0(f),arg,qarg);        n = rewrite_fnode_node((NODE)FA0(f),arg,qarg);
                         return mkfnode(1,f->id,n);        return mkfnode(1,f->id,n);
   
                 case I_STR: case I_FORMULA:      case I_STR: case I_FORMULA:
                         return f;        return f;
   
                 /* program variable */      /* program variable */
                 case I_PVAR:      case I_PVAR:
                         pv = (int)FA0(f);        pv = (int)FA0(f);
                         for ( t = arg; t; t = NEXT(t) ) {        for ( t = arg; t; t = NEXT(t) ) {
                                 pair = (NODE)BDY(t);          pair = (NODE)BDY(t);
                                 ind = (int)BDY(pair);          ind = (int)BDY(pair);
                                 value = (FNODE)BDY(NEXT(pair));          value = (FNODE)BDY(NEXT(pair));
                                 if ( pv == ind )          if ( pv == ind )
                                         return value;            return value;
                         }        }
                         return f;        return f;
                         break;        break;
   
                 default:      default:
                         error("rewrite_fnode : not implemented yet");        error("rewrite_fnode : not implemented yet");
         }    }
 }  }
   
 NODE rewrite_fnode_node(NODE n,NODE arg,int qarg)  NODE rewrite_fnode_node(NODE n,NODE arg,int qarg)
 {  {
         NODE r0,r,t;    NODE r0,r,t;
   
         for ( r0 = 0, t = n; t; t = NEXT(t) ) {    for ( r0 = 0, t = n; t; t = NEXT(t) ) {
                 NEXTNODE(r0,r);      NEXTNODE(r0,r);
                 BDY(r) = rewrite_fnode((FNODE)BDY(t),arg,qarg);      BDY(r) = rewrite_fnode((FNODE)BDY(t),arg,qarg);
         }    }
         if ( r0 ) NEXT(r) = 0;    if ( r0 ) NEXT(r) = 0;
         return r0;    return r0;
 }  }
   
 NODE fnode_to_nary_node(NODE n)  NODE fnode_to_nary_node(NODE n)
 {  {
         NODE r0,r,t;    NODE r0,r,t;
   
         for ( r0 = 0, t = n; t; t = NEXT(t) ) {    for ( r0 = 0, t = n; t; t = NEXT(t) ) {
                 NEXTNODE(r0,r);      NEXTNODE(r0,r);
                 BDY(r) = fnode_to_nary((FNODE)BDY(t));      BDY(r) = fnode_to_nary((FNODE)BDY(t));
         }    }
         if ( r0 ) NEXT(r) = 0;    if ( r0 ) NEXT(r) = 0;
         return r0;    return r0;
 }  }
   
 NODE fnode_to_bin_node(NODE n,int dir)  NODE fnode_to_bin_node(NODE n,int dir)
 {  {
         NODE r0,r,t;    NODE r0,r,t;
   
         for ( r0 = 0, t = n; t; t = NEXT(t) ) {    for ( r0 = 0, t = n; t; t = NEXT(t) ) {
                 NEXTNODE(r0,r);      NEXTNODE(r0,r);
                 BDY(r) = fnode_to_bin((FNODE)BDY(t),dir);      BDY(r) = fnode_to_bin((FNODE)BDY(t),dir);
         }    }
         if ( r0 ) NEXT(r) = 0;    if ( r0 ) NEXT(r) = 0;
         return r0;    return r0;
 }  }
   
 V searchvar(char *name);  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 v;    V v;
         V *a;    V *a;
         char *buf;    char *buf;
         FUNC func;    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;    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) ) {
                                         asir_out = stderr;            asir_out = stderr;
                                         printexpr(CO,eval((FNODE)FA2(f)));            printexpr(CO,eval((FNODE)FA2(f)));
                                         putc('\n',asir_out); fflush(asir_out);            putc('\n',asir_out); fflush(asir_out);
                                         asir_out = stdout;            asir_out = stdout;
                                 } else {          } else {
                                         nextbp = 1; nextbplevel = 0;            nextbp = 1; nextbplevel = 0;
                                 }          }
                         }        }
                         val = evalstat((SNODE)FA0(f));        val = evalstat((SNODE)FA0(f));
                         break;        break;
                 case S_PFDEF:      case S_PFDEF:
                         ac = argc(FA1(f)); a = (V *)MALLOC(ac*sizeof(V));        ac = argc(FA1(f)); a = (V *)MALLOC(ac*sizeof(V));
                         s = eval((FNODE)FA2(f));        s = eval((FNODE)FA2(f));
                         buf = (char *)ALLOCA(BUFSIZ);        buf = (char *)ALLOCA(BUFSIZ);
                         for ( i = 0, tn = (NODE)FA1(f); tn; tn = NEXT(tn), i++ ) {        for ( i = 0, tn = (NODE)FA1(f); tn; tn = NEXT(tn), i++ ) {
                                 t = eval((FNODE)tn->body); sprintf(buf,"_%s",NAME(VR((P)t)));          t = eval((FNODE)tn->body); sprintf(buf,"_%s",NAME(VR((P)t)));
                                 makevar(buf,&u); a[i] = VR(u);          makevar(buf,&u); a[i] = VR(u);
                                 substr(CO,0,(Obj)s,VR((P)t),(Obj)u,(Obj *)&s1); s = s1;          substr(CO,0,(Obj)s,VR((P)t),(Obj)u,(Obj *)&s1); s = s1;
                         }        }
                         mkpf((char *)FA0(f),(Obj)s,ac,a,0,0,0,(PF *)&val); val = 0;        mkpf((char *)FA0(f),(Obj)s,ac,a,0,0,0,(PF *)&val); val = 0;
                         v = searchvar((char *)FA0(f));        v = searchvar((char *)FA0(f));
                         if ( v ) {        if ( v ) {
                                 searchpf((char *)FA0(f),&func);          searchpf((char *)FA0(f),&func);
                                 makesrvar(func,&u);          makesrvar(func,&u);
                         }        }
                         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 ( 1 || GPVS != CPVS )        if ( 1 || GPVS != CPVS )
                                 f_break = 1;          f_break = 1;
                         break;        break;
                 case S_CONTINUE:      case S_CONTINUE:
                         if ( 1 || GPVS != CPVS )        if ( 1 || GPVS != CPVS )
                                 f_continue = 1;          f_continue = 1;
                         break;        break;
                 case S_RETURN:      case S_RETURN:
                         if ( 1 || 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;
                 case S_MODULE:      case S_MODULE:
                         CUR_MODULE = (MODULE)FA0(f);        CUR_MODULE = (MODULE)FA0(f);
                         if ( CUR_MODULE )        if ( CUR_MODULE )
                                         MPVS = CUR_MODULE->pvs;            MPVS = CUR_MODULE->pvs;
                         else        else
                                         MPVS = 0;            MPVS = 0;
                         break;        break;
                 default:      default:
                         error("evalstat : unknown id");        error("evalstat : unknown id");
                         break;        break;
         }    }
         return ( val );    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 );
 }  }
   
   
 LIST eval_arg(FNODE a,unsigned int quote)  LIST eval_arg(FNODE a,unsigned int quote)
 {  {
         LIST l;    LIST l;
         FNODE fn;    FNODE fn;
         NODE n,n0,tn;    NODE n,n0,tn;
         QUOTE q;    QUOTE q;
         int i;    int i;
   
         for ( tn = (NODE)FA0(a), n0 = 0, i = 0; tn; tn = NEXT(tn), i++ ) {    for ( tn = (NODE)FA0(a), n0 = 0, i = 0; tn; tn = NEXT(tn), i++ ) {
                 NEXTNODE(n0,n);      NEXTNODE(n0,n);
                 if ( quote & (1<<i) ) {      if ( quote & (1<<i) ) {
                         fn = (FNODE)(BDY(tn));        fn = (FNODE)(BDY(tn));
                         if ( fn->id == I_FORMULA && FA0(fn)        if ( fn->id == I_FORMULA && FA0(fn)
                                 && OID((Obj)FA0(fn))== O_QUOTE )          && OID((Obj)FA0(fn))== O_QUOTE )
                                 BDY(n) = FA0(fn);           BDY(n) = FA0(fn);
                         else {        else {
                                 MKQUOTE(q,(FNODE)BDY(tn));          MKQUOTE(q,(FNODE)BDY(tn));
                                 BDY(n) = (pointer)q;          BDY(n) = (pointer)q;
                         }        }
                 } else      } else
                         BDY(n) = eval((FNODE)BDY(tn));        BDY(n) = eval((FNODE)BDY(tn));
         }    }
         if ( n0 ) NEXT(n) = 0;    if ( n0 ) NEXT(n) = 0;
         MKLIST(l,n0);    MKLIST(l,n0);
         return l;    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,dmy;    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;    FUNC f1;
   
         if ( f->id == A_UNDEF ) {    if ( f->id == A_UNDEF ) {
                 gen_searchf_searchonly(f->fullname,&f1,0);      gen_searchf_searchonly(f->fullname,&f1,0);
                 if ( f1->id == A_UNDEF ) {      if ( f1->id == A_UNDEF ) {
                         sprintf(errbuf,"evalf : %s undefined",NAME(f));        sprintf(errbuf,"evalf : %s undefined",NAME(f));
                         error(errbuf);        error(errbuf);
                 } else      } else
                         *f = *f1;        *f = *f1;
         }    }
         if ( getsecuremode() && !PVSS && !f->secure ) {    if ( getsecuremode() && !PVSS && !f->secure ) {
                 sprintf(errbuf,"evalf : %s not permitted",NAME(f));      sprintf(errbuf,"evalf : %s not permitted",NAME(f));
                 error(errbuf);      error(errbuf);
         }    }
         if ( f->id != A_PARI ) {    if ( f->id != A_PARI ) {
                 for ( i = 0, tn = a?(NODE)FA0(a):0; tn; i++, tn = NEXT(tn) );      for ( i = 0, tn = a?(NODE)FA0(a):0; tn; i++, tn = NEXT(tn) );
                 if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {      if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
                         sprintf(errbuf,"evalf : argument mismatch in %s()",NAME(f));        sprintf(errbuf,"evalf : argument mismatch in %s()",NAME(f));
                         error(errbuf);        error(errbuf);
                 }      }
         }    }
         switch ( f->id ) {    switch ( f->id ) {
                 case A_BIN:      case A_BIN:
                         if ( opt ) {        if ( opt ) {
                                 opts = BDY((LIST)eval(opt));          opts = BDY((LIST)eval(opt));
                                 /* opts = ["opt1",arg1],... */          /* opts = ["opt1",arg1],... */
                                 opt1 = BDY((LIST)BDY(opts));          opt1 = BDY((LIST)BDY(opts));
                                 if ( !strcmp(BDY((STRING)BDY(opt1)),"option_list") ) {          if ( !strcmp(BDY((STRING)BDY(opt1)),"option_list") ) {
                                         /*            /*
                                          * the special option specification:             * the special option specification:
                                          *  option_list=[["o1","a1"],...]             *  option_list=[["o1","a1"],...]
                                          */             */
                                         asir_assert(BDY(NEXT(opt1)),O_LIST,"evalf");            asir_assert(BDY(NEXT(opt1)),O_LIST,"evalf");
                                         opts = BDY((LIST)BDY(NEXT(opt1)));            opts = BDY((LIST)BDY(NEXT(opt1)));
                                 }          }
                         } else        } else
                                 opts = 0;          opts = 0;
                         if ( !n ) {        if ( !n ) {
                                 current_option = opts;          current_option = opts;
                                 cur_binf = f;          cur_binf = f;
                                 (*f->f.binf)(&val);          (*f->f.binf)(&val);
                         } else {        } else {
                                 args = (LIST)eval_arg(a,f->quote);          args = (LIST)eval_arg(a,f->quote);
                                 current_option = opts;          current_option = opts;
                                 cur_binf = f;          cur_binf = f;
                                 (*f->f.binf)(args?BDY(args):0,&val);          (*f->f.binf)(args?BDY(args):0,&val);
                         }        }
                         cur_binf = 0;        cur_binf = 0;
                         break;        break;
                 case A_PARI:      case A_PARI:
                         args = (LIST)eval(a);        args = (LIST)eval(a);
                         cur_binf = f;        cur_binf = f;
                         val = evalparif(f,args?BDY(args):0);        val = evalparif(f,args?BDY(args):0);
                         cur_binf = 0;        cur_binf = 0;
                         break;        break;
                 case A_USR:      case A_USR:
                         /* stack check */        /* stack check */
 #if !defined(VISUAL) && !defined(__MINGW32__) && !defined(__CYGWIN__)  #if !defined(VISUAL) && !defined(__MINGW32__) && !defined(__CYGWIN__)
                         if ( !stack_size ) {        if ( !stack_size ) {
                                 struct rlimit rl;          struct rlimit rl;
                                 getrlimit(RLIMIT_STACK,&rl);          getrlimit(RLIMIT_STACK,&rl);
                                 stack_size = rl.rlim_cur;          stack_size = rl.rlim_cur;
                         }        }
             if ( !stack_base ) {              if ( !stack_base ) {
 #if defined(GC7)  #if defined(GC7)
                 stack_base = (void *)GC_get_main_stack_base();                  stack_base = (void *)GC_get_main_stack_base();
Line 936  pointer evalf(FUNC f,FNODE a,FNODE opt)
Line 936  pointer evalf(FUNC f,FNODE a,FNODE opt)
                 stack_base = (void *)GC_get_stack_base();                  stack_base = (void *)GC_get_stack_base();
 #endif  #endif
             }              }
                         if ( (stack_base - (void *)&args) +0x100000 > stack_size )        if ( (stack_base - (void *)&args) +0x100000 > stack_size )
                                 error("stack overflow");          error("stack overflow");
 #endif  #endif
                         args = (LIST)eval_arg(a,f->quote);        args = (LIST)eval_arg(a,f->quote);
                         if ( opt ) {        if ( opt ) {
                                 opts = BDY((LIST)eval(opt));          opts = BDY((LIST)eval(opt));
                                 /* opts = ["opt1",arg1],... */          /* opts = ["opt1",arg1],... */
                                 opt1 = BDY((LIST)BDY(opts));          opt1 = BDY((LIST)BDY(opts));
                                 if ( !strcmp(BDY((STRING)BDY(opt1)),"option_list") ) {          if ( !strcmp(BDY((STRING)BDY(opt1)),"option_list") ) {
                                         /*            /*
                                          * the special option specification:             * the special option specification:
                                          *  option_list=[["o1","a1"],...]             *  option_list=[["o1","a1"],...]
                                          */             */
                                         asir_assert(BDY(NEXT(opt1)),O_LIST,"evalf");            asir_assert(BDY(NEXT(opt1)),O_LIST,"evalf");
                                         opts = BDY((LIST)BDY(NEXT(opt1)));            opts = BDY((LIST)BDY(NEXT(opt1)));
                                 }          }
                         } else        } else
                                 opts = 0;          opts = 0;
                 pvs = f->f.usrf->pvs;          pvs = f->f.usrf->pvs;
                 if ( PVSS ) {          if ( PVSS ) {
                         ((VS)BDY(PVSS))->at = evalstatline;              ((VS)BDY(PVSS))->at = evalstatline;
                                 level = ((VS)BDY(PVSS))->level+1;          level = ((VS)BDY(PVSS))->level+1;
                         } else        } else
                                 level = 1;          level = 1;
                 MKNODE(tn,pvs,PVSS); PVSS = tn;          MKNODE(tn,pvs,PVSS); PVSS = tn;
                 CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;          CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
                 CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;          CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
                         CPVS->level = level;        CPVS->level = level;
                         CPVS->opt = opts;        CPVS->opt = opts;
                 if ( CPVS->n ) {          if ( CPVS->n ) {
                         CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));              CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
                         bcopy((char *)pvs->va,(char *)CPVS->va,              bcopy((char *)pvs->va,(char *)CPVS->va,
                                         (int)(pvs->n*sizeof(struct oPV)));            (int)(pvs->n*sizeof(struct oPV)));
                 }          }
                 if ( nextbp )          if ( nextbp )
                         nextbplevel++;              nextbplevel++;
                         for ( tn = f->f.usrf->args, sn = BDY(args);        for ( tn = f->f.usrf->args, sn = BDY(args);
                                 sn; tn = NEXT(tn), sn = NEXT(sn) )          sn; tn = NEXT(tn), sn = NEXT(sn) )
                                 ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));          ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
                         f_return = f_break = f_continue = 0;        f_return = f_break = f_continue = 0;
                         if ( f->f.usrf->module ) {        if ( f->f.usrf->module ) {
                                 prev_mpvs = MPVS;          prev_mpvs = MPVS;
                                 MPVS = f->f.usrf->module->pvs;          MPVS = f->f.usrf->module->pvs;
                                 val = evalstat((SNODE)BDY(f->f.usrf));          val = evalstat((SNODE)BDY(f->f.usrf));
                                 MPVS = prev_mpvs;          MPVS = prev_mpvs;
                         } else        } else
                                 val = evalstat((SNODE)BDY(f->f.usrf));          val = evalstat((SNODE)BDY(f->f.usrf));
                         f_return = f_break = f_continue = 0; poppvs();        f_return = f_break = f_continue = 0; poppvs();
                         if ( PVSS )        if ( PVSS )
                         evalstatline = ((VS)BDY(PVSS))->at;              evalstatline = ((VS)BDY(PVSS))->at;
                         break;        break;
                 case A_PURE:      case A_PURE:
                         args = (LIST)eval(a);        args = (LIST)eval(a);
                         val = evalpf(f->f.puref,args?BDY(args):0,0);        val = evalpf(f->f.puref,args?BDY(args):0,0);
                         break;        break;
                 default:      default:
                         sprintf(errbuf,"evalf : %s undefined",NAME(f));        sprintf(errbuf,"evalf : %s undefined",NAME(f));
                         error(errbuf);        error(errbuf);
                         break;        break;
         }    }
         return val;    return val;
 }  }
   
 pointer evalf_deriv(FUNC f,FNODE a,FNODE deriv)  pointer evalf_deriv(FUNC f,FNODE a,FNODE deriv)
 {  {
         LIST args,dargs;    LIST args,dargs;
         pointer val;    pointer val;
         char errbuf[BUFSIZ];    char errbuf[BUFSIZ];
   
         switch ( f->id ) {    switch ( f->id ) {
                 case A_PURE:      case A_PURE:
                         args = (LIST)eval(a);        args = (LIST)eval(a);
                         dargs = (LIST)eval(deriv);        dargs = (LIST)eval(deriv);
                         val = evalpf(f->f.puref,        val = evalpf(f->f.puref,
                                 args?BDY(args):0,dargs?BDY(dargs):0);          args?BDY(args):0,dargs?BDY(dargs):0);
                         break;        break;
                 default:      default:
                         sprintf(errbuf,        sprintf(errbuf,
                                 "evalf : %s is not a pure function",NAME(f));          "evalf : %s is not a pure function",NAME(f));
                         error(errbuf);        error(errbuf);
                         break;        break;
         }    }
         return val;    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_arg(a,f->quote);    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_arg(a,f->quote);    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,prev_mpvs;    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 ( getsecuremode() && !PVSS && !f->secure ) {    if ( getsecuremode() && !PVSS && !f->secure ) {
                 sprintf(errbuf,"bevalf : %s not permitted",NAME(f));      sprintf(errbuf,"bevalf : %s not permitted",NAME(f));
                 error(errbuf);      error(errbuf);
         }    }
         if ( f->id != A_PARI ) {    if ( f->id != A_PARI ) {
                 for ( i = 0, tn = a; tn; i++, tn = NEXT(tn) );      for ( i = 0, tn = a; tn; i++, tn = NEXT(tn) );
                 if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {      if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
                         sprintf(errbuf,"bevalf : argument mismatch in %s()",NAME(f));        sprintf(errbuf,"bevalf : argument mismatch in %s()",NAME(f));
                         error(errbuf);        error(errbuf);
                 }      }
         }    }
         switch ( f->id ) {    switch ( f->id ) {
                 case A_BIN:      case A_BIN:
                         current_option = 0;        current_option = 0;
                         if ( !n ) {        if ( !n ) {
                                 cur_binf = f;          cur_binf = f;
                                 (*f->f.binf)(&val);          (*f->f.binf)(&val);
                         } else {        } else {
                                 cur_binf = f;          cur_binf = f;
                                 (*f->f.binf)(a,&val);          (*f->f.binf)(a,&val);
                         }        }
                         cur_binf = 0;        cur_binf = 0;
                         break;        break;
                 case A_PARI:      case A_PARI:
                         cur_binf = f;        cur_binf = f;
                         val = evalparif(f,a);        val = evalparif(f,a);
                         cur_binf = 0;        cur_binf = 0;
                         break;        break;
                 case A_USR:      case A_USR:
                 pvs = f->f.usrf->pvs;          pvs = f->f.usrf->pvs;
                 if ( PVSS )          if ( PVSS )
                         ((VS)BDY(PVSS))->at = evalstatline;              ((VS)BDY(PVSS))->at = evalstatline;
                 MKNODE(tn,pvs,PVSS); PVSS = tn;          MKNODE(tn,pvs,PVSS); PVSS = tn;
                 CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;          CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
                 CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;          CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
                         CPVS->opt = 0;        CPVS->opt = 0;
                 if ( CPVS->n ) {          if ( CPVS->n ) {
                         CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));              CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
                         bcopy((char *)pvs->va,(char *)CPVS->va,              bcopy((char *)pvs->va,(char *)CPVS->va,
                                         (int)(pvs->n*sizeof(struct oPV)));            (int)(pvs->n*sizeof(struct oPV)));
                 }          }
                 if ( nextbp )          if ( nextbp )
                         nextbplevel++;              nextbplevel++;
                         for ( tn = f->f.usrf->args, sn = a;        for ( tn = f->f.usrf->args, sn = a;
                                 sn; tn = NEXT(tn), sn = NEXT(sn) )          sn; tn = NEXT(tn), sn = NEXT(sn) )
                                 ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));          ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
                         f_return = f_break = f_continue = 0;        f_return = f_break = f_continue = 0;
                         if ( f->f.usrf->module ) {        if ( f->f.usrf->module ) {
                                 prev_mpvs = MPVS;          prev_mpvs = MPVS;
                                 MPVS = f->f.usrf->module->pvs;          MPVS = f->f.usrf->module->pvs;
                                 val = evalstat((SNODE)BDY(f->f.usrf));          val = evalstat((SNODE)BDY(f->f.usrf));
                                 MPVS = prev_mpvs;          MPVS = prev_mpvs;
                         } else        } else
                                 val = evalstat((SNODE)BDY(f->f.usrf));          val = evalstat((SNODE)BDY(f->f.usrf));
                         f_return = f_break = f_continue = 0; poppvs();        f_return = f_break = f_continue = 0; poppvs();
                         break;        break;
                 case A_PURE:      case A_PURE:
                         val = evalpf(f->f.puref,a,0);        val = evalpf(f->f.puref,a,0);
                         break;        break;
                 default:      default:
                         sprintf(errbuf,"bevalf : %s undefined",NAME(f));        sprintf(errbuf,"bevalf : %s undefined",NAME(f));
                         error(errbuf);        error(errbuf);
                         break;        break;
         }    }
         return val;    return val;
 }  }
   
 pointer bevalf_with_opts(FUNC f,NODE a,NODE opts)  pointer bevalf_with_opts(FUNC f,NODE a,NODE opts)
 {  {
         pointer val;    pointer val;
         int i,n;    int i,n;
         NODE tn,sn;    NODE tn,sn;
         VS pvs,prev_mpvs;    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 ( getsecuremode() && !PVSS && !f->secure ) {    if ( getsecuremode() && !PVSS && !f->secure ) {
                 sprintf(errbuf,"bevalf : %s not permitted",NAME(f));      sprintf(errbuf,"bevalf : %s not permitted",NAME(f));
                 error(errbuf);      error(errbuf);
         }    }
         if ( f->id != A_PARI ) {    if ( f->id != A_PARI ) {
                 for ( i = 0, tn = a; tn; i++, tn = NEXT(tn) );      for ( i = 0, tn = a; tn; i++, tn = NEXT(tn) );
                 if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {      if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
                         sprintf(errbuf,"bevalf : argument mismatch in %s()",NAME(f));        sprintf(errbuf,"bevalf : argument mismatch in %s()",NAME(f));
                         error(errbuf);        error(errbuf);
                 }      }
         }    }
         switch ( f->id ) {    switch ( f->id ) {
                 case A_BIN:      case A_BIN:
                         current_option = opts;        current_option = opts;
                         if ( !n ) {        if ( !n ) {
                                 cur_binf = f;          cur_binf = f;
                                 (*f->f.binf)(&val);          (*f->f.binf)(&val);
                         } else {        } else {
                                 cur_binf = f;          cur_binf = f;
                                 (*f->f.binf)(a,&val);          (*f->f.binf)(a,&val);
                         }        }
                         cur_binf = 0;        cur_binf = 0;
                         break;        break;
                 case A_PARI:      case A_PARI:
                         cur_binf = f;        cur_binf = f;
                         val = evalparif(f,a);        val = evalparif(f,a);
                         cur_binf = 0;        cur_binf = 0;
                         break;        break;
                 case A_USR:      case A_USR:
                 pvs = f->f.usrf->pvs;          pvs = f->f.usrf->pvs;
                 if ( PVSS )          if ( PVSS )
                         ((VS)BDY(PVSS))->at = evalstatline;              ((VS)BDY(PVSS))->at = evalstatline;
                 MKNODE(tn,pvs,PVSS); PVSS = tn;          MKNODE(tn,pvs,PVSS); PVSS = tn;
                 CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;          CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
                 CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;          CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
                         CPVS->opt = opts;        CPVS->opt = opts;
                 if ( CPVS->n ) {          if ( CPVS->n ) {
                         CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));              CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
                         bcopy((char *)pvs->va,(char *)CPVS->va,              bcopy((char *)pvs->va,(char *)CPVS->va,
                                         (int)(pvs->n*sizeof(struct oPV)));            (int)(pvs->n*sizeof(struct oPV)));
                 }          }
                 if ( nextbp )          if ( nextbp )
                         nextbplevel++;              nextbplevel++;
                         for ( tn = f->f.usrf->args, sn = a;        for ( tn = f->f.usrf->args, sn = a;
                                 sn; tn = NEXT(tn), sn = NEXT(sn) )          sn; tn = NEXT(tn), sn = NEXT(sn) )
                                 ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));          ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
                         f_return = f_break = f_continue = 0;        f_return = f_break = f_continue = 0;
                         if ( f->f.usrf->module ) {        if ( f->f.usrf->module ) {
                                 prev_mpvs = MPVS;          prev_mpvs = MPVS;
                                 MPVS = f->f.usrf->module->pvs;          MPVS = f->f.usrf->module->pvs;
                                 val = evalstat((SNODE)BDY(f->f.usrf));          val = evalstat((SNODE)BDY(f->f.usrf));
                                 MPVS = prev_mpvs;          MPVS = prev_mpvs;
                         } else        } else
                                 val = evalstat((SNODE)BDY(f->f.usrf));          val = evalstat((SNODE)BDY(f->f.usrf));
                         f_return = f_break = f_continue = 0; poppvs();        f_return = f_break = f_continue = 0; poppvs();
                         break;        break;
                 case A_PURE:      case A_PURE:
                         val = evalpf(f->f.puref,a,0);        val = evalpf(f->f.puref,a,0);
                         break;        break;
                 default:      default:
                         sprintf(errbuf,"bevalf : %s undefined",NAME(f));        sprintf(errbuf,"bevalf : %s undefined",NAME(f));
                         error(errbuf);        error(errbuf);
                         break;        break;
         }    }
         return val;    return val;
 }  }
   
 pointer evalif(FNODE f,FNODE a,FNODE opt)  pointer evalif(FNODE f,FNODE a,FNODE opt)
 {  {
         Obj g;    Obj g;
         QUOTE q;    QUOTE q;
         FNODE t;    FNODE t;
         LIST l;    LIST l;
   
         g = (Obj)eval(f);    g = (Obj)eval(f);
         if ( g && (OID(g) == O_P) && (VR((P)g)->attr == (pointer)V_SR) )    if ( g && (OID(g) == O_P) && (VR((P)g)->attr == (pointer)V_SR) )
                 return evalf((FUNC)VR((P)g)->priv,a,opt);      return evalf((FUNC)VR((P)g)->priv,a,opt);
         else if ( g && OID(g) == O_QUOTEARG && ((QUOTEARG)g)->type == A_func ) {    else if ( g && OID(g) == O_QUOTEARG && ((QUOTEARG)g)->type == A_func ) {
                 t = mkfnode(2,I_FUNC,((QUOTEARG)g)->body,a);      t = mkfnode(2,I_FUNC,((QUOTEARG)g)->body,a);
                 MKQUOTE(q,t);      MKQUOTE(q,t);
                 return q;      return q;
         } else {    } else {
                 error("invalid function pointer");      error("invalid function pointer");
                 /* NOTREACHED */      /* NOTREACHED */
                 return (pointer)-1;      return (pointer)-1;
         }    }
 }  }
   
 pointer evalpf(PF pf,NODE args,NODE dargs)  pointer evalpf(PF pf,NODE args,NODE dargs)
 {  {
         Obj s,s1;    Obj s,s1;
         int i,di,j;    int i,di,j;
         NODE node,dnode;    NODE node,dnode;
         PFINS ins;    PFINS ins;
         PFAD ad;    PFAD ad;
   
         if ( !pf->body ) {    if ( !pf->body ) {
                 ins = (PFINS)CALLOC(1,sizeof(PF)+pf->argc*sizeof(struct oPFAD));      ins = (PFINS)CALLOC(1,sizeof(PF)+pf->argc*sizeof(struct oPFAD));
                 ins->pf = pf;      ins->pf = pf;
                 for ( i = 0, node = args, dnode = dargs, ad = ins->ad;      for ( i = 0, node = args, dnode = dargs, ad = ins->ad;
                         node; i++ ) {        node; i++ ) {
                         ad[i].arg = (Obj)node->body;        ad[i].arg = (Obj)node->body;
                         if ( !dnode ) ad[i].d = 0;        if ( !dnode ) ad[i].d = 0;
                         else        else
                                 ad[i].d = QTOS((Q)dnode->body);          ad[i].d = QTOS((Q)dnode->body);
                         node = NEXT(node);        node = NEXT(node);
                         if ( dnode ) dnode = NEXT(dnode);        if ( dnode ) dnode = NEXT(dnode);
                 }      }
                 simplify_ins(ins,&s);      simplify_ins(ins,&s);
         } else {    } else {
                 s = pf->body;      s = pf->body;
                 if ( dargs ) {      if ( dargs ) {
                         for ( i = 0, dnode = dargs; dnode; dnode = NEXT(dnode), i++ ) {        for ( i = 0, dnode = dargs; dnode; dnode = NEXT(dnode), i++ ) {
                                 di = QTOS((Q)dnode->body);          di = QTOS((Q)dnode->body);
                                 for ( j = 0; j < di; j++ ) {          for ( j = 0; j < di; j++ ) {
                                         derivr(CO,s,pf->args[i],&s1); s = s1;            derivr(CO,s,pf->args[i],&s1); s = s1;
                                 }          }
                         }        }
                 }      }
                 for ( i = 0, node = args; node; node = NEXT(node), i++ ) {      for ( i = 0, node = args; node; node = NEXT(node), i++ ) {
                         substr(CO,0,s,pf->args[i],(Obj)node->body,&s1); s = s1;        substr(CO,0,s,pf->args[i],(Obj)node->body,&s1); s = s1;
                 }      }
         }    }
         return (pointer)s;    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   * xxx.yyy() is searched in the flist
Line 1384  MODULE searchmodule(char *name)
Line 1384  MODULE searchmodule(char *name)
   
 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;    int global = 0;
         if ( *name == ':' ) {    if ( *name == ':' ) {
                 global = 1;      global = 1;
                 name += 2;      name += 2;
         }    }
         if ( CUR_MODULE && !global )    if ( CUR_MODULE && !global )
                 searchf(CUR_MODULE->usrf_list,name,&val);      searchf(CUR_MODULE->usrf_list,name,&val);
         if ( !val )    if ( !val )
                 searchf(sysf,name,&val);      searchf(sysf,name,&val);
         if ( !val )    if ( !val )
                 searchf(ubinf,name,&val);      searchf(ubinf,name,&val);
         if ( !val )    if ( !val )
                 searchpf(name,&val);      searchpf(name,&val);
         if ( !val )    if ( !val )
                 searchuf(name,&val);      searchuf(name,&val);
         if ( !val )    if ( !val )
                 appenduf(name,&val);      appenduf(name,&val);
         *r = val;    *r = val;
 }  }
   
 void gen_searchf_searchonly(char *name,FUNC *r,int global)  void gen_searchf_searchonly(char *name,FUNC *r,int global)
 {  {
         FUNC val = 0;    FUNC val = 0;
         if ( *name == ':' ) {    if ( *name == ':' ) {
                 global = 1;      global = 1;
                 name += 2;      name += 2;
         }    }
         if ( CUR_MODULE && !global )    if ( CUR_MODULE && !global )
                 searchf(CUR_MODULE->usrf_list,name,&val);      searchf(CUR_MODULE->usrf_list,name,&val);
         if ( !val )    if ( !val )
                 searchf(sysf,name,&val);      searchf(sysf,name,&val);
         if ( !val )    if ( !val )
                 searchf(ubinf,name,&val);      searchf(ubinf,name,&val);
         if ( !val )    if ( !val )
                 searchpf(name,&val);      searchpf(name,&val);
         if ( !val )    if ( !val )
                 searchuf(name,&val);      searchuf(name,&val);
         *r = 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 a 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;
                 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;      f->fullname = name;
                 mod = searchmodule(modname);      mod = searchmodule(modname);
                 if ( !mod )      if ( !mod )
                         mod = mkmodule(modname);        mod = mkmodule(modname);
                 MKNODE(tn,f,mod->usrf_list); mod->usrf_list = tn;      MKNODE(tn,f,mod->usrf_list); mod->usrf_list = tn;
         } else {    } else {
                 f->name = name;      f->name = name;
                 f->fullname = name;      f->fullname = name;
                 MKNODE(tn,f,usrf); usrf = tn;      MKNODE(tn,f,usrf); usrf = tn;
         }    }
         *r = f;    *r = f;
 }  }
   
 void appenduf_local(char *name,FUNC *r)  void appenduf_local(char *name,FUNC *r)
 {  {
         NODE tn;    NODE tn;
         FUNC f;    FUNC f;
         MODULE mod;    MODULE mod;
   
         for ( tn = CUR_MODULE->usrf_list; tn; tn = NEXT(tn) )    for ( tn = CUR_MODULE->usrf_list; tn; tn = NEXT(tn) )
                 if ( !strcmp(((FUNC)BDY(tn))->name,name) )      if ( !strcmp(((FUNC)BDY(tn))->name,name) )
                         break;        break;
         if ( tn )    if ( tn )
                 return;      return;
   
         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;
         f->name = name;    f->name = name;
         f->fullname =    f->fullname =
                 (char *)MALLOC_ATOMIC(strlen(CUR_MODULE->name)+strlen(name)+1);      (char *)MALLOC_ATOMIC(strlen(CUR_MODULE->name)+strlen(name)+1);
         sprintf(f->fullname,"%s.%s",CUR_MODULE->name,name);    sprintf(f->fullname,"%s.%s",CUR_MODULE->name,name);
         MKNODE(tn,f,CUR_MODULE->usrf_list); CUR_MODULE->usrf_list = tn;    MKNODE(tn,f,CUR_MODULE->usrf_list); CUR_MODULE->usrf_list = tn;
         *r = f;    *r = f;
 }  }
   
 void appenduflist(NODE n)  void appenduflist(NODE n)
 {  {
         NODE tn;    NODE tn;
         FUNC f;    FUNC f;
   
         for ( tn = n; tn; tn = NEXT(tn) )    for ( tn = n; tn; tn = NEXT(tn) )
                 appenduf_local((char *)BDY(tn),&f);      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;    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 ( getsecuremode() ) {    if ( getsecuremode() ) {
                 error("defining function is not permitted in the secure mode");      error("defining function is not permitted in the secure mode");
         }    }
         if ( *name == ':' )    if ( *name == ':' )
                 name += 2;      name += 2;
         if ( !module ) {    if ( !module ) {
                 searchf(sysf,name,&f);      searchf(sysf,name,&f);
                 if ( f ) {      if ( f ) {
                         fprintf(stderr,"def : builtin function %s() cannot be redefined.\n",name);        fprintf(stderr,"def : builtin function %s() cannot be redefined.\n",name);
                         CPVS = GPVS; return;        CPVS = GPVS; return;
                 }      }
         }    }
         for ( argc = 0, sn = args; sn; argc++, sn = NEXT(sn) ) {    for ( argc = 0, sn = args; sn; argc++, sn = NEXT(sn) ) {
                 fn = (FNODE)BDY(sn);      fn = (FNODE)BDY(sn);
                 if ( !fn || ID(fn) != I_PVAR ) {      if ( !fn || ID(fn) != I_PVAR ) {
                         fprintf(stderr,"illegal argument in %s()\n",name);        fprintf(stderr,"illegal  argument in %s()\n",name);
                         CPVS = GPVS; return;        CPVS = GPVS; return;
                 }      }
         }    }
         usrf_list = module ? module->usrf_list : usrf;    usrf_list = module ? module->usrf_list : usrf;
         for ( sn = usrf_list; sn && strcmp(NAME((FUNC)BDY(sn)),name); sn = NEXT(sn) );    for ( sn = usrf_list; sn && strcmp(NAME((FUNC)BDY(sn)),name); sn = NEXT(sn) );
         if ( sn )    if ( sn )
                 f = (FUNC)BDY(sn);      f = (FUNC)BDY(sn);
         else {    else {
                 f=(FUNC)MALLOC(sizeof(struct oFUNC));      f=(FUNC)MALLOC(sizeof(struct oFUNC));
                 f->name = name;      f->name = name;
                 MKNODE(tn,f,usrf_list); usrf_list = tn;      MKNODE(tn,f,usrf_list); usrf_list = tn;
                 if ( module ) {      if ( module ) {
                         f->fullname =        f->fullname =
                                 (char *)MALLOC_ATOMIC(strlen(f->name)+strlen(module->name)+1);          (char *)MALLOC_ATOMIC(strlen(f->name)+strlen(module->name)+1);
                         sprintf(f->fullname,"%s.%s",module->name,f->name);        sprintf(f->fullname,"%s.%s",module->name,f->name);
                         module->usrf_list = usrf_list;        module->usrf_list = usrf_list;
                 } else {      } else {
                         f->fullname = f->name;        f->fullname = f->name;
                         usrf = usrf_list;        usrf = usrf_list;
                 }      }
         }    }
         if ( Verbose && f->id != A_UNDEF ) {    if ( Verbose && f->id != A_UNDEF ) {
                 if ( module )      if ( module )
                         fprintf(stderr,"Warning : %s.%s() redefined.\n",module->name,name);        fprintf(stderr,"Warning : %s.%s() redefined.\n",module->name,name);
                 else      else
                         fprintf(stderr,"Warning : %s() redefined.\n",name);        fprintf(stderr,"Warning : %s() redefined.\n",name);
         }    }
         t=(USRF)MALLOC(sizeof(struct oUSRF));    t=(USRF)MALLOC(sizeof(struct oUSRF));
         t->args=args; BDY(t)=body; t->pvs = CPVS; t->fname = fname;    t->args=args; BDY(t)=body; t->pvs = CPVS; t->fname = fname;
         t->startl = startl; t->endl = endl; t->module = module;    t->startl = startl; t->endl = endl; t->module = module;
         t->desc = desc;    t->desc = desc;
         f->id = A_USR; f->argc = argc; f->f.usrf = t;    f->id = A_USR; f->argc = argc; f->f.usrf = t;
         CPVS = GPVS;    CPVS = GPVS;
         CUR_FUNC = 0;    CUR_FUNC = 0;
         clearbp(f);    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;
         }    }
   
 }  }
   
 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));
                 asir_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;
         }    }
 }  }
   
 void print_crossref(FUNC f)  void print_crossref(FUNC f)
 {  {
   FUNC r;    FUNC r;
   if ( show_crossref && CUR_FUNC ) {    if ( show_crossref && CUR_FUNC ) {
         searchuf(f->fullname,&r);    searchuf(f->fullname,&r);
         if (r != NULL) {    if (r != NULL) {
           fprintf(asir_out,"%s() at line %d in %s()\n",      fprintf(asir_out,"%s() at line %d in %s()\n",
                           f->fullname, asir_infile->ln, CUR_FUNC);          f->fullname, asir_infile->ln, CUR_FUNC);
         }    }
   }    }
 }  }
Legend:
Removed from v.1.79  
changed lines
  Added in v.1.80
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>