![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to b3sou.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / contrib / B / src / bint|
Return to b3sou.c CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / B / src / bint |
1.1 ! root 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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.