![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to eval.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2000 / parse|
Return to eval.c CVS log | Up to [local] / OpenXM_contrib2 / asir2000 / parse |
1.1 ! noro 1: /* $OpenXM: OpenXM/src/asir99/parse/eval.c,v 1.2 1999/11/18 05:42:03 noro Exp $ */
! 2: #include <ctype.h>
! 3: #include "ca.h"
! 4: #include "al.h"
! 5: #include "base.h"
! 6: #include "parse.h"
! 7: #if !defined(THINK_C)
! 8: #include <sys/types.h>
! 9: #include <sys/stat.h>
! 10: #endif
! 11: #include "genpari.h"
! 12:
! 13: extern jmp_buf timer_env;
! 14:
! 15: int f_break,f_return,f_continue;
! 16: int evalstatline;
! 17: int recv_intr;
! 18:
! 19: pointer bevalf(), evalmapf(), evall();
! 20: Obj getopt_from_cpvs();
! 21:
! 22: pointer eval(f)
! 23: FNODE f;
! 24: {
! 25: LIST t;
! 26: STRING str;
! 27: pointer val = 0;
! 28: pointer a,a1,a2;
! 29: NODE tn,ind;
! 30: R u;
! 31: DP dp;
! 32: int pv,c;
! 33: FNODE f1;
! 34: UP2 up2;
! 35: UP up;
! 36: GF2N gf2n;
! 37: GFPN gfpn;
! 38:
! 39: #if defined(VISUAL)
! 40: if ( recv_intr ) {
! 41: #include <signal.h>
! 42: if ( recv_intr == 1 ) {
! 43: recv_intr = 0;
! 44: int_handler(SIGINT);
! 45: } else {
! 46: recv_intr = 0;
! 47: ox_usr1_handler(0);
! 48: }
! 49: }
! 50: #endif
! 51: if ( !f )
! 52: return ( 0 );
! 53: switch ( f->id ) {
! 54: case I_BOP:
! 55: a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
! 56: (*((ARF)FA0(f))->fp)(CO,a1,a2,&val);
! 57: break;
! 58: case I_COP:
! 59: a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
! 60: c = arf_comp(CO,a1,a2);
! 61: switch ( (cid)FA0(f) ) {
! 62: case C_EQ:
! 63: c = (c == 0); break;
! 64: case C_NE:
! 65: c = (c != 0); break;
! 66: case C_GT:
! 67: c = (c > 0); break;
! 68: case C_LT:
! 69: c = (c < 0); break;
! 70: case C_GE:
! 71: c = (c >= 0); break;
! 72: case C_LE:
! 73: c = (c <= 0); break;
! 74: default:
! 75: c = 0; break;
! 76: }
! 77: if ( c )
! 78: val = (pointer)ONE;
! 79: break;
! 80: case I_AND:
! 81: if ( eval((FNODE)FA0(f)) && eval((FNODE)FA1(f)) )
! 82: val = (pointer)ONE;
! 83: break;
! 84: case I_OR:
! 85: if ( eval((FNODE)FA0(f)) || eval((FNODE)FA1(f)) )
! 86: val = (pointer)ONE;
! 87: break;
! 88: case I_NOT:
! 89: if ( eval((FNODE)FA0(f)) )
! 90: val = 0;
! 91: else
! 92: val = (pointer)ONE;
! 93: break;
! 94: case I_LOP:
! 95: a1 = eval((FNODE)FA1(f)); a2 = eval((FNODE)FA2(f));
! 96: val = evall((lid)FA0(f),a1,a2);
! 97: break;
! 98: case I_CE:
! 99: if ( eval((FNODE)FA0(f)) )
! 100: val = eval((FNODE)FA1(f));
! 101: else
! 102: val = eval((FNODE)FA2(f));
! 103: break;
! 104: case I_EV:
! 105: evalnodebody((NODE)FA0(f),&tn); nodetod(tn,&dp); val = (pointer)dp;
! 106: break;
! 107: case I_FUNC:
! 108: val = evalf((FUNC)FA0(f),(FNODE)FA1(f),0); break;
! 109: case I_FUNC_OPT:
! 110: val = evalf((FUNC)FA0(f),(FNODE)FA1(f),(FNODE)FA2(f)); break;
! 111: case I_PFDERIV:
! 112: error("eval : not implemented yet");
! 113: break;
! 114: case I_MAP:
! 115: val = evalmapf((FUNC)FA0(f),(FNODE)FA1(f)); break;
! 116: case I_IFUNC:
! 117: val = evalif((FNODE)FA0(f),(FNODE)FA1(f)); break;
! 118: #if !defined(VISUAL)
! 119: case I_TIMER:
! 120: {
! 121: int interval;
! 122: Obj expired;
! 123:
! 124: interval = QTOS((Q)eval((FNODE)FA0(f)));
! 125: expired = (Obj)eval((FNODE)FA2(f));
! 126: set_timer(interval);
! 127: savepvs();
! 128: if ( !setjmp(timer_env) )
! 129: val = eval((FNODE)FA1(f));
! 130: else {
! 131: val = (pointer)expired;
! 132: restorepvs();
! 133: }
! 134: reset_timer();
! 135: }
! 136: break;
! 137: #endif
! 138: #if 0
! 139: case I_PRESELF: case I_POSTSELF:
! 140: val = evalpv(f->id,FA1(f),FA0(f)); break;
! 141: case I_PVAR:
! 142: val = evalpv(f->id,FA0(f),0); break;
! 143: case I_ASSPVAR:
! 144: val = evalpv(f->id,FA0(f),FA1(f)); break;
! 145: #endif
! 146: #if 1
! 147: case I_PRESELF:
! 148: f1 = (FNODE)FA1(f);
! 149: if ( ID(f1) == I_PVAR ) {
! 150: pv = (int)FA0(f1); ind = (NODE)FA1(f1); GETPV(pv,a);
! 151: if ( !ind ) {
! 152: (*((ARF)FA0(f))->fp)(CO,a,ONE,&val); ASSPV(pv,val);
! 153: } else if ( a ) {
! 154: evalnodebody(ind,&tn); getarray(a,tn,(pointer *)&u);
! 155: (*((ARF)FA0(f))->fp)(CO,u,ONE,&val); putarray(a,tn,val);
! 156: }
! 157: } else
! 158: val = evalpv(f->id,(FNODE)FA1(f),FA0(f));
! 159: break;
! 160: case I_POSTSELF:
! 161: f1 = (FNODE)FA1(f);
! 162: if ( ID(f1) == I_PVAR ) {
! 163: pv = (int)FA0(f1); ind = (NODE)FA1(f1); GETPV(pv,val);
! 164: if ( !ind ) {
! 165: (*((ARF)FA0(f))->fp)(CO,val,ONE,&u); ASSPV(pv,u);
! 166: } else if ( val ) {
! 167: evalnodebody(ind,&tn); getarray(val,tn,&a);
! 168: (*((ARF)FA0(f))->fp)(CO,a,ONE,&u); putarray(val,tn,(pointer)u);
! 169: val = a;
! 170: }
! 171: } else
! 172: val = evalpv(f->id,(FNODE)FA1(f),FA0(f));
! 173: break;
! 174: case I_CAST:
! 175: getmember((FNODE)f,(Obj *)&val); break;
! 176: case I_PVAR:
! 177: pv = (int)FA0(f); ind = (NODE)FA1(f); GETPV(pv,a);
! 178: if ( !ind )
! 179: val = a;
! 180: else {
! 181: evalnodebody(ind,&tn); getarray(a,tn,&val);
! 182: }
! 183: break;
! 184: case I_ASSPVAR:
! 185: f1 = (FNODE)FA0(f);
! 186: if ( ID(f1) == I_PVAR ) {
! 187: pv = (int)FA0(f1); ind = (NODE)FA1(f1);
! 188: if ( !ind ) {
! 189: val = eval((FNODE)FA1(f)); ASSPV(pv,val);
! 190: } else {
! 191: GETPV(pv,a);
! 192: evalnodebody(ind,&tn);
! 193: putarray(a,tn,val = eval((FNODE)FA1(f)));
! 194: }
! 195: } else
! 196: val = evalpv(ID(f),(FNODE)FA0(f),FA1(f));
! 197: break;
! 198: #endif
! 199: case I_ANS:
! 200: if ( (pv =(int)FA0(f)) < (int)APVS->n )
! 201: val = APVS->va[pv].priv;
! 202: break;
! 203: case I_GF2NGEN:
! 204: NEWUP2(up2,1);
! 205: up2->w=1;
! 206: up2->b[0] = 2; /* @ */
! 207: MKGF2N(up2,gf2n);
! 208: val = (pointer)gf2n;
! 209: break;
! 210: case I_GFPNGEN:
! 211: up = UPALLOC(1);
! 212: up->d=1;
! 213: up->c[0] = 0;
! 214: up->c[1] = (Num)ONELM;
! 215: MKGFPN(up,gfpn);
! 216: val = (pointer)gfpn;
! 217: break;
! 218: case I_STR:
! 219: MKSTR(str,FA0(f)); val = (pointer)str; break;
! 220: case I_FORMULA:
! 221: val = FA0(f); break;
! 222: case I_LIST:
! 223: evalnodebody((NODE)FA0(f),&tn); MKLIST(t,tn); val = (pointer)t; break;
! 224: case I_NEWCOMP:
! 225: newstruct((int)FA0(f),(struct oCOMP **)&val); break;
! 226: case I_CAR:
! 227: if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )
! 228: val = 0;
! 229: else if ( !BDY((LIST)a) )
! 230: val = a;
! 231: else
! 232: val = (pointer)BDY(BDY((LIST)a));
! 233: break;
! 234: case I_CDR:
! 235: if ( !(a = eval((FNODE)FA0(f))) || (OID(a) != O_LIST) )
! 236: val = 0;
! 237: else if ( !BDY((LIST)a) )
! 238: val = a;
! 239: else {
! 240: MKLIST(t,NEXT(BDY((LIST)a))); val = (pointer)t;
! 241: }
! 242: break;
! 243: case I_PROC:
! 244: val = (pointer)FA0(f); break;
! 245: case I_INDEX:
! 246: a = eval((FNODE)FA0(f)); ind = (NODE)FA1(f);
! 247: evalnodebody(ind,&tn); getarray(a,tn,&val);
! 248: break;
! 249: case I_OPT:
! 250: MKSTR(str,(char *)FA0(f));
! 251: a = (pointer)eval(FA1(f));
! 252: tn = mknode(2,str,a);
! 253: MKLIST(t,tn); val = (pointer)t;
! 254: break;
! 255: case I_GETOPT:
! 256: val = (pointer)getopt_from_cpvs((char *)FA0(f));
! 257: break;
! 258: default:
! 259: error("eval : unknown id");
! 260: break;
! 261: }
! 262: return ( val );
! 263: }
! 264:
! 265: pointer evalstat(f)
! 266: SNODE f;
! 267: {
! 268: pointer val = 0,t,s,s1;
! 269: P u;
! 270: NODE tn;
! 271: int i,ac;
! 272: V *a;
! 273: char *buf;
! 274:
! 275: if ( !f )
! 276: return ( 0 );
! 277: if ( nextbp && nextbplevel <= 0 && f->id != S_CPLX ) {
! 278: nextbp = 0;
! 279: bp(f);
! 280: }
! 281: evalstatline = f->ln;
! 282:
! 283: switch ( f->id ) {
! 284: case S_BP:
! 285: if ( !nextbp && (!FA1(f) || eval((FNODE)FA1(f))) ) {
! 286: if ( (FNODE)FA2(f) ) {
! 287: #if PARI
! 288: pari_outfile = stderr;
! 289: #endif
! 290: asir_out = stderr;
! 291: printexpr(CO,eval((FNODE)FA2(f)));
! 292: putc('\n',asir_out); fflush(asir_out);
! 293: #if PARI
! 294: pari_outfile = stdout;
! 295: #endif
! 296: asir_out = stdout;
! 297: } else {
! 298: nextbp = 1; nextbplevel = 0;
! 299: }
! 300: }
! 301: val = evalstat((SNODE)FA0(f));
! 302: break;
! 303: case S_PFDEF:
! 304: ac = argc(FA1(f)); a = (V *)MALLOC(ac*sizeof(V));
! 305: s = eval((FNODE)FA2(f));
! 306: buf = (char *)ALLOCA(BUFSIZ);
! 307: for ( i = 0, tn = (NODE)FA1(f); tn; tn = NEXT(tn), i++ ) {
! 308: t = eval((FNODE)tn->body); sprintf(buf,"_%s",NAME(VR((P)t)));
! 309: makevar(buf,&u); a[i] = VR(u);
! 310: substr(CO,0,(Obj)s,VR((P)t),(Obj)u,(Obj *)&s1); s = s1;
! 311: }
! 312: mkpf((char *)FA0(f),(Obj)s,ac,a,0,0,0,(PF *)&val); val = 0; break;
! 313: case S_SINGLE:
! 314: val = eval((FNODE)FA0(f)); break;
! 315: case S_CPLX:
! 316: for ( tn = (NODE)FA0(f); tn; tn = NEXT(tn) ) {
! 317: if ( BDY(tn) )
! 318: val = evalstat((SNODE)BDY(tn));
! 319: if ( f_break || f_return || f_continue )
! 320: break;
! 321: }
! 322: break;
! 323: case S_BREAK:
! 324: if ( GPVS != CPVS )
! 325: f_break = 1;
! 326: break;
! 327: case S_CONTINUE:
! 328: if ( GPVS != CPVS )
! 329: f_continue = 1;
! 330: break;
! 331: case S_RETURN:
! 332: if ( GPVS != CPVS ) {
! 333: val = eval((FNODE)FA0(f)); f_return = 1;
! 334: }
! 335: break;
! 336: case S_IFELSE:
! 337: if ( evalnode((NODE)FA1(f)) )
! 338: val = evalstat((SNODE)FA2(f));
! 339: else if ( FA3(f) )
! 340: val = evalstat((SNODE)FA3(f));
! 341: break;
! 342: case S_FOR:
! 343: evalnode((NODE)FA1(f));
! 344: while ( 1 ) {
! 345: if ( !evalnode((NODE)FA2(f)) )
! 346: break;
! 347: val = evalstat((SNODE)FA4(f));
! 348: if ( f_break || f_return )
! 349: break;
! 350: f_continue = 0;
! 351: evalnode((NODE)FA3(f));
! 352: }
! 353: f_break = 0; break;
! 354: case S_DO:
! 355: while ( 1 ) {
! 356: val = evalstat((SNODE)FA1(f));
! 357: if ( f_break || f_return )
! 358: break;
! 359: f_continue = 0;
! 360: if ( !evalnode((NODE)FA2(f)) )
! 361: break;
! 362: }
! 363: f_break = 0; break;
! 364: default:
! 365: error("evalstat : unknown id");
! 366: break;
! 367: }
! 368: return ( val );
! 369: }
! 370:
! 371: pointer evalnode(node)
! 372: NODE node;
! 373: {
! 374: NODE tn;
! 375: pointer val;
! 376:
! 377: for ( tn = node, val = 0; tn; tn = NEXT(tn) )
! 378: if ( BDY(tn) )
! 379: val = eval((FNODE)BDY(tn));
! 380: return ( val );
! 381: }
! 382:
! 383: extern FUNC cur_binf;
! 384: extern NODE PVSS;
! 385:
! 386: pointer evalf(f,a,opt)
! 387: FUNC f;
! 388: FNODE a;
! 389: FNODE opt;
! 390: {
! 391: LIST args;
! 392: pointer val;
! 393: int i,n,level;
! 394: NODE tn,sn,opts;
! 395: VS pvs;
! 396: char errbuf[BUFSIZ];
! 397:
! 398: if ( f->id == A_UNDEF ) {
! 399: sprintf(errbuf,"evalf : %s undefined",NAME(f));
! 400: error(errbuf);
! 401: }
! 402: if ( f->id != A_PARI ) {
! 403: for ( i = 0, tn = a?(NODE)FA0(a):0; tn; i++, tn = NEXT(tn) );
! 404: if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
! 405: sprintf(errbuf,"evalf : argument mismatch in %s()",NAME(f));
! 406: error(errbuf);
! 407: }
! 408: }
! 409: switch ( f->id ) {
! 410: case A_BIN:
! 411: if ( !n ) {
! 412: cur_binf = f;
! 413: (*f->f.binf)(&val);
! 414: } else {
! 415: args = (LIST)eval(a);
! 416: cur_binf = f;
! 417: (*f->f.binf)(args?BDY(args):0,&val);
! 418: }
! 419: cur_binf = 0;
! 420: break;
! 421: case A_PARI:
! 422: args = (LIST)eval(a);
! 423: cur_binf = f;
! 424: val = evalparif(f,args?BDY(args):0);
! 425: cur_binf = 0;
! 426: break;
! 427: case A_USR:
! 428: args = (LIST)eval(a);
! 429: if ( opt )
! 430: opts = BDY((LIST)eval(opt));
! 431: else
! 432: opts = 0;
! 433: pvs = f->f.usrf->pvs;
! 434: if ( PVSS ) {
! 435: ((VS)BDY(PVSS))->at = evalstatline;
! 436: level = ((VS)BDY(PVSS))->level+1;
! 437: } else
! 438: level = 1;
! 439: MKNODE(tn,pvs,PVSS); PVSS = tn;
! 440: CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
! 441: CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
! 442: CPVS->level = level;
! 443: CPVS->opt = opts;
! 444: if ( CPVS->n ) {
! 445: CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
! 446: bcopy((char *)pvs->va,(char *)CPVS->va,
! 447: (int)(pvs->n*sizeof(struct oPV)));
! 448: }
! 449: if ( nextbp )
! 450: nextbplevel++;
! 451: for ( tn = f->f.usrf->args, sn = BDY(args);
! 452: sn; tn = NEXT(tn), sn = NEXT(sn) )
! 453: ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
! 454: val = evalstat((SNODE)BDY(f->f.usrf));
! 455: f_return = f_break = f_continue = 0; poppvs();
! 456: break;
! 457: case A_PURE:
! 458: args = (LIST)eval(a);
! 459: val = evalpf(f->f.puref,args?BDY(args):0);
! 460: break;
! 461: default:
! 462: sprintf(errbuf,"evalf : %s undefined",NAME(f));
! 463: error(errbuf);
! 464: break;
! 465: }
! 466: return val;
! 467: }
! 468:
! 469: pointer evalmapf(f,a)
! 470: FUNC f;
! 471: FNODE a;
! 472: {
! 473: LIST args;
! 474: NODE node,rest,t,n,r,r0;
! 475: Obj head;
! 476: VECT v,rv;
! 477: MAT m,rm;
! 478: LIST rl;
! 479: int len,row,col,i,j;
! 480: pointer val;
! 481:
! 482: args = (LIST)eval(a);
! 483: node = BDY(args); head = (Obj)BDY(node); rest = NEXT(node);
! 484: switch ( OID(head) ) {
! 485: case O_VECT:
! 486: v = (VECT)head; len = v->len; MKVECT(rv,len);
! 487: for ( i = 0; i < len; i++ ) {
! 488: MKNODE(t,BDY(v)[i],rest); BDY(rv)[i] = bevalf(f,t);
! 489: }
! 490: val = (pointer)rv;
! 491: break;
! 492: case O_MAT:
! 493: m = (MAT)head; row = m->row; col = m->col; MKMAT(rm,row,col);
! 494: for ( i = 0; i < row; i++ )
! 495: for ( j = 0; j < col; j++ ) {
! 496: MKNODE(t,BDY(m)[i][j],rest); BDY(rm)[i][j] = bevalf(f,t);
! 497: }
! 498: val = (pointer)rm;
! 499: break;
! 500: case O_LIST:
! 501: n = BDY((LIST)head);
! 502: for ( r0 = r = 0; n; n = NEXT(n) ) {
! 503: NEXTNODE(r0,r); MKNODE(t,BDY(n),rest); BDY(r) = bevalf(f,t);
! 504: }
! 505: if ( r0 )
! 506: NEXT(r) = 0;
! 507: MKLIST(rl,r0);
! 508: val = (pointer)rl;
! 509: break;
! 510: default:
! 511: val = bevalf(f,node);
! 512: break;
! 513: }
! 514: return val;
! 515: }
! 516:
! 517: pointer bevalf(f,a)
! 518: FUNC f;
! 519: NODE a;
! 520: {
! 521: pointer val;
! 522: int i,n;
! 523: NODE tn,sn;
! 524: VS pvs;
! 525: struct oLIST list;
! 526: struct oFNODE fnode;
! 527: char errbuf[BUFSIZ];
! 528:
! 529: if ( f->id == A_UNDEF ) {
! 530: sprintf(errbuf,"bevalf : %s undefined",NAME(f));
! 531: error(errbuf);
! 532: }
! 533: if ( f->id != A_PARI ) {
! 534: for ( i = 0, tn = a; tn; i++, tn = NEXT(tn) );
! 535: if ( ((n = f->argc)>= 0 && i != n) || (n < 0 && i > -n) ) {
! 536: sprintf(errbuf,"bevalf : argument mismatch in %s()",NAME(f));
! 537: error(errbuf);
! 538: }
! 539: }
! 540: switch ( f->id ) {
! 541: case A_BIN:
! 542: if ( !n ) {
! 543: cur_binf = f;
! 544: (*f->f.binf)(&val);
! 545: } else {
! 546: cur_binf = f;
! 547: (*f->f.binf)(a,&val);
! 548: }
! 549: cur_binf = 0;
! 550: break;
! 551: case A_PARI:
! 552: cur_binf = f;
! 553: val = evalparif(f,a);
! 554: cur_binf = 0;
! 555: break;
! 556: case A_USR:
! 557: pvs = f->f.usrf->pvs;
! 558: if ( PVSS )
! 559: ((VS)BDY(PVSS))->at = evalstatline;
! 560: MKNODE(tn,pvs,PVSS); PVSS = tn;
! 561: CPVS = (VS)ALLOCA(sizeof(struct oVS)); BDY(PVSS) = (pointer)CPVS;
! 562: CPVS->usrf = f; CPVS->n = CPVS->asize = pvs->n;
! 563: CPVS->opt = 0;
! 564: if ( CPVS->n ) {
! 565: CPVS->va = (struct oPV *)ALLOCA(CPVS->n*sizeof(struct oPV));
! 566: bcopy((char *)pvs->va,(char *)CPVS->va,
! 567: (int)(pvs->n*sizeof(struct oPV)));
! 568: }
! 569: if ( nextbp )
! 570: nextbplevel++;
! 571: for ( tn = f->f.usrf->args, sn = a;
! 572: sn; tn = NEXT(tn), sn = NEXT(sn) )
! 573: ASSPV((int)FA0((FNODE)BDY(tn)),BDY(sn));
! 574: val = evalstat((SNODE)BDY(f->f.usrf));
! 575: f_return = f_break = f_continue = 0; poppvs();
! 576: break;
! 577: case A_PURE:
! 578: val = evalpf(f->f.puref,a);
! 579: break;
! 580: default:
! 581: sprintf(errbuf,"bevalf : %s undefined",NAME(f));
! 582: error(errbuf);
! 583: break;
! 584: }
! 585: return val;
! 586: }
! 587:
! 588: pointer evalif(f,a)
! 589: FNODE f,a;
! 590: {
! 591: Obj g;
! 592:
! 593: g = (Obj)eval(f);
! 594: if ( g && (OID(g) == O_P) && (VR((P)g)->attr == (pointer)V_SR) )
! 595: return evalf((FUNC)VR((P)g)->priv,a,0);
! 596: else {
! 597: error("invalid function pointer");
! 598: }
! 599: }
! 600:
! 601: pointer evalpf(pf,args)
! 602: PF pf;
! 603: NODE args;
! 604: {
! 605: Obj s,s1;
! 606: int i;
! 607: NODE node;
! 608: PFINS ins;
! 609: PFAD ad;
! 610: char errbuf[BUFSIZ];
! 611:
! 612: if ( !pf->body ) {
! 613: ins = (PFINS)CALLOC(1,sizeof(PF)+pf->argc*sizeof(struct oPFAD));
! 614: ins->pf = pf;
! 615: for ( i = 0, node = args, ad = ins->ad;
! 616: node; node = NEXT(node), i++ ) {
! 617: ad[i].d = 0; ad[i].arg = (Obj)node->body;
! 618: }
! 619: simplify_ins(ins,&s);
! 620: } else {
! 621: for ( i = 0, s = pf->body, node = args;
! 622: node; node = NEXT(node), i++ ) {
! 623: substr(CO,0,s,pf->args[i],(Obj)node->body,&s1); s = s1;
! 624: }
! 625: }
! 626: return (pointer)s;
! 627: }
! 628:
! 629: void evalnodebody(sn,dnp)
! 630: NODE sn;
! 631: NODE *dnp;
! 632: {
! 633: NODE n,n0,tn;
! 634: int line;
! 635:
! 636: if ( !sn ) {
! 637: *dnp = 0;
! 638: return;
! 639: }
! 640: line = evalstatline;
! 641: for ( tn = sn, n0 = 0; tn; tn = NEXT(tn) ) {
! 642: NEXTNODE(n0,n);
! 643: BDY(n) = eval((FNODE)BDY(tn));
! 644: evalstatline = line;
! 645: }
! 646: NEXT(n) = 0; *dnp = n0;
! 647: }
! 648:
! 649: void searchf(fn,name,r)
! 650: NODE fn;
! 651: char *name;
! 652: FUNC *r;
! 653: {
! 654: NODE tn;
! 655:
! 656: for ( tn = fn;
! 657: tn && strcmp(NAME((FUNC)BDY(tn)),name); tn = NEXT(tn) );
! 658: if ( tn ) {
! 659: *r = (FUNC)BDY(tn);
! 660: return;
! 661: }
! 662: *r = 0;
! 663: }
! 664:
! 665: void appenduf(name,r)
! 666: char *name;
! 667: FUNC *r;
! 668: {
! 669: NODE tn;
! 670: FUNC f;
! 671:
! 672: f=(FUNC)MALLOC(sizeof(struct oFUNC));
! 673: f->name = name; f->id = A_UNDEF; f->argc = 0; f->f.binf = 0;
! 674: MKNODE(tn,f,usrf); usrf = tn;
! 675: *r = f;
! 676: }
! 677:
! 678: void mkparif(name,r)
! 679: char *name;
! 680: FUNC *r;
! 681: {
! 682: FUNC f;
! 683:
! 684: *r = f =(FUNC)MALLOC(sizeof(struct oFUNC));
! 685: f->name = name; f->id = A_PARI; f->argc = 0; f->f.binf = 0;
! 686: }
! 687:
! 688: void mkuf(name,fname,args,body,startl,endl,desc)
! 689: char *name,*fname;
! 690: NODE args;
! 691: SNODE body;
! 692: int startl,endl;
! 693: char *desc;
! 694: {
! 695: FUNC f;
! 696: USRF t;
! 697: NODE sn,tn;
! 698: FNODE fn;
! 699: int argc;
! 700:
! 701: searchf(sysf,name,&f);
! 702: if ( f ) {
! 703: fprintf(stderr,"def : builtin function %s() cannot be redefined.\n",name);
! 704: CPVS = GPVS; return;
! 705: }
! 706: for ( argc = 0, sn = args; sn; argc++, sn = NEXT(sn) ) {
! 707: fn = (FNODE)BDY(sn);
! 708: if ( !fn || ID(fn) != I_PVAR ) {
! 709: fprintf(stderr,"illegal argument in %s()\n",name);
! 710: CPVS = GPVS; return;
! 711: }
! 712: }
! 713: for ( sn = usrf; sn && strcmp(NAME((FUNC)BDY(sn)),name); sn = NEXT(sn) );
! 714: if ( sn )
! 715: f = (FUNC)BDY(sn);
! 716: else {
! 717: f=(FUNC)MALLOC(sizeof(struct oFUNC));
! 718: f->name = name;
! 719: MKNODE(tn,f,usrf); usrf = tn;
! 720: }
! 721: if ( Verbose && f->id != A_UNDEF )
! 722: fprintf(stderr,"Warning : %s() redefined.\n",name);
! 723: /* else
! 724: fprintf(stderr,"%s() defined.\n",name); */
! 725: t=(USRF)MALLOC(sizeof(struct oUSRF));
! 726: t->args=args; BDY(t)=body; t->pvs = CPVS; t->fname = fname;
! 727: t->startl = startl; t->endl = endl; t->vol = asir_infile->vol;
! 728: t->desc = desc;
! 729: f->id = A_USR; f->argc = argc; f->f.usrf = t;
! 730: CPVS = GPVS;
! 731: clearbp(f);
! 732: }
! 733:
! 734: /*
! 735: retrieve value of an option whose key matches 'key'
! 736: CVS->opt is a list(node) of key-value pair (list)
! 737: CVS->opt = BDY([[key,value],[key,value],...])
! 738: */
! 739:
! 740: Obj getopt_from_cpvs(key)
! 741: char *key;
! 742: {
! 743: NODE opts,opt;
! 744: Obj value;
! 745: extern Obj VOIDobj;
! 746:
! 747: opts = CPVS->opt;
! 748: for ( ; opts; opts = NEXT(opts) ) {
! 749: opt = BDY((LIST)BDY(opts));
! 750: if ( !strcmp(key,BDY((STRING)BDY(opt))) )
! 751: return (Obj)BDY(NEXT(opt));
! 752: }
! 753: return VOIDobj;
! 754:
! 755: }