1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1984. */ 2: /* $Header: b2uni.c,v 1.1 84/06/28 00:49:27 timo Exp $ */ 3: 4: /* B units */ 5: #include "b.h" 6: #include "b1obj.h" 7: #include "b1mem.h" /* for ptr */ 8: #include "b2fil.h" 9: #include "b2env.h" 10: #include "b2scr.h" 11: #include "b2err.h" 12: #include "b2key.h" 13: #include "b2syn.h" 14: #include "b2sou.h" 15: #include "b2sem.h" 16: 17: Forward loc fopnd(), fop(), basfop(); 18: 19: value resval; outcome resout; 20: bool terminated; 21: value global; 22: value formlist, sharelist; envtab reftab; 23: bool forming; 24: 25: Visible Procedure get_unit(filed) bool filed; { 26: bool xeq0= xeq, hu= No, yu= No, tu= No; 27: txptr fux= tx, lux; 28: value u; literal adic; 29: if ((hu= atkw(HOW_TO)) || (yu= atkw(YIELD)) || (tu= atkw(TEST))) { 30: lino= 1; uname= aster; 31: if (cur_ilev != 0) parerr("unit starts with indentation", ""); 32: cntxt= In_unit; 33: Skipsp(tx); 34: formlist= mk_elt(); 35: if (hu) { 36: txptr utx, vtx; value f; 37: uname= keyword(ceol); utype= FHW; 38: req(":", ceol, &utx, &vtx); 39: Skipsp(tx); 40: while (tx < utx) { 41: if (Cap(Char(tx))) goto nxt_kw; 42: if (!Letter(Char(tx))) 43: parerr("no formal parameter where expected", ""); 44: f= tag(); 45: if (in(f, formlist)) 46: pprerr("multiple use of formal parameter", ""); 47: insert(f, &formlist); 48: release(f); 49: Skipsp(tx); 50: nxt_kw: if (tx < utx) { 51: release(keyword(utx)); 52: Skipsp(tx); 53: } 54: } 55: tx= vtx; 56: } else { 57: ytu_heading(&uname, &adic, ceol, Yes); 58: utype= adic == Zer ? FZR : adic == Mon ? FMN : FDY; 59: } 60: xeq= No; 61: sharelist= mk_elt(); 62: unicomm_suite(); 63: Mark_unit_end(tx); 64: reftab= mk_elt(); 65: ref_suite(); 66: lux= tx+1; 67: adjust_unit(&fux, &lux, &reftab); 68: u= hu ? mk_how(fux, lux, reftab, filed) : 69: yu ? mk_fun(1, 8, adic, Use, fux, lux, reftab, filed) 70: : mk_prd(adic, Use, fux, lux, reftab, filed); 71: def_unit(u, uname, utype); 72: release(sharelist); release(u); release(formlist); release(uname); 73: xeq= xeq0; 74: } else parerr("no HOW'TO, YIELD or TEST where expected", ""); 75: } 76: 77: Visible Procedure ytu_heading(name, adic, wtx, form) 78: value *name; literal *adic; txptr wtx; bool form; { 79: /* xeq == No */ 80: intlet ad= 0; value t1= Vnil, t2= Vnil, t3= Vnil; 81: forming= form; /*should be a parameter to fopnd()*/ 82: Skipsp(tx); 83: if (Montormark(Char(tx))) 84: parerr("user defined functions or predicates must be tags", ""); 85: if (Letter(Char(tx))) *name= t1= tag(); 86: else if (Char(tx) == '(') { 87: if (fopnd(wtx) == Vnil) /* ignore */; 88: } else parerr("something unexpected instead of formal formula", ""); 89: Skipsp(tx); 90: if (Char(tx) == ':') goto postff; 91: if (Dyatormark(Char(tx))) 92: parerr("user defined functions or predicates must be tags", ""); 93: if (Letter(Char(tx))) { 94: t2= tag(); 95: if (t1 == Vnil) *name= t2; 96: } else if (Char(tx) == '(') { 97: if (t1 == Vnil) parerr("no function name where expected", ""); 98: if (fopnd(wtx) == Vnil) /* ignore */; 99: } else parerr("no function name or formal operand where expected", ""); 100: ad= 1; 101: Skipsp(tx); 102: if (Char(tx) == ':') { 103: if (t1 == Vnil) nothing(tx, "second formal operand"); 104: goto postff; 105: } 106: if (t2 == Vnil) 107: parerr("something unexpected following monadic formal formula", ""); 108: *name= t2; 109: if (forming && t1 != Vnil) insert(t1, &formlist); 110: if (Letter(Char(tx))) { 111: t3= tag(); 112: if (forming) insert(t3, &formlist); 113: } else if (Char(tx) == '(') { 114: if (fopnd(wtx) == Vnil) /* ignore */; 115: } else parerr("no formal operand where expected", ""); 116: ad= 2; 117: Skipsp(tx); 118: if (Char(tx) != ':') 119: parerr("something unexpected following dyadic formal formula", ""); 120: postff: if (t1 != Vnil && t1 != *name) release(t1); 121: if (t2 != Vnil && t2 != *name) release(t2); 122: if (t3 != Vnil) release(t3); 123: *adic= ad == 0 ? Zer : ad == 1 ? Mon : Dya; 124: tx++; 125: } 126: 127: Hidden value mk_formal(ftx) txptr ftx; { /* Move */ 128: value f= grab_for(); formal *fp= Formal(f); 129: sv_context(&(fp->con)); fp->ftx= ftx; 130: return f; 131: } 132: 133: Visible bool udc() { 134: value un, *aa; context ic, hc; envchain nw_envchain; 135: txptr tx0= tx, uux, vux, wux; bool formals= No; 136: if (!Cap(Char(tx))) return No; 137: if (!xeq) { 138: tx= ceol; 139: if (skipping) parerr("X", ""); /* to prevent skipping= No; */ 140: return Yes; 141: } 142: un= keyword(ceol); 143: debug("udc^ called"); 144: sv_context(&ic); 145: if (!is_unit(un, FHW, &aa)) { 146: release(un); 147: tx= tx0; 148: return No; 149: } 150: if (!Is_howto(*aa)) syserr("no howto associated with keyword"); 151: curnv= &nw_envchain; 152: curnv->tab= mk_elt(); curnv->inv_env= Enil; 153: cntxt= In_unit; resexp= Voi; uname= un; utype= FHW; 154: cur_ilev= 0; lino= 1; 155: tx= (How_to(*aa))->fux; 156: terminated= No; 157: debug("ready to howto"); 158: findceol(); 159: wux= ceol; req(":", wux, &uux, &vux); 160: if (!atkw(HOW_TO) || (compare(uname= keyword(uux), un) != 0)) 161: syserr("out of phase in udc"); 162: release(un); 163: Skipsp(tx); 164: while (tx < uux) { 165: txptr ftx, ttx, fux, tux; 166: value fp, ap, kw; 167: kw= findkw(uux, &fux, &tux); 168: if (Letter(Char(tx))) fp= bastarg(fux); 169: else if (tx < fux) { 170: release(kw); 171: parerr("no formal parameter where expected", ""); 172: } else fp= Vnil; 173: sv_context(&hc); set_context(&ic); 174: if (fux == uux) ftx= ttx= ceol; 175: else reqkw(strval(kw), &ftx, &ttx); /*dangerous use of strval*/ 176: release(kw); 177: if (fp != Vnil) { 178: Skipsp(tx); 179: nothing(ftx, "actual parameter"); 180: ap= mk_formal(ftx); formals= Yes; 181: } else { 182: Skipsp(tx); 183: if (tx < ftx) 184: parerr("actual parameter without formal", ""); 185: } 186: tx= ttx; 187: sv_context(&ic); set_context(&hc); 188: if (fp != Vnil) { 189: put(ap, fp); release(fp); release(ap); 190: } 191: tx= tux; Skipsp(tx); 192: } 193: tx= vux; 194: add_reftab((How_to(*aa))->reftab); 195: if (formals) curnv->inv_env= ic.curnv; 196: unicomm_suite(); terminated= No; 197: release(curnv->tab); release(uname); 198: set_context(&ic); 199: return Yes; 200: } 201: 202: Visible value eva_formal(f) value f; { 203: value v; formal *ff= Formal(f); context cc; 204: if (!Is_formal(f)) syserr("eva_formal has wrong argument"); 205: sv_context(&cc); if (cntxt != In_formal) how_context= cc; 206: set_context(&ff->con); cntxt= In_formal; 207: v= expr(ff->ftx); 208: set_context(&cc); 209: return v; 210: } 211: 212: Visible loc loc_formal(f) value f; { 213: loc l; formal *ff= Formal(f); context cc; 214: if (!Is_formal(f)) syserr("loc_formal has wrong argument"); 215: sv_context(&cc); if (cntxt != In_formal) how_context= cc; 216: set_context(&ff->con); cntxt= In_formal; 217: l= targ(ff->ftx); 218: set_context(&cc); 219: return l; 220: } 221: 222: Visible bool ref_com() { 223: /* if !xeq, ref_com always returns Yes unless skipping */ 224: value rn, *aa, rname; context ic; 225: txptr tx0= tx, wux; 226: if (!Cap(Char(tx))) return No; 227: debug("ref_com^ called"); 228: if (!xeq) { 229: tx= ceol; 230: if (skipping) parerr("X", ""); /* to prevent skipping= No; */ 231: return Yes; 232: } 233: rn= keyword(ceol); 234: aa= lookup(rn); 235: if (aa == Pnil) { 236: release(rn); 237: tx= tx0; 238: return No; 239: } 240: if (!Is_refinement(*aa)) syserr("no refinement associated with keyword"); 241: upto(ceol, "refined-command"); 242: sv_context(&ic); 243: cntxt= In_unit; resexp= Voi; 244: cur_ilev= 0; 245: lino= (Refinement(*aa))->rlino; 246: tx= (Refinement(*aa))->rp; 247: terminated= No; 248: debug("ready to execute refinement"); 249: findceol(); 250: wux= ceol; 251: if (compare(rname= keyword(wux), rn) != 0) 252: syserr("out of phase in ref_com"); 253: thought(':'); 254: comm_suite(); terminated= No; 255: release(rn); release(rname); 256: set_context(&ic); 257: return Yes; 258: } 259: 260: Visible Procedure udfpr(nd1, fpr, nd2, re) value nd1, nd2; funprd *fpr; literal re; { 261: context ic; envchain nw_envchain; value f; 262: txptr uux, vux, wux; 263: debug("udfpr^ called"); 264: sv_context(&ic); 265: curnv= &nw_envchain; 266: curnv->tab= mk_elt(); curnv->inv_env= Enil; 267: cntxt= In_unit; resexp= re; uname= aster; 268: cur_ilev= 0; lino= 1; 269: tx= fpr->fux; 270: resval= Vnil; resout= Und; terminated= No; 271: debug("ready to Yield/Test"); 272: findceol(); 273: wux= ceol; req(":", wux, &uux, &vux); 274: if (!atkw(YIELD) && !atkw(TEST)) syserr("out of phase in udfpr"); 275: Skipsp(tx); 276: switch (fpr->adic) { 277: case Zer: 278: uname= tag(); utype= FZR; 279: break; 280: case Mon: 281: uname= tag(); utype= FMN; 282: put(nd2, f= fopnd(uux)); release(f); 283: break; 284: case Dya: 285: put(nd1, f= fopnd(uux)); release(f); 286: uname= tag(); utype= FDY; 287: put(nd2, f= fopnd(uux)); release(f); 288: break; 289: } 290: thought(':'); 291: tx= vux; 292: add_reftab(fpr->reftab); 293: unicomm_suite(); terminated= No; 294: if (xeq) { 295: if (re == Ret && resval == Vnil) 296: error("command-suite of YIELD-unit returns no value"); 297: if (re == Rep && resout == Und) 298: error("command-suite of TEST-unit reports no outcome"); 299: } 300: terminated= No; 301: release(curnv->tab); release(uname); 302: set_context(&ic); 303: } 304: 305: #define NET 8 306: 307: Visible Procedure ref_et(rfv, re) value rfv; literal re; { 308: context ic; value bndtglist, rname; env ee; bool prmnv_saved= No; 309: envtab svperm_envtab= Vnil, et0, envtabs[NET], *et, *etp; intlet etl; 310: txptr uux, vux, wux; 311: debug("ref_et^ called"); 312: if (!Is_refinement(rfv)) syserr("ref_et called with non-refinement"); 313: sv_context(&ic); 314: ee= curnv; etl= 0; 315: while (ee != Enil) { 316: if (ee == prmnv) break; 317: etl++; 318: ee= ee->inv_env; 319: } 320: if (etl <= NET) et= envtabs; 321: else et= (envtab *) getmem((unsigned)etl*sizeof(value)); 322: ee= curnv; etp= et; 323: while (ee != Enil) { 324: if (ee == prmnv) { 325: if (prmnvtab == Vnil) { 326: /* the original permanent environment */ 327: prmnvtab= prmnv->tab; 328: prmnv->tab= copy(prmnvtab); 329: } else svperm_envtab= copy(prmnv->tab); 330: prmnv_saved= Yes; 331: break; 332: } 333: *etp++= copy(ee->tab); 334: ee= ee->inv_env; 335: } 336: if (resexp == Voi && !prmnv_saved) { 337: /* possible access through SHARE */ 338: if (prmnvtab == Vnil) { 339: prmnvtab= prmnv->tab; 340: prmnv->tab= copy(prmnvtab); 341: } else svperm_envtab= copy(prmnv->tab); 342: prmnv_saved= Yes; 343: } 344: bndtglist= mk_elt(); bndtgs= &bndtglist; 345: cntxt= In_unit; resexp= re; 346: cur_ilev= 0; 347: lino= (Refinement(rfv))->rlino; 348: tx= (Refinement(rfv))->rp; 349: resval= Vnil; resout= Und; terminated= No; 350: debug("ready to eval/test refinement"); 351: findceol(); 352: wux= ceol; req(":", wux, &uux, &vux); 353: rname= tag(); thought(':'); 354: comm_suite(); 355: if (xeq) { 356: if (re == Ret && resval == Vnil) 357: error("refinement returns no value"); 358: if (re == Rep && resout == Und) 359: error("refinement reports no outcome"); 360: } 361: terminated= No; 362: release (rname); 363: ee= curnv; etp= et; 364: while (ee != Enil) { 365: if (ee == prmnv) break; 366: if (ee == curnv) et0= ee->tab; else release(ee->tab); 367: ee->tab= *etp++; 368: ee= ee->inv_env; 369: } 370: if (prmnv_saved) { 371: release(prmnv->tab); 372: if (svperm_envtab == Vnil) { 373: prmnv->tab= prmnvtab; 374: prmnvtab= Vnil; 375: } else prmnv->tab= svperm_envtab; 376: } 377: set_context(&ic); 378: if (curnv != prmnv) { 379: if (re == Rep) extbnd_tags(bndtglist, &(curnv->tab), et0); 380: release(et0); 381: } 382: release(bndtglist); 383: if (etl > NET) freemem((ptr) et); 384: } 385: 386: Hidden loc fopnd(q) txptr q; { 387: txptr ttx; 388: Skipsp(tx); 389: if (tx >= q) syserr("fopnd called when it should not be"); 390: if (Letter(Char(tx))) { 391: ttx= tx+1; while(Tagmark(Char(ttx))) ttx++; 392: } else if (Char(tx) == '(') { 393: txptr tx0= tx++, ftx; 394: req(")", q, &ftx, &ttx); 395: tx= tx0; 396: } else syserr("fopnd does not see formal operand"); 397: return basfop(ttx); 398: } 399: 400: Hidden loc fop(q) txptr q; { 401: value c=Vnil; loc l; txptr i, j; intlet len, k; 402: if ((len= 1+count(",", q)) == 1) return basfop(q); 403: if (xeq) c= mk_compound(len); 404: k_Overfields { 405: if (!Lastfield(k)) req(",", q, &i, &j); 406: else i= q; 407: l= basfop(i); 408: if (xeq) put_in_field(l, &c, k); 409: if (!Lastfield(k)) tx= j; 410: } 411: return (loc) c; 412: } 413: 414: Hidden loc basfop(q) txptr q; { 415: loc l= Vnil; txptr i, j; 416: Skipsp(tx); 417: nothing(q, "formal operand"); 418: if (Char(tx) == '(') { 419: tx++; req(")", q, &i, &j); 420: l= fop(i); tx= j; 421: } else if (Letter(Char(tx))) { 422: value t= tag(); 423: if (forming && !xeq) insert(t, &formlist); 424: else l= local_loc(t); 425: release(t); 426: } else parerr("no formal operand where expected", ""); 427: return l; 428: } 429: 430: Hidden Procedure unicomm_suite() { 431: if (ateol()) { 432: while (ilev(Yes) > 0 && atkw(SHARE)) { 433: findceol(); 434: share(ceol); 435: To_eol(tx); 436: } 437: veli(); 438: if (cur_ilev > 0) { 439: cur_ilev= 0; 440: comm_suite(); 441: } 442: } else command(); 443: } 444: 445: Hidden Procedure share(q) txptr q; { 446: intlet n, k; 447: Skipsp(tx); 448: n= 1+count(",", q); 449: for (k= 0; k < n; k++) { 450: txptr i, j; 451: if (k < n-1) req(",", q, &i, &j); 452: else i= q; 453: sharebas(i); 454: if (k < n-1) need(","); 455: } 456: upto(q, "SHAREd identifier"); 457: } 458: 459: #define SH_IN_USE "SHAREd identifier is already in use as formal parameter or operand" 460: 461: Hidden Procedure sharebas(q) txptr q; { 462: Skipsp(tx); 463: nothing(q, "SHAREd identifier"); 464: if (Char(tx) == '(') { 465: txptr i, j; 466: tx++; req(")", q, &i, &j); 467: share(i); tx= j; 468: } else if (Letter(Char(tx))) { 469: value t= tag(); 470: if (!xeq) { 471: if (in(t, formlist)) pprerr(SH_IN_USE, ""); 472: insert(t, &sharelist); 473: } else if (resexp == Voi) { /*ie we're in a HOW'TO*/ 474: loc l; value *aa= lookup(t); 475: if (aa == Pnil) { 476: put(global, l= local_loc(t)); 477: release(l); 478: } 479: } else { /*we're in a TEST or YIELD*/ 480: loc l= global_loc(t); 481: value g= content(l); 482: release(l); 483: put(g, l= local_loc(t)); 484: release(l); release(g); 485: /* can this be achieved by scratch-pad copying? */ 486: } 487: release(t); 488: upto(q, "SHAREd identifier"); 489: } else parerr("no identifier where expected", ""); 490: } 491: 492: #define REF_IN_USE "refinement-tag is already in use as formal parameter or operand" 493: 494: Hidden Procedure ref_suite() { 495: txptr rp; intlet rlino; value r, kt, *aa; 496: rref: if (ilev(Yes) > 0) parerr("indentation where not allowed", ""); 497: findceol(); 498: if (Cap(Char(tx)) && !atkw(SELECT)) { 499: kt= findkw(lcol(), &rp, &tx); 500: Skipsp(tx); 501: if (Char(tx) != ':') { 502: release(kt); 503: veli(); return; 504: } 505: rlino= lino; 506: } else if (Letter(Char(tx))) { 507: rp= tx; 508: while(Tagmark(Char(tx))) tx++; 509: Skipsp(tx); 510: if (Char(tx) != ':') { 511: veli(); return; 512: } 513: tx= rp; rlino= lino; kt= tag(); 514: if (in(kt, formlist)) pprerr(REF_IN_USE, ""); 515: if (in(kt, sharelist)) pprerr( 516: "refinement-tag is already in use as SHAREd identifier", ""); 517: } else { 518: veli(); return; 519: } 520: if (in_env(reftab, kt, &aa)) error("redefinition of refinement"); 521: thought(':'); 522: r= mk_ref(rp, rlino); 523: e_replace(r, &reftab, kt); 524: comm_suite(); 525: if (!Eol(tx)) syserr("comm_suite does not leave tx at Eol"); 526: Mark_unit_end(tx); 527: release(r); release(kt); 528: goto rref; 529: } 530: 531: Hidden Procedure add_reftab(rt) envtab rt; { 532: int k, len; 533: if (!Is_table(rt)) syserr("add_reftab called with non_table"); 534: len= length(rt); 535: k_Over_len { 536: e_replace(*assoc(rt, k), &(curnv->tab), *key(rt, k)); 537: } 538: } 539: 540: Visible Procedure inithow() { 541: aster= mk_text("***"); 542: global= grab_glo(); 543: } 544: 545: Hidden Procedure adjust_unit(fux, lux, reftb) txptr *fux, *lux; value *reftb; { 546: /* The text of the unit still resides in the text buffer. 547: It is moved to an allocated area and the text pointers 548: are adjusted accordingly. */ 549: txptr tm, ta; int adj, k, len= length(*reftb); 550: 551: ta= (txptr) getmem((unsigned)(*lux-*fux)*sizeof(*tx)); 552: tm= *fux; adj= ta-tm; 553: while (tm <= tx) *ta++= *tm++; 554: *fux+= adj; *lux+= adj; 555: k_Over_len { 556: Refinement(*assoc(*reftb, k))->rp+= adj; /*Change*/ 557: } 558: }