1: /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
   2: 
   3: /*
   4:   $Header: b3sou.c,v 1.4 85/08/22 16:59:08 timo Exp $
   5: */
   6: 
   7: /* Sources: maintaining units and values on external files */
   8: 
   9: #include "b.h"
  10: #include "b0con.h"
  11: #include "b0fea.h"
  12: #include "b0fil.h"
  13: #include "b1mem.h"
  14: #include "b1obj.h"
  15: #include "b2syn.h"
  16: #include "b2par.h"
  17: #include "b2nod.h"
  18: #include "b3env.h"
  19: #include "b3scr.h"
  20: #include "b3err.h"
  21: #include "b3sem.h"
  22: #include "b3fil.h"
  23: #include "b3sou.h"
  24: #include "b3int.h"
  25: 
  26: /************************** UNITS ************************************/
  27: 
  28: Hidden value b_perm; /* The table that maps tags to their file names */
  29: Hidden value b_units; /* The table that maps tags to their internal repr. */
  30: 
  31: Hidden bool
  32: u_exists(pname, aa)
  33:     value pname, **aa;
  34: {
  35:     return in_env(b_units, pname, aa);
  36: }
  37: 
  38: Visible Procedure
  39: def_unit(pname, u)
  40:     value pname, u;
  41: {
  42:     e_replace(u, &b_units, pname);
  43: }
  44: 
  45: Hidden Procedure
  46: free_unit(pname)
  47:     value pname;
  48: {
  49:     e_delete(&b_units, pname);
  50: }
  51: 
  52: Hidden Procedure
  53: del_units()
  54: {
  55:     int len= length(b_units), k; how *u;
  56:     for (k= len-1; k >= 0; --k) {
  57:         /* Reverse loop so deletions don't affect the numbering! */
  58:         u= How_to(*assoc(b_units, k));
  59:         if (!u->unparsed) free_unit(*key(b_units, k));
  60:         /*Therefore standard B functions must be entered as unparsed*/
  61:     }
  62: }
  63: 
  64: Visible Procedure
  65: rem_unit(u)
  66:     parsetree u;
  67: {
  68:     value pname= get_pname(u);
  69:     free_unit(pname);
  70:     release(pname);
  71: }
  72: 
  73: /********************************************************************** */
  74: 
  75: Visible Procedure
  76: p_name_type(pname, name, type)
  77:     value pname, *name; literal *type;
  78: {
  79:     *name= behead(pname, MkSmallInt(2));
  80:     switch (strval(pname)[0]) {
  81:     case '0': *type= Zer; break;
  82:     case '1': *type= Mon; break;
  83:     case '2': *type= Dya; break;
  84:     case '3': *type= How; break;
  85:     case '4': *type= Tar; break;
  86:     default: syserr(MESS(4000, "p_name_type"));
  87:         /* NOTREACHED */
  88:     }
  89: }
  90: 
  91: Visible value
  92: permkey(name, type)
  93:     value name; literal type;
  94: {
  95:     value v, w; string t;
  96:     switch (type) {
  97:     case Zer: t= "0"; break;
  98:     case Mon: t= "1"; break;
  99:     case Dya: t= "2"; break;
 100:     case How: t= "3"; break;
 101:     case Tar: t= "4"; break;
 102:     default: syserr(MESS(4001, "wrong permkey"));
 103:     }
 104:     w= mk_text(t);
 105:     v= concat(w, name); release(w);
 106:     return v;
 107: }
 108: 
 109: Visible bool
 110: p_exists(pname, aa)
 111:     value pname, **aa;
 112: {
 113:     return in_env(b_perm, pname, aa);
 114: }
 115: 
 116: Visible value file_names;
 117: 
 118: Hidden Procedure
 119: def_perm(pname, f)
 120:     value pname, f;
 121: {
 122:     e_replace(f, &b_perm, pname);
 123:     if (!in(f, file_names)) insert(f, &file_names);
 124: }
 125: 
 126: Hidden Procedure
 127: free_perm(pname)
 128:     value pname;
 129: {
 130:     value *aa;
 131:     if (p_exists(pname, &aa)) {
 132:         remove(*aa, &file_names);
 133:         f_delete(*aa);
 134:         e_delete(&b_perm, pname);
 135:     }
 136: }
 137: 
 138: Hidden value
 139: get_fname(pname)
 140:     value pname;
 141: {
 142:     value *aa;
 143:     if (p_exists(pname, &aa)) return copy(*aa);
 144:     else {
 145:         value fname, name; literal type;
 146:         p_name_type(pname, &name, &type);
 147:         fname= new_fname(name, type);
 148:         def_perm(pname, fname);
 149:         release(name);
 150:         return fname;
 151:     }
 152: }
 153: 
 154: Hidden bool
 155: p_version(name, type, pname)
 156:     value name, *pname; literal type;
 157: {
 158:     value *aa;
 159:     *pname= permkey(name, type);
 160:     if (p_exists(*pname, &aa)) return Yes;
 161:     release(*pname); *pname= Vnil;
 162:     return No;
 163: }
 164: 
 165: Hidden bool
 166: how_unit(pname)
 167:     value pname;
 168: {
 169:     value name; literal type;
 170:     p_name_type(pname, &name, &type);
 171:     release(name);
 172:     return type == How;
 173: }
 174: 
 175: Hidden bool
 176: zermon_units(pname, other_pname)
 177:     value pname, *other_pname;
 178: {
 179:     value name; literal type; bool is;
 180:     p_name_type(pname, &name, &type);
 181:     is= (type == Zer && p_version(name, Mon, other_pname)) ||
 182:         (type == Mon && p_version(name, Zer, other_pname));
 183:     release(name);
 184:     return is;
 185: }
 186: 
 187: /***********************************************************************/
 188: 
 189: Hidden bool
 190: is_loaded(pname, aa)
 191:     value pname, **aa;
 192: {
 193:     value u= Vnil, npname= Vnil, get_unit();
 194:     if (u_exists(pname, aa)) return Yes; /* already loaded */
 195:     if (!p_exists(pname, aa)) return No;
 196:     ifile= fopen(strval(**aa), "r");
 197:     if (ifile == NULL) {
 198:         vs_ifile();
 199:         return No;
 200:     }
 201:     Eof= No;
 202:     first_ilev();
 203:     u= get_unit(&npname, Yes);
 204:     if (still_ok) def_unit(npname, u);
 205:     fclose(ifile);
 206:     vs_ifile();
 207:     Eof= No;
 208:     if (still_ok && !u_exists(pname, aa)) {
 209:         value name; literal type;
 210:         p_name_type(npname, &name, &type);
 211:         release(uname); uname= copy(pname);
 212:         curline= How_to(u)->unit; curlino= one;
 213:         error2(MESS(4002, "filename and unit name incompatible for "), name);
 214:         release(name);
 215:     }
 216:     release(u); release(npname);
 217:     return still_ok;
 218: }
 219: 
 220: /* Does the unit exist without faults? */
 221: 
 222: Visible bool
 223: is_unit(name, type, aa)
 224:     value name, **aa; literal type;
 225: {
 226:     value pname;
 227:     context c; bool is;
 228:     sv_context(&c);
 229:     cntxt= In_unit;
 230:     pname= permkey(name, type);
 231:     is= is_loaded(pname, aa);
 232:     release(pname);
 233:     set_context(&c);
 234:     return is;
 235: }
 236: 
 237: /***********************************************************************/
 238: 
 239: Hidden char DISCARD[]= "the unit name is already in use;\n\
 240: *** should the old unit be discarded?";
 241: 
 242: #define CANT_WRITE \
 243:     MESS(4003, "cannot create file; need write permission in directory")
 244: 
 245: #define CANT_READ MESS(4004, "unable to find file")
 246: #define MON_VERSION MESS(4005, " is already a monadic function/predicate")
 247: #define ZER_VERSION MESS(4006, " is already a zeroadic function/predicate")
 248: 
 249: Hidden Procedure
 250: u_name_type(v, name, type)
 251:     parsetree v; value *name; literal *type;
 252: {
 253:     switch (Nodetype(v)) {
 254:         case HOW_TO:    *name= copy(*Branch(v, UNIT_NAME));
 255:                 *type= How;
 256:                 break;
 257:         case YIELD:
 258:         case TEST:  *name= copy(*Branch(v, UNIT_NAME));
 259:                 switch (intval(*Branch(v, FPR_ADICITY))) {
 260:                     case 0: *type= Zer; break;
 261:                     case 1: *type= Mon; break;
 262:                     case 2: *type= Dya; break;
 263:                     default: syserr(MESS(4007, "wrong adicity"));
 264:                 }
 265:                 break;
 266:         default:    syserr(MESS(4008, "wrong nodetype of unit"));
 267:     }
 268: }
 269: 
 270: Hidden value
 271: get_unit(pname, filed)
 272:     value *pname; bool filed;
 273: {
 274:     value name; literal type;
 275:     parsetree u= unit(No);
 276:     if (u == NilTree) return Vnil;
 277:     u_name_type(u, &name, &type);
 278:     *pname= permkey(name, type);
 279:     release(name);
 280:     switch (Nodetype(u)) {
 281:         case HOW_TO:    return mk_how(u, filed);
 282:         case YIELD: return mk_fun(type, Use, u, filed);
 283:         case TEST:  return mk_prd(type, Use, u, filed);
 284:         default:    syserr(MESS(4009, "wrong nodetype in 'get_unit'"));
 285:     }
 286:     /* NOTREACHED */
 287: }
 288: 
 289: Visible value
 290: get_pname(v)
 291:     parsetree v;
 292: {
 293:     value pname, name; literal type;
 294:     u_name_type(v, &name, &type);
 295:     pname= permkey(name, type);
 296:     release(name);
 297:     return pname;
 298: }
 299: 
 300: Hidden Procedure
 301: get_heading(h, pname)
 302:     parsetree *h; value *pname;
 303: {
 304:     *h= unit(Yes);
 305:     *pname= still_ok ? get_pname(*h) : Vnil;
 306: }
 307: 
 308: /* Create a unit via the editor or from the input stream */
 309: 
 310: Visible Procedure
 311: create_unit()
 312: {
 313:     value pname= Vnil, *aa; parsetree heading= NilTree;
 314:     if (!interactive) {
 315:         value v= get_unit(&pname, No);
 316:         if (still_ok) def_unit(pname, v);
 317:         release(v); release(pname);
 318:         return;
 319:     }
 320:     get_heading(&heading, &pname);
 321:     if (still_ok) {
 322:         value v;
 323:         if (p_exists(pname, &aa)) {
 324:             if (is_intended(DISCARD)) {
 325:                 free_unit(pname);
 326:                 free_perm(pname);
 327:             } else {
 328:                 tx= ceol;
 329:                 release(pname);
 330:                 release(heading);
 331:                 return;
 332:             }
 333:         } else if (zermon_units(pname, &v)) {
 334:             value name; literal type;
 335:             p_name_type(pname, &name, &type);
 336:             curline= heading; curlino= one;
 337:             error3(0, name, type == Zer ? MON_VERSION
 338:                              : ZER_VERSION);
 339:             release(name); release(v);
 340:         }
 341:     }
 342:     if (still_ok) {
 343:         value fname= get_fname(pname);
 344:         FILE *ofile= fopen(strval(fname), "w");
 345:         if (ofile == NULL) error(CANT_WRITE);
 346:         else {
 347:             txptr tp= fcol();
 348:             do { fputc(Char(tp), ofile); }
 349:             while (Char(tp++) != '\n');
 350:             f_close(ofile);
 351:             ed_unit(pname, fname);
 352:         }
 353:         release(fname);
 354:     }
 355:     release(pname); release(heading);
 356: }
 357: 
 358: 
 359: /***********************************************************************/
 360: 
 361: /* Edit a unit. The name of the unit is either given, or is defaulted
 362:    to the last unit edited or the last unit that gave an error, whichever
 363:    was most recent.
 364:    It is possible for the user to mess things up with the w command, for
 365:    instance, but this is not checked. It is allowed to rename the unit though,
 366:    or delete it completely. If the file is empty, the unit is disposed of.
 367:    Otherwise, the name and adicity are determined and if these have changed,
 368:    the new unit is written out to a new file, and the original written back.
 369:    Thus the original is not lost.
 370: 
 371:    Renaming, deleting, or changing the adicity of a test or yield
 372:    unfortunately requires all other units to be thrown away internally
 373:    (by del_units), since the unit parse trees may be wrong. For instance,
 374:    consider the effect on the following of making a formerly monadic
 375:    function f, into a zeroadic function:
 376: 	WRITE f root 2
 377: */
 378: 
 379: Hidden char ZEROADIC[]=
 380:    "the unit name is in use both for a zeroadic and a dyadic version;\n\
 381: *** do you want to edit the zeroadic version?";
 382: 
 383: Hidden char MONADIC[]=
 384:    "the unit name is in use both for a monadic and a dyadic version;\n\
 385: *** do you want to edit the monadic version?";
 386: 
 387: Visible Procedure
 388: edit_unit()
 389: {
 390:     value name= Vnil, pname= Vnil, v= Vnil; bool ens_filed();
 391:     value fname;
 392:     if (Ceol(tx)) {
 393:         if (erruname == Vnil) parerr(MESS(4010, "no current unit"));
 394:         else pname= copy(erruname);
 395:     } else if (is_keyword(&name))
 396:         pname= permkey(name, How);
 397:      else if (is_tag(&name)) {
 398:         if (p_version(name, Zer, &pname)) {
 399:             if (p_version(name, Dya, &v) && !is_intended(ZEROADIC)) {
 400:                 release(pname); pname= copy(v);
 401:             }
 402:         } else if (p_version(name, Mon, &pname)) {
 403:             if (p_version(name, Dya, &v) && !is_intended(MONADIC)) {
 404:                 release(pname); pname= copy(v);
 405:             }
 406:         } else {
 407:             pname= permkey(name, Dya);
 408:         }
 409:     } else {
 410:         parerr(MESS(4011, "I find nothing editible here"));
 411:     }
 412:     if (still_ok && ens_filed(pname, &fname)) {
 413:         ed_unit(pname, fname);
 414:         release(fname);
 415:     }
 416:     release(name); release(pname); release(v);
 417: }
 418: 
 419: Hidden char NO_U_WRITE[]=
 420:    "you have no write permission in this workspace: you may not change the unit\n\
 421: *** do you still want to display the unit?";
 422: 
 423: Hidden char ZER_MON[]=
 424:    "the unit name is already in use for a zeroadic function or predicate;\n\
 425: *** should that unit be discarded?\n\
 426: *** (if not you have to change the monadic unit name)";
 427: 
 428: Hidden char MON_ZER[]=
 429:    "the unit name is already in use for a monadic function or predicate;\n\
 430: *** should that unit be discarded?\n\
 431: *** (if not you have to change the zeroadic unit name)";
 432: 
 433: Hidden Procedure
 434: ed_unit(pname, fname)
 435:     value pname, fname;
 436: {
 437:     value sname= Vnil, npname= Vnil, nfname= Vnil;
 438:     value u, *aa, v= Vnil, v_free= Vnil;
 439:     intlet err_line();
 440:     bool new_def= Yes, same_name= No, still_there(), ed_again= No;
 441: 
 442:     if (!ws_writable() && !is_intended(NO_U_WRITE)) return;
 443:     sname= f_save(fname); /* in case the unit gets renamed */
 444:     if (sname == Vnil) {
 445:         error(MESS(4012, "can't save to temporary file"));
 446:         return;
 447:     }
 448:     release(uname); uname= copy(pname);
 449: #ifndef INTEGRATION
 450:     f_edit(fname, err_line(pname));
 451: #else
 452:     f_edit(fname, err_line(pname), unit_prompt);
 453: #endif
 454:     if (!still_there(fname)) {
 455:         free_unit(pname);
 456:         if (!how_unit(pname)) del_units();
 457:         release(erruname); erruname= Vnil; errlino= 0;
 458:         free_perm(pname);
 459:         f_delete(sname);
 460:         release(sname);
 461:         return;
 462:     }
 463:     first_ilev();
 464:     u= get_unit(&npname, Yes);
 465:     fclose(ifile); vs_ifile(); Eof= No;
 466:     if (u == Vnil || npname == Vnil)
 467:         new_def= No;
 468:     else if (same_name= compare(pname, npname) == 0)
 469:         new_def= p_exists(pname, &aa);
 470:     else if (p_exists(npname, &aa))
 471:         new_def= is_intended(DISCARD);
 472:     else if (zermon_units(npname, &v)) {
 473:         value name; literal type;
 474:         p_name_type(npname, &name, &type);
 475:         if (new_def= is_intended(type == Zer ? MON_ZER : ZER_MON)) {
 476:             free_unit(v);
 477:             v_free= copy(v); /* YIELD f => YIELD f x */
 478:         } else {
 479:             nfname= new_fname(name, type);
 480:             f_rename(fname, nfname);
 481:             ed_again= Yes;
 482:         }
 483:         release(name);
 484:     }
 485:     if (new_def) {
 486:         if (!how_unit(npname)) del_units();
 487:         if (still_ok) def_unit(npname, u);
 488:         else free_unit(npname);
 489:         if (!same_name) {
 490:             nfname= get_fname(npname);
 491:             f_rename(fname, nfname);
 492:             if (v_free) free_perm(v_free);
 493:         }
 494:         release(erruname); erruname= copy(npname);
 495:     }
 496:     if (!same_name) f_rename(sname, fname);
 497:     else f_delete(sname);
 498:     if (!p_exists(pname, &aa)) f_delete(fname);
 499:     if (ed_again) ed_unit(npname, nfname);
 500:     release(npname); release(u); release(sname); release(nfname);
 501:     release(v); release(v_free);
 502: }
 503: 
 504: /* Find out if the file exists, and is not empty. Some wretched editors
 505:    for some reason don't allow a file to be edited to empty, but insist it
 506:    should be at least one empty line. Thus an initial empty line may be
 507:    disregarded, but this is not harmful. */
 508: 
 509: Hidden bool still_there(fname) value fname; {
 510:     int k;
 511:     ifile= fopen(strval(fname), "r");
 512:     if (ifile == NULL) {
 513:         vs_ifile();
 514:         /* error(CANT_READ); */
 515:         return No;
 516:     } else {
 517:         if ((k= getc(ifile)) == EOF || (k == '\n' && (k= getc(ifile)) == EOF)) {
 518:             fclose(ifile);
 519:             f_delete(fname);
 520:             vs_ifile();
 521:             return No;
 522:         }
 523:         ungetc(k, ifile);
 524:         return Yes;
 525:     }
 526: }
 527: 
 528: /* Ensure the unit is filed. If the unit was read non-interactively (eg passed
 529:    as a parameter to b), it is only held in store.
 530:    Editing it puts it into a file. This is the safest way to copy a unit from
 531:    one workspace to another.
 532: */
 533: 
 534: Hidden bool
 535: ens_filed(pname, fname)
 536:     value pname, *fname;
 537: {
 538:     value *aa;
 539:     if (p_exists(pname, &aa)) {
 540:         *fname= copy(*aa);
 541:         return Yes;
 542:     } else if (!u_exists(pname, &aa) || How_to(*aa)->unit == NilTree) {
 543:         pprerr(MESS(4013, "no such unit in this workspace"));
 544:         return No;
 545:     } else {
 546:         how *du= How_to(*aa); FILE *ofile;
 547:         if (du->filed == Yes) {
 548:             syserr(MESS(4014, "ens_filed()"));
 549:             return No;
 550:         }
 551:         *fname= get_fname(pname);
 552:         ofile= fopen(strval(*fname), "w");
 553:         if (!ofile) {
 554:             error(CANT_WRITE);
 555:             release(*fname);
 556:             return No;
 557:         } else {
 558:             display(ofile, du->unit, No);
 559:             f_close(ofile);
 560:             du->filed= Yes;
 561:             return Yes;
 562:         }
 563:     }
 564: }
 565: 
 566: Hidden intlet
 567: err_line(pname)
 568:     value pname;
 569: {
 570:     if (errlino == 0 || erruname == Vnil || compare(erruname, pname) != 0)
 571:         return 0;
 572:     else {
 573:         intlet el= errlino;
 574:         errlino= 0;
 575:         return el;
 576:     }
 577: }
 578: 
 579: /************************** VALUES ***************************************/
 580: /* The permanent environment in the old format was kept as a single file */
 581: /* but this caused slow start ups if the file was big.			 */
 582: /* Thus the new version stores each permanent target on a separate file, */
 583: /* that furthermore is only loaded on demand.				 */
 584: /* To achieve this, a directory is kept of the permanent tags and their  */
 585: /* file names. Care has to be taken that disaster occurring in		 */
 586: /* the middle of an update of this directory does the least harm.	 */
 587: /* Having the directory refer to a non-existent file is considered less  */
 588: /* harmful than leaving a file around that can never be accessed, for	 */
 589: /* instance, so a file is deleted before its directory entry,		 */
 590: /* and so forth.							 */
 591: /*************************************************************************/
 592: 
 593: Hidden bool
 594: t_exists(name, aa)
 595:     value name, **aa;
 596: {
 597:     return in_env(prmnv->tab, name, aa);
 598: }
 599: 
 600: Hidden Procedure
 601: def_target(name, t)
 602:     value name, t;
 603: {
 604:     e_replace(t, &prmnv->tab, name);
 605: }
 606: 
 607: Hidden Procedure
 608: free_target(name)
 609:     value name;
 610: {
 611:     e_delete(&prmnv->tab, name);
 612: }
 613: 
 614: Hidden Procedure
 615: tarfiled(name, v)
 616:     value name, v;
 617: {
 618:     value p= mk_per(v);
 619:     def_target(name, p);
 620:     release(p);
 621: }
 622: 
 623: Visible value
 624: tarvalue(name, v)
 625:     value name, v;
 626: {
 627:     value getval();
 628:     if (Is_filed(v)) {
 629:         per *p= Perm(v);
 630:         if (p->val == Vnil) {
 631:             value *aa, pname= permkey(name, Tar);
 632:             if (!p_exists(pname, &aa))
 633:                 syserr(MESS(4015, "tarvalue"));
 634:             release(pname);
 635:             p->val= getval(*aa, In_tarval);
 636:         }
 637:         return p->val;
 638:     }
 639:     return v;
 640: }
 641: 
 642: Hidden value last_tname= Vnil; /*last edited target */
 643: 
 644: Visible Procedure
 645: edit_target()
 646:  {
 647:     value name= Vnil; bool ens_tfiled();
 648:     value fname;
 649:     if (Ceol(tx)) {
 650:         if (last_tname == Vnil)
 651:             parerr(MESS(4016, "no current target"));
 652:         else
 653:             name= copy(last_tname);
 654:     } else if (!is_tag(&name))
 655:         parerr(MESS(4017, "I find nothing editible here"));
 656:     if (still_ok && ens_tfiled(name, &fname)) {
 657:         ed_target(name, fname);
 658:         release(fname);
 659:     }
 660:     release(name);
 661: }
 662: 
 663: Hidden char NO_T_WRITE[]=
 664:    "you have no write permission in this workspace: you may not change the target\n\
 665: *** do you still want to display the target?";
 666: 
 667: Hidden Procedure
 668: ed_target(name, fname)
 669:     value name, fname;
 670: {
 671:     /* Edit a target. The value in the target is written to the file,
 672: 	   and then removed from the internal permanent environment so that
 673: 	   if a syntax error occurs when reading the value back, the value is
 674: 	   absent from the internal permanent environment.
 675: 	   Thus when editing the file to correct the syntax error, the
 676: 	   file doesn't get overwritten.
 677: 	   The contents may be completely deleted in which case the target is
 678: 	   deleted.
 679: 	*/
 680:     value v, getval();
 681:     if (!ws_writable() && !is_intended(NO_T_WRITE)) return;
 682: #ifndef INTEGRATION
 683:     f_edit(fname, 0);
 684: #else
 685:     f_edit(fname, 0, tar_prompt);
 686: #endif
 687:     if (!still_there(fname)) {
 688:         value pname= permkey(name, Tar);
 689:         free_target(name);
 690:         free_perm(pname);
 691:         release(pname);
 692:         release(last_tname); last_tname= Vnil;
 693:         return;
 694:     }
 695:     release(last_tname); last_tname= copy(name);
 696:     fclose(ifile); /*since still_there leaves it open*/
 697:     v= getval(fname, In_edval);
 698:     if (still_ok) def_target(name, v);
 699:     release(v);
 700: }
 701: 
 702: Hidden bool
 703: ens_tfiled(name, fname)
 704:     value name, *fname;
 705: {
 706:     value *aa;
 707:     if (!t_exists(name, &aa)) {
 708:         pprerr(MESS(4018, "no such target in this workspace"));
 709:         return No;
 710:     } else {
 711:         value pname= permkey(name, Tar);
 712:         *fname= get_fname(pname);
 713:         if (!Is_filed(*aa)) {
 714:             putval(*fname, *aa, No);
 715:             tarfiled(name, *aa);
 716:         }
 717:         release(pname);
 718:         return Yes;
 719:     }
 720: }
 721: 
 722: /***************************** Values on files ****************************/
 723: 
 724: Hidden value
 725: getval(fname, ct)
 726:     value fname;
 727:     literal ct; /* context */
 728: {
 729:     char *buf= Nil; int k; parsetree e, code; value v= Vnil;
 730:     ifile= fopen(strval(fname), "r");
 731:     if (ifile) {
 732:         txptr fcol_save= first_col, tx_save= tx; context c;
 733:         sv_context(&c);
 734:         cntxt= ct;
 735:         buf= getmem((unsigned)(f_size(ifile)+2)*sizeof(char));
 736:         if (buf == Nil)
 737:             syserr(MESS(4019, "can't get buffer to read file"));
 738:         first_col= tx= ceol= buf;
 739:         while ((k= getc(ifile)) != EOF)
 740:             if (k != '\n') *ceol++= k;
 741:         *ceol= '\n';
 742:         fclose(ifile); vs_ifile();
 743:         e= expr(ceol);
 744:         if (still_ok) fix_nodes(&e, &code);
 745:         curline=e; curlino= one;
 746:         v= evalthread(code); curline= Vnil;
 747:         release(e);
 748:         if (buf != Nil) freemem((ptr) buf);
 749:         set_context(&c);
 750:         first_col= fcol_save; tx= tx_save;
 751:     } else {
 752:         error(CANT_READ);
 753:         vs_ifile();
 754:     }
 755:     return v;
 756: }
 757: 
 758: Visible Procedure
 759: getprmnv()
 760: {
 761:     intlet k, len; value name, fname; literal type;
 762:     if (f_exists(BPERMFILE)) {
 763:         value fn;
 764:         fn= mk_text(BPERMFILE);
 765:         b_perm= getval(fn, In_prmnv);
 766:         release(fn);
 767:         if (!still_ok) exit(1);
 768:         len= length(b_perm);
 769:         k_Over_len {
 770:             p_name_type(*key(b_perm, k), &name, &type);
 771:             if (type == Tar) tarfiled(name, Vnil);
 772:             fname= copy(*assoc(b_perm, k));
 773:             insert(fname, &file_names);
 774:             release(fname); release(name);
 775:         }
 776:     } else
 777:         b_perm= mk_elt();
 778: 
 779: #ifdef CONVERSION
 780:     if (f_exists(PRMNVFILE)) { /* convert from old to new format */
 781:         value tab, v, pname, new_fname();
 782:         value fn= mk_text(PRMNVFILE), save= mk_text(SAVEPRMNVFILE);
 783:         tab= getval(fn, In_prmnv);
 784:         if (!still_ok) exit(1);
 785:         len= length(tab);
 786:         k_Over_len {
 787:             name= copy(*key(tab, k));
 788:             v= copy(*assoc(tab, k));
 789:             def_target(name, v);
 790:             pname= permkey(name, Tar);
 791:             fname= get_fname(pname);
 792:             putval(fname, v, Yes);
 793:             tarfiled(name, v);
 794:             release(name); release(v); release(fname);
 795:             release(pname);
 796:         }
 797:         f_rename(fn, save);
 798:         if (len > 0)
 799:             printf("*** [Old permanent environment converted]\n");
 800:         release(tab); release(fn); release(save);
 801:     }
 802: #endif CONVERSION
 803: }
 804: 
 805: Hidden Procedure
 806: putval(fname, v, silently)
 807:     value fname, v; bool silently;
 808: {
 809:     FILE *ofile; value fn= mk_text(tempfile); bool was_ok= still_ok;
 810:     ofile= fopen(strval(fn), "w");
 811:     if (ofile != NULL) {
 812:         redirect(ofile);
 813:         still_ok= Yes;
 814:         wri(v, No, No, Yes); newline();
 815:         f_close(ofile);
 816:         redirect(stdout);
 817:         if (still_ok) f_rename(fn, fname);
 818:     } else if (!silently) error(CANT_WRITE);
 819:     still_ok= was_ok;
 820:     release(fn);
 821: }
 822: 
 823: Visible Procedure
 824: putprmnv()
 825: {
 826:     static bool active;
 827:     value v, name, fname, fn, *aa, pname; literal type;
 828:     int k, len;
 829:     if (active) return;
 830:     active= Yes;
 831:     len= length(b_perm);
 832:     for (k= len-1; k>=0; --k) {
 833:         p_name_type(*key(b_perm, k), &name, &type);
 834:         if (type == Tar && !t_exists(name, &aa))
 835:             free_perm(*key(b_perm, k));
 836:         release(name);
 837:     }
 838:     len= length(prmnv->tab);
 839:     k_Over_len {
 840:         v= copy(*assoc(prmnv->tab, k));
 841:         if (!Is_filed(v)) {
 842:             name= copy(*key(prmnv->tab, k));
 843:             pname= permkey(name, Tar);
 844:             fname= get_fname(pname);
 845:             putval(fname, v, Yes);
 846:             tarfiled(name, v);
 847:             release(name); release(fname); release(pname);
 848:         }
 849:         release(v);
 850:     }
 851:     fn= mk_text(BPERMFILE);
 852:     putval(fn, b_perm, Yes);
 853:     /* Remove the file if the permanent environment is empty */
 854:     if (length(b_perm) == 0) f_delete(fn);
 855:     release(fn);
 856:     active= No;
 857: }
 858: 
 859: Visible Procedure
 860: initsou()
 861: {
 862:     b_units= mk_elt();
 863:     file_names= mk_elt();
 864: }
 865: 
 866: Visible Procedure
 867: endsou()
 868: {
 869:     /* Release everything around so "memory leakage" can be detected */
 870:     release(b_units); b_units= Vnil;
 871:     release(b_perm); b_perm= Vnil;
 872:     release(file_names); file_names= Vnil;
 873:     release(last_tname); last_tname= Vnil;
 874: }
 875: 
 876: Visible Procedure
 877: lst_uhds()
 878: {
 879:     intlet k, len= length(b_perm); int c;
 880:     value name; literal type;
 881:     k_Over_len {
 882:         p_name_type(*key(b_perm, k), &name, &type);
 883:         if (type != Tar) {
 884:             FILE *fn= fopen(strval(*assoc(b_perm, k)), "r");
 885:             if (fn) {
 886:                 while ((c= getc(fn)) != EOF && c != '\n')
 887:                     putc(c, stdout);
 888:                 putc('\n', stdout);
 889:                 fclose(fn);
 890:             }
 891:         }
 892:         release(name);
 893:     }
 894:     len= length(b_units);
 895:     k_Over_len {
 896:         how *u= How_to(*assoc(b_units, k));
 897: #ifndef TRY
 898:         value *aa;
 899:         if (u -> filed == No && !p_exists(*key(b_units, k), &aa))
 900: #else
 901:         if (u -> filed == No)
 902: #endif
 903:             display(stdout, u -> unit, Yes);
 904:     }
 905:     fflush(stdout);
 906: }

