2.11BSD#431 - /usr/src/new/PORT/B/src/bsmall/b2cmd.c

   1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1984. */
   2: /* $Header: b2cmd.c,v 1.1 84/06/28 00:49:04 timo Exp $ */
   3: 
   4: /* B commands */
   5: #include "b.h"
   6: #include "b0con.h"
   7: #include "b1obj.h"
   8: #include "b2env.h"
   9: #include "b2scr.h"
  10: #include "b2err.h"
  11: #include "b2key.h"
  12: #include "b2syn.h"
  13: #include "b2sem.h"
  14: #include "b2typ.h"
  15: 
  16: #define Nex if (!xeq) {tx= ceol; return Yes;}
  17: 
  18: char rdbuf[RDBUFSIZE];
  19: txptr rdbufend= &rdbuf[RDBUFSIZE];
  20: 
  21: #define USE_QUIT "\r*** use QUIT or interrupt to abort READ command\n"
  22: 
  23: Hidden Procedure read_line(l, t, eg) loc l; btype t; bool eg; {
  24:     context c; txptr tx0= tx, rp; intlet k; value r; btype rt;
  25:     envtab svprmnvtab= Vnil; bool must_sv= eg, got;
  26:     sv_context(&c);
  27:     if (active_reads >= MAX_NMB_ACT_READS)
  28:         error("too many READs simultaneously active");
  29:     if (setjmp(reading[active_reads++]) != 0) /* long jump occurred */
  30:         set_context(&c);
  31:     if (cntxt != In_read) sv_context(&read_context);
  32:     if (must_sv) svprmnvtab= prmnvtab == Vnil ? Vnil : prmnv->tab;
  33:     /* save scratch-pad copy because of following setprmnv() */
  34:     if (eg) setprmnv(); must_sv= No;
  35:     cntxt= In_read;
  36:     got= No;
  37:     while (!got) {
  38:         tx= rp= rdbuf;
  39:         if (read_interactive) {
  40:             fprintf(stderr, eg ? eg_prompt : raw_prompt);
  41:         }
  42:         got= Yes;
  43:         while ((k= getchar()) != EOF && k != '\n') {
  44:             *rp++= k;
  45:             if (rp > rdbufend-1) syserr("read buffer overflow");
  46:         }
  47:         if (k == EOF) {
  48:             if (read_interactive) {
  49:                 fprintf(stderr, USE_QUIT);
  50:                 CLEAR_EOF;
  51:                 if (outeractive) at_nwl= Yes;
  52:                 got= No;
  53:             } else error("End of file encountered during READ command");
  54:         }
  55:     }
  56:     if (read_interactive && outeractive && k == '\n') at_nwl= Yes;
  57:     *rp= '\n';
  58:     Skipsp(tx);
  59:     if (atkw(QUIT)) int_signal(Yes);
  60:     if (eg) {
  61:         r= expr(rp); rt= valtype(r);
  62:         if (svprmnvtab != Vnil) {
  63:             prmnvtab= prmnv->tab;
  64:             prmnv->tab= svprmnvtab;
  65:         }
  66:         must_sv= Yes;
  67:         set_context(&c);
  68:         must_agree(t, rt,
  69:             "type of expression does not agree with that of EG sample");
  70:         release(rt);
  71:     } else {
  72:         *rp= '\0';
  73:         r= mk_text(rdbuf);
  74:         set_context(&c);
  75:     }
  76:     put(r, l);
  77:     active_reads--;
  78:     release(r);
  79:     tx= tx0;
  80: }
  81: 
  82: Hidden Procedure check(o) outcome o; {
  83:     if (o == Fail) checkerr();
  84: }
  85: 
  86: Hidden bool sim_com() {
  87:     txptr ftx, ttx;
  88:     switch (Char(tx)) {
  89: case 'C': if (atkw(CHECK)) {
  90:         env e0= curnv; outcome o;
  91:         Nex;
  92:         o= test(ceol);
  93:         if (xeq) {
  94:             check(o);
  95:             restore_env(e0);
  96:         }
  97:         return Yes;
  98:     } else if (atkw(CHOOSE)) {
  99:         loc l; value v;
 100:         reqkw(FROM_choose, &ftx, &ttx);
 101:         Nex;
 102:         l= targ(ftx);
 103:         tx= ttx; v= expr(ceol);
 104:         if (xeq) choose(l, v);
 105:         release(v); release(l);
 106:         return Yes;
 107:       }
 108:       return No;
 109: case 'D': if (atkw(DELETE)) {
 110:         loc l;
 111:         Nex;
 112:         l= targ(ceol);
 113:         if (xeq) l_delete(l);
 114:         release(l);
 115:         return Yes;
 116:     } else if (atkw(DRAW)) {
 117:         loc l;
 118:         Nex;
 119:         l= targ(ceol);
 120:         if (xeq) draw(l);
 121:         release(l);
 122:         return Yes;
 123:       }
 124:       return No;
 125: case 'E': if (atkw(ELSE)) {
 126:            pprerr("ELSE only allowed as alternative test after SELECT", "");
 127:       }
 128:       return No;
 129: case 'I': if (atkw(INSERT)) {
 130:         value v; loc l;
 131:         reqkw(IN_insert, &ftx, &ttx);
 132:         Nex;
 133:         v= expr(ftx);
 134:         tx= ttx; l= targ(ceol);
 135:         if (xeq) l_insert(v, l);
 136:         release(v); release(l);
 137:         return Yes;
 138:       }
 139:       return No;
 140: case 'P': if (atkw(PUT)) {
 141:         value v; loc l;
 142:         reqkw(IN_put, &ftx, &ttx);
 143:         Nex;
 144:         v= expr(ftx);
 145:         tx= ttx; l= targ(ceol);
 146:         if (xeq) put(v, l);
 147:         release(v); release(l);
 148:         return Yes;
 149:       }
 150:       return No;
 151: case 'R': if (atkw(READ)) {
 152:         value v; loc l; btype vt, lt; bool eg= Yes;
 153:         if (find(RAW, ceol, &ftx, &ttx)) {
 154:             eg= No;
 155:             vt= mk_text("");
 156:         } else reqkw(EG, &ftx, &ttx);
 157:         Nex;
 158:         l= targ(ftx); lt= loctype(l);
 159:         tx= ttx;
 160:         if (eg) {
 161:             v= expr(ceol);
 162:             vt= valtype(v); release(v);
 163:         }
 164:         must_agree(vt, lt,
 165:             eg ? "this sample could not lawfully be put in the target"
 166:                : "in READ x RAW, x must be a simple textual target");
 167:         release(lt);
 168:         if (xeq) read_line(l, vt, eg);
 169:         release(l); release(vt);
 170:         return Yes;
 171:     } else if (atkw(REMOVE)) {
 172:         value v; loc l;
 173:         reqkw(FROM_remove, &ftx, &ttx);
 174:         Nex;
 175:         v= expr(ftx);
 176:         tx= ttx; l= targ(ceol);
 177:         if (xeq) l_remove(v, l);
 178:         release(v); release(l);
 179:         return Yes;
 180:       }
 181:       return No;
 182: case 'S': if (atkw(SET_RANDOM)) {
 183:         value v;
 184:         Nex;
 185:         v= expr(ceol);
 186:         if (xeq) set_random(v);
 187:         release(v);
 188:         return Yes;
 189:       } else if (atkw(SHARE)) pprerr(
 190:       "SHARE only allowed following HOW'TO-, YIELD- or TEST-heading", "");
 191:       return No;
 192: case 'W': if (atkw(WRITE)) {
 193:         txptr tx0; value v; intlet nwlc;
 194:         Nex;
 195:         Skipsp(tx);
 196:         while (Char(tx) == '/' && (Char(tx+1) == '/')) {
 197:             if (xeq) newline();
 198:             tx++;
 199:         }
 200:         tx0= tx;
 201:     loop:   if (Char(tx++) != '/') {tx= tx0; goto postnl;}
 202:         if (Char(tx++) == '*') goto loop;
 203:         if (xeq) newline();
 204:         tx= tx0+1;
 205:     postnl: ftx= ceol;
 206:         while (Space(Char(ftx-1))) ftx--;
 207:         nwlc= 0;
 208:         while (ftx > tx && Char(ftx-1) == '/') {
 209:             nwlc++;
 210:             ftx--;
 211:         }
 212:         if (ftx > tx) {
 213:             v= expr(ftx);
 214:             if (xeq) writ(v);
 215:             release(v);
 216:         }
 217:         while (nwlc-- > 0) {
 218:             if (xeq) newline();
 219:         }
 220:         return Yes;
 221:       }
 222:       return No;
 223: default:  return No;
 224:     }
 225: }
 226: 
 227: #define Reqcol {req(":", ceol, &utx, &vtx); \
 228:         if (!xeq) {tx= vtx; comm_suite(); return Yes;}}
 229: #define Resetx(tx0) {tx= (tx0); lino= lino0; cur_ilev= cil;}
 230: 
 231: Hidden bool con_com() {
 232:     intlet lino0= lino, cil= cur_ilev;
 233:     txptr ftx, ttx, utx, vtx;
 234:     switch (Char(tx)) {
 235: case 'I': if (atkw(IF)) {
 236:         env e0= curnv; bool xeq0= xeq;
 237:         outcome o;
 238:         Reqcol;
 239:         o= test(utx);
 240:         xeq= o == Succ;
 241:         tx= vtx; comm_suite();
 242:         xeq= xeq0; restore_env(e0);
 243:         return Yes;
 244:       }
 245:       return No;
 246: case 'S': if (atkw(SELECT)) {
 247:         need(":");
 248:         upto(ceol, "SELECT:");
 249:         alt_suite();
 250:         return Yes;
 251:       }
 252:       return No;
 253: case 'W': if (atkw(WHILE)) {
 254:         env e0= curnv; bool xeq0= xeq; txptr tx0= tx;
 255:         outcome o;
 256:         Reqcol;
 257:     loop:   o= test(utx);
 258:         if (xeq0) xeq= o == Succ;
 259:         tx= vtx; comm_suite();
 260:         xeq= xeq0; restore_env(e0);
 261:         if (xeq && o == Succ && !terminated) {
 262:             Resetx(tx0); goto loop;
 263:         }
 264:         return Yes;
 265:       }
 266:       return No;
 267: case 'F': if (atkw(FOR)) {
 268:         env e0= curnv; bool xeq0= xeq; loc l; value v, w;
 269:         Reqcol;
 270:         if (find(PARSING, utx, &ftx, &ttx)) {
 271:             tx= ttx; pprerr("PARSING not allowed in FOR ...", "");
 272:         }
 273:         reqkw(IN_for, &ftx, &ttx);
 274:         if (ttx > ceol) {
 275:             tx= ceol;
 276:             parerr("IN after colon", "");
 277:         }
 278:         l= targ(ftx);
 279:         if (!Is_simploc(l) && !Is_compound(l)) /*to bloc.c?*/
 280:             pprerr("inappropriate identifier after FOR", "");
 281:         bind(l);
 282:         tx= ttx; v= expr(utx);
 283:         {value k, k1, len= xeq ? size(v) : copy(one);
 284:             if (compare(len, zero) == 0) {
 285:                 xeq= No; release(len); len= copy(one);
 286:             }
 287:             k= copy(one);
 288:             while (!terminated && compare(k, len) <= 0) {
 289:                 Resetx(utx);
 290:                 if (xeq) {
 291:                     w= th_of(k, v);
 292:                     put(w, l);
 293:                     release(w);
 294:                 }
 295:                 k= sum(k1= k, one); release(k1);
 296:                 tx= vtx; comm_suite();
 297:             }
 298:             release(k); release(len);
 299:         }
 300:         xeq= xeq0; restore_env(e0);
 301:         release(v); release(l);
 302:         return Yes;
 303:       }
 304:       return No;
 305: default:  return No;
 306:     }
 307: }
 308: 
 309: Hidden bool term_com() {
 310:     switch (Char(tx)) {
 311: case 'F': if (atkw(FAIL)) {
 312:         upto(ceol, "FAIL");
 313:         if (xeq) {
 314:             chckvtc(Rep);
 315:             resout= Fail;
 316:             terminated= Yes;
 317:         } else tx= ceol;
 318:         return Yes;
 319:       }
 320:       return No;
 321: case 'Q': if (atkw(QUIT)) {
 322:         upto(ceol, "QUIT");
 323:         if (xeq) {
 324:             if (cur_ilev == 0) bye(0);
 325:             chckvtc(Voi);
 326:             terminated= Yes;
 327:         }
 328:         return Yes;
 329:       }
 330:       return No;
 331: case 'R': if (atkw(RETURN)) {
 332:         if (xeq) {
 333:             chckvtc(Ret);
 334:             resval= expr(ceol);
 335:             terminated= Yes;
 336:         } else tx= ceol;
 337:         return Yes;
 338:       } else if (atkw(REPORT)) {
 339:         if (xeq) {
 340:             chckvtc(Rep);
 341:             resout= test(ceol);
 342:             terminated= Yes;
 343:         } else tx= ceol;
 344:         return Yes;
 345:       }
 346:       return No;
 347: case 'S': if (atkw(SUCCEED)) {
 348:         upto(ceol, "SUCCEED");
 349:         if (xeq) {
 350:             chckvtc(Rep);
 351:             resout= Succ;
 352:             terminated= Yes;
 353:         } else tx= ceol;
 354:         return Yes;
 355:       }
 356:       return No;
 357: default:  return No;
 358:     }
 359: }
 360: 
 361: Hidden bool secret_com() {
 362:     switch (Char(tx)) {
 363: case 'D': if (atkw("DEBUG")) {
 364:         Nex;
 365:         bugs= Yes;
 366:         return Yes;
 367:       }
 368:       return No;
 369: case 'G': if (atkw("GR")) {
 370:         Nex;
 371:         prgr();
 372:         return Yes;
 373:       }
 374:       return No;
 375: case 'N': if (atkw("NO'DEBUG")) {
 376:         Nex;
 377:         bugs= No;
 378:         return Yes;
 379:       } else if (atkw("NO'TRACE")) {
 380:         Nex;
 381:         tracing= No;
 382:         return Yes;
 383:       }
 384:       return No;
 385: case 'T': if (atkw("TRACE")) {
 386:         Nex;
 387:         tracing= Yes;
 388:         return Yes;
 389:       }
 390:       return No;
 391: default:  return No;
 392:     }
 393: }
 394: 
 395: Hidden Procedure chckvtc(re) literal re; {
 396:     if (cntxt != In_unit || resexp == Voi) {
 397:         if (re == Ret)
 398:             pprerr("RETURN e only allowed inside YIELD-unit or\n",
 399:                    "    expression-refinement");
 400:         else if (re == Rep)
 401:             pprerr("REPORT t only allowed inside TEST-unit",
 402:                    " or test-refinement");
 403:     }
 404:     if (re != resexp) {
 405:         if (resexp == Ret)
 406:             pprerr(
 407:     "RETURN e must terminate YIELD-unit or expression-refinement", "");
 408:         if (resexp == Rep)
 409:             pprerr(
 410:     "REPORT t must terminate TEST-unit or test-refinement", "");
 411:     }
 412: }
 413: 
 414: Hidden bool expr_s() {
 415:     char c;
 416:     Skipsp(tx);
 417:     if (tx >= ceol) return No;
 418:     c= Char(tx);
 419:     return Letter(c) || Montormark(c) || Dig(c) || c == '.' || c == 'E' ||
 420:         c == '(' || c == '{' || c == '\'' || c == '"';
 421: }
 422: 
 423: intlet comcnt= 0;
 424: 
 425: Visible Procedure command() {
 426:     if (++comcnt > 10000) {
 427:         putprmnv();
 428:         comcnt= 1;
 429:     }
 430:     if (Char(tx) == Eotc) getline();
 431: debug("analyzing command");
 432:     if (tracing) trace();
 433:     if (Ceol(tx));
 434:     else if (sim_com() || con_com() ||
 435:         unit() || term_com() || ref_com() || udc() ||
 436:         secret_com()) skipping= No;
 437:     else if (Char(tx) == ':' || Char(tx) == '=' || Char(tx) == '!') {
 438:         if (!interactive) parerr("special commands only interactively", "");
 439:         if (!(cntxt == In_command && cur_ilev == 0)) parerr(
 440:             "special commands only on outermost level (no indentation)", "");
 441:         special();
 442:     } else if (cntxt == In_command && cur_ilev == 0 && expr_s()) {
 443:         value w= expr(ceol);
 444:         wri(w, Yes, No, No);
 445:         release(w);
 446:     } else {txptr tx0= tx; value uc= keyword(ceol);
 447:         tx= tx0; parerr("you have not told me HOW'TO ", strval(uc));
 448:     }
 449:     To_eol(tx);
 450: debug("command treated");
 451: }
 452: 
 453: Visible Procedure comm_suite() {
 454:     intlet cil= cur_ilev;
 455:     if (ateol()) {
 456:         txptr tx0= tx; bool xeq0= xeq;
 457:         if (Char(tx+1) == Eotc) xeq= No;
 458:         while (ilev(No) > cil) {
 459:             findceol();
 460:             command();
 461:             if (terminated) return;
 462:             if (cur_ilev <= cil) goto brk1;
 463:         }
 464:         veli();
 465:     brk1:   if (xeq0 && !xeq) {
 466:             tx= tx0; xeq= Yes;
 467:             cur_ilev= cil;
 468:             while (ilev(No) > cil) {
 469:                 findceol();
 470:                 command();
 471:                 if (terminated) return;
 472:                 if (cur_ilev <= cil) goto brk2;
 473:             }
 474:             veli();
 475:         brk2:   ;
 476:         }
 477:     } else command();
 478: }
 479: 
 480: Hidden Procedure alt_suite() {
 481:     intlet cil= cur_ilev; env e0= curnv; txptr utx, vtx;
 482:     bool xeq0= xeq, succ= !xeq, Else= No;
 483:     if (!ateol()) syserr("alt_suite not at end of line");
 484:     while (ilev(No) > cil) {
 485:         findceol();
 486:         if (Else)
 487:         parerr("after ELSE: ... no more alternatives are allowed", "");
 488:         req(":", ceol, &utx, &vtx);
 489:         if (atkw(ELSE)) {
 490:             succ= Else= Yes;
 491:             upto(utx, "ELSE");
 492:             tx= vtx; comm_suite();
 493:             if (terminated) return;
 494:         } else {
 495:             if (xeq) succ= test(utx) == Succ;
 496:             xeq= xeq && succ;
 497:             tx= vtx; comm_suite();
 498:             if (terminated) return;
 499:             xeq= !succ;
 500:         }
 501:         if (cur_ilev <= cil) goto brk;
 502:     }
 503:     veli();
 504: brk:    if (!succ) error("none of the alternative tests of SELECT succeeds");
 505:     xeq= xeq0; if (xeq) restore_env(e0);
 506: }

Defined functions

Defined variables

Defined macros