![[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.