# 2.11BSD#431 - /usr/src/new/PORT/B/src/bint/b3sou.c

##### Functions

    create_unit       X
    def_perm          X
    def_target        X
    def_unit          X
    del_units         X
    ed_target         X
    ed_unit           X
    edit_target       X
    edit_unit         X
    endsou            X
    ens_filed         X
    ens_tfiled        X
    err_line          X
    free_perm         X
    free_target       X
    free_unit         X
    get_fname         X
    get_heading       X
    get_pname         X
    get_unit          X
    getprmnv          X
    getval            X
    how_unit          X
    initsou           X
    is_loaded         X
    is_unit           X
    lst_uhds          X
    p_exists          X
    p_name_type       X
    p_version         X
    permkey           X
    putprmnv          X
    putval            X
    rem_unit          X
    still_there       X
    t_exists          X
    tarfiled          X
    tarvalue          X
    u_exists          X
    u_name_type       X
    zermon_units      X

##### Variables

    DISCARD           X
    MONADIC           X
    MON_ZER           X
    NO_T_WRITE        X
    NO_U_WRITE        X
    ZEROADIC          X
    ZER_MON           X
    b_perm            X
    b_units           X
    file_names        X
    last_tname        X

##### Macros

    CANT_READ         X
    CANT_WRITE        X
    MON_VERSION       X
    ZER_VERSION       X

       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

- in /usr/src/new/PORT/B/src/bint/b3mai.c line 294

def_perm defined in line 118; used 1 times

- in line 148

def_target defined in line 600; used 3 times

- in line 619, 698, 789

def_unit defined in line 38; used 5 times

- in line 204, 316, 487
- in /usr/src/new/PORT/B/src/bint/b3fpr.c line 112, 126

del_units defined in line 52; used 2 times

- in line 456, 486

ed_target defined in line 667; used 1 times

- in line 657

ed_unit defined in line 433; used 3 times

- in line 351, 413, 499

edit_target defined in line 644; used 1 times

- in /usr/src/new/PORT/B/src/bint/b3mai.c line 264

edit_unit defined in line 387; used 1 times

- in /usr/src/new/PORT/B/src/bint/b3mai.c line 260

endsou defined in line 866; used 1 times

- in /usr/src/new/PORT/B/src/bint/b3mai.c line 230

ens_filed defined in line 534; used 2 times

- in line 390, 412

ens_tfiled defined in line 702; used 2 times

- in line 647, 656

err_line defined in line 566; used 3 times

- in line 439, 450-452(2)

free_perm defined in line 126; used 5 times

- in line 326, 458, 492, 690, 835

free_target defined in line 607; used 1 times

- in line 689

free_unit defined in line 45; used 6 times

- in line 59, 69, 325, 455, 476, 488

get_fname defined in line 138; used 6 times

- in line 343, 490, 551, 712, 791, 844

get_heading defined in line 300; used 1 times

- in line 320

get_pname defined in line 289; used 5 times

- in line 68, 305
- in /usr/src/new/PORT/B/src/bint/b2ana.c line 44
- in /usr/src/new/PORT/B/src/bint/b3sou.h line 12
- in /usr/src/new/PORT/B/src/bint/b3sta.c line 464

get_unit defined in line 270; used 4 times

- in line 193, 203, 315, 464

getprmnv defined in line 758; used 1 times

- in /usr/src/new/PORT/B/src/bint/b3mai.c line 222

getval defined in line 724; used 6 times

- in line 627, 635, 680, 697, 765, 783

how_unit defined in line 165; used 2 times

- in line 456, 486

initsou defined in line 859; used 2 times

- in /usr/src/new/PORT/B/src/bint/b3mai.c line 192, 200

is_loaded defined in line 189; used 1 times

- in line 231

is_unit defined in line 222; used 5 times

