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