2.11BSD#431 - /usr/src/new/PORT/B/src/bint/b3sta.c

   1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
   2: 
   3: /*
   4:   $Header: b3sta.c,v 1.4 85/08/22 16:59:30 timo Exp $
   5: */
   6: 
   7: /* Stacks used by the interpreter */
   8: 
   9: /* Scratch-pad copying.
  10: 
  11:    One of the hairiest details of B is scratch-pad copying and its
  12:    interaction with formal parameters (to HOW'TO units).
  13:    Via formal parameters one can peek and poke into the local environment
  14:    of the HOW'TO's in the call chain.  When a parameter is changed from
  15:    within an expression- or test-refinement, the scratch-pad copying
  16:    prescribes that the whole chain of local environments is restored
  17:    to its original state when the refinement exits.  Example:
  18: 
  19:     >>> HOW'TO X fp:
  20: 	    WRITE fp, ref, fp /
  21: 	ref:
  22: 	    PUT fp+1 IN fp
  23: 	    RETURN fp
  24:     >>> HOW'TO Y fp:
  25: 	    X fp
  26:     >>> HOW'TO Z:
  27: 	    PUT 1 IN t
  28: 	    Y t
  29: 	    WRITE t
  30:     >>> Z
  31:     1 2 1
  32:     1
  33: 
  34:    It is clear that the scratch-pad copying for the call of ref in X
  35:    must save the local environments of Y and Z, and restore them when
  36:    ref exits.
  37:    For similar reasons we must save the permanent environment.
  38:    All this also interacts with the practice of 'locating' a target.
  39:    All targets eventually refer to (one or more) basic targets.
  40:    The location of a basic target is represented as a pair (env, key)
  41:    where 'env' is the address of the environment in which the target
  42:    resides and 'key' is the target's name (for permanent targets) or
  43:    its number (for local targets).  When we consider the PUT fp+1 IN fp
  44:    line in unit X above, we can see that the (local) environment
  45:    for the location returned by 'fp' is the local environment of Z.
  46:    Therefore this whole chain must still be intact.
  47:    There can be even trickier cases, where a location is saved for a
  48:    long time on the execution stack while the environment it refers to
  49:    is subject to scratch-pad copying and restoring; when the location
  50:    is finally popped off the stack, it must still refer to the correct
  51:    environment.
  52: 
  53:    Another detail to consider is that for the permanent environment,
  54:    we need access to the 'real' permanent environment, i.e., its value
  55:    before any scratch-pad copying occurred.  (Example:
  56: 
  57:     >>> YIELD f:
  58: 	    SHARE x
  59: 	    PUT x+1 IN x
  60: 	    READ t EG 0
  61: 	    RETURN t
  62:     >>> PUT 0 IN x
  63:     >>> WRITE x, f, x
  64:     ??? x
  65:     0, 0, 0
  66:     >>>
  67: 
  68:    Even though at the time the READ is called, x has been given the value
  69:    1 temporarily, the value of x used in the evaluation of the input
  70:    expression is the original value, 0.)
  71: 
  72:    A final detail to be observed is the passing back of 'bound tags'
  73:    when a refined test is called.
  74: 
  75:    The chosen implementation is as follows:
  76:    - Environments are saved in a linked list of structures (envchain) with
  77:      two fields: tab, the actual environment (a table or compound) and
  78:      inv_env, the link to the previous entry in the list.
  79:    - The routines newenvchain and popenvchain push and pop such lists.
  80:    - There is one list for the permanent environment, whose head is prmnv,
  81:      and one list for the current environment, whose head is usually curnv.
  82:      The last element of both lists is actually the same, because at the
  83:      immediate command level the current environment is the permanent
  84:      environment.  When we are evaluating or locating a formal parameter,
  85:      'curnv' points somewhere in the middle of its chain, to the local
  86:      environment of the caller.
  87:      The two lists are manipulated separately:
  88:    - Prmnv is pushed (with a copy of itself) for each scratch-pad copy,
  89:      and popped whe a scratch-pad is thrown away.
  90:    - Curnv is pushed for each unit invocation, with the new local
  91:      environment, and popped when the unit exits.
  92:    - When a scratch-pad copy is required, the chain headed by curnv
  93:      is walked until a local environment is found without HOW'TO formal
  94:      parameters, and a compound containing copies of all the local
  95:      environments thus found is saved on the general-purpose value stack.
  96:      This value is popped off that stack again and the local environments
  97:      in the chain are restored when the scratch-pad copy has to be thrown
  98:      away.  (Thus we work on the real thing and save and restore a copy
  99:      of it, while the DP prescribes that the system work on a copy.
 100:      The effect is the same, of course.)
 101:    - There is a third list for bound tags whose treatment is left as an
 102:      exercise for the reader.
 103:    - When a formal parameter is called, the current value of 'curnv' must
 104:      be saved somewhere, so that it can be restored later; in this case
 105:      it doesn't follow the stack-wise discipline of the chain.
 106:    - Finally note thate that when a YIELD unit is called during the
 107:      evaluation of a formal parameter, the chain of local environments
 108:      "splices" temorarily, because the new local environment is linked
 109:      to curnv which is not the end of the chain.  No problem!
 110: 
 111:    All this nonsense can be avoided when a copy-restore parameter mechanism
 112:    is used instead: then there are no accesses to other local environments
 113:    that the current, except a transfer between two "adjacent" ones at call
 114:    and return time.  Maybe ABC will have such a parameter mechanism...
 115: 
 116: */
 117: 
 118: #include "b.h"
 119: #include "b1mem.h"
 120: #include "b1obj.h"
 121: #include "b2nod.h"
 122: #include "b3env.h"
 123: #include "b3err.h"
 124: #include "b3int.h"
 125: #include "b3sem.h"
 126: #include "b3sou.h" /* for permkey() and get_pname() */
 127: #include "b3sta.h"
 128: 
 129: /* Fundamental registers: (shared only between this file and b3int.c) */
 130: 
 131: Visible parsetree pc; /* 'Program counter', current parsetree node */
 132: Visible parsetree next; /* Next parsetree node (changed by jumps) */
 133: Visible bool report; /* 'Condition code register', outcome of last test */
 134: 
 135: Visible bool noloc; /* Set while evaluating (as opposed to locating)
 136: 			formal parameters of HOW'TOs */
 137: 
 138: Hidden env boundtags; /* Holds bound tags chain */
 139: 
 140: /* Value stack: */
 141: 
 142: /* The run-time value stack grows upward, sp points to the next free entry.
 143:    Allocated stack space lies between st_base and st_top.
 144:    In the current invocation, the stack pointer (sp) must lie between
 145:    st_bottom and st_top.
 146:    Stack overflow is corrected by growing st_top, underflow is a fatal
 147:    error (generated code is wrong).
 148: */
 149: 
 150: Hidden value *st_base, *st_bottom, *st_top, *sp;
 151: Visible int call_level; /* While run() can be called recursively */
 152: 
 153: #define EmptyStack() (sp == st_bottom)
 154: #define BotOffset() (st_bottom - st_base)
 155: #define SetBotOffset(n) (st_bottom= st_base + (n))
 156: 
 157: #define INCREMENT 100
 158: 
 159: Hidden Procedure st_grow(incr) int incr; {
 160:     if (!st_base) { /* First time ever */
 161:         st_bottom= sp= st_base=
 162:             (value*) getmem((unsigned) incr * sizeof(value *));
 163:         st_top= st_base + incr;
 164:     }
 165:     else {
 166:         int syze= (st_top - st_base) + incr;
 167:         int n_bottom= BotOffset();
 168:         int n_sp= sp - st_base;
 169:         regetmem((ptr*) &st_base, (unsigned) syze * sizeof(value *));
 170:         sp = st_base + n_sp;
 171:         SetBotOffset(n_bottom);
 172:         st_top= st_base + syze;
 173:     }
 174: }
 175: 
 176: Visible value pop() {
 177:     if (sp <= st_bottom) {
 178:         syserr(MESS(4100, "stack underflow"));
 179:         return Vnil;
 180:     }
 181:     return *--sp;
 182: }
 183: 
 184: Visible Procedure push(v) value v; {
 185:     if (sp >= st_top) st_grow(INCREMENT);
 186:     *sp++ = (v);
 187: }
 188: 
 189: /* - - - */
 190: 
 191: /* Various call types, used as index in array: */
 192: 
 193: #define C_prmnv 0
 194: #define C_immexp 1
 195: #define C_immcmd 2
 196: #define C_read 3
 197: 
 198: #define C_howto 4
 199: #define C_yield 5
 200: #define C_test 6
 201: 
 202: #define C_refcmd 7
 203: #define C_refexp 8
 204: #define C_reftest 9
 205: 
 206: #define C_formal 10
 207: 
 208: 
 209: /* What can happen to a thing: */
 210: 
 211: #define Old 'o'
 212: #define Cpy 'c'
 213: #define New 'n'
 214: #define Non '-'
 215: 
 216: typedef struct {
 217:     literal do_cur;
 218:     literal do_prm;
 219:     literal do_bnd;
 220:     literal do_for;
 221:     literal do_cntxt;
 222:     literal do_resexp;
 223: } dorecord;
 224: 
 225: 
 226: /* Table encoding what to save/restore for various call/return types: */
 227: /* (Special cases are handled elsewhere.) */
 228: 
 229: Hidden dorecord doo[] = {
 230:     /*		 cur  prm  bnd  for  cntxt    resexp */
 231: 
 232:     /* prmnv */ {Old, Old, Old, Old, In_prmnv, Voi},
 233:     /* imm expr */  {Old, Old, Old, Old, In_command, Voi},
 234:     /* imm cmd */   {Old, Old, Old, Old, In_command, Voi},
 235:     /* READ EG */   {Non, Non, Non, Non, In_read, Voi},
 236: 
 237:     /* HOW-TO */    {New, Old, Non, New, In_unit, Voi},
 238:     /* YIELD */ {New, Cpy, Non, Non, In_unit, Ret},
 239:     /* TEST */  {New, Cpy, Non, Non, In_unit, Rep},
 240: 
 241:     /* REF-CMD */   {Old, Old, Old, Old, In_unit, Voi},
 242:     /* ref-expr */  {Cpy, Cpy, Non, Old, In_unit, Ret},
 243:     /* ref-test */  {Cpy, Cpy, New, Old, In_unit, Rep},
 244: 
 245:     /* formal */    {Non, Old, Non, Non, In_formal, Voi},
 246: };
 247: 
 248: #define MAXTYPE ((sizeof doo) / (sizeof doo[0]))
 249: 
 250: #define Checksum(type) (12345 - (type)) /* Reversible */
 251: 
 252: 
 253: #define Ipush(n) push(MkSmallInt(n))
 254: #define Ipop() SmallIntVal(pop())
 255: 
 256: 
 257: Hidden env newenv(tab, inv_env) envtab tab; env inv_env; {
 258:     env e= (env) getmem(sizeof(envchain));
 259:     e->tab= tab; /* Eats a reference to tab! */
 260:     e->inv_env= inv_env;
 261:     return e;
 262: }
 263: 
 264: 
 265: Hidden Procedure popenv(pe) env *pe; {
 266:     env e= *pe;
 267:     *pe= e->inv_env;
 268:     release(e->tab);
 269:     freemem((ptr) e);
 270: }
 271: 
 272: 
 273: Forward value save_curnv_chain();
 274: 
 275: Hidden Procedure call(type, new_pc) intlet type; parsetree new_pc; {
 276:     if (type < 0 || type >= MAXTYPE) syserr(MESS(4101, "bad call type"));
 277:     if (tracing) tr_call();
 278: 
 279:     /* Push other stacks */
 280: 
 281:     if (doo[type].do_bnd != Old) {
 282:         boundtags= newenv(
 283:             (doo[type].do_bnd == New) ? mk_elt() : Vnil,
 284:             boundtags);
 285:         bndtgs= &boundtags->tab;
 286:     }
 287:     switch (doo[type].do_cur) {
 288: 
 289:     case New:
 290:         curnv= newenv(Vnil, curnv);
 291:         break;
 292: 
 293:     case Cpy:
 294:         push(save_curnv_chain());
 295:         break;
 296: 
 297:     case Non:
 298:         push(mk_int((double) ((int) curnv)));
 299:             /* PORTABILITY?!?! */
 300:         break;
 301: 
 302:     }
 303:     if (doo[type].do_prm != Old) {
 304:         prmnv= newenv(
 305:             (doo[type].do_prm == Cpy) ? copy(prmnv->tab) : Vnil,
 306:             prmnv);
 307:     }
 308: 
 309:     /* Push those things that depend on the call type: */
 310: 
 311:     if (doo[type].do_for != Old) {
 312:         /* Formal parameter context and unit name/type */
 313:         /* FP removed */
 314:         push(uname); uname= Vnil;
 315:     }
 316: 
 317:     /* Push miscellaneous context info: */
 318:     push(curline);
 319:     push(curlino);
 320:     Ipush(noloc); noloc= No;
 321:     Ipush(resexp); resexp= doo[type].do_resexp;
 322:     Ipush(cntxt); cntxt= doo[type].do_cntxt;
 323:     resval= Vnil;
 324: 
 325:     /* Push vital data: */
 326:     push(next);
 327:     Ipush(BotOffset()); ++call_level;
 328:     Ipush(Checksum(type)); /* Kind of checksum */
 329: 
 330:     /* Set st_bottom and jump: */
 331:     st_bottom= sp;
 332:     next= new_pc;
 333: }
 334: 
 335: 
 336: Visible Procedure ret() {
 337:     int type; value rv= resval; literal re= resexp;
 338:     value oldcurnvtab= Vnil, oldbtl= Vnil;
 339: 
 340:     if (tracing) tr_ret();
 341:     if (cntxt == In_formal && still_ok) { rv= pop(); re= Ret; }
 342: 
 343:     /* Clear stack: */
 344:     while (!EmptyStack()) release(pop());
 345: 
 346:     /* Pop type and hope it's good: */
 347:     st_bottom= st_base; /* Trick to allow popping the return info */
 348:     type= Checksum(Ipop());
 349:     if (type < 0 || type >= MAXTYPE) syserr(MESS(4102, "stack clobbered"));
 350: 
 351:     /* Pop vital data: */
 352:     SetBotOffset(Ipop()); --call_level;
 353:     next= pop();
 354: 
 355:     /* Pop context info: */
 356:     cntxt= Ipop();
 357:     resexp= Ipop();
 358:     noloc= Ipop();
 359:     curlino= pop();
 360:     curline= pop();
 361: 
 362:     /* Variable part: */
 363:     if (doo[type].do_for != Old) {
 364:         release(uname); uname= pop();
 365:         /* FP removed */
 366:     }
 367:     if (doo[type].do_prm != Old)
 368:         popenv(&prmnv);
 369:     switch (doo[type].do_cur) {
 370: 
 371:     case Cpy:
 372:         oldcurnvtab= copy(curnv->tab);
 373:         rest_curnv_chain(pop());
 374:         break;
 375: 
 376:     case New:
 377:         oldcurnvtab= copy(curnv->tab);
 378:         popenv(&curnv);
 379:         break;
 380: 
 381:     case Non:
 382:         { value v= pop();
 383:           curnv= (env) intval(v);
 384:          release(v);
 385:         }
 386:         break;
 387: 
 388:     }
 389:     if (doo[type].do_bnd != Old) {
 390:         oldbtl= copy(*bndtgs);
 391:         popenv(&boundtags);
 392:         bndtgs= &boundtags->tab;
 393:     }
 394: 
 395:     /* Fiddle bound tags */
 396:     if (oldbtl != Vnil) {
 397:         extbnd_tags(oldbtl, oldcurnvtab);
 398:         release(oldbtl);
 399:     }
 400:     if (oldcurnvtab != Vnil) release(oldcurnvtab);
 401:     if (call_level == 0) re_env(); /* Resets bndtgs */
 402: 
 403:     /* Push return value (if any): */
 404:     if (re == Ret && still_ok) push(rv);
 405: }
 406: 
 407: /* - - - */
 408: 
 409: Visible Procedure call_formal(name, number, targ)
 410:  value name, number; bool targ; {
 411:     value *aa= envassoc(curnv->tab, number); formal *ff= Formal(*aa);
 412:     literal ct;
 413:     if (aa == Pnil || !Is_formal(*aa)) syserr(MESS(4103, "formal gone"));
 414:     if (cntxt != In_formal) {
 415:         release(how_context.uname);
 416:         sv_context(&how_context); /* for error messages */
 417:     }
 418:     call(C_formal, ff->fp);
 419: 
 420:     /* The following should be different, but for now... */
 421:     curnv= ff->con.curnv;
 422:     release(uname); uname= copy(ff->con.uname);
 423:     curline= ff->con.cur_line; curlino= ff->con.cur_lino;
 424:     ct= cntxt; cntxt= ff->con.cntxt;
 425:     release(act_context.uname);
 426:     sv_context(&act_context); cntxt= ct; /* for error messages */
 427: 
 428:     if (!targ) noloc= Yes;
 429:     else if (!Thread2(next)) error(MESS(4104, "expression used as target"));
 430: }
 431: 
 432: Visible Procedure call_refinement(name, def, test)
 433:  value name; parsetree def; bool test; {
 434:     call(test ? C_reftest : C_refexp,
 435:         *Branch(Refinement(def)->rp, REF_START));
 436: }
 437: 
 438: #define YOU_TEST MESS(4105, "You haven't told me how to TEST ")
 439: #define YOU_YIELD MESS(4106, "You haven't told me how to YIELD ")
 440: 
 441: Hidden Procedure udfpr(nd1, name, nd2, isfunc)
 442:  value nd1, name, nd2; bool isfunc; {
 443:     value *aa;
 444:     parsetree u; int k, nlocals; funprd *fpr;
 445:     int adicity= nd1 ? Dya : nd2 ? Mon : Zer;
 446:     if (!is_unit(name, adicity, &aa)
 447:         || !(isfunc ? Is_function(*aa) : Is_predicate(*aa))) {
 448:         error3(isfunc ? YOU_YIELD : YOU_TEST, name, 0);
 449:         return;
 450:     }
 451:     fpr= Funprd(*aa);
 452:     if (!(fpr->adic==Zer ? nd2==Vnil : (fpr->adic==Mon) == (nd1==Vnil)))
 453:         syserr(MESS(4107, "invoked unit has other adicity than invoker"));
 454:     if (fpr->pre != Use) syserr(MESS(4108, "udfpr with predefined unit"));
 455: 
 456:     u= fpr->unit;
 457:     if (fpr->unparsed) fix_nodes(&u, &fpr->code);
 458:     if (!still_ok) { rem_unit(u); return; }
 459:     fpr->unparsed= No;
 460:     nlocals= intval(*Branch(u, FPR_NLOCALS));
 461:     call(isfunc ? C_yield : C_test, fpr->code);
 462:     curnv->tab= mk_compound(nlocals);
 463:     for (k= 0; k < nlocals; ++k) *Field(curnv->tab, k)= Vnil;
 464:     release(uname); uname= get_pname(u);
 465:     if (nd1 != Vnil) push(copy(nd1));
 466:     if (nd2 != Vnil) push(copy(nd2));
 467: }
 468: 
 469: Visible Procedure formula(nd1, name, nd2, tor) value nd1, name, nd2, tor; {
 470:     if (tor == Vnil) udfpr(nd1, name, nd2, Yes);
 471:     else {
 472:         if (!Is_function(tor))
 473:             syserr(MESS(4109, "formula called with non-function"));
 474:         push(pre_fun(nd1, Funprd(tor)->pre, nd2));
 475:     }
 476: }
 477: 
 478: Visible Procedure proposition(nd1, name, nd2, pred) value nd1, name, nd2, pred; {
 479:     if (pred == Vnil) udfpr(nd1, name, nd2, No);
 480:     else {
 481:         if (!Is_predicate(pred))
 482:             syserr(MESS(4110, "proposition called with non-predicate"));
 483:         report= pre_prop(nd1, Funprd(pred)->pre, nd2);
 484:     }
 485: }
 486: 
 487: Visible Procedure v_mystery(name, number) value name, number; {
 488:     value *aa; fun f;
 489:     aa= envassoc(curnv->tab, Is_compound(curnv->tab) ? number : name);
 490:     if (aa != Pnil) push(copy(*aa));
 491:     else if (is_zerfun(name, &f)) {
 492:         if (Funprd(f)->pre == Use) f= Vnil;
 493:         formula(Vnil, name, Vnil, f);
 494:     }
 495:     else error3(0, name, MESS(4111, " has not yet received a value"));
 496: }
 497: 
 498: Hidden value mk_formal(pt) parsetree pt; {
 499:     value f= grab_for(); formal *ff= Formal(f);
 500:     sv_context(&ff->con); ff->fp= pt;
 501:     return f;
 502: }
 503: 
 504: Visible Procedure x_user_command(name, actuals, def)
 505:  value name; parsetree actuals; value def;
 506: {
 507:     how *h; parsetree u; value *aa;
 508:     value v, formals; int k, len;
 509:     if (def != Vnil) {
 510:         if (!Is_refinement(def)) syserr(MESS(4112, "bad def in x_user_command"));
 511:         call(C_refcmd, *Branch(Refinement(def)->rp, REF_START));
 512:         return;
 513:     }
 514:     if (!is_unit(name, How, &aa)) {
 515:         error3(MESS(4113, "You haven't told me HOW'TO "), name, 0);
 516:         return;
 517:     }
 518:     u= (h= How_to(*aa))->unit;
 519:     if (h->unparsed) fix_nodes(&u, &h->code);
 520:     if (!still_ok) { rem_unit(u); return; }
 521:     h->unparsed= No;
 522:     formals= *Branch(u, HOW_FORMALS);
 523:     len= intval(*Branch(u, HOW_NLOCALS)); k= 0;
 524:     v= mk_compound(len);
 525:     while (actuals != Vnil && formals != Vnil) { /* Save actuals */
 526:         if (*Branch(actuals, ACT_EXPR) != Vnil) {
 527:             if (k >= len) syserr(MESS(4114, "too many actuals"));
 528:             *Field(v, k++)= mk_formal(*Branch(actuals, ACT_START));
 529:         }
 530:         actuals= *Branch(actuals, ACT_NEXT);
 531:         formals= *Branch(formals, FML_NEXT);
 532:     }
 533:     for (; k < len; ++k) { *Field(v, k)= Vnil; }
 534: 
 535:     call(C_howto, h->code);
 536: 
 537:     curnv->tab= v;
 538:     release(uname); uname= permkey(name, How);
 539: }
 540: 
 541: Visible Procedure endsta() {
 542:     if (st_base) {
 543:         freemem((ptr) st_base);
 544:         st_base= Pnil;
 545:     }
 546: }
 547: 
 548: Hidden value save_curnv_chain() {
 549:     value pad;
 550:     value c, f;
 551:     formal *ff;
 552:     int cnt, k;
 553: 
 554:     /* Count how many */
 555:     c= curnv->tab;
 556:     for (cnt= 0; ; ) {
 557:         if (!Is_compound(c)) break;
 558:         ++cnt;
 559:         f= *Field(c, 0);
 560:         if (!Is_formal(f)) break;
 561:         ff= Formal(f);
 562:         c= ff->con.curnv->tab;
 563:     }
 564: 
 565:     pad= mk_compound(cnt);
 566: 
 567:     /* Do the copy */
 568:     c= curnv->tab;
 569:     for (k= 0; ; ) {
 570:         if (!Is_compound(c)) break;
 571:         *Field(pad, k)= copy(c);
 572:         if (++k >= cnt) break;
 573:         f= *Field(c, 0);
 574:         if (!Is_formal(f)) break;
 575:         ff= Formal(f);
 576:         c= ff->con.curnv->tab;
 577:     }
 578:     if (k != cnt)
 579:         syserr(MESS(4115, "save_curnv_chain: phase error"));
 580: 
 581:     return pad;
 582: }
 583: 
 584: Hidden rest_curnv_chain(pad) value pad; {
 585:     int k, cnt;
 586:     value f, *c= &curnv->tab;
 587:     formal *ff;
 588: 
 589:     if (pad == Vnil || !Is_compound(pad))
 590:         syserr(MESS(4116, "rest_curnv_chain: bad pad"));
 591:     cnt= Nfields(pad);
 592:     for (k= 0; ; ) {
 593:         if (!Is_compound(*c)) break;
 594:         release(*c);
 595:         *c= copy(*Field(pad, k));
 596:         if (++k >= cnt) break;
 597:         f= *Field(*c, 0);
 598:         if (!Is_formal(f)) break;
 599:         ff= Formal(f);
 600:         c= &ff->con.curnv->tab;
 601:     }
 602:     if (k != cnt)
 603:         syserr(MESS(4117, "rest_curnv_chain: phase error"));
 604:     release(pad);
 605: }

Defined functions

Defined variables

Defined macros