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: }

Defined functions

add_reftab defined in line 531; used 2 times
adjust_unit defined in line 545; used 1 times
  • in line 67
basfop defined in line 414; used 4 times
fop defined in line 400; used 2 times
fopnd defined in line 386; used 7 times
get_unit defined in line 25; used 3 times
inithow defined in line 540; used 1 times
mk_formal defined in line 127; used 1 times
ref_suite defined in line 494; used 1 times
  • in line 65
share defined in line 445; used 2 times
sharebas defined in line 461; used 1 times
udc defined in line 133; used 2 times
udfpr defined in line 260; used 2 times
unicomm_suite defined in line 430; used 3 times
ytu_heading defined in line 77; used 2 times

Defined variables

Procedure defined in line 260; never used
Visible defined in line 260; never used
forming defined in line 23; used 4 times
terminated defined in line 20; used 9 times
value defined in line 202; used 27 times

Defined macros

NET defined in line 305; used 3 times
REF_IN_USE defined in line 492; used 1 times
SH_IN_USE defined in line 459; used 1 times
Last modified: 1985-08-27
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 2272
Valid CSS Valid XHTML 1.0 Strict