- in /usr/src/new/PORT/B/src/bint/b2gen.c line 530
- in /usr/src/new/PORT/B/src/bint/b3fpr.c line 133
- in /usr/src/new/PORT/B/src/bint/b3sou.h line 9
- in /usr/src/new/PORT/B/src/bint/b3sta.c line 446, 514

lst_uhds defined in line 876; used 1 times

- in /usr/src/new/PORT/B/src/bint/b3mai.c line 259

p_exists defined in line 109; used 13 times

- in line 131, 143, 160, 195, 323, 469-470(2), 498, 539, 632, 899
- in /usr/src/new/PORT/B/src/bint/b3err.c line 222
- in /usr/src/new/PORT/B/src/bint/b3sou.h line 11

p_name_type defined in line 75; used 10 times

- in line 146, 170, 180, 210, 335, 474, 770, 833, 882
- in /usr/src/new/PORT/B/src/bint/b3err.c line 205

p_version defined in line 154; used 6 times

- in line 181-182(2), 398-403(4)

permkey defined in line 91; used 19 times

- in line 159, 230, 278, 295, 396, 407, 631, 688, 711, 790, 843
- in /usr/src/new/PORT/B/src/bint/b2uni.c line 68, 202, 214, 226
- in /usr/src/new/PORT/B/src/bint/b3fpr.c line 111, 125
- in /usr/src/new/PORT/B/src/bint/b3sou.h line 10
- in /usr/src/new/PORT/B/src/bint/b3sta.c line 538

putprmnv defined in line 823; used 3 times

- in /usr/src/new/PORT/B/src/bint/b3err.c line 409
- in /usr/src/new/PORT/B/src/bint/b3sig.c line 77, 99

putval defined in line 805; used 4 times

- in line 714, 792, 845, 852

rem_unit defined in line 64; used 2 times

- in /usr/src/new/PORT/B/src/bint/b3sta.c line 458, 520

still_there defined in line 509; used 3 times

- in line 440, 454, 687

t_exists defined in line 593; used 2 times

- in line 707, 834

tarfiled defined in line 614; used 4 times

- in line 715, 771, 793, 846

tarvalue defined in line 623; used 3 times

- in /usr/src/new/PORT/B/src/bint/b3in2.c line 80
- in /usr/src/new/PORT/B/src/bint/b3loc.c line 55
- in /usr/src/new/PORT/B/src/bint/b3sou.h line 13

u_exists defined in line 31; used 3 times

- in line 194, 208, 542

u_name_type defined in line 249; used 2 times

- in line 277, 294

zermon_units defined in line 175; used 2 times

- in line 333, 472

#### Defined variables

DISCARD defined in line 239; used 2 times

- in line 324, 471

MONADIC defined in line 383; used 1 times

- in line 403

MON_ZER defined in line 428; used 1 times

- in line 475

NO_T_WRITE defined in line 663; used 1 times

- in line 681

NO_U_WRITE defined in line 419; used 1 times

- in line 442

ZEROADIC defined in line 379; used 1 times

- in line 399

ZER_MON defined in line 423; used 1 times

- in line 475

b_perm defined in line 28; used 18 times

- in line 113, 122, 134, 765-777(5), 831-835(3), 852-854(2), 871(2), 879-884(3)

b_units defined in line 29; used 12 times

- in line 35, 42, 49, 55-59(3), 862, 870(2), 894-899(3)

file_names defined in line 116; used 7 times

- in line 123(2), 132, 773, 863, 872(2)

last_tname defined in line 642; used 8 times

- in line 650-653(2), 692-695(4), 873(2)

#### Defined macros

CANT_READ defined in line 245; used 1 times

- in line 752

CANT_WRITE defined in line 242; used 3 times

- in line 345, 554, 818

MON_VERSION defined in line 246; used 1 times

- in line 337

ZER_VERSION defined in line 247; used 1 times

- in line 338

Last modified: 1985-08-27 Generated: 2016-12-26 | Generated by src2html V0.67 page hit count: 3339 |