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

##### Functions

    create_prmnv      X
    def_unit          X
    ed_target         X
    ed_unit           X
    editar            X
    ediuni            X
    ens_filed         X
    ens_tfiled        X
    err_line          X
    free_unit         X
    getprmnv          X
    getval            X
    initsou           X
    is_loaded         X
    is_tloaded        X
    is_unit           X
    lst_ttgs          X
    new_tname         X
    putprmnv          X
    putval            X
    shellcmd          X
    special           X
    still_there       X
    uheading          X
    unit              X
    unit_defn         X
    unit_info         X
    wri_target        X

##### Variables

    last_tname        X
    value             X

##### Macros

    CANT_READ         X
    CANT_WRITE        X
    DISCARD           X
    FnSwitch          X
    MONADIC           X
    On_file           X

       1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1984. */
       2: /* $Header: b2sou.c,v 1.1 84/06/28 00:49:20 timo Exp $ */
       3:
       4: /* Sources: maintaining units and values on external files */
       5: #include "b.h"
       6: #include "b0con.h"
       7: #include "b1mem.h" /* shouldn't really */
       8: #include "b1obj.h"
       9: #include "b2env.h"
      10: #include "b2scr.h"
      11: #include "b2err.h"
      12: #include "b2key.h"
      13: #include "b2syn.h"
      14: #include "b2sem.h"
      15: #include "b2fil.h"
      16: #include "b2sou.h"
      17:
      18: /************************** UNITS ************************************/
      19:
      20: value defunits, aster, global;
      21:
      22: Hidden value* unit_defn(fn) value fn; {
      23:     return envassoc(defunits, fn);
      24: }
      25:
      26: Visible Procedure def_unit(u, un, ut) value u, un; literal ut; {
      27:     value fn= f_uname(un, ut);
      28:     e_replace(u, &defunits, fn);
      29:     release(fn);
      30: }
      31:
      32: Visible value unit_info(un, ut) value un; literal ut; {
      33:     value fn= f_uname(un, ut);
      34:     value *aa= unit_defn(fn);
      35:     if (aa == Pnil) syserr("undefined function");
      36:     release(fn);
      37:     return *aa;
      38: }
      39:
      40: Hidden bool is_loaded(un, ut, aa) value un, **aa; literal ut; {
      41:     value fn= f_uname(un, ut); txptr tx0, txstart0;
      42:     *aa= unit_defn(fn);
      43:     if (*aa != Pnil) { release(fn); return Yes; } /*already loaded*/
      44:     release(iname);
      45:     iname= fn;
      46:     ifile= fopen(strval(iname), "r");
      47:     if (ifile == NULL) {
      48:         vs_ifile();
      49:         return No;
      50:     }
      51:     tx0= tx; txstart0= txstart;
      52:     open_stream();
      53:     Eof= Eof0= No;
      54:     ilev(Yes); findceol();
      55:     get_unit(Yes);
      56:     *aa= unit_defn(iname);
      57:     if ((*aa) == Pnil) {
      58:         uname= un; /*utype= ???*/
      59:         parerr("filename and unit name incompatible","");
      60:     }
      61:     close_stream(tx0, txstart0);
      62:     fclose(ifile);
      63:     vs_ifile();
      64:     Eof= Eof0= No;
      65:     return Yes;
      66: }
      67:
      68: Visible bool is_unit(un, ut, aa) value un, **aa; literal ut; {
      69:     context c; bool is;
      70:     sv_context(&c);
      71:     cntxt= In_unit;
      72:     is= is_loaded(un, ut, aa);
      73:     set_context(&c);
      74:     return is;
      75: }
      76:
      77: #define DISCARD "the unit name is already in use; should the old unit be discarded?"
      78: #define CANT_WRITE "cannot open file for editing; you need write permission in directory"
      79: #define CANT_READ "unable to find file"
      80:
      81: Visible bool unit() {
      82:     txptr tx0= tx; value name, fname; literal type; FILE *ofile;
      83:     if (atkw(HOW_TO) || atkw(YIELD) || atkw(TEST)) {
      84:         tx= tx0;
      85:         uheading(aster, &name, &type);
      86:         fname= f_uname(name, type);
      87:         if (unit_defn(fname) != Pnil) {
      88:             if (is_intended(DISCARD)) free_unit(fname);
      89:             else { tx= ceol; release(fname); release(name);
      90:                 return Yes;
      91:             }
      92:         }
      93:         if (interactive) {
      94:             ofile= fopen(strval(fname), "w");
      95:             if (ofile == NULL) error(CANT_WRITE);
      96:             while (Char(tx) != Eotc) putc(Char(tx++), ofile);
      97:             tx--;
      98:             fclose(ofile);
      99:             ed_unit(name, type, fname);
     100:         } else get_unit(No);
     101:         release(name); release(fname);
     102:         return Yes;
     103:     } else return No;
     104: }
     105:
     106: #define On_file Vnil
     107:
     108: value last_tname= Vnil, last_tfname= Vnil; /*target*/
     109:
     110: Visible Procedure special() {
     111:     switch(Char(tx++)) {
     112:         case ':':   ediuni(); break;
     113:         case '=':   editar(); break;
     114:         case '!':   shellcmd(); break;
     115:         default:    syserr("edit");
     116:     }
     117: }
     118:
     119:
     120: #define FnSwitch(X) {release(fname); type= X; fname= f_uname(name, X);}
     121:
     122: #define MONADIC \
     123:    "the unit name is in use both for a monadic and a dyadic version;\n\
     124: *** do you want to edit the monadic version?"
     125:
     126: Hidden Procedure ediuni() {
     127:     value name, fname; literal type;
     128:     Skipsp(tx);
     129:     if (Char(tx) == ':') {
     130:         lst_uhds();
     131:         To_eol(tx);
     132:         return;
     133:     }
     134:     if (Ceol(tx)) {
     135:         if (erruname == Vnil)
     136:             parerr("no current unit name known", "");
     137:         name= copy(erruname);
     138:         type= errutype;
     139:         fname= f_uname(name, type);
     140:     } else if (Cap(Char(tx))) {
     141:         name= keyword(ceol);
     142:         type= FHW;
     143:         fname= f_uname(name, FHW);
     144:     } else if (Letter(Char(tx))) {
     145:         name= tag(); type= FZR;
     146:         fname= f_uname(name, FZR);
     147:         if (!f_exists(fname)) {
     148:             bool is_mon, is_dya;
     149:             FnSwitch(FMN);
     150:             is_mon= f_exists(fname);
     151:             FnSwitch(FDY);
     152:             is_dya= f_exists(fname);
     153:             if (is_mon && (!is_dya || is_intended(MONADIC)))
     154:                 FnSwitch(FMN);
     155:         }
     156:     } else parerr("I find nothing editible here", "");
     157:     To_eol(tx);
     158:     if (!f_exists(fname)) pprerr("no such unit in this workspace","");
     159:     ens_filed(fname);
     160:     ed_unit(name, type, fname); release(name); release(fname);
     161: }
     162:
     163: Forward bool still_there();
     164: Forward intlet err_line();
     165:
     166: /* Edit a unit.
     167:    It is possible that the user messes things up with the w command:
     168:    this is not checked. However it is allowed to rename the unit,
     169:    or delete it completely. If the file is empty, the unit is disposed of.
     170:    Otherwise, uheading is used to work out the name and adicity:
     171:    if these have changed, the new unit is written out to a new file,
     172:    and the original is written back. Thus the original is not lost.
     173:    Inability to find the file at all leads to the main_loop,
     174:    so that nothing is changed. */
     175:
     176: Hidden Procedure ed_unit(name, type, fname) value name, fname; literal type; {
     177:     intlet el= err_line(name); value nname, nfname, sname; literal ntype;
     178:     sname= f_save(fname); /*in case the unit gets renamed*/
     179:     f_edit(fname, el);
     180:     if (still_there(fname)) {
     181:         ilev(Yes); findceol();
     182:         uheading(name, &nname, &ntype);
     183:         nfname= f_uname(nname, ntype);
     184:         if (compare(fname, nfname) != 0) { /* unit heading was changed */
     185:             f_rename(fname, nfname); f_rename(sname, fname);
     186:             release(erruname); erruname= copy(nname);
     187:             errutype= ntype;
     188:         } else {
     189:             release(erruname); erruname= copy(name);
     190:             errutype= type;
     191:             f_delete(sname);
     192:         }
     193:         release(nname); release(nfname);
     194:         get_unit(Yes); /* file is still open */
     195:     } else {
     196:         free_unit(fname);
     197:         f_delete(sname);
     198:         release(erruname); erruname= Vnil; errlino= 0;
     199:     }
     200:     release(sname);
     201:     inistreams();
     202: }
     203:
     204: Hidden Procedure uheading(oname, nname, ntype) value oname, *nname; literal *ntype; {
     205:     context ic; bool hu= No;
     206:     sv_context(&ic);
     207:     cntxt= In_unit; uname= oname;
     208:     lino= 1;
     209:     if ((hu= atkw(HOW_TO)) || atkw(YIELD) || atkw(TEST)) {
     210:         if (cur_ilev != 0) parerr("unit starts with indentation", "");
     211:         if (hu) {
     212:             uname= keyword(ceol); utype= FHW;
     213:         } else {
     214:             literal adic;
     215:             ytu_heading(&uname, &adic, ceol, No);
     216:             utype= (adic == Zer ? FZR : adic == Mon ? FMN : FDY);
     217:         }
     218:         *nname= uname; /*should really be n=copy(u); release(u);*/
     219:         *ntype= utype;
     220:         set_context(&ic);
     221:     } else parerr("no HOW'TO, YIELD or TEST where expected", "");
     222: }
     223:
     224: Hidden bool still_there(fname) value fname; {
     225:     /* Find out if the file exists, and is not empty.
     226: 	   Some editors don't allow a file to be edited to empty,
     227: 	   but insist it should be at least one empty line.
     228: 	   Because it is hard to unget 2 chars, an initial empty line
     229: 	   may be disregarded, but this is not harmful. */
     230:     int k;
     231:     ifile= fopen(strval(fname), "r");
     232:     if (ifile == NULL) {
     233:         vs_ifile();
     234:         error(CANT_READ);
     235:     }
     236:     if ((k= getc(ifile)) == EOF || (k == '\n' && (k= getc(ifile)) == EOF)) {
     237:         fclose(ifile);
     238:         f_delete(fname);
     239:         vs_ifile();
     240:         return No;
     241:     }
     242:     ungetc(k, ifile);
     243:     return Yes;
     244: }
     245:
     246: Hidden Procedure ens_filed(fname) value fname; {
     247:     value *aa= unit_defn(fname); how *du;
     248:     if (aa != Pnil) {
     249:         du= How_to(*aa);
     250:         if (du->filed == No) {
     251:             txptr ux= du->fux, lux= du->lux;
     252:             FILE *ofile= fopen(strval(fname), "w");
     253:             if (ofile == NULL) error(CANT_WRITE);
     254:             while (ux < lux) {
     255:                 char c= *ux++;
     256:                 putc(c == Eouc ? '\n' : c, ofile);
     257:             }
     258:             fclose(ofile);
     259:             du->filed= Yes;
     260:         }
     261:     }
     262: }
     263:
     264: Hidden intlet err_line(name) value name; {
     265:     intlet el;
     266:     if (errlino == 0 || compare(erruname, name) != 0) return 0;
     267:     el= errlino; errlino= 0;
     268:     return el;
     269: }
     270:
     271: Hidden Procedure free_unit(fname) value fname; {
     272:     e_delete(&defunits, fname);
     273: }
     274:
     275: Hidden Procedure shellcmd() {
     276:     system(tx);
     277:     To_eol(tx);
     278: }
     279:
     280: /************************** VALUES ***************************************/
     281: /* The permanent environment in the old format was kept as a single file */
     282: /* but this caused slow start ups if the file was big.			 */
     283: /* Thus the new version stores each permanent target on a separate file, */
     284: /* that furthermore is only loaded on demand.				 */
     285: /* To achieve this, a directory is kept of the permanent tags and their	 */
     286: /* file names. Care has to be taken that user interrupts occurring in	 */
     287: /* the middle of an update of this directory do the least harm.		 */
     288: /* Having the directory refer to a non-existent file is considered less	 */
     289: /* harmful than leaving a file around that can never be accessed, for	 */
     290: /* instance, so a file is deleted before its directory entry,		 */
     291: /* and so forth.							 */
     292: /*************************************************************************/
     293:
     294: value b_perm; /*The table that maps tags to their file names*/
     295:
     296: Visible bool is_tloaded(name, aa) value name, **aa; {
     297:     return No; /*for now*/
     298: }
     299:
     300: Hidden bool new_tname(name, fname) value name, *fname; {
     301:     value *aa;
     302:     if (in_env(b_perm, name, &aa)) {
     303:         *fname= copy(*aa);
     304:         return No;
     305:     } else {
     306:         *fname= f_tname(name);
     307:         e_replace(*fname, &b_perm, name);
     308:         return Yes;
     309:     }
     310: }
     311:
     312: Hidden Procedure editar() {
     313:     value name, fname;
     314:     Skipsp(tx);
     315:     if (Char(tx) == '=') {
     316:         lst_ttgs();
     317:         To_eol(tx);
     318:         return;
     319:     }
     320:     if (Ceol(tx)) {
     321:         if (last_tfname == Vnil)
     322:             parerr("no current target name known", "");
     323:         fname= copy(last_tfname);
     324:         name= copy(last_tname);
     325:     } else if (Letter(Char(tx))) {
     326:         name= tag();
     327:         VOID new_tname(name, &fname);
     328:     } else parerr("I find nothing editible here", "");
     329:     if (!f_exists(fname)) pprerr("no such target in this workspace","");
     330:     ens_tfiled(name, fname);
     331:     ed_target(name, fname); release(fname); release(name);
     332: }
     333:
     334: Hidden Procedure lst_ttgs() {
     335:     int k, len;
     336:     len= length(prmnv->tab);
     337:     k_Over_len {
     338:         writ(*key(prmnv->tab, k));
     339:         wri_space();
     340:     }
     341:     newline();
     342: }
     343:
     344: Hidden Procedure ed_target(name, fname) value name, fname; {
     345:     /* Edit a target. The value in the target is written to the file,
     346: 	   and then removed from the internal permanent environment so that
     347: 	   if a syntax error occurs when reading the value back, the value is
     348: 	   absent from the internal permanent environment.
     349: 	   Thus when editing the file to correct the syntax error, the
     350: 	   file doesn't get overwritten.
     351: 	   The contents may be completely deleted in which case the target is
     352: 	   deleted.
     353: 	*/
     354:     value v, p; context c; bool wia;
     355:     f_edit(fname, 0);
     356:     if (still_there(fname)) {
     357:         release(last_tfname); last_tfname= copy(fname);
     358:         release(last_tname); last_tname= copy(name);
     359:         fclose(ifile); /*since still_there leaves it open*/
     360:         sv_context(&c); wia= interactive;
     361:         cntxt= In_value;
     362:         getval(fname, &v);
     363: /*		p= mk_per(v);
     364: */p=v;      e_replace(p, &prmnv->tab, name);
     365:         set_context(&c); interactive= wia;
     366:         vs_ifile();
     367:         release(p);
     368: /*		release(v);
     369: */  } else {
     370:         e_delete(&prmnv->tab, name);
     371:         e_delete(&b_perm, name);
     372:         release(last_tfname); release(last_tname);
     373:         last_tfname= Vnil; last_tname= Vnil;
     374:     }
     375: f_delete(fname);
     376: }
     377:
     378: Hidden Procedure ens_tfiled(name, fname) value name, fname; {
     379:     value p, *aa;
     380:     if (in_env(prmnv->tab, name, &aa) && !Is_filed(*aa)) {
     381:         putval(fname, *aa, No);
     382:         p= mk_per(Vnil);
     383:         e_replace(p, &prmnv->tab, name);
     384:         release(p);
     385:     }
     386: }
     387:
     388: Hidden Procedure getval(nm, v) value nm, *v; {
     389:     char *buf= Nil; int k;
     390:     release(iname);
     391:     iname= copy(nm);
     392:     ifile= fopen(strval(iname), "r");
     393:     if (ifile != NULL) {
     394:         interactive= No;
     395:         alino= 0; xeq= Yes; active_reads= 0; /*CHANGE*/
     396:         buf= getmem((unsigned)(f_size(ifile)+2)*sizeof(char));
     397:         if (buf == Nil) syserr("can't get buffer to read file");
     398:         *(txend= buf)= Eotc; tx= ceol= txend+1;
     399:         while ((k= getc(ifile)) != EOF)
     400:             if (k != '\n') *ceol++= k;
     401:         *ceol= '\n'; alino= 1; *v= expr(ceol);
     402:         fclose(ifile);
     403:         if (buf != Nil) freemem(buf);
     404:     } else error(CANT_READ);
     405: }
     406:
     407: Visible Procedure getprmnv() {
     408:     value fn= mk_text(".prmnv");
     409:     cntxt= In_prmnv;
     410:     if (f_exists(fn)) { /* convert from old to new format */
     411:         getval(fn, &prmnv->tab);
     412:         b_perm= mk_elt();
     413: /*		putprmnv();
     414: 		f_delete(fn); /*after writing the new one, for safety*/
     415: /* */       release(fn);
     416:     } else {
     417: prmnv->tab= mk_elt();
     418: b_perm= mk_elt();
     419: /*		release(fn);
     420: 		fn= mk_text(".b_perm");
     421: 		if (f_exists(fn)) {
     422: 			getval(fn, &b_perm);
     423: 			create_prmnv();
     424: 		} else {
     425: 			b_perm= mk_elt();
     426: 			prmnv->tab= mk_elt();
     427: 		}
     428: */      release(fn);
     429:     }
     430: }
     431:
     432: Hidden Procedure putval(nm, v, silently) value nm, v; bool silently; {
     433:     FILE *ofile;
     434:     ofile= fopen(strval(nm), "w");
     435:     if (ofile != NULL) {
     436:         redirect(ofile);
     437:         wri(v, No, No, Yes); newline();
     438:         fclose(ofile);
     439:         redirect(stdout);
     440:     } else if (!silently) error(CANT_WRITE);
     441: }
     442:
     443: Visible Procedure putprmnv() {
     444:     bool changed= No; value fn;
     445:     value pt1, pt2; env c;
     446:     int k, len= length(prmnv->tab);
     447:
     448:     ignsigs(); /*because files are created before the directory is written*/
     449:     pt1= prmnv->tab; pt2= prmnvtab; c= curnv;
     450:     setprmnv();
     451:     k_Over_len {
     452:         value v= copy(*assoc(prmnv->tab, k));
     453:         if (!Is_filed(v)) {
     454: /*			value t= copy(*key(prmnv->tab, k));
     455: 			wri_target(t, v, &changed);
     456: 			release(t);
     457: */}else{e_delete(&prmnv->tab, *key(prmnv->tab, k));
     458:         }
     459:         release(v);
     460:     }
     461: fn= mk_text(".prmnv");
     462: putval(fn, prmnv->tab, Yes);
     463: release(fn);
     464:     if (changed) {
     465:         fn= mk_text(".b_perm");
     466:         putval(fn, b_perm, Yes);
     467:         release(fn);
     468:     }
     469:     prmnv->tab= pt1; prmnvtab= pt2; curnv= c; /* kludgy */
     470:     re_sigs();
     471: }
     472:
     473: Hidden Procedure wri_target(t, v, changed) value t, v; bool* changed; {
     474:     value fn, p;
     475:     bool new= new_tname(t, &fn);
     476:     if (new) *changed= Yes;
     477:     putval(fn, v, Yes);
     478:     p= mk_per(v);
     479:     e_replace(p, &prmnv->tab, t); /*after writing file*/
     480:     release(p); release(fn);
     481: }
     482:
     483: Hidden Procedure create_prmnv() {
     484:     value p= mk_per(Vnil);
     485:     int k, len= length(b_perm);
     486:
     487:     k_Over_len {
     488:         e_replace(copy(p), &prmnv->tab, *key(b_perm, k));
     489:     }
     490:     release(p);
     491: }
     492:
     493: Visible Procedure initsou() {
     494:     defunits= mk_elt();
     495: }

