![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to b2uni.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / contrib / B / src / bsmall|
Return to b2uni.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / B / src / bsmall |
1.1 ! root 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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.