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

   1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
   2: 
   3: /*
   4:   $Header: b2uni.c,v 1.4 85/08/22 16:57:24 timo Exp $
   5: */
   6: 
   7: #include "b.h"
   8: #include "b0fea.h"
   9: #include "b1obj.h"
  10: #include "b2par.h"
  11: #include "b2key.h"
  12: #include "b2syn.h"
  13: #include "b2nod.h"
  14: #include "b3env.h"
  15: #include "b3err.h"
  16: #include "b3sou.h" /* for permkey() */
  17: 
  18: /* ******************************************************************** */
  19: /*		unit							*/
  20: /* ******************************************************************** */
  21: 
  22: Visible bool unit_keyword() {
  23:     bool b; txptr tx0= tx;
  24:     b= how_to_keyword() || yield_keyword() || test_keyword();
  25:     tx= tx0;
  26:     return b;
  27: }
  28: 
  29: Hidden value formlist, sharelist;
  30: Hidden envtab reftab;
  31: Visible literal idf_cntxt;
  32: 
  33: Forward bool is_howto_unit(), is_yield_unit(), is_test_unit();
  34: Forward parsetree unicmd_suite(), ref_suite();
  35: 
  36: Visible parsetree unit(heading) bool heading; {
  37:     parsetree v= NilTree;
  38:     if (!heading) {
  39:         lino= 1;
  40:         cntxt= In_unit;
  41:         release(uname); uname= Vnil;
  42:     }
  43:     if (!is_howto_unit(&v, heading) &&
  44:         !is_yield_unit(&v, heading) &&
  45:         !is_test_unit(&v, heading)
  46:        )
  47:         parerr(MESS(2800, "no unit keyword where expected"));
  48: #ifdef TYPE_CHECK
  49:     if (!heading) type_check(v);
  50: #endif
  51:     return v;
  52: }
  53: 
  54: /* ******************************************************************** */
  55: /*		howto_unit						*/
  56: /* ******************************************************************** */
  57: 
  58: Forward value hu_formals();
  59: 
  60: Hidden bool is_howto_unit(v, heading) parsetree *v; bool heading; {
  61:     if (how_to_keyword()) {
  62:         value kw, w, f;
  63:         txptr ftx, ttx;
  64:         if (cur_ilev != 0) parerr(MESS(2801, "unit starts with indentation"));
  65:         formlist= mk_elt();
  66:         skipsp(&tx);
  67:         kw= keyword();
  68:         release(uname); uname= permkey(kw, How);
  69:         if (in(kw, kwlist)) pprerr2(kw, MESS(2802, " is a reserved keyword"));
  70:         req(":", ceol, &ftx, &ttx);
  71:         idf_cntxt= In_formal;
  72:         f= hu_formals(ftx, kw); tx= ttx;
  73:         if (!is_comment(&w)) w= Vnil;
  74:         *v= node8(HOW_TO, copy(kw), f, w, NilTree, NilTree, Vnil, Vnil);
  75:         if (!heading) {
  76:             sharelist= mk_elt();
  77:             *Branch(*v, HOW_SUITE)= unicmd_suite();
  78:             reftab= mk_elt();
  79:             *Branch(*v, HOW_REFINEMENT)= ref_suite();
  80:             *Branch(*v, HOW_R_NAMES)= reftab;
  81:             release(sharelist);
  82:         }
  83:         release(formlist);
  84:         return Yes;
  85:     }
  86:     return No;
  87: }
  88: 
  89: Hidden value hu_formals(q, kw) txptr q; value kw; {
  90:     value t, v, w;
  91:     skipsp(&tx);
  92:     if (Text(q) && is_tag(&t)) treat_idf(t);
  93:     else t= Vnil;
  94:     skipsp(&tx);
  95:     v= Text(q) ? hu_formals(q, keyword()) : Vnil;
  96:     w= node4(FORMAL, kw, t, v);
  97:     return w;
  98: }
  99: 
 100: /* ******************************************************************** */
 101: /*		yield_unit						*/
 102: /* ******************************************************************** */
 103: 
 104: Forward parsetree ytu_formals();
 105: 
 106: Hidden bool is_yield_unit(v, heading) parsetree *v; bool heading; {
 107:     if (yield_keyword()) {
 108:         parsetree f; value name, w, adicity;
 109:         txptr ftx, ttx;
 110:         if (cur_ilev != 0) parerr(MESS(2803, "unit starts with indentation"));
 111:         formlist= mk_elt();
 112:         skipsp(&tx);
 113:         req(":", ceol, &ftx, &ttx);
 114:         f= ytu_formals(ftx, 'y', &name, &adicity); tx= ttx;
 115:         if (!is_comment(&w)) w= Vnil;
 116:         *v= node9(YIELD, copy(name), adicity, f, w, NilTree,
 117:               NilTree, Vnil, Vnil);
 118:         if (!heading) {
 119:             sharelist= mk_elt();
 120:             *Branch(*v, FPR_SUITE)= unicmd_suite();
 121:             reftab= mk_elt();
 122:             *Branch(*v, FPR_REFINEMENT)= ref_suite();
 123:             *Branch(*v, FPR_R_NAMES)= reftab;
 124:             release(sharelist);
 125:         }
 126:         release(formlist);
 127:         return Yes;
 128:     }
 129:     return No;
 130: }
 131: 
 132: /* ******************************************************************** */
 133: /*		test_unit						*/
 134: /* ******************************************************************** */
 135: 
 136: Hidden bool is_test_unit(v, heading) parsetree *v; bool heading; {
 137:     if (test_keyword()) {
 138:         parsetree f; value name, w, adicity;
 139:         txptr ftx, ttx;
 140:         if (cur_ilev != 0) parerr(MESS(2804, "unit starts with indentation"));
 141:         formlist= mk_elt();
 142:         skipsp(&tx);
 143:         req(":", ceol, &ftx, &ttx);
 144:         f= ytu_formals(ftx, 't', &name, &adicity); tx= ttx;
 145:         if (!is_comment(&w)) w= Vnil;
 146:         *v= node9(TEST, copy(name), adicity, f, w, NilTree,
 147:               NilTree, Vnil, Vnil);
 148:         if (!heading) {
 149:             sharelist= mk_elt();
 150:             *Branch(*v, FPR_SUITE)= unicmd_suite();
 151:             reftab= mk_elt();
 152:             *Branch(*v, FPR_REFINEMENT)= ref_suite();
 153:             *Branch(*v, FPR_R_NAMES)= reftab;
 154:             release(sharelist);
 155:         }
 156:         release(formlist);
 157:         return Yes;
 158:     }
 159:     return No;
 160: }
 161: 
 162: /* ******************************************************************** */
 163: 
 164: #define FML_IN_FML MESS(2805, " is already a formal parameter or operand")
 165: #define SH_IN_FML  MESS(2806, " is already a formal parameter")
 166: #define SH_IN_SH   MESS(2807, " is already a shared identifier")
 167: #define REF_IN_FML MESS(2808, " is already a formal parameter")
 168: #define REF_IN_SH  MESS(2809, " is already a shared identifier")
 169: #define REF_IN_REF MESS(2810, " is already a refinement name")
 170: 
 171: Hidden Procedure treat_idf(t) value t; {
 172:     switch (idf_cntxt) {
 173:         case In_formal: if (in(t, formlist)) pprerr2(t, FML_IN_FML);
 174:                 insert(t, &formlist);
 175:                 break;
 176:         case In_share:  if (in(t, formlist)) pprerr2(t, SH_IN_FML);
 177:                 if (in(t, sharelist)) pprerr2(t, SH_IN_SH);
 178:                 insert(t, &sharelist);
 179:                 break;
 180:         case In_ref:    if (in(t, formlist)) pprerr2(t, REF_IN_FML);
 181:                 if (in(t, sharelist)) pprerr2(t, REF_IN_SH);
 182:                 break;
 183:         case In_ranger: break;
 184:         default:    break;
 185:     }
 186: }
 187: 
 188: Forward parsetree fml_operand();
 189: 
 190: Hidden parsetree ytu_formals(q, yt, name, adic)
 191:     txptr q; char yt; value *name, *adic; {
 192: 
 193:     parsetree v1, v2, v3;
 194:     *name= Vnil;
 195:     idf_cntxt= In_formal;
 196:     v1= fml_operand(q);
 197:     skipsp(&tx);
 198:     if (!Text(q)) { /* zeroadic */
 199:         *adic= zero;
 200:         if (nodetype(v1) == TAG) {
 201:             *name= *Branch(v1, TAG_NAME);
 202:             release(uname); uname= permkey(*name, Zer);
 203:         } else
 204:             pprerr(MESS(2811, "user defined functions must be tags"));
 205:         return v1;
 206:     }
 207: 
 208:     v2= fml_operand(q);
 209:     skipsp(&tx);
 210:     if (!Text(q)) { /* monadic */
 211:         *adic= one;
 212:         if (nodetype(v1) == TAG) {
 213:             *name= *Branch(v1, TAG_NAME);
 214:             release(uname); uname= permkey(*name, Mon);
 215:         } else
 216:             pprerr(MESS(2812, "no monadic function name"));
 217:         if (nodetype(v2) == TAG) treat_idf(*Branch(v2, TAG_NAME));
 218:         return node4(yt == 'y' ? MONF : MONPRD, *name, v2, Vnil);
 219:     }
 220: 
 221:     v3= fml_operand(q);
 222:     /* dyadic */
 223:     *adic= mk_integer(2);
 224:     if (nodetype(v2) == TAG) {
 225:         *name= *Branch(v2, TAG_NAME);
 226:         release(uname); uname= permkey(*name, Dya);
 227:     } else
 228:         pprerr(MESS(2813, "no dyadic function name"));
 229:     upto(q, "dyadic formal formula");
 230:     if (nodetype(v1) == TAG) treat_idf(*Branch(v1, TAG_NAME));
 231:     if (nodetype(v3) == TAG) treat_idf(*Branch(v3, TAG_NAME));
 232:     return node5(yt == 'y' ? DYAF : DYAPRD, v1, *name, v3, Vnil);
 233: }
 234: 
 235: Hidden parsetree fml_operand(q) txptr q; {
 236:     value t;
 237:     skipsp(&tx);
 238:     if (nothing(q, "formal operand")) return NilTree;
 239:     else if (is_tag(&t)) return node2(TAG, t);
 240:     else if (open_sign()) return compound(q, idf);
 241:     else {
 242:         parerr(MESS(2814, "no formal operand where expected"));
 243:         tx= q;
 244:         return NilTree;
 245:     }
 246: }
 247: 
 248: /* ******************************************************************** */
 249: /*		unit_command_suite					*/
 250: /* ******************************************************************** */
 251: 
 252: Forward parsetree ucmd_seq();
 253: 
 254: Forward bool share();
 255: 
 256: Hidden parsetree unicmd_suite() {
 257:     if (ateol())
 258:         return ucmd_seq(0, Yes);
 259:     else {
 260:         parsetree v; value c; intlet l= lino;
 261:         suite_command(&v, &c);
 262:         return node5(SUITE, mk_integer(l), v, c, NilTree);
 263:     }
 264: }
 265: 
 266: Hidden parsetree ucmd_seq(cil, first) intlet cil; bool first; {
 267:     value c; intlet level, l;
 268:     level= ilev(); l= lino;
 269:     if (is_comment(&c))
 270:         return node5(SUITE, mk_integer(l), NilTree, c,
 271:                 ucmd_seq(cil, first));
 272:     if ((level == cil && !first) || (level > cil && first)) {
 273:         parsetree v;
 274:         findceol();
 275:         if (share(ceol, &v, &c))
 276:             return node5(SUITE, mk_integer(l), v, c,
 277:                     ucmd_seq(level, No));
 278:         veli();
 279:         return cmd_suite(cil, first);
 280:     }
 281:     veli();
 282:     return NilTree;
 283: }
 284: 
 285: Hidden bool share(q, v, c) txptr q; parsetree *v; value *c; {
 286:     if (share_keyword()) {
 287:         idf_cntxt= In_share;
 288:         *v= node2(SHARE, idf(q));
 289:         *c= tail_line();
 290:         return Yes;
 291:     }
 292:     return No;
 293: }
 294: 
 295: 
 296: /* ******************************************************************** */
 297: /*		refinement_suite					*/
 298: /* ******************************************************************** */
 299: 
 300: Hidden parsetree ref_suite() {
 301:     value name; bool t;
 302:     if (ilev() > 0) {
 303:         parerr(MESS(2815, "indentation where not allowed"));
 304:         return NilTree;
 305:     }
 306:     if ((t= is_tag(&name)) || is_keyword(&name)) {
 307:         parsetree v, s; value w, *aa, r;
 308:         skipsp(&tx);
 309:         if (Char(tx) != ':') {
 310:             release(name);
 311:             tx= fcol();
 312:             veli(); return NilTree;
 313:         }
 314:         /* lino= 1; cntxt= In_ref; */
 315:         tx++;
 316:         if (t) {
 317:             idf_cntxt= In_ref;
 318:             treat_idf(name);
 319:         }
 320:         if (in_env(reftab, name, &aa)) pprerr2(name, REF_IN_REF);
 321:         findceol();
 322:         if (!is_comment(&w)) w= Vnil;
 323:         s= cmd_suite(0, Yes);
 324:         v= node6(REFINEMENT, name, w, s, Vnil, Vnil);
 325:         e_replace(r= mk_ref(v), &reftab, name);
 326:         release(r);
 327:         *Branch(v, REF_NEXT)= ref_suite();
 328:         return v;
 329:     }
 330:     veli();
 331:     return NilTree;
 332: }
 333: 
 334: /* ******************************************************************** */
 335: /*		collateral, compound					*/
 336: /* ******************************************************************** */
 337: 
 338: Hidden parsetree n_collateral(q, n, base)
 339:     txptr q; intlet n; parsetree (*base)(); {
 340: 
 341:     parsetree v, w; txptr ftx, ttx;
 342:     if (find(",", q, &ftx, &ttx)) {
 343:         w= (*base)(ftx); tx= ttx;
 344:         v= n_collateral(q, n+1, base);
 345:     } else {
 346:         w= (*base)(q);
 347:         if (n == 1) return w;
 348:         v= mk_compound(n);
 349:     }
 350:     *Field(v, n-1)= w;
 351:     return n > 1 ? v : node2(COLLATERAL, v);
 352: }
 353: 
 354: Visible parsetree collateral(q, base) txptr q; parsetree (*base)(); {
 355:     return n_collateral(q, 1, base);
 356: }
 357: 
 358: Visible parsetree compound(q, base) txptr q; parsetree (*base)(); {
 359:     parsetree v; txptr ftx, ttx;
 360:     req(")", q, &ftx, &ttx);
 361:     v= (*base)(ftx); tx= ttx;
 362:     return node2(COMPOUND, v);
 363: }
 364: 
 365: /* ******************************************************************** */
 366: /*		idf, singidf						*/
 367: /* ******************************************************************** */
 368: 
 369: Hidden parsetree singidf(q) txptr q; {
 370:     parsetree v;
 371:     skipsp(&tx);
 372:     if (nothing(q, "identifier"))
 373:         v= NilTree;
 374:     else if (open_sign())
 375:         v= compound(q, idf);
 376:     else if (is_tag(&v)) {
 377:         treat_idf(v);
 378:         v= node2(TAG, v);
 379:     } else {
 380:         parerr(MESS(2816, "no identifier where expected"));
 381:         v= NilTree;
 382:     }
 383:     upto(q, "identifier");
 384:     return v;
 385: }
 386: 
 387: Visible parsetree idf(q) txptr q; {
 388:     return collateral(q, singidf);
 389: }

Defined functions

Defined variables

Defined macros