#### Defined functions

create_prmnv defined in line 483; never used
def_unit defined in line 26; used 3 times

- in /usr/src/new/PORT/B/src/bsmall/b2fpr.c line 91, 103
- in /usr/src/new/PORT/B/src/bsmall/b2uni.c line 71

ed_target defined in line 344; used 1 times

- in line 331

ed_unit defined in line 176; used 2 times

- in line 99, 160

editar defined in line 312; used 1 times

- in line 113

ediuni defined in line 124; used 1 times

- in line 112

ens_filed defined in line 246; used 1 times

- in line 159

ens_tfiled defined in line 378; used 1 times

- in line 330

err_line defined in line 264; used 2 times

- in line 164, 177

free_unit defined in line 271; used 2 times

- in line 88, 196

getprmnv defined in line 407; used 1 times

- in /usr/src/new/PORT/B/src/bsmall/b2mai.c line 109

getval defined in line 388; used 2 times

- in line 362, 411

initsou defined in line 493; used 1 times

- in /usr/src/new/PORT/B/src/bsmall/b2mai.c line 104

is_loaded defined in line 40; used 1 times

- in line 72

is_tloaded defined in line 296; used 3 times

- in /usr/src/new/PORT/B/src/bsmall/b2exp.c line 229-232(2)
- in /usr/src/new/PORT/B/src/bsmall/b2sou.h line 15

