Annotation of OpenXM_contrib2/asir2018/parse/quote.c, Revision 1.1
1.1 ! noro 1: /* $OpenXM$ */
! 2:
! 3: #include "ca.h"
! 4: #include "parse.h"
! 5:
! 6: void addquote(VL vl,QUOTE a,QUOTE b,QUOTE *c)
! 7: {
! 8: FNODE fn;
! 9: QUOTE t;
! 10:
! 11: objtoquote((Obj)a,&t); a = t; objtoquote((Obj)b,&t); b = t;
! 12: fn = mkfnode(3,I_BOP,addfs,BDY(a),BDY(b));
! 13: MKQUOTE(*c,fn);
! 14: }
! 15:
! 16: void subquote(VL vl,QUOTE a,QUOTE b,QUOTE *c)
! 17: {
! 18: FNODE fn;
! 19: QUOTE t;
! 20:
! 21: objtoquote((Obj)a,&t); a = t; objtoquote((Obj)b,&t); b = t;
! 22: fn = mkfnode(3,I_BOP,subfs,BDY(a),BDY(b));
! 23: MKQUOTE(*c,fn);
! 24: }
! 25:
! 26: void mulquote(VL vl,QUOTE a,QUOTE b,QUOTE *c)
! 27: {
! 28: FNODE fn;
! 29: QUOTE t;
! 30:
! 31: objtoquote((Obj)a,&t); a = t; objtoquote((Obj)b,&t); b = t;
! 32: fn = mkfnode(3,I_BOP,mulfs,BDY(a),BDY(b));
! 33: MKQUOTE(*c,fn);
! 34: }
! 35:
! 36: void divquote(VL vl,QUOTE a,QUOTE b,QUOTE *c)
! 37: {
! 38: FNODE fn;
! 39: QUOTE t;
! 40:
! 41: objtoquote((Obj)a,&t); a = t; objtoquote((Obj)b,&t); b = t;
! 42: fn = mkfnode(3,I_BOP,divfs,BDY(a),BDY(b));
! 43: MKQUOTE(*c,fn);
! 44: }
! 45:
! 46: void pwrquote(VL vl,QUOTE a,QUOTE b,QUOTE *c)
! 47: {
! 48: FNODE fn;
! 49: QUOTE t;
! 50:
! 51: objtoquote((Obj)a,&t); a = t; objtoquote((Obj)b,&t); b = t;
! 52: fn = mkfnode(3,I_BOP,pwrfs,BDY(a),BDY(b));
! 53: MKQUOTE(*c,fn);
! 54: }
! 55:
! 56: void chsgnquote(QUOTE a,QUOTE *c)
! 57: {
! 58: FNODE fn;
! 59: QUOTE t;
! 60:
! 61: objtoquote((Obj)a,&t); a = t;
! 62: fn = mkfnode(1,I_MINUS,BDY(a));
! 63: MKQUOTE(*c,fn);
! 64: }
! 65:
! 66: void objtoquote(Obj a,QUOTE *c)
! 67: {
! 68: QUOTE nm,dn;
! 69: NODE arg,t0,t,t1,t2,t3;
! 70: FNODE fn;
! 71: Obj obj;
! 72: Obj *b;
! 73: Obj **m;
! 74: int i,j,len,row,col;
! 75: Z q,qrow,qcol;
! 76: FUNC f;
! 77:
! 78: if ( !a ) {
! 79: MKQUOTE(*c,mkfnode(1,I_FORMULA,(pointer)a));
! 80: return;
! 81: }
! 82: switch ( OID(a) ) {
! 83: case O_N:
! 84: if ( negative_number((Num)a) ) {
! 85: arf_chsgn(a,&obj);
! 86: MKQUOTE(*c,mkfnode(1,I_MINUS,
! 87: mkfnode(1,I_FORMULA,(pointer)obj)));
! 88: } else {
! 89: MKQUOTE(*c,mkfnode(1,I_FORMULA,(pointer)a));
! 90: }
! 91: break;
! 92: case O_STR:
! 93: MKQUOTE(*c,mkfnode(1,I_FORMULA,(pointer)a));
! 94: break;
! 95: case O_P:
! 96: polytoquote((P)a,c);
! 97: break;
! 98: case O_R:
! 99: polytoquote(NM((R)a),&nm);
! 100: polytoquote(DN((R)a),&dn);
! 101: divquote(CO,nm,dn,c);
! 102: break;
! 103: case O_LIST:
! 104: t0 = 0;
! 105: for ( arg = BDY((LIST)a); arg; arg = NEXT(arg) ) {
! 106: NEXTNODE(t0,t);
! 107: objtoquote(BDY(arg),&nm);
! 108: BDY(t) = BDY(nm);
! 109: }
! 110: if ( t0 )
! 111: NEXT(t) = 0;
! 112: MKQUOTE(*c,mkfnode(1,I_LIST,t0));
! 113: break;
! 114: case O_VECT:
! 115: len = ((VECT)a)->len;
! 116: b = (Obj *)BDY(((VECT)a));
! 117: t = 0;
! 118: for ( i = len-1; i >= 0; i-- ) {
! 119: objtoquote(b[i],&nm);
! 120: MKNODE(t1,BDY(nm),t);
! 121: t = t1;
! 122: }
! 123: STOQ(len,q);
! 124: t = mknode(2,mkfnode(1,I_FORMULA,q),mkfnode(1,I_LIST,t));
! 125: gen_searchf("vector",&f);
! 126: MKQUOTE(*c,mkfnode(2,I_FUNC,f,mkfnode(1,I_LIST,t)));
! 127: break;
! 128: case O_MAT:
! 129: row = ((MAT)a)->row;
! 130: col = ((MAT)a)->row;
! 131: m = (Obj **)BDY(((MAT)a));
! 132: t2 = 0;
! 133: for ( i = row-1; i >= 0; i-- ) {
! 134: t = 0;
! 135: for ( j = col-1; j >= 0; j-- ) {
! 136: objtoquote(m[i][j],&nm);
! 137: MKNODE(t1,BDY(nm),t);
! 138: t = t1;
! 139: }
! 140: fn = mkfnode(1,I_LIST,t);
! 141: MKNODE(t3,fn,t2);
! 142: t2 = t3;
! 143: }
! 144: fn = mkfnode(1,I_LIST,t2);
! 145:
! 146: STOQ(row,qrow);
! 147: STOQ(col,qcol);
! 148: t = mknode(3,
! 149: mkfnode(1,I_FORMULA,qrow),mkfnode(1,I_FORMULA,qcol),fn);
! 150: gen_searchf("matrix",&f);
! 151: MKQUOTE(*c,mkfnode(2,I_FUNC,f,mkfnode(1,I_LIST,t)));
! 152: break;
! 153: case O_DP:
! 154: dptoquote((DP)a,c);
! 155: break;
! 156: case O_QUOTE:
! 157: *c = (QUOTE)a;
! 158: break;
! 159: default:
! 160: error("objtoquote : not implemented");
! 161: }
! 162: }
! 163:
! 164: void polytoquote(P a,QUOTE *c)
! 165: {
! 166: DCP dc,t;
! 167: DCP *dca;
! 168: int n,i,sgn;
! 169: QUOTE v,r,s,u;
! 170:
! 171: if ( !a ) {
! 172: MKQUOTE(*c,mkfnode(1,I_FORMULA,(pointer)a));
! 173: return;
! 174: } else if ( OID(a) == O_N ) {
! 175: MKQUOTE(*c,mkfnode(1,I_FORMULA,(pointer)a));
! 176: return;
! 177: }
! 178: vartoquote(VR((P)a),&v);
! 179: dc = DC((P)a);
! 180: dctoquote(dc,v,&r,&sgn);
! 181: if ( sgn == -1 ) {
! 182: MKQUOTE(u,mkfnode(1,I_MINUS,BDY(r)));
! 183: r = u;
! 184: }
! 185: for (dc = NEXT(dc); dc; dc = NEXT(dc) ) {
! 186: dctoquote(dc,v,&s,&sgn);
! 187: if ( sgn == -1 )
! 188: subquote(CO,r,s,&u);
! 189: else
! 190: addquote(CO,r,s,&u);
! 191: r = u;
! 192: }
! 193: *c = r;
! 194: }
! 195:
! 196: void dptoquote(DP a,QUOTE *c)
! 197: {
! 198: MP t;
! 199: MP m;
! 200: int i,n,nv,sgn;
! 201: QUOTE s,r,u;
! 202:
! 203: if ( !a ) {
! 204: MKQUOTE(*c,mkfnode(1,I_FORMULA,(pointer)a));
! 205: return;
! 206: }
! 207: nv = NV(a);
! 208: m = BDY(a);
! 209: mptoquote(m,nv,&r,&sgn);
! 210: if ( sgn == -1 ) {
! 211: MKQUOTE(u,mkfnode(1,I_MINUS,BDY(r)));
! 212: r = u;
! 213: }
! 214: for ( m = NEXT(m); m; m = NEXT(m) ) {
! 215: mptoquote(m,nv,&s,&sgn);
! 216: if ( sgn < 0 )
! 217: subquote(CO,r,s,&u);
! 218: else
! 219: addquote(CO,r,s,&u);
! 220: r = u;
! 221: }
! 222: *c = r;
! 223: }
! 224:
! 225: void dctoquote(DCP dc,QUOTE v,QUOTE *q,int *sgn)
! 226: {
! 227: QUOTE t,s,u,r;
! 228: P c;
! 229: Z d;
! 230:
! 231: if ( mmono(COEF(dc)) ) {
! 232: /* -xyz... */
! 233: chsgnp(COEF(dc),&c);
! 234: *sgn = -1;
! 235: } else {
! 236: c = COEF(dc);
! 237: *sgn = 1;
! 238: }
! 239: d = DEG(dc);
! 240: if ( UNIQ(c) ) {
! 241: if ( d ) {
! 242: if ( UNIQ(d) )
! 243: r = v;
! 244: else {
! 245: objtoquote((Obj)d,&t);
! 246: pwrquote(CO,v,t,&r);
! 247: }
! 248: } else
! 249: objtoquote((Obj)ONE,&r);
! 250: } else {
! 251: objtoquote((Obj)c,&u);
! 252: if ( !NUM(c) && NEXT(DC(c)) && d ) {
! 253: MKQUOTE(t,mkfnode(1,I_PAREN,BDY(u)));
! 254: u = t;
! 255: }
! 256: if ( d ) {
! 257: if ( UNIQ(d) )
! 258: s = v;
! 259: else {
! 260: objtoquote((Obj)d,&t);
! 261: pwrquote(CO,v,t,&s);
! 262: }
! 263: mulquote(CO,u,s,&r);
! 264: } else
! 265: r = u;
! 266: }
! 267: *q = r;
! 268: }
! 269:
! 270: void mptoquote(MP m,int n,QUOTE *r,int *sgn)
! 271: {
! 272: QUOTE s,u;
! 273: P c;
! 274: NODE t,t1;
! 275: FNODE f;
! 276: Z q;
! 277: DL dl;
! 278: int i;
! 279:
! 280: if ( mmono((P)C(m)) ) {
! 281: chsgnp((P)C(m),&c);
! 282: *sgn = -1;
! 283: } else {
! 284: c = (P)C(m);
! 285: *sgn = 1;
! 286: }
! 287: objtoquote((Obj)c,&s);
! 288: if ( !NUM(c) && NEXT(DC(c)) ) {
! 289: MKQUOTE(u,mkfnode(1,I_PAREN,BDY(s)));
! 290: s = u;
! 291: }
! 292: dl = m->dl;
! 293: for ( i = n-1, t = 0; i >= 0; i-- ) {
! 294: STOQ(dl->d[i],q);
! 295: f = mkfnode(1,I_FORMULA,q);
! 296: MKNODE(t1,f,t);
! 297: t = t1;
! 298: }
! 299: MKQUOTE(u,mkfnode(1,I_EV,t));
! 300: if ( UNIQ(c) )
! 301: *r = u;
! 302: else
! 303: mulquote(CO,s,u,r);
! 304: }
! 305:
! 306: void vartoquote(V v,QUOTE *c)
! 307: {
! 308: P x;
! 309: PF pf;
! 310: PFAD ad;
! 311: QUOTE a,b,u;
! 312: int i;
! 313: FUNC f;
! 314: NODE t,t1;
! 315:
! 316: if ( NAME(v) ) {
! 317: MKV(v,x);
! 318: MKQUOTE(*c,mkfnode(1,I_FORMULA,(pointer)x));
! 319: } else if ( (vid)v->attr == V_PF ) {
! 320: /* pure function */
! 321: pf = ((PFINS)v->priv)->pf;
! 322: ad = ((PFINS)v->priv)->ad;
! 323: if ( !strcmp(NAME(pf),"pow") ) {
! 324: /* pow(a,b) = a^b */
! 325: objtoquote(ad[0].arg,&a);
! 326: x = (P)ad[0].arg;
! 327: /* check whether x is a variable */
! 328: if ( x && OID(x)==O_P && !NEXT(DC(x))
! 329: && UNIQ(DEG(DC(x))) && UNIQ(COEF(DC(x))) ) {
! 330: /* use a as is */
! 331: } else {
! 332: /* a => (a) */
! 333: MKQUOTE(u,mkfnode(1,I_PAREN,BDY(a))); a = u;
! 334: }
! 335: objtoquote(ad[1].arg,&b);
! 336: pwrquote(CO,a,b,c);
! 337: } else {
! 338: for ( i = 0; i < pf->argc; i++ )
! 339: if ( ad[i].d )
! 340: break;
! 341: if ( i < pf->argc )
! 342: error("vartoquote : not implemented");
! 343: gen_searchf(NAME(pf),&f);
! 344: t = 0;
! 345: for ( i = pf->argc-1; i >= 0; i-- ) {
! 346: objtoquote(ad[i].arg,&a);
! 347: MKNODE(t1,BDY(a),t);
! 348: t = t1;
! 349: }
! 350: MKQUOTE(*c,mkfnode(2,I_FUNC,f,mkfnode(1,I_LIST,t)));
! 351: }
! 352: }
! 353: }
! 354:
! 355: /*
! 356: * A_arf : arithmetic function
! 357: * A_int : machine integer
! 358: * A_fnode : FNODE
! 359: * A_node : NODE with FNODE bodies
! 360: * A_internal : internal object
! 361: * A_str : string
! 362: * A_end : terminal
! 363: * A_func : FUNC
! 364: * A_notimpl : not implemented
! 365: */
! 366:
! 367: struct fid_spec fid_spec_tab[] = {
! 368: {I_BOP,A_arf,A_fnode,A_fnode,A_end},
! 369: {I_COP,A_int,A_fnode,A_fnode,A_end},
! 370: {I_AND,A_fnode,A_fnode,A_end},
! 371: {I_OR,A_fnode,A_fnode,A_end},
! 372: {I_NOT,A_fnode,A_end},
! 373: {I_CE,A_fnode,A_fnode,A_end},
! 374: {I_PRESELF,A_arf,A_fnode,A_end},
! 375: {I_POSTSELF,A_arf,A_fnode,A_end},
! 376: {I_FUNC,A_func,A_fnode,A_end},
! 377: {I_FUNC_OPT,A_func,A_fnode,A_fnode,A_end},
! 378: {I_IFUNC,A_fnode,A_fnode,A_end},
! 379: {I_MAP,A_func,A_fnode,A_end},
! 380: {I_RECMAP,A_func,A_fnode,A_end},
! 381: {I_PFDERIV,A_notimpl,A_end},
! 382: {I_ANS,A_int,A_end},
! 383: {I_PVAR,A_int,A_node,A_end},
! 384: {I_ASSPVAR,A_fnode,A_fnode,A_end},
! 385: {I_FORMULA,A_internal,A_end},
! 386: {I_LIST,A_node,A_end},
! 387: {I_STR,A_str,A_end},
! 388: {I_NEWCOMP,A_int,A_end},
! 389: {I_CAR,A_fnode,A_end},
! 390: {I_CDR,A_fnode,A_end},
! 391: {I_CAST,A_notimpl,A_end},
! 392: {I_INDEX,A_fnode,A_node,A_end},
! 393: {I_EV,A_node,A_end},
! 394: {I_TIMER,A_fnode,A_fnode,A_fnode,A_end},
! 395: {I_GF2NGEN,A_end},
! 396: {I_GFPNGEN,A_end},
! 397: {I_GFSNGEN,A_end},
! 398: {I_LOP,A_int,A_fnode,A_fnode,A_end},
! 399: {I_OPT,A_str,A_fnode,A_end},
! 400: {I_GETOPT,A_str,A_end},
! 401: {I_POINT,A_fnode,A_str,A_end},
! 402: {I_PAREN,A_fnode,A_end},
! 403: {I_MINUS,A_fnode,A_end},
! 404: {I_NARYOP,A_arf,A_node,A_end},
! 405: {I_CONS,A_node,A_fnode,A_end},
! 406: {I_FUNC_QARG,A_func,A_fnode,A_end},
! 407: {I_FUNC_HEAD,A_func,A_end},
! 408: };
! 409:
! 410: #define N_FID_SPEC (sizeof(fid_spec_tab)/sizeof(struct fid_spec))
! 411:
! 412: void get_fid_spec(fid id,fid_spec_p *spec)
! 413: {
! 414: int i;
! 415:
! 416: for ( i = 0; i < N_FID_SPEC; i++ )
! 417: if ( fid_spec_tab[i].id == id ) {
! 418: *spec = &fid_spec_tab[i];
! 419: return;
! 420: }
! 421: *spec = 0;
! 422: }
! 423:
! 424: FNODE strip_paren(FNODE f)
! 425: {
! 426: if ( !f || f->id != I_PAREN ) return f;
! 427: else {
! 428: return strip_paren((FNODE)FA0(f));
! 429: }
! 430: }
! 431:
! 432: NODE flatten_fnodenode(NODE n,char *opname);
! 433: FNODE flatten_fnode(FNODE f,char *opname);
! 434:
! 435: NODE flatten_fnodenode(NODE n,char *opname)
! 436: {
! 437: NODE r0,r,t;
! 438:
! 439: r0 = 0;
! 440: for ( t = n; t; t = NEXT(t) ) {
! 441: NEXTNODE(r0,r);
! 442: BDY(r) = (pointer)flatten_fnode((FNODE)BDY(t),opname);
! 443: }
! 444: if ( r0 ) NEXT(r) = 0;
! 445: return r0;
! 446: }
! 447:
! 448: FNODE flatten_fnode(FNODE f,char *opname)
! 449: {
! 450: fid_spec_p spec;
! 451: farg_type *type;
! 452: fid id;
! 453: FNODE f1,f2,r;
! 454: int i;
! 455:
! 456: if ( !f ) return f;
! 457: id = f->id;
! 458: get_fid_spec(id,&spec);
! 459: /* unknown fid */
! 460: if ( !spec ) return f;
! 461: if ( id == I_BOP && !strcmp(((ARF)FA0(f))->name,opname) ) {
! 462: f1 = (pointer)flatten_fnode(FA1(f),opname);
! 463: f1 = strip_paren(f1);
! 464: f2 = (pointer)flatten_fnode(FA2(f),opname);
! 465: f2 = strip_paren(f2);
! 466: if ( f1->id == I_BOP && !strcmp(((ARF)FA0(f1))->name,opname) ) {
! 467: /* [op [op A B] C] => [op A [op B C]] */
! 468: f2 = flatten_fnode(mkfnode(3,I_BOP,(ARF)FA0(f),FA2(f1),f2),opname);
! 469: return mkfnode(3,I_BOP,(ARF)FA0(f),FA1(f1),f2);
! 470: } else
! 471: return mkfnode(3,I_BOP,(ARF)FA0(f),f1,f2);
! 472: } else {
! 473: type = spec->type;
! 474: for ( i = 0; type[i] != A_end; i++ );
! 475: NEWFNODE(r,i); ID(r) = f->id;
! 476: for ( i = 0; type[i] != A_end; i++ ) {
! 477: if ( type[i] == A_fnode )
! 478: r->arg[i] = (pointer)flatten_fnode(f->arg[i],opname);
! 479: else if ( type[i] == A_node )
! 480: r->arg[i] = (pointer)flatten_fnodenode(f->arg[i],opname);
! 481: else
! 482: r->arg[i] = f->arg[i];
! 483: }
! 484: return r;
! 485: }
! 486: }
! 487:
! 488: /* comparison of QUOTE */
! 489:
! 490: int compquote(VL vl,QUOTE q1,QUOTE q2)
! 491: {
! 492: return compfnode(BDY(q1),BDY(q2));
! 493: }
! 494:
! 495: /* comparison of QUOTEARG */
! 496: /* XXX : executes a non-sense comparison for bodies */
! 497:
! 498: int compqa(VL vl,QUOTEARG q1,QUOTEARG q2)
! 499: {
! 500: if ( !q1 ) return q2?-1:0;
! 501: else if ( !q2 ) return 1;
! 502: else if ( OID(q1) > OID(q2) ) return 1;
! 503: else if ( OID(q1) < OID(q2) ) return -1;
! 504: else if ( q1->type > q2->type ) return 1;
! 505: else if ( q1->type < q2->type ) return -1;
! 506: else switch ( q1->type ) {
! 507: case A_func:
! 508: return strcmp(((FUNC)q1->body)->name,((FUNC)q2->body)->name);
! 509: case A_arf:
! 510: return strcmp(((ARF)q1->body)->name,((ARF)q2->body)->name);
! 511: default:
! 512: if ( (unsigned long)q1->body > (unsigned long)q2->body ) return 1;
! 513: else if ( (unsigned long)q1->body < (unsigned long)q2->body ) return -1;
! 514: else return 0;
! 515: }
! 516: }
! 517:
! 518: int compfnode(FNODE f1,FNODE f2)
! 519: {
! 520: fid_spec_p spec;
! 521: int t,s1,s2,i;
! 522: NODE n1,n2;
! 523:
! 524: if ( !f1 ) return f2 ? -1 : 1;
! 525: else if ( !f2 ) return 1;
! 526: else if ( f1->id > f2->id ) return 1;
! 527: else if ( f1->id < f2->id ) return -1;
! 528: spec = fid_spec_tab+f1->id;
! 529: for ( i = 0; spec->type[i] != A_end; i++ ) {
! 530: switch ( spec->type[i] ) {
! 531: case A_fnode:
! 532: t = compfnode((FNODE)f1->arg[i],(FNODE)f2->arg[i]);
! 533: if ( t ) return t;
! 534: break;
! 535: case A_int:
! 536: s1 = (long)f1->arg[i];
! 537: s2 = (long)f2->arg[i];
! 538: if ( s1 > s2 ) return 1;
! 539: else if ( s1 < s2 ) return -1;
! 540: break;
! 541: case A_str:
! 542: t = strcmp((char *)f1->arg[i],(char *)f2->arg[i]);
! 543: if ( t ) return t;
! 544: break;
! 545: case A_internal:
! 546: t = arf_comp(CO,(Obj)f1->arg[i],(Obj)f2->arg[i]);
! 547: if ( t ) return t;
! 548: break;
! 549: case A_node:
! 550: n1 = (NODE)f1->arg[i];
! 551: n2 = (NODE)f2->arg[i];
! 552: for ( ; n1 && n2; n1 = NEXT(n1), n2 = NEXT(n2) ) {
! 553: t = compfnode(BDY(n1),BDY(n2));
! 554: if ( t ) return t;
! 555: }
! 556: if ( n1 ) return 1;
! 557: else if ( n2 ) return -1;
! 558: break;
! 559: case A_arf:
! 560: t = strcmp(((ARF)f1->arg[i])->name,((ARF)f2->arg[i])->name);
! 561: if ( t ) return t;
! 562: break;
! 563: case A_func:
! 564: t = strcmp(((FUNC)f1->arg[i])->name,((FUNC)f2->arg[i])->name);
! 565: if ( t ) return t;
! 566: break;
! 567: case A_notimpl:
! 568: default:
! 569: error("compfnode : not implemented");
! 570: break;
! 571: }
! 572: }
! 573: return 0;
! 574: }
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to quote.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2018 / parse