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