is_unit defined in line 68; used 3 times

- in /usr/src/new/PORT/B/src/bsmall/b2fpr.c line 110
- in /usr/src/new/PORT/B/src/bsmall/b2sou.h line 9
- in /usr/src/new/PORT/B/src/bsmall/b2uni.c line 145

lst_ttgs defined in line 334; used 1 times

- in line 316

new_tname defined in line 300; used 2 times

- in line 327, 475

putprmnv defined in line 443; used 3 times

- in /usr/src/new/PORT/B/src/bsmall/b2cmd.c line 427
- in /usr/src/new/PORT/B/src/bsmall/b2err.c line 41
- in /usr/src/new/PORT/B/src/bsmall/b2sig.c line 41

putval defined in line 432; used 4 times

- in line 381, 462-466(2), 477

shellcmd defined in line 275; used 1 times

- in line 114

special defined in line 110; used 1 times

- in /usr/src/new/PORT/B/src/bsmall/b2cmd.c line 441

still_there defined in line 224; used 3 times

- in line 163, 180, 356

uheading defined in line 204; used 2 times

- in line 85, 182

unit defined in line 81; used 3 times

- in /usr/src/new/PORT/B/src/bsmall/b2cmd.c line 435
- in /usr/src/new/PORT/B/src/bsmall/b2sem.h line 76
- in /usr/src/new/PORT/B/src/bsmall/b2sou.h line 8

unit_defn defined in line 22; used 5 times

- in line 34, 42, 56, 87, 247

unit_info defined in line 32; used 3 times

- in /usr/src/new/PORT/B/src/bsmall/b2fpr.c line 164, 194
- in /usr/src/new/PORT/B/src/bsmall/b2sou.h line 11

wri_target defined in line 473; never used

#### Defined variables

last_tname defined in line 108; used 5 times

- in line 324, 358(2), 372-373(2)

value defined in line 108; used 40 times

- in line 20-34(9), 40-41(2), 68, 82, 127, 176-177(2), 204, 224, 246-247(2), 264, 271, 294-301(4), 313, 344, 354, 378-379(2), 388, 408, 432, 444-445(2), 452, 473-474(2), 484

#### Defined macros

CANT_READ defined in line 79; used 2 times

- in line 234, 404

CANT_WRITE defined in line 78; used 3 times

- in line 95, 253, 440

DISCARD defined in line 77; used 1 times

- in line 88

FnSwitch defined in line 120; used 3 times

- in line 149-154(3)

MONADIC defined in line 122; used 1 times

- in line 153

On_file defined in line 106; never used

Last modified: 1985-08-27 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 2109 |