Defined functions

create_unit defined in line 310; used 1 times
def_perm defined in line 118; used 1 times
def_target defined in line 600; used 3 times
def_unit defined in line 38; used 5 times
del_units defined in line 52; used 2 times
ed_target defined in line 667; used 1 times
ed_unit defined in line 433; used 3 times
edit_target defined in line 644; used 1 times
edit_unit defined in line 387; used 1 times
endsou defined in line 866; used 1 times
ens_filed defined in line 534; used 2 times
ens_tfiled defined in line 702; used 2 times
err_line defined in line 566; used 3 times
free_perm defined in line 126; used 5 times
free_target defined in line 607; used 1 times
free_unit defined in line 45; used 6 times
get_fname defined in line 138; used 6 times
get_heading defined in line 300; used 1 times
get_unit defined in line 270; used 4 times
getprmnv defined in line 758; used 1 times
getval defined in line 724; used 6 times
how_unit defined in line 165; used 2 times
initsou defined in line 859; used 2 times
is_loaded defined in line 189; used 1 times
lst_uhds defined in line 876; used 1 times
p_exists defined in line 109; used 13 times
p_name_type defined in line 75; used 10 times
p_version defined in line 154; used 6 times
putval defined in line 805; used 4 times
rem_unit defined in line 64; used 2 times
still_there defined in line 509; used 3 times
t_exists defined in line 593; used 2 times
tarfiled defined in line 614; used 4 times
u_exists defined in line 31; used 3 times
u_name_type defined in line 249; used 2 times
zermon_units defined in line 175; used 2 times

Defined variables

DISCARD defined in line 239; used 2 times
MONADIC defined in line 383; used 1 times
MON_ZER defined in line 428; used 1 times
NO_T_WRITE defined in line 663; used 1 times
NO_U_WRITE defined in line 419; used 1 times
ZEROADIC defined in line 379; used 1 times
ZER_MON defined in line 423; used 1 times
b_perm defined in line 28; used 18 times
b_units defined in line 29; used 12 times
file_names defined in line 116; used 7 times
last_tname defined in line 642; used 8 times

Defined macros

CANT_READ defined in line 245; used 1 times
CANT_WRITE defined in line 242; used 3 times
MON_VERSION defined in line 246; used 1 times
ZER_VERSION defined in line 247; used 1 times
Last modified: 1985-08-27
Generated: 2016-12-26
Generated by src2html V0.67
page hit count: 6638
Valid CSS Valid XHTML 1.0 Strict