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: }