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

   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

Defined variables

Defined macros