![[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.