Return to b2cmd.c CVS log

Up to [CSRG BSD Unix] / 43BSD / contrib / B / src / bsmall

Annotation of 43BSD/contrib/B/src/bsmall/b2cmd.c, revision 1.1

1.1     ! root        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: }

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.