$CONTROL SUBPROGRAM,USLINIT,MAP,CODE                           <<S7468>>00010000
<< initial - utility routines >>                                        00012000
<< hp32002c mpe source c.00.00 >>                                       00014000
$copyright     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1980. ",            & 00016000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00018000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00020000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00022000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00024000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."   00026000
begin                                                                   00028000
$control segment=initutil                                               00030000
                                                                        00032000
<<----------------------------------------------------------------->>   00034000
<<                 initial    utility procedures                   >>   00036000
<<    these procedures are used by initial iii and icf version.    >>   00038000
<<----------------------------------------------------------------->>   00040000
                                                               <<sy>>   00042000
                                                               <<sy>>   00044000
     <<******************************************************>><<sy>>   00046000
     <<    global arrays and variable shared with initial    >><<sy>>   00048000
     <<******************************************************>><<sy>>   00050000
                                                               <<sy>>   00052000
     define ext'dcl =                                          <<sy>>   00054000
                external integer pointer                       <<sy>>   00056000
                                                               <<sy>>   00058000
                         buf',                                 <<sy>>   00060000
                         lbuf',                                <<sy>>   00062000
                         flab',                                <<sy>>   00064000
                         mhinfo',                              <<sy>>   00066000
                         reassigned',                          <<sy>>   00068000
                                                               <<sy>>   00070000
                         lpdt,                                 <<sy>>   00072000
                         ldt,                                  <<sy>>   00074000
                         vtab;                                 <<sy>>   00076000
                                                               <<sy>>   00078000
                external logical listpurge                     <<sy>>   00080000
                                                               <<sy>>   00082000
                << end of external declarations >> #;          <<sy>>   00084000
                                                               <<sy>>   00086000
     <<******************************************************>><<sy>>   00088000
     <<     end external  -   start of global equates        >><<sy>>   00090000
     <<******************************************************>><<sy>>   00092000
                                                               <<sy>>   00094000
   logical   status       =   q-1,                             <<sy>>   00096000
             stat         =   q-1;                             <<sy>>   00098000
                                                               <<sy>>   00100000
   integer   x            =   x,                               <<sy>>   00102000
             s0           =   s-0,                             <<sy>>   00104000
             s1           =   s-1,                             <<sy>>   00106000
             s2           =   s-2,                             <<sy>>   00108000
             s3           =   s-3,                             <<sy>>   00110000
             s4           =   s-4,                             <<sy>>   00112000
             s5           =   s-5,                             <<sy>>   00114000
             xreg         =   x,                               <<sy>>   00116000
             deltaq       =   q-0;                             <<sy>>   00118000
logical  xr = x;                                               <<s7468>>00120000
                                                               <<sy>>   00122000
   double    ds0          =   s-1,                             <<sy>>   00124000
             ds1          =   s-1,                             <<sy>>   00126000
             ds3          =   s-3,                             <<sy>>   00128000
             ds5          =   s-5,                             <<sy>>   00130000
             ds6          =   s-6;                             <<sy>>   00132000
                                                               <<sy>>   00134000
   define    carryx       =   stat.(5:1) #,                    <<sy>>   00136000
             asmb         =   assemble #,                      <<sy>>   00138000
             cc           =   stat.(6:2) #;                    <<sy>>   00140000
   equate    ccg          =   0,                               <<sy>>   00142000
             ccl          =   1,                               <<sy>>   00144000
             cce          =   2,                               <<sy>>   00146000
                                                               <<sy>>   00148000
             cstix        =    1,  <<cst table>>               <<sy>>   00150000
             dstix        =    2,  <<dst table>>               <<sy>>   00152000
             sysdisc      =    1,  <<ldev for system disc>>    <<sy>>   00154000
             write        =    1,                              <<sy>>   00156000
             read         =    0,                              <<sy>>   00158000
             dirdstn      =   20,                              <<sy>>   00160000
             filetype     =    0;                              <<sy>>   00162000
                                                               <<sy>>   00164000
   pointer   s0pntr       =   s-0;                             <<sy>>   00166000
                                                               <<sy>>   00168000
   integer pointer                                             <<sy>>   00170000
             ps0          =   s-0,                             <<sy>>   00172000
             ps1          =   s-1,                             <<sy>>   00174000
             ps4          =   s-4,                             <<sy>>   00176000
             s0ipntr      =   s-0,                             <<sy>>   00178000
             dst          =   dstix;  << data segment table >> <<sy>>   00180000
                                                               <<sy>>   00182000
   double pointer                                              <<sy>>   00184000
             dps0         =   s-0,                             <<sy>>   00186000
             dps2         =   s-2;                             <<sy>>   00188000
                                                               <<sy>>   00190000
   define nreass          =   reassigned'(0) #;                <<sy>>   00192000
   define flmiscx         =   28 #,                            <<sy>>   00194000
          flchecksumx     =   34 #,                            <<sy>>   00196000
          flclidx         =   35 #,                            <<sy>>   00198000
          flchecksum      =   flab'(34) #,                     <<sy>>   00200000
          checksum        =                                    <<sy>>   00202000
                x := 127;                                      <<sy>>   00204000
                tos := -1;                                     <<sy>>   00206000
                do begin                                       <<sy>>   00208000
                   if x <> flchecksumx and                     <<sy>>   00210000
                      x <> flmiscx and x <> flclidx            <<sy>>   00212000
                      then tos:=tos xor logical(flab'(x));     <<sy>>   00214000
                   x := x - 1;                                 <<ss>>   00216000
                   end until < #;                              <<sy>>   00218000
                                                               <<sy>>   00220000
  equate    nmhsubtypes   =  14,                               <<sy>>   00222000
            mhdisctype    =  0,                                <<sy>>   00224000
            nfhsubtypes   =  3,                                <<sy>>   00226000
            nfhsubtypesp1 =  nfhsubtypes+1,                    <<sy>>   00228000
            nmhsubtypesp1 =  nmhsubtypes+1,                    <<sy>>   00230000
            mhsectrk      =  3,   << sectors/track >>          <<sy>>   00232000
            mhinfosize    =  7,                                <<sy>>   00234000
                                                               <<sy>>   00236000
            disc0         =  0,   << moving head disc >>       <<sy>>   00238000
            disc1         =  1,   << fixed  head disc >>       <<sy>>   00240000
                                                                        00242000
         << error message numbers >>                           <<sy>>   00244000
            m275          =  275,                              <<sy>>   00246000
            m276          =  276,                              <<sy>>   00248000
            m328          =  328;                              <<sy>>   00250000
$page "DIRECTORY DATA STRUCTURE "                              <<sy>>   00252000
                                                               <<sy>>   00254000
           <<------------------------>>                        <<sy>>   00256000
           << directory data segment >>                        <<sy>>   00258000
           <<------------------------>>                        <<sy>>   00260000
                                                               <<de>>   00262000
equate  << directory block sizes >>                            <<de>>   00264000
                                                               <<de>>   00266000
   syssaibsize  =  3,      << sysaccount index block size>>    <<de>>   00268000
   sysauibsize  =  1,      << account/user  index block  >>    <<de>>   00270000
   sysagibsize  =  1,      << account/group index block  >>    <<de>>   00272000
   sysgfibsize  =  2,      << group/files   index block  >>    <<de>>   00274000
   sysgvsibsize =  1,      << group/vsd     index block  >>    <<de>>   00276000
   sysaebsize   =  3,      << account entry block size   >>    <<de>>   00278000
   sysuebsize   =  2,      << user    entry block size   >>    <<de>>   00280000
   sysgebsize   =  2,      << group   entry block size   >>    <<de>>   00282000
   sysfebsize   =  2,      << files   entry block size   >>    <<de>>   00284000
   sysvsebsize  =  1,      << vsd     etnry block size   >>    <<de>>   00286000
   ddsbsize     =  3,      << maximum block sector size  >>    <<de>>   00288000
   ddsbwsize    = %600;    << maximum block word  size   >>    <<de>>   00290000
                                                                        00292000
equate                                                                  00294000
   namesize        = 4,                  <<unpacked representation>>    00296000
                   <<entry equates>>                                    00298000
<< account entry >>                                                     00300000
   aname           = 0,                  <<name>>                       00302000
   agipntr         = aname+namesize,     <<group index pntr>>           00304000
   auipntr         = agipntr+1,          <<user index pntr>>            00306000
   acap            = auipntr+1,          <<capability>>                 00308000
   alattr          = acap+2,                                            00310000
   apass           = alattr+2,                                          00312000
   adfscount       = apass+namesize,     <<disc file space>>            00314000
   adfscountd      = adfscount /2,                                      00316000
   adfslimit       = adfscount+2,                                       00318000
   acpucount       = adfslimit+2,        <<cpu time>>                   00320000
   acpulimit       = acpucount+2,                                       00322000
   acontimecount   = acpulimit+2,        <<connect time>>               00324000
   acontimelimit   = acontimecount+2,                                   00326000
   asecw           = acontimelimit+2,                                   00328000
   amaxjobw        = asecw+1,            <<max. job priority (byte) >>  00330000
   aspare1         = amaxjobw+1,                               <<04733>>00332000
   aspare2         = aspare1+1,                                <<04733>>00334000
   asize           = aspare2+1,                                <<04733>>00336000
<<group entry>>                                                         00338000
   gname           = 0,                  <<name>>                       00340000
   gfipntr         = gname+namesize,     <<file index (or volume) pntr>>00342000
   gpass           = gfipntr+1,          <<password>>                   00344000
   gdfscount       = gpass+namesize,     <<disc file space>>            00346000
   gdfslimit       = gdfscount+2,                                       00348000
   gcpucount       = gdfslimit+2,        <<cpu time>>                   00350000
   gcpulimit       = gcpucount+2,                                       00352000
   gcontimecount   = gcpulimit+2,                                       00354000
   gcontimelimit   = gcontimecount+2,                                   00356000
   gsec            = gcontimelimit+2,                                   00358000
   gcap            = gsec+2,                                            00360000
   glinkage        = gcap+1,                                   <<04733>>00362000
   gvsdipntr       = glinkage+1,         <<vs def index pntr>> <<04733>>00364000
   ghvsname        = gvsdipntr+1,        <<home vs name>>      <<04733>>00366000
   ghvsaname       = ghvsname,           << "   "  acct name>> <<04733>>00368000
   ghvsgname       = ghvsaname+namesize, << "   "  grp  name>> <<04733>>00370000
   ghvsvsname      = ghvsgname+namesize, << "   "  vs   name>> <<04733>>00372000
   gsavefipntr     = ghvsvsname+namesize,<<saves gfipntr>>     <<04733>>00374000
   gmountrefcntr   = gsavefipntr+1,      <<mount ref counter>> <<04733>>00376000
   gspare          = gmountrefcntr+1,                          <<04733>>00378000
   gsize           = gspare+1;                                 <<04733>>00380000
<<glinkage definitions>>                                       <<04733>>00382000
define                                                         <<04733>>00384000
   pvf             = 0:1 #,                                    <<04733>>00386000
   mvtabxf         = 8:8 #;                                    <<04733>>00388000
equate                                                         <<04733>>00390000
   pv              = 1,                                        <<04733>>00392000
   vmax            = 8,                  <<vs membership max>> <<04733>>00394000
<<file entry >>                                                         00396000
   fname           = 0,                  <<name>>                       00398000
   fvolpntrw       = fname+namesize,     <<volume table pointer>>       00400000
   flabelpntrw     = fvolpntrw,          <<file label pointer>>         00402000
   fsize           = flabelpntrw+2,                                     00404000
<<user entry>>                                                          00406000
   uname           = 0,                  <<name>>                       00408000
   ucap            = uname+namesize,     <<capability>>                 00410000
   ulattr          = ucap+2,                                            00412000
   upass           = ulattr+2,                                          00414000
   uhgroup         = upass+namesize,     <<home group>>                 00416000
   ulogcount       = uhgroup+namesize,   <<# of users logged on under>> 00418000
   umaxjob         = ulogcount+1,                                       00420000
   uspare          = umaxjob+1,                                         00422000
   usize           = uspare+1,                                          00424000
<<volume set definition entry>>                                <<04733>>00426000
   gvsname         = 0,                  <<volume set name>>   <<04733>>00428000
   gvslinkagew     = gvsname+namesize,   <<mvtab linkage>>     <<04733>>00430000
   gvsinfo         = gvslinkagew+1,      <<definition info>>   <<04733>>00432000
   gvsmembers      = gvsinfo+1,          <<vmax members>>      <<04733>>00434000
                                         <<member info>>       <<04733>>00436000
                                         <<vmax members>>      <<04733>>00438000
   gvsvolname      = gvsmembers,         <<member name>>       <<04733>>00440000
   gvsdrefcnt      = (gvsinfo-gvsname+1)*(vmax+1),             <<04733>>00442000
   gvsdspare2      = gvsdrefcnt+1,                             <<04733>>00444000
   gvsdsize        = gvsdspare2+1,                             <<04733>>00446000
                                                               <<04733>>00448000
<<volume class definition entry>>                              <<04733>>00450000
   gvcname        = 0,                   <<volume class name>> <<04733>>00452000
   gvclinkagew     = gvcname+namesize,                         <<04733>>00454000
   gvcinfo         = gvclinkagew+1,      <<definition info>>   <<04733>>00456000
   gvcpname        = gvcinfo+1,          <<parent def  name>>  <<04733>>00458000
   gvcpaname       = gvcpname,           <<  "    ACCT   " >>  <<04733>>00460000
   gvcpgname       = gvcpaname+namesize, <<  "    GRP    " >>  <<04733>>00462000
   ie1stname       = 0,                  <<1st name of entry block>>    00464000
   iepntr          = ie1stname+namesize, <<pntr to it >>                00466000
   iecount         = iepntr+1,           <<# of entries in it>>         00468000
   isize           = iecount+1;                                         00470000
equate                                                                  00472000
   premiscwd       = 0;                                                 00474000
define                                                                  00476000
   typef           = 0:1 #;                                             00478000
equate                                                                  00480000
   indextype       = 1,                                                 00482000
   entrytype       = 0;                                                 00484000
define                                                                  00486000
   levelf          = 2:3 #;                                    <<04733>>00488000
equate                                                                  00490000
   filelevel       = 0,                                                 00492000
   grouplevel      = 1,                                                 00494000
   accountlevel    = 2,                                                 00496000
   userlevel       = 3,                                        <<04733>>00498000
   vsdeflevel      = 4;                                        <<04733>>00500000
define                                                                  00502000
   xsizef          = 5:7 #,                                    <<04733>>00504000
   bsizef          = 12:4 #;                                   <<04733>>00506000
equate                                                                  00508000
   prexcount       = premiscwd+1,        <<element count>>              00510000
   prepcount       = prexcount+1,        <<pointer ref. count>>         00512000
   preetotal       = prepcount+1,        <<total entries count >>       00514000
   preemiscwd      = preetotal+1,                                       00516000
   prepindexp      = preemiscwd+1,       <<index pntr in which father>> 00518000
   prepname        = prepindexp+1,       <<father's name (if any)>>     00520000
   presize         = prepname+namesize;                                 00522000
equate                                                                  00524000
   xx              = 22,                                                00526000
   zz              = 139;                                      <<04733>>00528000
equate                                                                  00530000
   ddsdst          = 20;                                                00532000
array                                                                   00534000
   dds(*)          = db+0,                                              00536000
   ddsentry(*)     = dds,                                               00538000
   ddsname(*)      = dds,                                               00540000
   workarea (*)    = dds(128);                                          00542000
integer           << variables set by dirstartoff >>                    00544000
   adjust         = workarea,            <<dl-db>>                      00546000
   xtype          = adjust +1;           <<input parm>>        <<04733>>00548000
double                                                         <<04733>>00550000
   xlinkage'indexp= xtype+1;                                   <<04733>>00552000
integer                                                        <<04733>>00554000
   xmvtabx        = xlinkage'indexp,                           <<04733>>00556000
   xindexp        = xmvtabx+1,           <<final index pntr>>  <<04733>>00558000
   xaname         = xindexp +1,          <<db-rel addrs>>               00560000
   xguname        = xaname +1,                                          00562000
   xfname         = xguname +1,                                         00564000
   xasec          = xfname +1;           <<acct security>>              00566000
double                                                                  00568000
   xgsec          = xasec +1;            <<group security>>             00570000
logical                                                                 00572000
   sirreturn      = xgsec +2;            <<from getsir>>                00574000
equate                                   <<disps into prepre>>          00576000
   dirbase'        = 0,                  <<dirbase of content>><<04733>>00578000
   dirbase1'       = dirbase',                                 <<04733>>00580000
   dirbase2'       = dirbase1'+1,                              <<04733>>00582000
   contents        = dirbase2'+1,        <<directory p. pntr>> <<04733>>00584000
   lpntr           = contents+1,         <<db addr of 1st element>>     00586000
   iopntr          = lpntr+1,            <<block starting addr>>        00588000
   numvalid        = iopntr+1,           <<# valid dir pp after iopntr>>00590000
   dirty           = numvalid+1,                                        00592000
   xsize           = dirty+1,                                           00594000
   used            = xsize+1,            <<=xsize * xcount>>            00596000
   bsize           = used+1,             <<block size (pp.)>>           00598000
   bwsize          = bsize+1,            <<= bsize & lsr(7)>>           00600000
   bfactor         = bwsize+1,           <<= bwsize/xsize>>             00602000
   miscwd          = bfactor+1,                                         00604000
   xcount          = miscwd+1,                                          00606000
   pcount          = xcount+1,                                          00608000
   etotal          = pcount+1,                                          00610000
   emiscwd         = etotal+1,                                          00612000
   pindexp         = emiscwd+1,                                         00614000
   pname           = pindexp+1;                                         00616000
array                                                                   00618000
   daprepre(*)     = dds(zz);                                           00620000
logical                                                                 00622000
   dacontents      = daprepre+contents;                                 00624000
logical pointer                                                         00626000
   dalpntr         = daprepre+lpntr,                                    00628000
   daiopntr        = daprepre+iopntr;                                   00630000
integer                                                                 00632000
   danumvalid      = daprepre+numvalid;                                 00634000
logical                                                                 00636000
   dadirty         = daprepre+dirty;                                    00638000
integer                                                                 00640000
   daxsize         = daprepre+xsize,                                    00642000
   daused          = daprepre+used,                                     00644000
   dabsize         = daprepre+bsize,                                    00646000
   dabwsize        = daprepre+bwsize,                                   00648000
   dabfactor       = daprepre+bfactor,                                  00650000
   damiscwd        = daprepre+miscwd;                                   00652000
integer                                                                 00654000
   daxcount        = daprepre+xcount;                          <<04733>>00656000
array                                                                   00658000
   dapname (*)     = daprepre(pname);                                   00660000
array                                                                   00662000
   dbprepre (*)    = daprepre(xx);                                      00664000
logical                                                                 00666000
   dbcontents      = dbprepre+contents;                                 00668000
logical pointer                                                         00670000
   dblpntr         = dbprepre+lpntr,                                    00672000
   dbiopntr        = dbprepre+iopntr;                                   00674000
integer                                                                 00676000
   dbnumvalid      = dbprepre+numvalid;                                 00678000
logical                                                                 00680000
   dbdirty         = dbprepre+dirty;                                    00682000
integer                                                                 00684000
   dbxsize         = dbprepre+xsize,                                    00686000
   dbused          = dbprepre+used,                                     00688000
   dbbsize         = dbprepre+bsize,                                    00690000
   dbbwsize        = dbprepre+bwsize,                                   00692000
   dbbfactor       = dbprepre+bfactor,                                  00694000
   dbmiscwd        = dbprepre+miscwd;                                   00696000
integer                                                                 00698000
   dbxcount        = dbprepre+xcount,                                   00700000
   dbpcount        = dbprepre+pcount;                                   00702000
logical                                                                 00704000
   dbetotal        = dbprepre+etotal,                                   00706000
   dbemiscwd       = dbprepre+emiscwd;                                  00708000
define                                                                  00710000
   dbelevel        = integer (dbemiscwd.(levelf)) #,                    00712000
   dbexsize        = integer (dbemiscwd.(xsizef)) #,                    00714000
   dbebsize        = integer (dbemiscwd.(bsizef)) #;                    00716000
logical                                                                 00718000
   dbpindexp       = dbprepre+pindexp;                                  00720000
array                                                                   00722000
   dbpname (*)     = dbprepre(pname);                                   00724000
integer                                                        <<04733>>00726000
   sysacctindex    = dbprepre + xx; <<index to sysacctindex>>  <<de>>   00728000
double                                                                  00730000
   dirbase         = sysacctindex+1;                           <<de>>   00732000
                                                               <<de>>   00734000
integer                                                        <<de>>   00736000
   sysacctinx'sav  = dirbase+2,                                <<de>>   00738000
   dds'cnt         = sysacctinx'sav+1;                         <<de>>   00740000
                                                               <<de>>   00742000
double                                                         <<de>>   00744000
   dds'cnt1        = dds'cnt+1,                                <<de>>   00746000
   dds'cnt2        = dds'cnt1+2,                               <<de>>   00748000
   dds'cnt3        = dds'cnt2+2,                               <<de>>   00750000
   dds'cnt4        = dds'cnt3+2,                               <<de>>   00752000
   dds'cnt5        = dds'cnt4+2;                               <<de>>   00754000
                                                               <<de>>   00756000
real                                                           <<de>>   00758000
   goodpercent     = dds'cnt5+2;                               <<de>>   00760000
                                                               <<de>>   00762000
logical pointer                                                         00764000
   base            = goodpercent+2;                                     00766000
integer pointer                                                         00768000
   ibase           = base;                                              00770000
define                                                                  00772000
   whichdirty = base(dirty) #;                                          00774000
                                                               <<de>>   00776000
                                                               <<de>>   00778000
<<----------------------------------------------------------->><<s7468>>00780000
<< directory space management data segment defines           >><<s7468>>00782000
<<----------------------------------------------------------->><<s7468>>00784000
                                                               <<s7468>>00786000
<< directory space management control data                   >><<s7468>>00788000
                                                               <<s7468>>00790000
logical  ds'base         = db + 0;                             <<s7468>>00792000
double   ds'dir'addr     = ds'base;            << dir. addr. >><<s7468>>00794000
define   ds'ldev         = ds'base.(0:8)#;     << dir. ldev  >><<s7468>>00796000
logical  ds'last'word    = ds'dir'addr + 2;    << buf. last w>><<s7468>>00798000
pointer  ds'first'word   = ds'last'word + 1;   << buf. firs.w>><<s7468>>00800000
logical  ds'dir'size     = ds'first'word + 1;  << dir. size  >><<s7468>>00802000
logical  ds'flags        = ds'dir'size + 1;    << dsm flags  >><<s7468>>00804000
define   ds'dirty        = ds'flags.(0:1)#;    << buf. mod.  >><<s7468>>00806000
define   ds'err'in'prog  = ds'flags.(1:1)#;    << in progress>><<s7468>>00808000
define   ds'dir'disabled = ds'flags.(2:1)#;    << sys. disabl>><<s7468>>00810000
define   ds'perm'disable = ds'flags.(3:1)#;    << perm. dis. >><<s7468>>00812000
logical  ds'cur'sector   = ds'flags + 1;       << sec. in buf>><<s7468>>00814000
double   ds'addr         = ds'cur'sector + 1;  << sec. addr. >><<s7468>>00816000
integer  ds'addr1        = ds'addr;                            <<s7468>>00818000
integer  ds'addr2        = ds'addr + 1;                        <<s7468>>00820000
integer  ds'size         = ds'addr + 2;        << buf data sz>><<s7468>>00822000
logical  ds'req'sector   = ds'size + 1;        << requested s>><<s7468>>00824000
logical  ds'last'sector  = ds'req'sector + 1;  << bm last sec>><<s7468>>00826000
logical  ds'sys'last     = ds'last'sector + 1; << saved buf p>><<s7468>>00828000
logical  ds'sys'first    = ds'sys'last + 1;    << saved buf p>><<s7468>>00830000
logical  ds'sys'cur      = ds'sys'first + 1;   << saved buf s>><<s7468>>00832000
logical  ds'sys'size     = ds'sys'cur + 1;     << sys dir siz>><<s7468>>00834000
logical  ds'error'ldev   = ds'sys'size + 1;    << bad dir ldv>><<s7468>>00836000
logical  ds'error'type   = ds'error'ldev + 1;  << dir err typ>><<s7468>>00838000
define   ds'header       = 18#;                << ds head sz >><<s7468>>00840000
                                                               <<s7468>>00842000
<< buffer area                                               >><<s7468>>00844000
                                                               <<s7468>>00846000
array    ds'buffer (*)   = db + ds'header;     << buffer     >><<s7468>>00848000
logical  ds'dir'last     = ds'buffer;          << sector 0 lw>><<s7468>>00850000
logical  ds'dir'first    = ds'dir'last + 1;    << sector 0 fw>><<s7468>>00852000
define   ds'dir'header   = 2#;                 << bm header  >><<s7468>>00854000
define   ds'buf'size's   = 3#;                 << buf sz sec.>><<s7468>>00856000
define   ds'buf'size'w   = %600#;              << buf sz word>><<s7468>>00858000
define   ds'dst          = %25#;               << dsm dst    >><<s7468>>00860000
                                                               <<s7468>>00862000
<<----------------------------------------------------------->><<s7468>>00864000
                                                               <<de>>   00866000
                                                               <<de>>   00868000
<< flags to directory routines >>                                       00870000
equate                                                                  00872000
   a               = 0,                  <<block a>>                    00874000
   b               = 1,                                                 00876000
   e               = 0,                  <<exact search>>               00878000
   en              = 2,                  <<exact or next search>>       00880000
   ep              = 4,                  <<exact or preceeding search>> 00882000
   ea              = e+a,                                               00884000
   ena             = en+a,                                              00886000
   enb             = en+b,                                              00888000
   epb             = ep+b;                                              00890000
define                                                                  00892000
   startlevelf     = 13:3 #,                                            00894000
   endlevelf       = 10:3 #,                                   <<04733>>00896000
   allflag         = 9:1#,                                     <<04733>>00898000
   endlevelfx      = 9:4 #,                                    <<04733>>00900000
   tolevelf        = 6:3  #,                                   <<04733>>00902000
   hitflag         = 5:1  #;                                   <<04733>>00904000
equate                                                                  00906000
   allxxx          = %(2)1000,                                 <<04733>>00908000
   allaccts        = allxxx + accountlevel;                    <<04733>>00910000
$page " EXTERNAL PROCEDURES "                                           00912000
                                                                        00914000
  procedure dirdisc (func, addr, buf, words);                           00916000
    value   func, addr, words;                                          00918000
    integer func, words;                                                00920000
    double  addr;                                                       00922000
    array   buf;                                                        00924000
    option  external;                                                   00926000
                                                                        00928000
  procedure direrror (registers, fname);                                00930000
    value   registers;                                                  00932000
    double  registers;                                                  00934000
    byte array fname;                                                   00936000
    option  external;                                                   00938000
                                                                        00940000
  procedure disc (write, ldev, record, buf, words);                     00942000
    value   write, ldev, record, words;                                 00944000
    integer write, ldev, words;                                         00946000
    double  record;                                                     00948000
    array   buf;                                                        00950000
    option  external;                                                   00952000
                                                                        00954000
  procedure errmessage (msgnr, num1, num2, num3, num4,                  00956000
                     string1, string2);                                 00958000
    value   msgnr, num1, num2, num3, num4;                              00960000
    integer msgnr;                                                      00962000
    logical num1, num2, num3, num4;                                     00964000
    byte array string1, string2;                                        00966000
    option  external, variable;                                         00968000
                                                                        00970000
  procedure exchangedb (dstn);                                          00972000
    value   dstn;                                                       00974000
    integer dstn;                                                       00976000
    option  external;                                                   00978000
                                                                        00980000
  logical procedure getextlen ( extent );                               00982000
    value   extent;                                                     00984000
    integer extent;                                                     00986000
    option external;                                                    00988000
                                                                        00990000
  procedure help;                                                       00992000
    option  external;                                                   00994000
                                                                        00996000
  procedure message (msgnr, num1, num2, num3, num4,                     00998000
                     string1, string2);                                 01000000
    value   msgnr, num1, num2, num3, num4;                              01002000
    integer msgnr;                                                      01004000
    logical num1, num2, num3, num4;                                     01006000
    byte array string1, string2;                                        01008000
    option  external, variable;                                         01010000
                                                                        01012000
  procedure printfname ( name );                                        01014000
    array   name;                                                       01016000
    option  external;                                                   01018000
                                                                        01020000
  procedure printfnr (name, reason);                                    01022000
    value   reason;                                                     01024000
    byte array name;                                                    01026000
    integer reason;                                                     01028000
    option  external;                                                   01030000
                                                                        01032000
  procedure remdiscspace ( ldev, nsect, daddr );                        01034000
    value   ldev, nsect, daddr;                                         01036000
    integer ldev;                                                       01038000
    double  nsect, daddr;                                               01040000
    option  external;                                                   01042000
                                                                        01044000
  procedure retdiscspace ( ldev, nsect, daddr );                        01046000
    value   ldev, nsect, daddr;                                         01048000
    integer ldev;                                                       01050000
    double  nsect, daddr;                                               01052000
    option  external;                                                   01054000
                                                                        01056000
  logical   procedure get'area (area'list,entry',maxent,ldev,           01058000
                                disc'addr,length);                      01060000
    value   entry', maxent;                                             01062000
    integer array area'list;                                            01064000
    integer entry', maxent, ldev;                                       01066000
    double  disc'addr, length;                                          01068000
    option  external;                                                   01070000
                                                                        01072000
  logical   procedure add'badfile (fname);                              01074000
    array   fname;                                                      01076000
    option  external;                                                   01078000
                                                                        01080000
  logical   procedure remove'badfile (fname);                           01082000
    array   fname;                                                      01084000
    option  external;                                                   01086000
                                                                        01088000
                                                               <<s7468>>01090000
procedure dirxxxbitmap (func);                                 <<s7468>>01092000
   value   func;                                               <<s7468>>01094000
   integer func;                                               <<s7468>>01096000
   option  forward;                                            <<s7468>>01098000
                                                               <<s7468>>01100000
$page "Directory Space Management"                             <<s7468>>01102000
$control segment=directory1                                    <<s7468>>01104000
<<***********************************************************>><<s7468>>01106000
<<                                                           >><<s7468>>01108000
<<                directory  space  management               >><<s7468>>01110000
<<                                                           >><<s7468>>01112000
<<***********************************************************>><<s7468>>01114000
                                                               <<s7468>>01116000
<<----------------------------------------------------------->><<s7468>>01118000
<< the directory space management is a set of procedures     >><<s7468>>01120000
<< which allows to allocate or deallocate directory space.   >><<s7468>>01122000
<< to allocate the directory space the dirallocate procedure >><<s7468>>01124000
<< with parameter size must be invoked. it will return the   >><<s7468>>01126000
<< sector start address relative to the directory base. to   >><<s7468>>01128000
<< deallocate the directory space the dirdeallocate procedure>><<s7468>>01130000
<< should be invoked with two parameters (sector address and >><<s7468>>01132000
<< size). if any io errors occurs during allocation or       >><<s7468>>01134000
<< deallocation then the dsm of specific directory will be   >><<s7468>>01136000
<< disabled.                                                 >><<s7468>>01138000
<< the directory occupies contigious space on the disc. if it>><<s7468>>01140000
<< is system directory it will be located on ldev 1 otherwise>><<s7468>>01142000
<< on master volume of private volume set. the first sectors >><<s7468>>01144000
<< (up to 32) are occupied by the directory bit map. the dir->><<s7468>>01146000
<< rectory data (index and entry blocks) follows directory   >><<s7468>>01148000
<< bit map. each bit in the directory bit map represents one >><<s7468>>01150000
<< sector of the directory (that includes the directory bit  >><<s7468>>01152000
<< map itself). the bit value of "1" in the directory bit map>><<s7468>>01154000
<< indicates available sector. the dsm maintains the dir-    >><<s7468>>01156000
<< rectory in the directory space data segment (%25). this   >><<s7468>>01158000
<< data segment can handle up to 3 contigious sector of the  >><<s7468>>01160000
<< directory bit map.                                        >><<s7468>>01162000
<<                                                           >><<s7468>>01164000
<< in the ds data segment residue following control data:    >><<s7468>>01166000
<< ds'dir'addr     - directory disc address including ldev,  >><<s7468>>01168000
<< ds'last'word    - last available word in the buffer,      >><<s7468>>01170000
<< ds'first'word   - first available word in the buffer,     >><<s7468>>01172000
<< ds'dir'size     - directory size,                         >><<s7468>>01174000
<< ds'dirty        - flag indicating modified data in buffer,>><<s7468>>01176000
<< ds'err'in'prog  - erorr procedure in progress,            >><<s7468>>01178000
<< ds'dir'disabled - system directory disabled,              >><<s7468>>01180000
<< ds'perm'disable - permantently disable directory alloc.,  >><<s7468>>01182000
<< ds'cur'sector   - sector start address in the buffer,     >><<s7468>>01184000
<< ds'addr         - real address of sector in the buffer,   >><<s7468>>01186000
<< ds'size         - size of data in the buffer,             >><<s7468>>01188000
<< ds'req'sector   - requested sector to be read,            >><<s7468>>01190000
<< ds'last'sector  - directory bit map last sector,          >><<s7468>>01192000
<< ds'sys'last     - saved system directory last word,       >><<s7468>>01194000
<< ds'sys'first    - saved system directory first word,      >><<s7468>>01196000
<< ds'sys'cur      - saved system dircetory current sector,  >><<s7468>>01198000
<< ds'error'ldev   - ldev of disabled directory,             >><<s7468>>01200000
<< ds'error'type   - type of error when disabled.            >><<s7468>>01202000
<< the buffer follows the above control data.                >><<s7468>>01204000
<<----------------------------------------------------------->><<s7468>>01206000
$page "Directory Space Management - DSM'INIT"                  <<s7468>>01208000
logical procedure dsm'init (dir'addr);                         <<s7468>>01210000
   value   dir'addr;                                           <<s7468>>01212000
   double  dir'addr;                                           <<s7468>>01214000
   option  privileged, uncallable;                             <<s7468>>01216000
                                                               <<s7468>>01218000
<<----------------------------------------------------------->><<s7468>>01220000
<< this procedure initializes directory space data segment   >><<s7468>>01222000
<< when the directory is switched. if old directory is       >><<s7468>>01224000
<< a system directory, then it will save all pointer i.e.    >><<s7468>>01226000
<< ds'cur'sector, ds'last'word, ds'first'word and ds'dir'size>><<s7468>>01228000
<< if new directory is a p.v. directory then the first sec-  >><<s7468>>01230000
<< tors of the directory bit map are read into the buffer    >><<s7468>>01232000
<< and the directory size is extracted from the disc label.  >><<s7468>>01234000
<< procedure will return false if the directory is diabled.  >><<s7468>>01236000
<<----------------------------------------------------------->><<s7468>>01238000
                                                               <<s7468>>01240000
begin                                                          <<s7468>>01242000
integer addr = dir'addr;                                       <<s7468>>01244000
define dir'ldev = addr.(0:8)#;                                 <<s7468>>01246000
define exit' = dsm'init := false;                              <<s7468>>01248000
               exchangedb (ddsdst);                            <<s7468>>01250000
               return#;                                        <<s7468>>01252000
                                                               <<s7468>>01254000
dsm'init := true;          << directory is o.k.              >><<s7468>>01256000
ds'req'sector := 1;                                            <<s7468>>01258000
ds'dir'size := ds'sys'size;                                    <<s7468>>01260000
ds'dir'addr := dir'addr;                                       <<s7468>>01262000
                                                               <<s7468>>01264000
<<----------------------------------------------------------->><<s7468>>01266000
<< if dir. bit map is greater than 3 sectors (dir. > 6112)   >><<s7468>>01268000
<< then dir. address must be adjusted. the new dir. bit map  >><<s7468>>01270000
<< is 32 sectors long, so the dir. address is pointing to    >><<s7468>>01272000
<< last 3 sectors of the bit map. the directory bit map addr.>><<s7468>>01274000
<< is 32-3 sectors lower i.e. dir. address - 29.             >><<s7468>>01276000
<<----------------------------------------------------------->><<s7468>>01278000
if ds'dir'size > 6112 then                                     <<s7468>>01280000
   begin                                                       <<s7468>>01282000
   dir'ldev := 0;                                              <<s7468>>01284000
   dir'addr := dir'addr - 29d;                                 <<s7468>>01286000
   dir'ldev := ds'ldev;                                        <<s7468>>01288000
   ds'dir'addr := dir'addr;                                    <<s7468>>01290000
   addr := ds'dir'size + 29;                                   <<s7468>>01292000
   end                                                         <<s7468>>01294000
else                                                           <<s7468>>01296000
   addr := ds'dir'size;                                        <<s7468>>01298000
ds'last'sector := ((addr - 1) &lsr(4) + ds'dir'header)         <<s7468>>01300000
   &lsr (7) + 1;                                               <<s7468>>01302000
                                                               <<s7468>>01304000
<<----------------------------------------------------------->><<s7468>>01306000
<< read sectors into the buffer                              >><<s7468>>01308000
<<----------------------------------------------------------->><<s7468>>01310000
dirxxxbitmap (read);       << read sectors into the buffer   >><<s7468>>01312000
                                                               <<s7468>>01314000
<<----------------------------------------------------------->><<s7468>>01316000
<< check if directory is permanently disabled                >><<s7468>>01318000
<<----------------------------------------------------------->><<s7468>>01320000
if (ds'cur'sector = 1) and (ds'dir'last <= 2) then             <<s7468>>01322000
   << directory is disabled                                  >><<s7468>>01324000
   begin                                                       <<s7468>>01326000
   ds'dir'disabled := true;                                    <<s7468>>01328000
   exit';                  << return to caller               >><<s7468>>01330000
   end;                                                        <<s7468>>01332000
                                                               <<s7468>>01334000
end;                                                           <<s7468>>01336000
$page "Directory Space Management - DIRXXXBITMAP"              <<s7468>>01338000
procedure dirxxxbitmap (function);                             <<s7468>>01340000
   value   function;                                           <<s7468>>01342000
   integer function;                                           <<s7468>>01344000
   option  privileged, uncallable;                             <<s7468>>01346000
                                                               <<s7468>>01348000
<<----------------------------------------------------------->><<s7468>>01350000
<< this procedure performs directory bit map io functions.   >><<s7468>>01352000
<< the directory bit map which defines allocated/deallocated >><<s7468>>01354000
<< space of directory proceeds the directory contents (index >><<s7468>>01356000
<< and entry blocks). each bit in the bit map represents one >><<s7468>>01358000
<< sector of the directory including the directory bit map.  >><<s7468>>01360000
<< the bit set to "1" indicates that sector is not used and  >><<s7468>>01362000
<< consequently bit set to "0" indicates that sector is used.>><<s7468>>01364000
<< the directory can be up to 65000 sectors long i.e. the    >><<s7468>>01366000
<< directory bit map can occupied up to 32 sectors on disc.  >><<s7468>>01368000
<< the directory space management maintains the bit map in   >><<s7468>>01370000
<< dst # %25 called directory space data segment (ds dst).   >><<s7468>>01372000
<< the ds data segment have a buffer which can handle up to  >><<s7468>>01374000
<< 3 contigious directory bit map sectors. the ds'first'word >><<s7468>>01376000
<< and ds'last'word offsets relative to the begining of ds   >><<s7468>>01378000
<< data segment represents the limits of the buffer. the     >><<s7468>>01380000
<< two words in the begining of the first sector of the bit  >><<s7468>>01382000
<< map represent the last and first available word in the    >><<s7468>>01384000
<< directory. however, because they are not consistent in    >><<s7468>>01386000
<< diffrent mits we stop using them. they must be kept in    >><<s7468>>01388000
<< this sector for compatibility reason. to determine the end>><<s7468>>01390000
<< of the directory we will use a directory size value which >><<s7468>>01392000
<< can be obtain for the system directory from cold load info>><<s7468>>01394000
<< (ldev 1, sector 28, word 20) or from disc label for       >><<s7468>>01396000
<< private volumes (master volume ldev, sector 0, word 16).  >><<s7468>>01398000
<< the ds'cur'sector pointer (relative offset to the begin-  >><<s7468>>01400000
<< ning of the directory starting from 1) indicates the start>><<s7468>>01402000
<< address of current sectors in the ds buffer.              >><<s7468>>01404000
<< the ds'req'sector pointer indicates (use only when read)  >><<s7468>>01406000
<< the sector to be requested by the reader. two consequtive >><<s7468>>01408000
<< reads will overalp last sector i.e. if setors 2, 3 and 4  >><<s7468>>01410000
<< are in buffer then the next sectors to be read into the   >><<s7468>>01412000
<< buffer, will be 4, 5 and 6. this will allow to handle     >><<s7468>>01414000
<< sector spans.                                             >><<s7468>>01416000
<< the dirxxxbitmap procedure returns following condition    >><<s7468>>01418000
<< code:                                                     >><<s7468>>01420000
<< - cce - o.k.                                              >><<s7468>>01422000
<< - ccl - requested sectors are beyond the bit map; first   >><<s7468>>01424000
<<         sectors of the bit map are placed in the buffer,  >><<s7468>>01426000
<< - ccg - io error and the directory space management for   >><<s7468>>01428000
<<         this directory is disabled.                       >><<s7468>>01430000
<<----------------------------------------------------------->><<s7468>>01432000
                                                               <<s7468>>01434000
                                                               <<s7468>>01436000
begin                                                          <<s7468>>01438000
logical out = function;                                        <<s7468>>01440000
                                                               <<s7468>>01442000
cc := cce;                                                     <<s7468>>01444000
                                                               <<s7468>>01446000
<<----------------------------------------------------------->><<s7468>>01448000
<< switch to directory space management data segment         >><<s7468>>01450000
<<----------------------------------------------------------->><<s7468>>01452000
push (db);                << save caller db - initial only   >><<s7468>>01454000
exchangedb (ds'dst);                                           <<s7468>>01456000
                                                               <<s7468>>01458000
<<----------------------------------------------------------->><<s7468>>01460000
<< write current buffer contents                             >><<s7468>>01462000
<<----------------------------------------------------------->><<s7468>>01464000
if out then                                                    <<s7468>>01466000
   dirdisc (write, ds'addr, ds'buffer, ds'size)                <<s7468>>01468000
                                                               <<s7468>>01470000
else                                                           <<s7468>>01472000
<<----------------------------------------------------------->><<s7468>>01474000
<< read bit map sectors into the directory space data segment>><<s7468>>01476000
<<----------------------------------------------------------->><<s7468>>01478000
   begin                                                       <<s7468>>01480000
                                                               <<s7468>>01482000
   if ds'req'sector > ds'last'sector then                      <<s7468>>01484000
      <<----------------------------------------------------->><<s7468>>01486000
      << start from the beginnig of the bit map              >><<s7468>>01488000
      <<----------------------------------------------------->><<s7468>>01490000
      begin                                                    <<s7468>>01492000
      cc := ccl;                                               <<s7468>>01494000
      ds'req'sector := 1;                                      <<s7468>>01496000
      end;                                                     <<s7468>>01498000
                                                               <<s7468>>01500000
   <<-------------------------------------------------------->><<s7468>>01502000
   << set pointer to the first available word in buffer      >><<s7468>>01504000
   <<-------------------------------------------------------->><<s7468>>01506000
   if ds'req'sector = 1 then                                   <<s7468>>01508000
      @ds'first'word := ds'header + ds'dir'header              <<s7468>>01510000
   else                                                        <<s7468>>01512000
      @ds'first'word := ds'header;                             <<s7468>>01514000
                                                               <<s7468>>01516000
   if (ds'last'sector > ds'buf'size's) and                     <<s7468>>01518000
      ((ds'req'sector < ds'cur'sector) or                      <<s7468>>01520000
      ((ds'last'sector - ds'cur'sector) >= ds'buf'size's) land <<s7468>>01522000
      (ds'req'sector - ds'cur'sector) >= (ds'buf'size's - 1))  <<s7468>>01524000
      or (ds'cur'sector = 0) then                              <<s7468>>01526000
      begin                                                    <<s7468>>01528000
                                                               <<s7468>>01530000
      <<----------------------------------------------------->><<s7468>>01532000
      << new sectors are read into the buffer when:          >><<s7468>>01534000
      << directory size > 6000 sectors and requested sector  >><<s7468>>01536000
      << has lower address than current segment or the last  >><<s7468>>01538000
      << sector of bit map is not in the buffer and the      >><<s7468>>01540000
      << requested sector is last in the buffer or initial.  >><<s7468>>01542000
      <<----------------------------------------------------->><<s7468>>01544000
                                                               <<s7468>>01546000
      <<----------------------------------------------------->><<s7468>>01548000
      << note. it is potential problem with directory > 6000 >><<s7468>>01550000
      << sectors. in such case if the system crash while     >><<s7468>>01552000
      << delete account/group is in progress the directory   >><<s7468>>01554000
      << bit map and the directory itself can be in inconsis->><<s7468>>01556000
      << tent state. the directory deallocates space but     >><<s7468>>01558000
      << without forcing updates to be written to the disc.  >><<s7468>>01560000
      << however, if the deallocation procedure will require >><<s7468>>01562000
      << new sectors to be read into the buffer, the modified>><<s7468>>01564000
      << sectors from the buffer will be written to the disc.>><<s7468>>01566000
      <<----------------------------------------------------->><<s7468>>01568000
                                                               <<s7468>>01570000
      <<----------------------------------------------------->><<s7468>>01572000
      << set pointer to last word in buffer                  >><<s7468>>01574000
      <<----------------------------------------------------->><<s7468>>01576000
      if (ds'last'sector - ds'req'sector) >= ds'buf'size's then<<s7468>>01578000
         <<-------------------------------------------------->><<s7468>>01580000
         << directory bit map > 3 sectors (not last sector)  >><<s7468>>01582000
         <<-------------------------------------------------->><<s7468>>01584000
         ds'last'word := ds'header + ds'buf'size'w - 1         <<s7468>>01586000
      else                                                     <<s7468>>01588000
         ds'last'word := ds'header + ds'dir'header +           <<s7468>>01590000
            (ds'dir'size - 1) &lsr(4) -                        <<s7468>>01592000
            (ds'req'sector - 1) &lsl(7);                       <<s7468>>01594000
                                                               <<s7468>>01596000
      <<----------------------------------------------------->><<s7468>>01598000
      << read sectors into the buffer.                       >><<s7468>>01600000
      <<----------------------------------------------------->><<s7468>>01602000
      ds'cur'sector := ds'req'sector;                          <<s7468>>01604000
      ds'addr := ds'dir'addr;                                  <<s7468>>01606000
      ds'addr1 := ds'addr1 &lsl(8) &lsr(8);   << remove ldev >><<s7468>>01608000
      ds'addr := ds'addr + double (ds'cur'sector - 1);         <<s7468>>01610000
      ds'size := (ds'last'word - ds'header + 128) &lsr(7)      <<s7468>>01612000
         &lsl (7);            << read and write full sectors >><<s7468>>01614000
      dirdisc (read, ds'addr, ds'buffer, ds'size);             <<s7468>>01616000
      end;                                                     <<s7468>>01618000
   end;                                                        <<s7468>>01620000
                                                               <<s7468>>01622000
<<----------------------------------------------------------->><<s7468>>01624000
<< switch back to caller dst                                 >><<s7468>>01626000
<<----------------------------------------------------------->><<s7468>>01628000
set (db);                                                      <<s7468>>01630000
end;                                                           <<s7468>>01632000
$page "Directory Space Management - DIRXXXLLOCATE"             <<s7468>>01634000
                                                               <<s7468>>01636000
procedure dirxxxllocate (pntr, ppsize, set1);                  <<s7468>>01638000
   value   pntr, ppsize, set1;                                 <<s7468>>01640000
   logical pntr, set1;                                         <<s7468>>01642000
   integer ppsize;                                             <<s7468>>01644000
   option  privileged, uncallable;                             <<s7468>>01646000
                                                               <<s7468>>01648000
<<----------------------------------------------------------->><<s7468>>01650000
<< this procedure sets and resets bits in the buffer.        >><<s7468>>01652000
<< input arguments:                                          >><<s7468>>01654000
<< pntr   - sector address relative to ds'dir,               >><<s7468>>01656000
<< ppsize - space size,                                      >><<s7468>>01658000
<< set1   - "1" when deallocate or "0" when allocate space.  >><<s7468>>01660000
<<----------------------------------------------------------->><<s7468>>01662000
                                                               <<s7468>>01664000
begin                                                          <<s7468>>01666000
logical pointer pntrx = pntr;                                  <<s7468>>01668000
                                                               <<s7468>>01670000
<<----------------------------------------------------------->><<s7468>>01672000
<< set buffer word pointer and word bit pointer (x reg.)     >><<s7468>>01674000
<<----------------------------------------------------------->><<s7468>>01676000
xr := pntr &lsl(12) &lsr(12);    << bit offset in the word   >><<s7468>>01678000
@pntrx := ds'header + ds'dir'header + pntr &lsr(4) -           <<s7468>>01680000
   (ds'cur'sector - 1) &lsl(7);                                <<s7468>>01682000
                                                               <<s7468>>01684000
tos := pntrx;                << fetch word from buffer       >><<s7468>>01686000
                                                               <<s7468>>01688000
while (ppsize := ppsize - 1) >= 0 do                           <<s7468>>01690000
   begin                                                       <<s7468>>01692000
   if xr = 16 then                                             <<s7468>>01694000
      <<----------------------------------------------------->><<s7468>>01696000
      << fetch new word                                      >><<s7468>>01698000
      <<----------------------------------------------------->><<s7468>>01700000
      begin                                                    <<s7468>>01702000
      pntrx := tos;          << saved a modified word        >><<s7468>>01704000
      @pntrx := @pntrx + 1;                                    <<s7468>>01706000
      tos := pntrx;          << get new word                 >><<s7468>>01708000
      xr := 0;                                                 <<s7468>>01710000
      end;                                                     <<s7468>>01712000
                                                               <<s7468>>01714000
   if set1 then                                                <<s7468>>01716000
      <<----------------------------------------------------->><<s7468>>01718000
      << deallocate - set bit to "1"                         >><<s7468>>01720000
      <<----------------------------------------------------->><<s7468>>01722000
      assemble (tsbc 0, x)                                     <<s7468>>01724000
   else                                                        <<s7468>>01726000
                                                               <<s7468>>01728000
      <<----------------------------------------------------->><<s7468>>01730000
      << allocate - set bit to "0"                           >><<s7468>>01732000
      <<----------------------------------------------------->><<s7468>>01734000
      assemble (trbc 0, x);                                    <<s7468>>01736000
                                                               <<s7468>>01738000
   xr := xr + 1;        << advance bit pointer               >><<s7468>>01740000
   end;                                                        <<s7468>>01742000
                                                               <<s7468>>01744000
pntrx := tos;          << store modified word                >><<s7468>>01746000
dirxxxbitmap (write);         << write back modified buffer  >><<s7468>>01748000
end;                                                           <<s7468>>01750000
$page "Directory Space Management - DIRALLOCATE"               <<s7468>>01752000
logical procedure dirallocate (ppsize);                        <<s7468>>01754000
   value   ppsize;                                             <<s7468>>01756000
   logical ppsize;                                             <<s7468>>01758000
   option  privileged, uncallable;                             <<s7468>>01760000
                                                               <<s7468>>01762000
<<----------------------------------------------------------->><<s7468>>01764000
<< this procedure is looking for a contigious space (size =  >><<s7468>>01766000
<< ppsize). it starts to exam the bit map sectors which are  >><<s7468>>01768000
<< currently in the ds'buffer. the relative pointers to dst  >><<s7468>>01770000
<< (ds'first'word and ds'last'word) indicate buffer limits.  >><<s7468>>01772000
<< if it cannot find the requested space then it will try to >><<s7468>>01774000
<< read the next bit map sectors into the buffer. however, it>><<s7468>>01776000
<< starts to read from the address of the last sector in the >><<s7468>>01778000
<< buffer. this will allow to allocate space between the     >><<s7468>>01780000
<< sector bounds. if this procedure reaches the end of the   >><<s7468>>01782000
<< directory bit map it will make another pass through the   >><<s7468>>01784000
<< directory bit map. if for some reason the directory bit   >><<s7468>>01786000
<< map is trashed at the beginnig (space allocated for the   >><<s7468>>01788000
<< directory bit map) or at the end (beyond the directory),  >><<s7468>>01790000
<< it will not encounter as a valid allocation.              >><<s7468>>01792000
<<                                                           >><<s7468>>01794000
<< this procedure returns:                                   >><<s7468>>01796000
<< - start address of allocated space (relative to the       >><<s7468>>01798000
<<   beginning of the directory address).                    >><<s7468>>01800000
<< - cce - o.k.                                              >><<s7468>>01802000
<< - ccl - space not available; returns zero address,        >><<s7468>>01804000
<< - ccg - requested size too big or directory space         >><<s7468>>01806000
<<         allocation disabled; returns zero address.        >><<s7468>>01808000
<<----------------------------------------------------------->><<s7468>>01810000
                                                               <<s7468>>01812000
                                                               <<s7468>>01814000
begin                                                          <<s7468>>01816000
logical size;                                                  <<s7468>>01818000
double dir'addr;                                               <<s7468>>01820000
logical addr = dir'addr;                                       <<s7468>>01822000
define  dir'ldev = addr.(0:8)#;                                <<s7468>>01824000
logical word  = s0;     << tested word from bit map          >><<s7468>>01826000
logical words = s2;     << tested word from bit map          >><<s7468>>01828000
logical result = dirallocate;                                  <<s7468>>01830000
logical only'one'pass;                                         <<s7468>>01832000
define  exit' = exchangedb (ddsdst);                           <<s7468>>01834000
                return#;                                       <<s7468>>01836000
                                                               <<s7468>>01838000
logical subroutine get'word;                                   <<s7468>>01840000
                                                               <<s7468>>01842000
   <<-------------------------------------------------------->><<s7468>>01844000
   << this subroutine returns non zero word from buffer and  >><<s7468>>01846000
   << status true or status false when words in buffer are   >><<s7468>>01848000
   << null. the ds'first'word and ds'last'word are the buffer>><<s7468>>01850000
   << limits.                                                >><<s7468>>01852000
   <<-------------------------------------------------------->><<s7468>>01854000
                                                               <<s7468>>01856000
   begin                                                       <<s7468>>01858000
   while (logical (@ds'first'word) <= ds'last'word) and        <<s7468>>01860000
         (ds'first'word = 0) do                                <<s7468>>01862000
      @ds'first'word := @ds'first'word + 1;                    <<s7468>>01864000
                                                               <<s7468>>01866000
   if logical (@ds'first'word) <= ds'last'word then            <<s7468>>01868000
      begin                                                    <<s7468>>01870000
      words := ds'first'word;                                  <<s7468>>01872000
      get'word := true;                                        <<s7468>>01874000
      end                                                      <<s7468>>01876000
   else                                                        <<s7468>>01878000
      begin                                                    <<s7468>>01880000
      words := 0;                                              <<s7468>>01882000
      get'word := false;                                       <<s7468>>01884000
      end;                                                     <<s7468>>01886000
   end;                                                        <<s7468>>01888000
                                                               <<s7468>>01890000
                                                               <<s7468>>01892000
size := 0;             << initialize size                    >><<s7468>>01894000
result := 0;           << initialize sector address          >><<s7468>>01896000
                                                               <<s7468>>01898000
<<----------------------------------------------------------->><<s7468>>01900000
<< switch to directory space data segment                    >><<s7468>>01902000
<<----------------------------------------------------------->><<s7468>>01904000
dir'addr := dirbase;   << directory address from dst # %24   >><<s7468>>01906000
exchangedb (ds'dst);                                           <<s7468>>01908000
                                                               <<s7468>>01910000
<<----------------------------------------------------------->><<s7468>>01912000
<< switch to new directory if necessary                      >><<s7468>>01914000
<<----------------------------------------------------------->><<s7468>>01916000
if (ds'ldev <> dir'ldev) then                                  <<s7468>>01918000
   if not dsm'init (dir'addr) then                             <<s7468>>01920000
      begin                                                    <<s7468>>01922000
      cc := ccg;                                               <<s7468>>01924000
      return;          << directory disabled                 >><<s7468>>01926000
      end;                                                     <<s7468>>01928000
                                                               <<s7468>>01930000
<<----------------------------------------------------------->><<s7468>>01932000
<< if system directory then check if it is not disabled      >><<s7468>>01934000
<<----------------------------------------------------------->><<s7468>>01936000
if (ds'ldev = 1) and ds'dir'disabled then                      <<s7468>>01938000
   begin                                                       <<s7468>>01940000
   cc := ccg;                                                  <<s7468>>01942000
   exit';                            << return to caller     >><<s7468>>01944000
   end;                                                        <<s7468>>01946000
                                                               <<s7468>>01948000
                                                               <<s7468>>01950000
tos := 0;              << reserved word on stack for testing >><<s7468>>01952000
                                                               <<s7468>>01954000
do                                                             <<s7468>>01956000
   begin                                                       <<s7468>>01958000
   if (ds'cur'sector = 1) and (logical (@ds'first'word) =      <<s7468>>01960000
      ds'header + ds'dir'header) then                          <<s7468>>01962000
      <<----------------------------------------------------->><<s7468>>01964000
      << only one pass through directory bit map             >><<s7468>>01966000
      <<----------------------------------------------------->><<s7468>>01968000
      only'one'pass := true                                    <<s7468>>01970000
   else                                                        <<s7468>>01972000
      <<----------------------------------------------------->><<s7468>>01974000
      << two passes through directory bit map if necessary   >><<s7468>>01976000
      <<----------------------------------------------------->><<s7468>>01978000
      only'one'pass := false;                                  <<s7468>>01980000
                                                               <<s7468>>01982000
   do                                                          <<s7468>>01984000
      <<----------------------------------------------------->><<s7468>>01986000
      << scan the bit map directory                          >><<s7468>>01988000
      <<----------------------------------------------------->><<s7468>>01990000
      begin                                                    <<s7468>>01992000
      while get'word do                                        <<s7468>>01994000
         <<-------------------------------------------------->><<s7468>>01996000
         << scan words in the buffer                         >><<s7468>>01998000
         <<-------------------------------------------------->><<s7468>>02000000
         begin                                                 <<s7468>>02002000
         <<-------------------------------------------------->><<s7468>>02004000
         << set sector address ds'dir relative               >><<s7468>>02006000
         <<-------------------------------------------------->><<s7468>>02008000
         xr := ((ds'cur'sector - 1) &lsl(7) - ds'dir'header +  <<s7468>>02010000
            logical (@ds'first'word) - ds'header) &lsl(4) - 1; <<s7468>>02012000
         while word <> 0 do  << while does not modify x reg. >><<s7468>>02014000
            begin                                              <<s7468>>02016000
            <<----------------------------------------------->><<s7468>>02018000
            << scan word                                     >><<s7468>>02020000
            <<----------------------------------------------->><<s7468>>02022000
            assemble (scan ,x);                                <<s7468>>02024000
            <<----------------------------------------------->><<s7468>>02026000
            << check results                                 >><<s7468>>02028000
            <<----------------------------------------------->><<s7468>>02030000
            if 3 <= xr and xr < ds'dir'size then     << o.k. >><<s7468>>02032000
               begin                                           <<s7468>>02034000
               if (result + size) = xr then    << contigious >><<s7468>>02036000
                  size := size + 1                             <<s7468>>02038000
               else                                            <<s7468>>02040000
                  begin                << reset pointers     >><<s7468>>02042000
                  result := xr;                                <<s7468>>02044000
                  size := 1;                                   <<s7468>>02046000
                  end;                                         <<s7468>>02048000
               if size = ppsize then   << allocate           >><<s7468>>02050000
                  <<----------------------------------------->><<s7468>>02052000
                  << exit - space allocated                  >><<s7468>>02054000
                  <<----------------------------------------->><<s7468>>02056000
                  begin                                        <<s7468>>02058000
                  dirxxxllocate (result, ppsize, 0);           <<s7468>>02060000
                  cc := cce;                                   <<s7468>>02062000
                  exit';         << return to caller         >><<s7468>>02064000
                  end;                                         <<s7468>>02066000
               end;                                            <<s7468>>02068000
            end;                                               <<s7468>>02070000
         @ds'first'word := @ds'first'word + 1;  << next word >><<s7468>>02072000
         end;                                                  <<s7468>>02074000
      <<----------------------------------------------------->><<s7468>>02076000
      << read next sectors into the buffer                   >><<s7468>>02078000
      <<----------------------------------------------------->><<s7468>>02080000
      ds'req'sector := ds'cur'sector + ds'buf'size's;          <<s7468>>02082000
      if ((ds'header + ds'dir'header + result &lsr(4) -        <<s7468>>02084000
         (ds'cur'sector - 1) &lsl(7)) = ds'last'word) and      <<s7468>>02086000
         (ds'req'sector <= ds'last'sector) then                <<s7468>>02088000
         begin                                                 <<s7468>>02090000
         <<-------------------------------------------------->><<s7468>>02092000
         << sectors span - valid only for ppsize <= 16       >><<s7468>>02094000
         <<-------------------------------------------------->><<s7468>>02096000
         ds'req'sector := ds'req'sector - 1;                   <<s7468>>02098000
         result := size := 0;      << start from beginning   >><<s7468>>02100000
         end;                                                  <<s7468>>02102000
      dirxxxbitmap (read);                                     <<s7468>>02104000
      end                                                      <<s7468>>02106000
   until <>;           << until reach the end of the bit map >><<s7468>>02108000
   if > then                                                   <<s7468>>02110000
      <<----------------------------------------------------->><<s7468>>02112000
      << exit - space is not allocated - io error            >><<s7468>>02114000
      <<----------------------------------------------------->><<s7468>>02116000
      begin                                                    <<s7468>>02118000
      result := 0;                                             <<s7468>>02120000
      cc := ccg;                                               <<s7468>>02122000
      exit';               << return to caller               >><<s7468>>02124000
      end;                                                     <<s7468>>02126000
                                                               <<s7468>>02128000
   end                                                         <<s7468>>02130000
until only'one'pass;                                           <<s7468>>02132000
<<----------------------------------------------------------->><<s7468>>02134000
<< exit - space is not available                             >><<s7468>>02136000
<<----------------------------------------------------------->><<s7468>>02138000
result := 0;                                                   <<s7468>>02140000
cc := ccl;                                                     <<s7468>>02142000
exchangedb (ddsdst);            << switch back to dst # %24  >><<s7468>>02144000
end;                                                           <<s7468>>02146000
$page "Directory Space Management - DIRDEALLOCATE"             <<s7468>>02148000
                                                               <<s7468>>02150000
procedure dirdeallocate (pntr, ppsize);                        <<s7468>>02152000
   value    pntr, ppsize;                                      <<s7468>>02154000
   logical  pntr, ppsize;                                      <<s7468>>02156000
   option   privileged, uncallable;                            <<s7468>>02158000
                                                               <<s7468>>02160000
<<----------------------------------------------------------->><<s7468>>02162000
<< this procedure deallocates directory space                >><<s7468>>02164000
<< input arguments:                                          >><<s7468>>02166000
<< pntr - sector address relative to ds'dir,                 >><<s7468>>02168000
<< ppsize - size of deallocated space.                       >><<s7468>>02170000
<<----------------------------------------------------------->><<s7468>>02172000
                                                               <<s7468>>02174000
begin                                                          <<s7468>>02176000
double dir'addr;                                               <<s7468>>02178000
logical addr = dir'addr;                                       <<s7468>>02180000
define  dir'ldev = addr.(0:8)#;                                <<s7468>>02182000
logical word'pntr;      << word offset into diretory bit map >><<s7468>>02184000
define  exit' = exchangedb (ddsdst);                           <<s7468>>02186000
                return#;                                       <<s7468>>02188000
                                                               <<s7468>>02190000
<<----------------------------------------------------------->><<s7468>>02192000
<< switch to directory space data segment                    >><<s7468>>02194000
<<----------------------------------------------------------->><<s7468>>02196000
dir'addr := dirbase;                                           <<s7468>>02198000
exchangedb (ds'dst);                                           <<s7468>>02200000
                                                               <<s7468>>02202000
<<----------------------------------------------------------->><<s7468>>02204000
<< switch to new directory if necessary                      >><<s7468>>02206000
<<----------------------------------------------------------->><<s7468>>02208000
if (ds'ldev <> dir'ldev) then                                  <<s7468>>02210000
   if not dsm'init (dir'addr) then                             <<s7468>>02212000
      return;                                                  <<s7468>>02214000
                                                               <<s7468>>02216000
<<----------------------------------------------------------->><<s7468>>02218000
<< if system directory then check if it not disabled or if   >><<s7468>>02220000
<< pntr points to bit map or beyond directory then exit.     >><<s7468>>02222000
<<----------------------------------------------------------->><<s7468>>02224000
if (ds'ldev = 1) and ds'dir'disabled or                        <<s7468>>02226000
   (pntr + ppsize) > ds'dir'size or                            <<s7468>>02228000
   (pntr < 3) then                                             <<s7468>>02230000
   begin                                                       <<s7468>>02232000
   exit';               << return to caller                  >><<s7468>>02234000
   end;                                                        <<s7468>>02236000
                                                               <<s7468>>02238000
word'pntr := pntr &lsr(4) + ds'dir'header;  << buffer pntr   >><<s7468>>02240000
                                                               <<s7468>>02242000
<<----------------------------------------------------------->><<s7468>>02244000
<< check if returned space belongs to sectors in the buffer  >><<s7468>>02246000
<<----------------------------------------------------------->><<s7468>>02248000
if not (((word'pntr &lsr(7) + 1) >= ds'cur'sector) land        <<s7468>>02250000
   (((pntr + ppsize - 1) &lsr(4) + ds'dir'header) &lsr(7) + 1) <<s7468>>02252000
   < (ds'cur'sector + ds'buf'size's)) then                     <<s7468>>02254000
   <<-------------------------------------------------------->><<s7468>>02256000
   << read new sectors into the buffer if necessary          >><<s7468>>02258000
   <<-------------------------------------------------------->><<s7468>>02260000
   begin                                                       <<s7468>>02262000
   ds'req'sector := word'pntr &lsr(7) + 1;                     <<s7468>>02264000
   dirxxxbitmap (read);                                        <<s7468>>02266000
   if > then                                                   <<s7468>>02268000
      <<----------------------------------------------------->><<s7468>>02270000
      << exit error                                          >><<s7468>>02272000
      <<----------------------------------------------------->><<s7468>>02274000
      begin                                                    <<s7468>>02276000
      exit';                << return to caller              >><<s7468>>02278000
      end;                                                     <<s7468>>02280000
   end;                                                        <<s7468>>02282000
                                                               <<s7468>>02284000
<<----------------------------------------------------------->><<s7468>>02286000
<< reset bits in the buffer                                  >><<s7468>>02288000
<<----------------------------------------------------------->><<s7468>>02290000
dirxxxllocate (pntr, ppsize, 1);                               <<s7468>>02292000
                                                               <<s7468>>02294000
if (logical (@ds'first'word) - ds'header) >                    <<s7468>>02296000
   (word'pntr - (ds'cur'sector - 1) &lsl(7)) then              <<s7468>>02298000
   <<-------------------------------------------------------->><<s7468>>02300000
   << reset the ds'first'word pointer                        >><<s7468>>02302000
   <<-------------------------------------------------------->><<s7468>>02304000
   @ds'first'word := word'pntr - (ds'cur'sector - 1) &lsl(7) + <<s7468>>02306000
      ds'header;                                               <<s7468>>02308000
                                                               <<s7468>>02310000
exchangedb (ddsdst);      << return to directory dst (%24)   >><<s7468>>02312000
end;                                                           <<s7468>>02314000
$page "Directory Data Management Routines"                     <<s7468>>02316000
<<***********************************************************>><<s7468>>02318000
<<                                                           >><<s7468>>02320000
<<              directory  data  management                  >><<s7468>>02322000
<<                                                           >><<s7468>>02324000
<<***********************************************************>><<s7468>>02326000
                                                               <<s7468>>02328000
                                                               <<s7468>>02330000
procedure dirset (which);                                      <<s7468>>02332000
   value   which;                                              <<s7468>>02334000
   integer which;                                              <<s7468>>02336000
begin                                                          <<s7468>>02338000
case (which) of                                                <<s7468>>02340000
   begin                                                       <<s7468>>02342000
   tos := @daprepre;                                           <<s7468>>02344000
   tos := @dbprepre;                                           <<s7468>>02346000
   end;                                                        <<s7468>>02348000
@base := tos;                                                  <<s7468>>02350000
end;   << dirset >>                                            <<s7468>>02352000
                                                               <<s7468>>02354000
                                                                        02356000
procedure dirwrite (which);                                             02358000
   value which;                                                         02360000
   logical which;                                                       02362000
begin                                                                   02364000
   integer temp = which;                                                02366000
   logical pointer tempp;                                               02368000
<< >>                                                                   02370000
   dirset (which);                                                      02372000
   whichdirty := false;                                                 02374000
   @tempp := base(iopntr);                                              02376000
   tos := base(used);                                                   02378000
   if base(miscwd).(typef) = indextype then                             02380000
      begin                                                             02382000
      move tempp := base(miscwd), (presize);                            02384000
      tos := tos+presize;                                               02386000
      end;                                                              02388000
   assemble (test);                                                     02390000
   if = then return;                                                    02392000
   temp := tos;                                                         02394000
   tos := write;                                                        02396000
   tos := dirbase;                                                      02398000
   tos := 0;                                                            02400000
   tos := ibase(contents);                                              02402000
   assemble(dadd);                                                      02404000
   dirdisc(*,*,tempp,temp);                                             02406000
   end    <<dirwrite>>;                                                 02408000
                                                                        02410000
procedure dirread (pntr, which, excount, eemiscwd);                     02412000
   value pntr, which, excount, eemiscwd;                                02414000
   logical pntr, which, eemiscwd;                                       02416000
   integer excount;                                                     02418000
                                                               <<de>>   02420000
begin                                                          <<de>>   02422000
   logical temp;                                                        02424000
   logical pointer tempp;                                               02426000
   dirset (which);                                                      02428000
   if base (contents)= pntr then return;                                02430000
   if whichdirty then dirwrite (which);                                 02432000
   @tempp := base(iopntr);                                              02434000
<< *** check for pp. contained in dds blocks and move *** >>            02436000
   tos := read;                                                         02438000
   tos := dirbase;                                                      02440000
   tos := 0;                                                            02442000
   tos := pntr;                                                <<de>>   02444000
   assemble(dadd);                                                      02446000
   dirdisc(*,*,tempp,ddsbwsize);                                        02448000
   temp := ddsbsize;                                                    02450000
   base (contents) := pntr;                                             02452000
   base (numvalid) := temp;                                             02454000
   if tempp.(typef) = indextype then                                    02456000
      begin                                                             02458000
      move base(miscwd) := tempp, (presize);                            02460000
      temp := presize;                                                  02462000
      end                                                               02464000
   else                                                                 02466000
      begin                                                             02468000
      base(xcount) := excount;                                          02470000
      base(miscwd) := eemiscwd;                                         02472000
      temp := 0;                                                        02474000
      end;                                                              02476000
   base (lpntr) := @tempp+integer(temp);                                02478000
   base(used) := (base(xsize) := base(miscwd).(xsizef)) * base(xcount); 02480000
   base(bfactor) := ((base(bwsize) := (base(bsize)                      02482000
      := base(miscwd).(bsizef)) & lsl(7)) - temp) / base(xsize);        02484000
   end <<dirread>>;                                                     02486000
                                                                        02488000
logical procedure dirnewindex (ibsize, ilevel, ebsize, esize);          02490000
   value ibsize, ilevel, ebsize, esize;                                 02492000
   integer ibsize, ilevel, ebsize, esize;                               02494000
<< caller must move pindexp and pname into dbpindexp and dbpname >>     02496000
begin                                                                   02498000
   if ebsize > ddsbsize then goto never;                                02500000
   tos := dirallocate (ibsize);                                         02502000
   if <> then                                                           02504000
      begin                                                             02506000
      if < then xreg := ccl                                             02508000
      else                                                              02510000
never:   xreg := ccg;                                                   02512000
      cc := xreg;                                                       02514000
      dirnewindex := 0;                                                 02516000
      return;                                                           02518000
      end;                                                              02520000
   cc := cce;                                                           02522000
   dbcontents := (dirnewindex := tos);                                  02524000
   @dblpntr := @dbiopntr+presize;                                       02526000
   dbnumvalid := ibsize;                                                02528000
   dbused := 0;                                                         02530000
   dbbfactor := (dbbwsize := (dbbsize := ibsize) & lsl(7)) / isize;     02532000
   tos := 0;                                                            02534000
   tos.(typef) := indextype;                                            02536000
   tos.(levelf) := ilevel;                                              02538000
   tos.(xsizef) := (dbxsize := isize);                                  02540000
   tos.(bsizef) := dbbsize;                                             02542000
   dbmiscwd := tos;                                                     02544000
   dbxcount := (dbpcount := (dbetotal := 0));                           02546000
   tos := 0;                                                            02548000
   tos.(typef) := entrytype;                                            02550000
   tos.(levelf) := ilevel;                                              02552000
   tos.(xsizef) := esize;                                               02554000
   tos.(bsizef) := ebsize;                                              02556000
   dbemiscwd := tos;                                                    02558000
   dirwrite (b);                                                        02560000
   end    <<dirnewindex>>;                                              02562000
$page                                                          <<de>>   02564000
double procedure direcnull (numsect);                          <<s7468>>02566000
   value   numsect;                                            <<s7468>>02568000
   logical numsect;                                            <<s7468>>02570000
                                                               <<s7468>>02572000
<<----------------------------------------------------------->><<s7468>>02574000
<< this procedure creates empty system directory.            >><<s7468>>02576000
<<----------------------------------------------------------->><<s7468>>02578000
                                                               <<s7468>>02580000
begin                                                          <<s7468>>02582000
double  addr;                                                  <<s7468>>02584000
integer addr1 = addr;                                          <<s7468>>02586000
define  dir'ldev = addr1.(0:8)#;                               <<s7468>>02588000
logical size;                                                  <<s7468>>02590000
logical dirsize;                        << directory size    >><<s7468>>02592000
equate  bufsizeinsec = 3;               << buffer size in sec>><<s7468>>02594000
equate  sector'size = 128;                                     <<s7468>>02596000
logical pntr;                           << index into dir.   >><<s7468>>02598000
<< working buffer must be q relative                         >><<s7468>>02600000
array   buffer (0 : (bufsizeinsec*sector'size) - 1) = q;       <<s7468>>02602000
define  dir'lastw = buffer#;            << last word in bm   >><<s7468>>02604000
define  dir'firstw = buffer (1)#;       << first word in bm  >><<s7468>>02606000
equate  maxdeallocsize = %10000;        << two sectors of bm >><<s7468>>02608000
                                                               <<s7468>>02610000
<<----------------------------------------------------------->><<s7468>>02612000
<< extract directory address and sys. account index from     >><<s7468>>02614000
<< directory data segment                                    >><<s7468>>02616000
<<----------------------------------------------------------->><<s7468>>02618000
                                                               <<s7468>>02620000
exchangedb (ddsdst);                                           <<s7468>>02622000
addr := dirbase;                                               <<s7468>>02624000
dir'ldev := 0;                          << remove ldev       >><<s7468>>02626000
exchangedb (0);                                                <<s7468>>02628000
                                                               <<s7468>>02630000
<<----------------------------------------------------------->><<s7468>>02632000
<< set first sector of the bit map                           >><<s7468>>02634000
<<----------------------------------------------------------->><<s7468>>02636000
                                                               <<s7468>>02638000
buffer := 0;                                                   <<s7468>>02640000
move buffer (1) := buffer, (bufsizeinsec * sector'size - 1);   <<s7468>>02642000
dir'lastw := (numsect + 15) / 16;       << penultimate word  >><<s7468>>02644000
if numsect > 6112 then                                         <<s7468>>02646000
   dir'lastw := (numsect - 29 + 15) / 16;                      <<s7468>>02648000
dir'firstw := ds'dir'header;                   << first      >><<s7468>>02650000
                                                               <<s7468>>02652000
<<----------------------------------------------------------->><<s7468>>02654000
<< zero entire directory including bit map i.e. space dealloc>><<s7468>>02656000
<<----------------------------------------------------------->><<s7468>>02658000
                                                               <<s7468>>02660000
<<----------------------------------------------------------->><<s7468>>02662000
<< if dir. bit map > 3 sectors (dir. size > 6112) then the   >><<s7468>>02664000
<< directory bit map starts at dir. address - (32-3).        >><<s7468>>02666000
<<----------------------------------------------------------->><<s7468>>02668000
dirsize := numsect;                                            <<s7468>>02670000
if dirsize > 6112 then                                         <<s7468>>02672000
   addr := addr - 29d;                                         <<s7468>>02674000
                                                               <<s7468>>02676000
while dirsize <> 0 do                                          <<s7468>>02678000
   begin                                                       <<s7468>>02680000
   if dirsize >= bufsizeinsec then                             <<s7468>>02682000
      size := bufsizeinsec                                     <<s7468>>02684000
   else                                                        <<s7468>>02686000
      size := dirsize;                                         <<s7468>>02688000
   dirdisc (write, addr ,buffer, size * sector'size);          <<s7468>>02690000
   dirsize := dirsize - size;                                  <<s7468>>02692000
   addr := addr + double (bufsizeinsec);                       <<s7468>>02694000
   buffer := buffer (1) := 0;                                  <<s7468>>02696000
   end;                                                        <<s7468>>02698000
                                                               <<s7468>>02700000
<<----------------------------------------------------------->><<s7468>>02702000
<< release all directory free space                          >><<s7468>>02704000
<<----------------------------------------------------------->><<s7468>>02706000
                                                               <<s7468>>02708000
<<----------------------------------------------------------->><<s7468>>02710000
<< if dir. bit map > 3 sectors i.e. 32 sectors do not include>><<s7468>>02712000
<< the 32-3 sectors in the bit map. only first 3 bits in the >><<s7468>>02714000
<< bit map represent directory bit map.                      >><<s7468>>02716000
<<----------------------------------------------------------->><<s7468>>02718000
if numsect > 6112 then                                         <<s7468>>02720000
   numsect := numsect - 29;                                    <<s7468>>02722000
                                                               <<s7468>>02724000
exchangedb (ddsdst);                                           <<s7468>>02726000
pntr := numsect;                                               <<s7468>>02728000
while pntr > 3 do       << the bit map bits must be allocated>><<s7468>>02730000
   begin                                                       <<s7468>>02732000
   if pntr >= (maxdeallocsize + 3) then                        <<s7468>>02734000
      size := maxdeallocsize                                   <<s7468>>02736000
   else                                                        <<s7468>>02738000
      size := pntr - 3;                                        <<s7468>>02740000
   pntr := pntr - size;                                        <<s7468>>02742000
   dirdeallocate (pntr, size);                                 <<s7468>>02744000
   end;                << first sector must be in the buffer >><<s7468>>02746000
                                                               <<s7468>>02748000
<<----------------------------------------------------------->><<s7468>>02750000
<< create system account index                               >><<s7468>>02752000
<<----------------------------------------------------------->><<s7468>>02754000
                                                               <<s7468>>02756000
dbpindexp := 0;                         << father index      >><<s7468>>02758000
dbpname := "  ";                        << father name       >><<s7468>>02760000
move dbpname (1) := dbpname, (namesize - 1);                   <<s7468>>02762000
dirnewindex (syssaibsize, accountlevel, sysaebsize, asize);    <<s7468>>02764000
exchangedb (0);                                                <<s7468>>02766000
                                                               <<s7468>>02768000
direcnull := 0d;                                               <<s7468>>02770000
cc := cce;                                                     <<s7468>>02772000
end;    << direcnull>>                                         <<s7468>>02774000
                                                               <<s7468>>02776000
                                                                        02778000
integer procedure dirscan (entryname, type'which);                      02780000
   value type'which;                                                    02782000
   array entryname;                                                     02784000
   logical type'which;                                                  02786000
   << assumes namesize = 4 >>                                           02788000
<< returns:                                                             02790000
   ccg - exact entry returned.                                          02792000
   ccl - preceeding or next entry returned                              02794000
   cce - "PSEUDO" preceeding or next entry returned (outside bounds)  >>02796000
begin                                                                   02798000
   double pointer dentryname = entryname;                               02800000
   define                                                               02802000
      whichfield  = 15:1 #,                                             02804000
      typefield  = 13:2 #;                                              02806000
   double pointer endx;                                                 02808000
   double pointer pntr;                                                 02810000
<< >>                                                                   02812000
   dirset (type'which.(whichfield));                                    02814000
   @endx := (@pntr := ibase(lpntr))+ibase(used);                        02816000
   << change to binary search later >>                                  02818000
   while @pntr < @endx do                                               02820000
      begin                                                             02822000
      if dentryname = pntr then                                         02824000
         if dentryname (1) &dlsl (1) & dlsr (1) =                       02826000
            pntr (xreg) & dlsl (1) & dlsr (1)                           02828000
         then go to exactone;                                           02830000
      if < then goto nextone;                                           02832000
      @pntr := @pntr+ibase(xsize);                                      02834000
      end;                                                              02836000
   @endx := 0;                                                          02838000
nextone:                                                                02840000
   if type'which.(typefield) <= 1 then                                  02842000
      << exact or exact/next request >>                                 02844000
         begin                                                          02846000
         tos := @pntr;                                                  02848000
         xreg := if @endx <> 0 then ccl else cce;                       02850000
         end                                                            02852000
   else                                                                 02854000
      << exact/preceeding request >>                                    02856000
         begin                                                          02858000
         tos := @pntr-ibase(xsize);                                     02860000
         xreg := if @pntr <> ibase(lpntr) then ccl else cce;            02862000
         end;                                                           02864000
   goto exit;                                                           02866000
exactone:                                                               02868000
   tos := @pntr;                                                        02870000
   xreg := ccg;                                                         02872000
exit:                                                                   02874000
   cc := xreg;                                                          02876000
   dirscan := tos;                                                      02878000
   end    <<dirscan>>;                                                  02880000
                                                                        02882000
double procedure dirinsert (indexpointer);                              02884000
   value indexpointer;                                                  02886000
   logical indexpointer;                                                02888000
<< when called:                                                         02890000
   1. directory is locked,                                              02892000
   2. entry has been moved to the data segment (at 0),                  02894000
   3. db is set at the data segment.  >>                                02896000
<< returns:                                                             02898000
   (s-0)                  (s-1)                                         02900000
   0 - successful            0                                          02902000
   1 - duplicate name        0                                          02904000
   4 - no user room          n         n% used.  no index room          02906000
   5 - no user room          0         > 65k entries                    02908000
   6 - no system room        n         for n contiguous blocks        >>02910000
begin                                                                   02912000
   logical newpreietotal;                                               02914000
   integer stemp;                                                       02916000
   integer stemp2;                                                      02918000
   integer stemp3, stemp4;                                              02920000
   integer                                                              02922000
      zt,                                                               02924000
      ztotal,                                                           02926000
      zh1,                                                              02928000
      zhalf1,                                                           02930000
      zh2,                                                              02932000
      zhalf2;                                                           02934000
   logical pointer                                                      02936000
      ipntr,                                                            02938000
      ipntr2;                                                           02940000
   integer pointer                                                      02942000
      iipntr = ipntr,                                                   02944000
      iipntr2 = ipntr2;                                                 02946000
   integer temp;                                                        02948000
   logical pointer tempp = temp;                                        02950000
   integer esize;                                                       02952000
   logical pointer s2pntr = s-2;                                        02954000
   logical pointer s4pntr = s-4;                                        02956000
   logical override := false;  << true-ok to override good% >> <<04733>>02958000
   logical tipntr;  << hold ipntr incase of override >>        <<04733>>02960000
   logical tipntr2;  << ditto for ipntr2 >>                    <<04733>>02962000
   integer tzt;  << ditto for zt >>                            <<04733>>02964000
logical subroutine zinsert (element, which, pntr);                      02966000
   value which;                                                         02968000
   array element, pntr;                                                 02970000
   logical which;                                                       02972000
begin                                                                   02974000
   dirset (which);                                                      02976000
   if @pntr = 0 then                                                    02978000
      << *** find previous element *** >>                               02980000
      begin                                                             02982000
      @pntr := dirscan (element, en lor which);                         02984000
      if > then                                                         02986000
         begin                                                          02988000
         zinsert := 0;                                                  02990000
         return;                                                        02992000
         end;                                                           02994000
      end;                                                              02996000
   stemp2 := base(xsize);                                               02998000
   stemp := ibase(lpntr) + ibase(used) - @pntr;                         03000000
   if <> then                                                           03002000
      << ******** check code for following 2 statements **************>>03004000
      move pntr (stemp+stemp2-1) := pntr(stemp-1), (-stemp);            03006000
   move pntr := element, (stemp2);                                      03008000
   zinsert := @pntr;                                                    03010000
   end    <<zinsert>>;                                                  03012000
logical subroutine znewentryblock (name, indexplace);                   03014000
   array name, indexplace;                                              03016000
begin                                                                   03018000
   if (stemp3 := dbxcount+1) > dbbfactor then                           03020000
      begin                                                             03022000
      if override then go cram'it;  << override good% >>       <<04733>>03024000
      tos := integer (fixr ((real(dbetotal)/real((dbxcount) *           03026000
         ((dbebsize & lsl(7))/esize)))*100.));                          03028000
      tos := 4;                                                         03030000
      << *********** check this branch ***********>>                    03032000
      goto badexit;                                                     03034000
      end;                                                              03036000
   stemp4 := dirallocate (dbebsize);                                    03038000
   if < then                                                            03040000
      begin                                                             03042000
      if override then go cram'it;  << override good% >>       <<04733>>03044000
      tos := dbebsize;                                                  03046000
      tos := 6;                                                         03048000
      << *********** check this branch ***********>>                    03050000
      goto badexit;                                                     03052000
      end;                                                              03054000
   << *** index has room and we have a block *** >>                     03056000
   << ******* check code for folllowing statement **************>>      03058000
   zinsert (name, b, indexplace);                                       03060000
   dbxcount := stemp3;                                                  03062000
   dbused := dbused+isize;                                              03064000
   indexplace (iepntr) := (znewentryblock := stemp4);                   03066000
   end    <<znewentryblock>>;                                           03068000
subroutine zset;                                                        03070000
begin                                                                   03072000
   ztotal := zt * (xreg := esize);                                      03074000
   zhalf1 := (zh1 := zt & lsr(1)) * xreg;                               03076000
   zhalf2 := (zh2 := (zt+1) & lsr(1)) * xreg;                           03078000
   end    <<zset>>;                                                     03080000
subroutine zdistribute;                                                 03082000
begin                                                                   03084000
   move dblpntr (zhalf2-1) := dalpntr (ztotal-1), (-zhalf2);            03086000
   dbused := zhalf2;                                                    03088000
   dbxcount := zh2;                                                     03090000
   dirwrite (b);                                                        03092000
   daused := zhalf1;                                                    03094000
   daxcount := zh1;                                                     03096000
   dirwrite (a);                                                        03098000
   end    <<zdistribute>>;                                              03100000
<< >>                                                                   03102000
   dirread (indexpointer, b, 0, 0);                                     03104000
   esize := dbexsize;                                                   03106000
   newpreietotal := dbetotal+1;                                         03108000
   if carry then                                                        03110000
      begin                                                             03112000
      tos := 5;                                                         03114000
      goto badexitz;                                                    03116000
      end;                                                              03118000
   @ipntr := dirscan (ddsentry, epb);                                   03120000
   if > then                                                            03122000
dupname:                                                                03124000
      begin                                                             03126000
      tos := 1;                                                         03128000
badexitz:                                                               03130000
      assemble (zrob);                                                  03132000
badexit:                                                                03134000
      cc := ccg;                                                        03136000
      goto exit;                                                        03138000
      end;                                                              03140000
   if = then                                                            03142000
      <<*** no containing block: allocate 1 or insert in first one ***>>03144000
      begin                                                             03146000
      @ipntr := @dblpntr;                                               03148000
      if dbxcount > 0 then goto checkfit;                               03150000
      tos := znewentryblock (ddsentry, ipntr);                          03152000
      ipntr (iecount) := 0;                                             03154000
      << *** set up null block *** >>                                   03156000
      dbnumvalid := dbbsize;    <<procect against inaccurate copy in b>>03158000
      dacontents := tos;                                                03160000
      @dalpntr := @daiopntr;                                            03162000
      danumvalid := dbebsize;                                           03164000
      daxsize := dbexsize;                                              03166000
      daused := 0;                                                      03168000
      dabwsize := (dabsize := dbebsize) & lsl(7);                       03170000
      dabfactor := dabwsize/daxsize;                                    03172000
      damiscwd := dbemiscwd;                                            03174000
      daxcount := 0;                                                    03176000
      goto normalinsert;                                                03178000
      end;                                                              03180000
checkfit:                                                               03182000
   if iipntr (iecount) < (temp := (dbebsize & lsl(7)) / esize) then     03184000
      << *** a normal insertion *** >>                                  03186000
      begin                                                             03188000
      dirread (ipntr (iepntr), a, ipntr(iecount), dbemiscwd);           03190000
normalinsert:                                                           03192000
      if zinsert (ddsentry, a, dds) = 0 then goto dupname;              03194000
      daused := daused+esize;                                           03196000
      daxcount := daxcount+1;                                           03198000
      dirwrite (a);                                                     03200000
      dbetotal := newpreietotal;                                        03202000
      move ipntr := dalpntr, (namesize);                                03204000
      iipntr (iecount) := iipntr (iecount) + 1;                         03206000
      dirwrite (b);                                                     03208000
      end                                                               03210000
   else                                                                 03212000
      << *** distribution required *** >>                               03214000
      begin                                                             03216000
      if dbxcount = 1 then goto newdistribute;                          03218000
      if @ipntr = @dblpntr then goto upper;                             03220000
      if @ipntr = @dblpntr (dbused-isize) then goto lower;              03222000
      if iipntr (isize+iecount) <= iipntr (-isize+iecount) then         03224000
upper:   xreg := isize                                                  03226000
      else                                                              03228000
lower:   xreg := -isize;                                                03230000
      @ipntr2 := @ipntr (xreg);                                         03232000
      tos := (zt := iipntr (iecount) + iipntr2 (xreg) + 1);             03234000
      if iipntr2(iecount) < temp then                          <<04733>>03236000
        begin                                                  <<04733>>03238000
          override := true;                                    <<04733>>03240000
          tipntr := ipntr;                                     <<04733>>03242000
          tipntr2 := ipntr2;                                   <<04733>>03244000
          tzt := zt;                                           <<04733>>03246000
        end;                                                   <<04733>>03248000
      if real (tos & lsr(1)) / real (temp) < goodpercent then           03250000
         << *** distribute among neighbors *** >>                       03252000
         begin                                                          03254000
cram'it:   if override then                                    <<04733>>03256000
             begin                                             <<04733>>03258000
               ipntr := tipntr;                                <<04733>>03260000
               ipntr2 := tipntr;                               <<04733>>03262000
               zt := tzt;                                      <<04733>>03264000
             end;                                              <<04733>>03266000
         zset;                                                          03268000
         if @ipntr > @ipntr2 then                                       03270000
            begin  <<make ipntr lower one>>                             03272000
            tos := @ipntr2;                                             03274000
            @ipntr2 := @ipntr;                                          03276000
            @ipntr := tos;                                              03278000
            end;                                                        03280000
         << read in lower block >>                                      03282000
         dirread (ipntr (iepntr), a, ipntr (iecount), dbemiscwd);       03284000
         << kluge to read in upper block right on top of lower >>       03286000
         danumvalid := dbebsize;                                        03288000
         tos := @dbiopntr;                                              03290000
         @dbiopntr := @dalpntr (daused);                                03292000
         dirread (ipntr2 (iepntr), b, ipntr2 (iecount), dbemiscwd);     03294000
         @dbiopntr := (@dblpntr := tos);                                03296000
         << (kluge a's size for zinsert) >>                             03298000
         tos := daxcount;                                               03300000
         tos := daused;                                                 03302000
         daused := ztotal-esize;                                        03304000
         daxcount := zt-1;                                              03306000
         if (temp := zinsert (ddsentry, a,  dds)) = 0 then              03308000
            begin                                                       03310000
            daused := tos;                                              03312000
            daxcount := tos;                                            03314000
            dbcontents := 0;                                            03316000
            goto dupname;                                               03318000
            end;                                                        03320000
         dbnumvalid := danumvalid;                                      03322000
         zdistribute;                                                   03324000
         move dapname := dblpntr, (namesize);   <<dapname not used>>    03326000
         dirread (indexpointer, b, 0, 0);                               03328000
         dbetotal := newpreietotal;                                     03330000
         if temp = @dalpntr then                                        03332000
            move ipntr := dalpntr, (namesize);                          03334000
         ipntr (iecount) := zh1;                                        03336000
         move ipntr2 := dapname, (namesize);                            03338000
         ipntr2 (xreg) := zh2;                                          03340000
         dirwrite (b);                                                  03342000
         end                                                            03344000
      else                                                              03346000
newdistribute:                                                          03348000
         << *** distribute with new block *** >>                        03350000
         begin                                                          03352000
         zt := ipntr (iecount) +1;                                      03354000
         zset;                                                          03356000
         dirread (ipntr (iepntr), a, ipntr(iecount), dbemiscwd);        03358000
         temp := dirscan (ddsentry, ena);                               03360000
         if > then goto dupname;                                        03362000
         @ipntr2 := @ipntr+isize;                                       03364000
         xreg := @dalpntr(zhalf1);                                      03366000
         if temp <= xreg then                                           03368000
            if < then xreg := xreg-daxsize                              03370000
            else xreg := @ddsentry;                                     03372000
         tos := znewentryblock (dds(xreg), ipntr2);                     03374000
         ipntr2 (iecount) := zh2;                                       03376000
         dbetotal := newpreietotal;                                     03378000
         ipntr (xreg) := zh1;                                           03380000
         if temp = @dalpntr then                                        03382000
            move ipntr := ddsentry, (namesize);                         03384000
         dirwrite (b);                                                  03386000
         << *** set up null block in b *** >>                           03388000
         danumvalid := dbebsize;    <<protect against inaccurate copya>>03390000
         dbcontents := tos;                                             03392000
         @dblpntr := @dbiopntr;                                         03394000
         dbnumvalid := dbebsize;                                        03396000
         dbxsize := dbexsize;                                           03398000
         dbused := 0;                                                   03400000
         dbbfactor := (dbbwsize := (dbbsize := dbebsize) & lsl(7))      03402000
            / dbxsize;                                                  03404000
         dbmiscwd := dbemiscwd;                                         03406000
         dbxcount := 0;                                                 03408000
         zinsert (ddsentry, a, tempp);                                  03410000
         zdistribute;                                                   03412000
         end;                                                           03414000
      end;                                                              03416000
   tos := 0d;    <<successfil return>>                                  03418000
   cc := cce;                                                           03420000
exit:                                                                   03422000
   dirinsert := tos;                                                    03424000
   end    <<dirinsert>>;                                                03426000
double procedure dirfind (indexpointer);                                03428000
   value indexpointer;                                                  03430000
   logical indexpointer;                                                03432000
<< return:                                                              03434000
   high order  =  db addr of index (in b).                              03436000
   low order   =  db addr of entry (in a).    >>                        03438000
begin                                                                   03440000
   dirread (indexpointer, b, 0, 0);                                     03442000
   tos := dirscan (ddsentry, epb);                                      03444000
   if = then                                                            03446000
notfound:                                                               03448000
      begin                                                             03450000
      dirfind := 0d;                                                    03452000
      return;                                                           03454000
      end;                                                              03456000
   dirread (s0pntr(iepntr), a, s0pntr(iecount), dbemiscwd);             03458000
   tos := dirscan (ddsentry, ea);                                       03460000
   if <= then goto notfound;                                            03462000
   dirfind := tos;                                                      03464000
   end    <<dirfind>>;                                                  03466000
                                                                        03468000
procedure dirremove (element, which);                                   03470000
   value which;                                                         03472000
   logical which;                                                       03474000
   array element;                                                       03476000
<< decrements <used> and <xcount>;                                      03478000
   removes element;                                                     03480000
   deallocates block when an entry block is depleted.  >>               03482000
begin                                                                   03484000
   dirset (which);                                                      03486000
   whichdirty := true;                                                  03488000
   ibase(used) := ibase(used) - ibase(xsize);                           03490000
   ibase(xcount) := ibase(xcount)-1;                                    03492000
   if = then                                                            03494000
      begin                                                             03496000
      if base(miscwd).(typef) = entrytype then                          03498000
         begin                                                          03500000
         dirdeallocate (base(contents), base(bsize));                   03502000
         base (contents) := (whichdirty := 0);                          03504000
         end;                                                           03506000
      return;                                                           03508000
      end;                                                              03510000
   move element := element (base(xsize)),                               03512000
      (ibase(lpntr)+ibase(used)-@element);                              03514000
   end    <<dirremove>>;                                                03516000
procedure dirreset (numsects);                                          03518000
   value numsects;                                                      03520000
   double numsects;                                                     03522000
<< called to subtract <numsects> from father (and grandfather) when     03524000
   error detected after they are bumped.  assumes b contains current    03526000
   index (thus pointer to father)                                       03528000
   >>                                                                   03530000
   while dbpindexp <> 0 do                                              03532000
      begin                                                             03534000
      move ddsname := dbpname, (namesize);                              03536000
      tos := dirfind (dbpindexp);                                       03538000
      if damiscwd.(levelf) = grouplevel then tos := tos +gdfscount      03540000
      else tos := tos +adfscount;                                       03542000
      dps0 := dps0 -numsects;                                           03544000
      dirwrite (a);                                                     03546000
      end;                                                              03548000
                                                                        03550000
double procedure dirstartoff (parr, numsects, recip, parms);            03552000
   value numsects, parms;                                               03554000
   array parr;                         <<db addr of spec part>>         03556000
   double numsects;                    <<to adjust acct/group>>         03558000
   integer procedure recip;            <<for visit of @ hit>>           03560000
   integer parms;                      <<for visit of @ hit>>           03562000
   option variable;                                                     03564000
<<                                                                      03566000
   analyzes the specification part for directory routines, and          03568000
   goes down tree until just before hit of target, leaving:             03570000
      adjust, xtype, xindexp, xaname, xguname, xfname, xasec and xgsec; 03572000
      db thru db+3 to final name.                                       03574000
   if <numsects> specified, then it's added to acct and group.          03576000
   if <recip> and <parms> specified, then @ entry hit is visited.       03578000
      carry set on return => recip said stop or don't scan my tree.     03580000
   if just <parms> specified, then s access to group checked.           03582000
   type return is directory error pair.                                 03584000
   >>                                                                   03586000
begin                                                                   03588000
   logical pmask = q-4;                                                 03590000
   integer ipmask = pmask;                                              03592000
   switch startswitch := noindex, aindex, gindex, noindex;              03594000
   define                                                               03596000
      movlb1 =                                                          03598000
         tos := 0;                                                      03600000
         tos := #,                                                      03602000
      movlb2 =                                                          03604000
                +adjust;                                                03606000
         tos := namesize;                                               03608000
         assemble (mvlb) #;                                             03610000
                                                                        03612000
                                                                        03614000
subroutine visit;                                                       03616000
   << s-0 = pointer to entry >>                                         03618000
   if ipmask.(14:2) = 3 then                                            03620000
      begin                                                             03622000
      tos := 0d;                                                        03624000
      tos := 0;                                                         03626000
      tos := @ps4;                                                      03628000
      tos := damiscwd.(levelf);                                         03630000
      tos := parms;                                                     03632000
      tos := ds5;                                                       03634000
      tos := recip (*, *, *, *);  <<visit>>                             03636000
      if tos &lsr(1) > 0 then    <<stop or goto brother>>               03638000
         begin        <<so stop entire scan>>                           03640000
         carryx := 1;                                                   03642000
         goto okayexit;                                                 03644000
         end;                                                           03646000
      assemble (ddel);                                                  03648000
      end;                                                              03650000
                                                                        03652000
                                                                        03654000
subroutine badexit (num);                                               03656000
   value num;                                                           03658000
   integer num;                                                         03660000
begin                                                                   03662000
   tos := dbelevel;                                                     03664000
   tos := s2;                                                           03666000
   if pmask & lsr(2) then dirreset (numsects);                          03668000
   goto exit;                                                           03670000
   end    <<subroutine badexit>>;                                       03672000
                                                                        03674000
                                                                        03676000
<< >>                                                                   03678000
   push (dl);                                                           03680000
   exchangedb(ddsdst);                                                  03682000
   adjust := -tos;                                                      03684000
   xasec := -1;                                                         03686000
   xgsec := -1d;                                                        03688000
   if ipmask.(14:2) = 3 then parms := parms -deltaq;                    03690000
   carryx := 0;                                                         03692000
   tos := @workarea+1;                                                  03694000
   tos := @parr+adjust;                                                 03696000
   tos := 1;                                                   <<04733>>03698000
   assemble (mvlb 1);                                          <<04733>>03700000
   assemble (incb);                                            <<04733>>03702000
   tos := 4;                                                   <<04733>>03704000
   assemble (mvlb);                                                     03706000
   goto startswitch (xtype.(startlevelf));                              03708000
noindex:                                                                03710000
   xindexp := sysacctindex;                                             03712000
   if xtype.(endlevelfx) = allaccts then goto okayexit;                 03714000
   movlb1 xaname movlb2;                                                03716000
   if xtype.(endlevelf) = accountlevel then goto okayexit;              03718000
   tos := dirfind (sysacctindex);                                       03720000
   assemble (dtst, delb);                                               03722000
                                                                        03724000
   if = then goto nonexist;                                             03726000
   xasec := ps0 (asecw);                                                03728000
   if pmask &lsr(2) then                                                03730000
      begin    <<bump sector count>>                                    03732000
      tos := tos +adfscount;                                            03734000
      if (tos := dps0 +numsects) > dps0(1) then goto noroom;            03736000
      dps2 := tos;                                                      03738000
      dirwrite (a);                                                     03740000
      tos := tos -adfscount;                                            03742000
      end;                                                              03744000
   visit;                                                               03746000
   case xtype.(endlevelf) of                                   <<04733>>03748000
   begin                                                       <<04733>>03750000
       xreg := agipntr;    <<0 : file>>                        <<04733>>03752000
       xreg := agipntr;    <<1 : group>>                       <<04733>>03754000
       ;                   <<2 : acct>>                        <<04733>>03756000
       xreg := auipntr;    <<3 : user>>                        <<04733>>03758000
       xreg := agipntr;    <<4 : vsd>>                         <<04733>>03760000
   end;                                                        <<04733>>03762000
   xindexp := s0pntr (xreg);                                            03764000
aindex:                                                                 03766000
   movlb1 xguname movlb2;                                               03768000
   case xtype.(endlevelf) of                                   <<04733>>03770000
   begin                                                       <<04733>>03772000
       ; <<keep going>>    <<0>>                               <<04733>>03774000
       go to okayexit;     <<1>>                               <<04733>>03776000
       ;                   <<2>>                               <<04733>>03778000
       go to okayexit;     <<3>>                               <<04733>>03780000
       ; <<keep going>>    <<4>>                               <<04733>>03782000
   end;                                                        <<04733>>03784000
   tos := dirfind (xindexp);                                            03786000
   assemble (dtst, delb);                                               03788000
                                                                        03790000
   if = then                                                            03792000
nonexist:    badexit (2);                                               03794000
   tos := ps0(gsec);                                                    03796000
   tos := ps1(gsec+1);                                                  03798000
   xgsec := tos;                                                        03800000
   if pmask & lsr(2) then                                               03802000
      begin    <<adjust by numsects>>                                   03804000
      tos := tos +gdfscount;                                            03806000
      if (tos := dps0 +numsects) > dps0(1) then                         03808000
noroom:    badexit (8);                                                 03810000
      dps2 := tos;                                                      03812000
      dirwrite (a);                                                     03814000
      tos := tos -gdfscount;                                            03816000
      end;                                                              03818000
   visit;                                                               03820000
   case xtype.(endlevelf) of                                   <<04733>>03822000
   begin                                                       <<04733>>03824000
       xreg := gfipntr;    <<0 : file>>                        <<04733>>03826000
       ;                   <<1 : group>>                       <<04733>>03828000
       ;                   <<2 : acct>>                        <<04733>>03830000
       ;                   <<3 : user>>                        <<04733>>03832000
       xreg := gvsdipntr;  <<4 : vsd>>                         <<04733>>03834000
   end;                                                        <<04733>>03836000
   xindexp := s0pntr (xreg);                                   <<04733>>03838000
gindex:                                                                 03840000
   if not logical (xtype.(allflag)) then                       <<04733>>03842000
      begin                                                             03844000
      movlb1 xfname movlb2;                                             03846000
      end;                                                              03848000
okayexit:                                                               03850000
   tos := 0d;                                                           03852000
exit:                                                                   03854000
   dirstartoff := tos;                                                  03856000
   end    <<simplestartoff>>;                                           03858000
$page                                                                   03860000
$control segment=directory2                                             03862000
                                                                        03864000
double procedure direcinsert (type, indexp, aname, guname, fname,       03866000
   insert);                                                             03868000
   value type, indexp;                                                  03870000
   logical type, indexp;                                                03872000
   array aname, guname, fname, insert;                                  03874000
<< <insert> points to word after <name> in then entry  (i.e. to         03876000
   an indexpointer or file pointer cell).                               03878000
   allocates and initializes appropriate indices for account and group  03880000
   entries  (the corresponding index cells of <insert> are ignored).  >>03882000
    begin                                                               03884000
        array parr (*) = type;                                          03886000
        double                                                          03888000
            junkd;                                                      03890000
        integer                                                         03892000
            junk1 = junkd,                                              03894000
            junk0 = junk1+1;                                            03896000
<<>>                                                                    03898000
        double subroutine newtree (level, ibsize, ebsize,               03900000
                                   esize, xipntr, sd);                  03902000
            value   level, ibsize, ebsize, esize, xipntr, sd;           03904000
            integer level, ibsize, ebsize, esize, xipntr, sd;           03906000
            begin                                                       03908000
                dbpindexp := xindexp;                                   03910000
                move dbpname := ddsentry ,(namesize);                   03912000
                tos := dirnewindex (ibsize,                             03914000
                    level, ebsize, esize);                              03916000
                if <> then                                              03918000
                 begin                                                  03920000
                     del;                                               03922000
                     cc := ccg;                                         03924000
                     junk1 := ibsize;                                   03926000
                     junk0 := 6;                                        03928000
                     newtree := junkd;                                  03930000
                 end                                                    03932000
                else                                                    03934000
                begin                                                   03936000
                    exchangedb (0);                                     03938000
                    insert (s3<<xipntr>>-namesize) := tos;              03940000
                    exchangedb (ddsdst);                                03942000
                end;                                                    03944000
            end;<<of newtree>>                                          03946000
                                                                        03948000
                                                                        03950000
        subroutine returntree (xipntr, ibsize);                         03952000
            value   xipntr, ibsize;                                     03954000
            integer xipntr, ibsize;                                     03956000
            begin                                                       03958000
                exchangedb (0);                                         03960000
                tos := insert (xipntr-namesize);                        03962000
                exchangedb (ddsdst);                                    03964000
                dirdeallocate (*, s2<<ibsize>>);                        03966000
            end;<<of returntree>>                                       03968000
                                                                        03970000
                                                                        03972000
        double subroutine insertentry (level);                          03974000
            value   level;                                              03976000
            integer level;                                              03978000
            begin                                                       03980000
                tos := namesize;                                        03982000
                tos := @insert+adjust;                                  03984000
                case *s3 <<level>> of                          <<04733>>03986000
                begin                                                   03988000
                    tos := fsize;                                       03990000
                    tos := gsize;                                       03992000
                    tos := asize;                                       03994000
                    tos := usize;                                       03996000
                    tos := gvsdsize;                                    03998000
                end;                                                    04000000
                tos := tos - namesize;                                  04002000
                asmb (mvlb);                                            04004000
                if (insertentry := dirinsert (xindexp)) <> 0d then      04006000
                begin  <<need to return dir space>>                     04008000
                    case *level of                             <<04733>>04010000
                    begin                                               04012000
                        ;      <<0: file>>                              04014000
                        begin  <<1: group>>                             04016000
                            returntree (gfipntr, sysgfibsize);          04018000
                            returntree (gvsdipntr, sysgvsibsize);       04020000
                        end;<<of group>>                                04022000
                        begin  <<2: acct>>                              04024000
                            returntree (agipntr, sysagibsize);          04026000
                            returntree (auipntr, sysauibsize);          04028000
                        end;<<of acct>>                                 04030000
                        ;       <<3: user>>                             04032000
                        ;       <<4: vsd>>                              04034000
                    end;<<of level>>                                    04036000
                    cc := ccg;  <<failure>>                             04038000
                end;                                                    04040000
            end;<<of insertentry>>                                      04042000
                                                                        04044000
                                                                        04046000
        cc := cce;  <<ok until any failure>>                            04048000
        tos := dirstartoff (parr);                                      04050000
        asmb (dtst);                                                    04052000
        if = then                                                       04054000
        begin <<found required level>>                                  04056000
            ddel;                                                       04058000
            case *type.(endlevelf) of                          <<04733>>04060000
            begin                                                       04062000
                tos := insertentry (filelevel);                         04064000
                begin  <<group>>                                        04066000
                    tos := newtree (filelevel, sysgfibsize,             04068000
                                    sysfebsize, fsize,                  04070000
                                    gfipntr, 405);                      04072000
                    asmb (dtst);                                        04074000
                    if = then  <<successfull?>>                         04076000
                    begin                                               04078000
                        ddel;                                           04080000
                        tos := newtree (vsdeflevel,                     04082000
                             sysgvsibsize,sysvsebsize,                  04084000
                             gvsdsize,gvsdipntr,415);                   04086000
                        asmb (dtst);                                    04088000
                        if <> then                                      04090000
                         returntree (gfipntr, sysgfibsize)              04092000
                        else                                            04094000
                        begin                                           04096000
                            ddel;                                       04098000
                            tos := insertentry (grouplevel);            04100000
                        end;                                            04102000
                    end;                                                04104000
                end;<<of group>>                                        04106000
                begin  <<acct>>                                         04108000
                    tos := newtree (grouplevel, sysagibsize,            04110000
                                    sysgebsize, gsize, agipntr, 405);   04112000
                    asmb (dtst);                                        04114000
                    if = then <<successfull?>>                          04116000
                    begin                                               04118000
                        ddel;                                           04120000
                        tos := newtree (userlevel, sysauibsize,         04122000
                                        sysuebsize, usize,              04124000
                                        auipntr,405);                   04126000
                        asmb (dtst);                                    04128000
                        if <> then returntree (agipntr, sysagibsize)    04130000
                        else                                            04132000
                        begin <<successfull>>                           04134000
                            ddel;                                       04136000
                            tos := insertentry (accountlevel);          04138000
                        end;                                            04140000
                    end;                                                04142000
                end;<<of acct>>                                         04144000
                tos := insertentry (userlevel);                         04146000
                tos := insertentry (vsdeflevel);                        04148000
            end;<<of endlevel>>                                         04150000
        end else cc := ccg;                                             04152000
        direcinsert := tos;                                             04154000
        exchangedb (0);                                                 04156000
    end;<<of direcinsert>>                                              04158000
double procedure direcinsertfile (numsects, aname, gname,               04160000
      fname, faddr);                                                    04162000
   value numsects, faddr;                                               04164000
   double numsects, faddr;                                              04166000
   array aname, gname, fname;                                           04168000
<<                                                                      04170000
   inserts file entry under acct and group.                             04172000
   increments acct and group space counts by <numsects>.                04174000
   checks that user has save access to group.                           04176000
   (always global access).                                              04178000
   >>                                                                   04180000
begin                                                                   04182000
   array parr (*) = numsects;                                           04184000
   double lnumsects;                                                    04186000
   double ddb4 = db+4;                                                  04188000
<< >>                                                                   04190000
   lnumsects := numsects;                                               04192000
   numsects := 0d;                                                      04194000
   if (tos := dirstartoff (parr, lnumsects, , 0)) <> 0d then            04196000
      goto badexit;                                                     04198000
   ddb4 := faddr;                                                       04200000
   tos := dirinsert (xindexp);                                          04202000
   assemble (dtst);                                                     04204000
   if <> then                                                           04206000
      begin                                                             04208000
      dirreset (lnumsects);                                             04210000
badexit:                                                                04212000
      tos := ccg;                                                       04214000
      end                                                               04216000
   else                                                                 04218000
      tos := cce;                                                       04220000
   cc := tos;                                                           04222000
   direcinsertfile := tos;                                              04224000
   exchangedb (0);                                                      04226000
   end    <<procedure direcinsertfile>>;                                04228000
double procedure direcfind (type, indexp, aname, guname, fname,         04230000
   preturn);                                                            04232000
   value type, indexp;                                                  04234000
   integer type, indexp;                                                04236000
   array aname, guname, fname, preturn;                                 04238000
<< <preturn> will contain full final entry .  >>                        04240000
begin                                                                   04242000
   logical ltype = type;                                                04244000
                                                                        04246000
   array parr (*) = type;                                               04248000
   if (tos := dirstartoff (parr)) <> 0d then goto badexit;              04250000
   assemble (ddel);                                                     04252000
   tos := @preturn+adjust;                                              04254000
   tos := dirfind (xindexp);                                            04256000
   assemble (dtst, delb);                                               04258000
   if = then                                                            04260000
      begin                                                             04262000
      ddel;                                                             04264000
      tos := ltype.(endlevelf);                                         04266000
      tos := 2;                                                         04268000
badexit:                                                                04270000
      tos := ccg;                                                       04272000
      goto exit;                                                        04274000
      end;                                                              04276000
   case type.(endlevelf) of                                    <<04733>>04278000
      begin                                                             04280000
      tos := fsize;                                                     04282000
      tos := gsize;                                                     04284000
      tos := asize;                                                     04286000
      tos := usize;                                                     04288000
      tos := gvsdsize;                                         <<04733>>04290000
      end;                                                              04292000
   assemble (mvbl);                                                     04294000
   tos := 0d;                                                           04296000
   tos := cce;                                                          04298000
exit:                                                                   04300000
   cc := tos;                                                           04302000
   direcfind := tos;                                                    04304000
   exchangedb (0);                                                      04306000
   end    <<direcfind>>;                                                04308000
                                                                        04310000
double procedure direcfindfile (type, indexp, aname, gname,             04312000
      fname, preturn);                                                  04314000
   value type, indexp;                                                  04316000
   logical type, indexp;                                                04318000
   array aname, gname, fname, preturn;                                  04320000
<< returns in <preturn> then file pointer; and asec/gsec                04322000
      depending on the type of search. >>                               04324000
begin                                                                   04326000
   array parr (*) = type;                                               04328000
   if (tos := dirstartoff (parr)) <> 0d then goto badexit;              04330000
   << 2 zeroes on stack >>                                              04332000
   tos := dirfind (xindexp);                                            04334000
   assemble (dtst, delb);                                               04336000
   if = then                                                            04338000
      begin                                                             04340000
      << 2 zeros on stack >>                                            04342000
      tos := tos +2;                                                    04344000
badexit:                                                                04346000
      exchangedb (0);                                                   04348000
      tos := ccg;                                                       04350000
      goto exit;                                                        04352000
      end;                                                              04354000
   tos := dps0(2);                                                      04356000
   tos := xgsec;                                                        04358000
   tos := xasec;                                                        04360000
   exchangedb (0);                                                      04362000
   tos := @preturn;                                                     04364000
   tos := @s5;                                                          04366000
   if integer (type.(startlevelf)) = 1 then tos := 4                    04368000
   else if < then tos := 5                                              04370000
      else tos := 2;                                                    04372000
   assemble (move);                                                     04374000
   assemble (subs 6);                                                   04376000
   tos := cce;                                                          04378000
exit:                                                                   04380000
   cc := tos;                                                           04382000
   direcfindfile := tos;                                                04384000
   end    <<procedure direcfindfile>>;                                  04386000
double procedure direcpurge (type, indexp, aname, guname, fname);       04388000
   value type, indexp;                                                  04390000
   integer type, indexp;                                                04392000
   array aname, guname, fname;                                          04394000
                                                                        04396000
<< general purge routine                                                04398000
double procedure direcpurgefile                                         04400000
      (numsects, aname, gname, fname);                                  04402000
   value numsects;                                                      04404000
   double numsects;                                                     04406000
   ...                                                                  04408000
   purge file entry and adjust acct & group space counts                04410000
   by <numsects>.                                                       04412000
   >>                                                                   04414000
begin                                                                   04416000
   entry direcpurgefile;                                                04418000
   array parr (*) = type;                                               04420000
   double numsects = type;                                              04422000
   double lnumsects;                                                    04424000
   logical fflag := false;                                              04426000
   double groupspacegone := 0d;                                         04428000
                                                                        04430000
                                                                        04432000
   tos := dirstartoff (parr);                                           04434000
   goto start;                                                          04436000
                                                                        04438000
                                                                        04440000
direcpurgefile:                                                         04442000
   fflag := true;                                                       04444000
   lnumsects := numsects;                                               04446000
   numsects := 0d;                                                      04448000
   tos := dirstartoff (parr, lnumsects);                                04450000
                                                                        04452000
                                                                        04454000
start:                                                                  04456000
   if ds1 <> 0d then goto badexit;                                      04458000
   assemble (ddel);                                                     04460000
   tos := dirfind (xindexp);                                            04462000
   assemble (dtst);                                                     04464000
   if = then                                                            04466000
      begin                                                             04468000
      ddel;                                                             04470000
      tos := type.(endlevelf);                                          04472000
      tos := 2;                                                         04474000
      goto badexit0;                                                    04476000
      end;                                                              04478000
   assemble (ddup, zrob);                                               04480000
   assemble (dup, zrob);                                                04482000
         dirremove (*, a);                                              04484000
         assemble (neg, ddel);    <<set carry>>                         04486000
   if dadirty then dirwrite (a);                                        04488000
   if carry then                                                        04490000
      begin                                                             04492000
      xreg := iecount;                                                  04494000
      dbetotal := dbetotal-1;                                           04496000
      if tos = @dalpntr then                                            04498000
         begin                                                          04500000
         assemble (dup);                                                04502000
         move * := dalpntr, (namesize);                                 04504000
         end;                                                           04506000
      s0ipntr(xreg) := s0ipntr(xreg)-1;                                 04508000
      if = then                                                         04510000
         begin                                                          04512000
         dirremove (*, b);                                              04514000
         tos := 0;                                                      04516000
         end;                                                           04518000
      assemble (zero, zrob);                                            04520000
      tos := cce;                                                       04522000
      dirwrite (b);                                                     04524000
      end                                                               04526000
   else                                                                 04528000
      begin                                                             04530000
      assemble (zrob, del);                                             04532000
      tos := 7;                                                         04534000
badexit0:                                                               04536000
      if fflag then dirreset (lnumsects);                               04538000
badexit:                                                                04540000
      tos := ccg;                                                       04542000
      end;                                                              04544000
   cc := tos;                                                           04546000
   direcpurge := tos;                                                   04548000
   tos := groupspacegone;                                               04550000
   if <> then dirreset (*) else assemble (ddel);                        04552000
   exchangedb (0);                                                      04554000
   end    <<direcpurge>>;                                               04556000
double procedure direcadjust (numsects, aname, gname);                  04558000
   value numsects;                                                      04560000
   double numsects;                                                     04562000
   array aname, gname;                                                  04564000
<< adjusts tha acct and group space counts by numsects >>               04566000
begin                                                                   04568000
   array parr (*) = numsects;                                           04570000
   double lnumsects;                                                    04572000
   lnumsects := numsects;                                               04574000
   tos := %40;                                                          04576000
   tos := 0;                                                            04578000
   numsects := tos;                                                     04580000
   if (direcadjust := dirstartoff (parr, lnumsects)) <> 0d then         04582000
      tos := ccg                                                        04584000
   else tos := cce;                                                     04586000
   cc := tos;                                                           04588000
   exchangedb (0);                                                      04590000
   end    <<procedure direcadjust>>;                                    04592000
logical procedure dirdoentry (element, leaflevel, recip, parms,         04594000
   getsirresult);                                                       04596000
   value leaflevel, parms, getsirresult;                                04598000
   array element;                                                       04600000
   integer leaflevel, parms, getsirresult;                              04602000
   integer procedure recip;                                             04604000
   option forward;                                                      04606000
procedure dirscantree (index, leaflevel, recip, parms, getsirresult);   04608000
   value index, leaflevel, parms, getsirresult;                         04610000
   integer index, leaflevel, parms, getsirresult;                       04612000
   integer procedure recip;                                             04614000
begin                                                                   04616000
   integer pointer                                                      04618000
      ip,                                                               04620000
      ep;                                                               04622000
   double pointer                                                       04624000
      dip = ip,                                                         04626000
      dep = ep,                                                         04628000
      ddblpntr = dblpntr;                                               04630000
   double array dddsentry (*) = ddsentry;                               04632000
<< >>                                                                   04634000
   dirread (index, b, 0, 0);     << get tree >>                         04636000
   dbpcount := dbpcount +1;      << mark as undeletable >>              04638000
   dirwrite (b);                                                        04640000
   tos := ddblpntr;              << start scan: initial name >>         04642000
   tos := ddblpntr (1) & dlsl (1) & dlsr (1);                           04644000
   parms := parms -deltaq;                                              04646000
                                                                        04648000
nextname:                                                               04650000
   << index in block b; target name on tos >>                           04652000
   dddsentry (1) := tos;                                                04654000
   dddsentry := tos;                                                    04656000
   @ip := dirscan (ddsentry, epb);  << find containing block >>         04658000
   if = then                                                            04660000
      begin                                                             04662000
      @ip := dirscan(ddsentry,enb);                                     04664000
      if = then goto leave;                                             04666000
   end;                                                                 04668000
nextblock:                                                              04670000
   dirread (ip (iepntr), a, ip (iecount), dbemiscwd);                   04672000
   @ep := dirscan (ddsentry, ena);  << find entry in block >>           04674000
   if = then                                                            04676000
      begin                      << not in entry block >>               04678000
      if (@ip := @ip +dbxsize) >= @dblpntr +dbused then goto leave;     04680000
      goto nextblock;                                                   04682000
      end;                                                              04684000
   tos := dep;                                                          04686000
   tos := dep (1) & dlsl (1) & dlsr (1);                                04688000
   assemble (inca);              << next target name >>                 04690000
   tos := dirdoentry (ep, leaflevel, recip, parms, getsirresult);       04692000
   << directory may be completely modified, except that                 04694000
      index block <index> still exists.     the directory is locked >>  04696000
   dirread (index, b, 0, 0);                                            04698000
   if not (tos) then goto nextname;                                     04700000
                                                                        04702000
leave:                                                                  04704000
   dbpcount := dbpcount-1; <<allow deletion of index>>                  04706000
   dirwrite (b);                                                        04708000
   end    <<dirscantree>>;                                              04710000
logical procedure dirdoentry (element, leaflevel, recip, parms,         04712000
   getsirresult);                                                       04714000
   value leaflevel, parms, getsirresult;                                04716000
   array element;                                                       04718000
   integer leaflevel, parms, getsirresult;                              04720000
   integer procedure recip;                                             04722000
begin                                                                   04724000
<< >>                                                                   04726000
   xreg := 0;                                                  <<04733>>04728000
   case damiscwd.(levelf) of  <<current subtree>>              <<04733>>04730000
   begin                                                       <<04733>>04732000
       ;                                               <<0>>   <<04733>>04734000
       xreg := if leaflevel = filelevel then gfipntr   <<1>>   <<04733>>04736000
                                         else gvsdipntr;       <<04733>>04738000
       case leaflevel of                               <<2>>   <<04733>>04740000
       begin                                                   <<04733>>04742000
           xreg := agipntr;   <<0>>                            <<04733>>04744000
           xreg := agipntr;   <<1>>                            <<04733>>04746000
           ;                  <<2>>                            <<04733>>04748000
           xreg := auipntr;   <<3>>                            <<04733>>04750000
           xreg := agipntr;   <<4>>                            <<04733>>04752000
       end;                                                    <<04733>>04754000
       ;                                               <<3>>   <<04733>>04756000
       ;                                               <<4>>   <<04733>>04758000
   end;                                                        <<04733>>04760000
   tos := damiscwd.(levelf);                                            04762000
   tos := 0;                     << get ready for visit via recip >>    04764000
   tos := @element;                                                     04766000
   tos := s2;                                                           04768000
   tos := (parms := parms -deltaq);                                     04770000
          tos := 0;                                                     04772000
   tos := getsirresult;                                                 04774000
   tos := recip (*, *, *, *);    << visit entry >>                      04776000
   if tos & lsr(1) > 1 then                                             04778000
      dirdoentry := 1;           << stop scan >>                        04780000
   if < then                     << continue scan >>                    04782000
      if tos <> leaflevel then                                          04784000
         dirscantree (                                                  04786000
            element (xreg),                                    <<04733>>04788000
            leaflevel, recip, parms, getsirresult);                     04790000
   end    <<dirdoentry>>;                                               04792000
double procedure direcscan (type, indexp, aname, guname, fname,         04794000
   recip, parms);                                                       04796000
   value type, indexp;                                                  04798000
   integer type, indexp;                                                04800000
   integer procedure recip;                                             04802000
   array aname, guname, fname, parms;                                   04804000
begin                                                                   04806000
   array parr (*) = type;                                               04808000
   logical savesir;                                                     04810000
logical ltype = type;                                                   04812000
<< >>                                                                   04814000
                                                                        04816000
                                                                        04818000
   tos := @parms;                                                       04820000
   push (q);                                                            04822000
   @parms := tos -tos;                                                  04824000
   if ltype.(hitflag) then                                              04826000
      tos := dirstartoff (parr, , recip, @parms)                        04828000
   else tos := dirstartoff (parr);                                      04830000
   savesir := sirreturn;                                                04832000
   if ds1 <> 0d then goto badexit;                                      04834000
   if carry then goto goodexit;                                         04836000
   << (2 zeros on stack) >>                                             04838000
   if logical (type.(allflag)) then                                     04840000
      dirscantree (xindexp, type.(tolevelf), recip, @parms,             04842000
         savesir)                                                       04844000
   else                                                                 04846000
      begin                                                             04848000
      tos := xindexp;            << make use of 2 zeros >>              04850000
      tos := dirfind (*);        << visit root >>                       04852000
      assemble (dtst, zrob);     << setup for dirdoentry >>             04854000
      if = then                                                         04856000
         begin                                                          04858000
         assemble (ddel);                                               04860000
         tos := type.(endlevelf);                                       04862000
         tos := 2;                                                      04864000
badexit: tos := ccg;                                                    04866000
         goto exit;                                                     04868000
         end;                                                           04870000
      dirdoentry (*, type.(tolevelf), recip, @parms, savesir);          04872000
      tos := 0d;                                                        04874000
      end;                                                              04876000
                                                                        04878000
goodexit:                                                               04880000
   if dadirty then dirwrite (a);                                        04882000
   if dbdirty then dirwrite (b);                                        04884000
   tos := cce;                                                          04886000
exit:                                                                   04888000
   cc := tos;                                                           04890000
   direcscan := tos;                                                    04892000
   exchangedb (0);                                                      04894000
   end    <<direcscan>>;                                                04896000
          <<--------------------                                        04898000
            clean up directory                                          04900000
          -------------------->>                                        04902000
  integer procedure directoryclean(element,level,parms,garbage);        04904000
    value level,parms,garbage;                                          04906000
    array element;                                                      04908000
    integer level,parms;                                                04910000
    double garbage;                                                     04912000
    comment                                                             04914000
      scan directory and perform the following actions:                 04916000
    at account level -                                                  04918000
       reset count of # logged on in index block                        04920000
       if reload or recovery reset file space count                     04922000
    at group level -                                                    04924000
       same actions as account level                                    04926000
    at file level -                                                     04928000
       accountsonly reload: purge file                                  04930000
       reload: set bit 8 of first word of disc address                  04932000
       recovery: remove disc space for file. if any part of it          04934000
                 overlaps a deleted track, purge the file. otherwise    04936000
                 adjust the account and group file space counts;        04938000
      begin                                                             04940000
                                                               <<sy>>   04942000
        ext'dcl;                                               <<sy>>   04944000
        integer pointer dtt;                                   <<04772>>04946000
        byte    pointer bbuf;                                  <<04772>>04948000
        double  pointer flabdbl;                               <<04772>>04950000
                                                               <<sy>>   04952000
        integer array arq(*)=q+0;                                       04954000
        double array delement(*)=element;                               04956000
        double pointer delementp1;                                      04958000
        logical len, nsect;                                             04960000
        double fileadr,discadr=fileadr,fsect;                           04962000
        double sectors;                                                 04964000
        integer discadr0=discadr;                                       04966000
        byte pointer bflab;                                             04968000
        integer                                                <<*7467>>04970000
           area'ldev,                                          <<*7467>>04972000
           i,                                                  <<*7467>>04974000
           j,                                                  <<*7467>>04976000
           k,                                                  <<*7467>>04978000
           ldev,                                               <<*7467>>04980000
           ldt'index,                                          <<*7467>>04982000
           lpdt'index,                                         <<*7467>>04984000
           subtyp,                                             <<*7467>>04986000
           type,                                               <<*7467>>04988000
           volume;                                             <<*7467>>04990000
        double size;                                           <<04733>>04992000
        integer err'code;                                      <<sy>>   04994000
                                                               <<04733>>04996000
        equate  vtabsize          =  14,                       <<sy>>   04998000
                vtab12            =  12,                       <<sy>>   05000000
                rel               =   4,                       <<sy>>   05002000
                ldtsize           =   7,                       <<*7467>>05004000
                lpdtsize          =   4;                       <<*7467>>05006000
                                                               <<sy>>   05008000
        define                                                 <<*7467>>05010000
                ldt'device'type   = ldt(ldt'index+2).(10:6)  #,<<*7467>>05012000
                lpdt'subtype      = lpdt(lpdt'index+1).(12:4)#,<<*7467>>05014000
                flnumexts         =  flab'(39).(11:5) #,       <<sy>>   05016000
                ext0              =  22 #,                     <<sy>>   05018000
                vtabldev          =  (0:8)  #;                 <<sy>>   05020000
                                                               <<sy>>   05022000
                                                               <<04733>>05024000
subroutine remove(err'code);                                   <<04733>>05026000
value err'code;                                                <<04733>>05028000
integer                                                        <<04733>>05030000
   err'code;        << indicates reason for purge >>           <<04733>>05032000
                                                               <<04733>>05034000
comment                                                        <<04733>>05036000
purge the directory entry for a file.  print the file name     <<04733>>05038000
and reason for purging.                                        <<04733>>05040000
                                                               <<04733>>05042000
;                                                              <<04733>>05044000
begin                                                          <<04733>>05046000
                                                               <<04733>>05048000
<< if no files purged yet, print header:  following files >>   <<04733>>05050000
<< purged--disc errors                                    >>   <<04733>>05052000
                                                               <<04733>>05054000
if arq(parms+1) = 0 then message(2280);                        <<04733>>05056000
                                                               <<04733>>05058000
arq(parms+1) := arq(parms+1) + 1;                              <<04733>>05060000
printfnr(arq(parms+2),err'code);                               <<04733>>05062000
                                                               <<04733>>05064000
tos := direcpurge(filetype,0,arq(parms+10),arq(parms+6),       <<04733>>05066000
                  arq(parms+2));                               <<04733>>05068000
if <> then direrror(*,bbuf);                                   <<04733>>05070000
                                                               <<04733>>05072000
ddel;                                                          <<04733>>05074000
end;   << remove >>                                            <<04733>>05076000
                                                               <<04733>>05078000
integer subroutine check'data'lost(flabel);                    <<04733>>05080000
value flabel;                                                  <<04733>>05082000
logical                                                        <<04733>>05084000
   flabel;     << if true, discadr and len point at  >>        <<04733>>05086000
               <<     a file label                   >>        <<04733>>05088000
comment                                                        <<04733>>05090000
check if the disc area beginning at discadr, of length len     <<04733>>05092000
overlaps an area of the disc which lost data                   <<04733>>05094000
during sparing.  if flabel is true, do further checks to see   <<04733>>05096000
if the area overlaps a deleted track or if the file label or   <<04733>>05098000
file label checksum is bad.  we do not check file extents      <<04733>>05100000
to see if they overlap deleted tracks because this is taken    <<04733>>05102000
care of when we try to remove the disc space for the extent.   <<04733>>05104000
if any of these errors are found, return an error number.      <<04733>>05106000
otherwise return zero.  the returns are:                       <<04733>>05108000
                                                               <<04733>>05110000
                0   no error                                   <<04733>>05112000
                4   file label checksum error                  <<04733>>05114000
                6   on deleted or newly reassigned area        <<04733>>05116000
                7   bad file label                             <<04733>>05118000
;                                                              <<04733>>05120000
begin                                                          <<04733>>05122000
check'data'lost := 0;     << initialize return >>              <<04733>>05124000
                                                               <<04733>>05126000
<< see if the area overlaps a newly reassigned area    >>      <<04733>>05128000
<< (an area where data was just lost)                  >>      <<04733>>05130000
                                                               <<04733>>05132000
j := 1;                                                        <<04733>>05134000
while get'area(reassigned',j,nreass+1,area'ldev,fsect,size) do <<ss>>   05136000
   begin                                                       <<04733>>05138000
   if ldev = area'ldev then                                    <<04733>>05140000
      if fsect < (discadr + double(len)) and                   <<04733>>05142000
         (fsect + size) > discadr then                         <<04733>>05144000
         begin                                                 <<04733>>05146000
         check'data'lost := 6;                                 <<04733>>05148000
         return;                                               <<04733>>05150000
         end;                                                  <<04733>>05152000
   j := j+1;                                                   <<04733>>05154000
   end;                                                        <<04733>>05156000
                                                               <<04733>>05158000
if not flabel then return;      << not a file label >>         <<04733>>05160000
                                                               <<04733>>05162000
<< if the space is on a type 0 or type 1 disc, check the >>    <<04733>>05164000
<< dtt to see if it overlays a deleted track.            >>    <<04733>>05166000
                                                               <<04733>>05168000
ldt'index := ldev * ldtsize;                                   <<*7467>>05170000
lpdt'index:= ldev * lpdtsize;                                  <<*7467>>05172000
type := ldt'device'type;                                       <<*7467>>05174000
subtyp := lpdt'subtype;                                        <<*7467>>05176000
                                                               <<04733>>05178000
if type = disc0 or type = disc1 then                           <<04733>>05180000
   begin                                                       <<04733>>05182000
   disc(read,ldev,1d,dtt,128);   << get the dtt >>             <<04733>>05184000
   j := 0;                                                     <<04733>>05186000
   while (j:=j+1) <= dtt(0) do                                 <<04733>>05188000
      if dtt(j).(14:2) = 2 then                                <<04733>>05190000
         begin           << deleted track >>                   <<04733>>05192000
         nsect := if type = disc0 then                         <<04733>>05194000
                     mhinfo'(subtyp*mhinfosize+mhsectrk)       <<ss>>   05196000
                  else                                         <<04733>>05198000
                     32;                                       <<04733>>05200000
         fsect := nsect**logical(dtt(j)&lsr(2));               <<04733>>05202000
                                                               <<04733>>05204000
         if fsect < (discadr+double(len)) and                  <<04733>>05206000
            (fsect + double(nsect)) > discadr then             <<04733>>05208000
            begin                                              <<04733>>05210000
            check'data'lost := 6;                              <<04733>>05212000
            return;                                            <<04733>>05214000
            end;                                               <<04733>>05216000
         end;                                                  <<04733>>05218000
   end;                                                        <<04733>>05220000
                                                               <<04733>>05222000
if arq(parms+4) < 0 then                                       <<04733>>05224000
   begin                        << bad file label >>           <<04733>>05226000
   check'data'lost := 7;                                       <<04733>>05228000
   return;                                                     <<04733>>05230000
   end;                                                        <<04733>>05232000
                                                               <<04733>>05234000
<< wait till now to read the file label because it might >>    <<04733>>05236000
<< have been found above to overlap a deleted track.     >>    <<04733>>05238000
                                                               <<04733>>05240000
disc (read,ldev,discadr,flab',128);  <<read the file label>>   <<ss>>   05242000
checksum;            << check for file label checksum error >> <<04733>>05244000
if tos <> flchecksum then     << label must be in 'flab' >>    <<04733>>05246000
   begin                                                       <<04733>>05248000
   check'data'lost := 4;                                       <<04733>>05250000
   return;                                                     <<04733>>05252000
   end;                                                        <<04733>>05254000
                                                               <<04733>>05256000
end;   << check'data'lost >>                                   <<04733>>05258000
                                                               <<04733>>05260000
          exchangedb(0);               << initialize these   >><<04772>>05262000
          @dtt     :=  @lbuf' (128);   << 3 vars. w/o split  >><<04772>>05264000
          @bbuf    :=  @buf';          << stck bcause of ex- >><<04772>>05266000
          @flabdbl :=  @flab';         << ternal globals:    >><<04772>>05268000
          exchangedb(ddsdst);          << lbuf',buf',& flab' >><<04772>>05270000
                                                               <<04772>>05272000
          parms := parms-arq;                                           05274000
                                                               <<04733>>05276000
                                                               <<04733>>05278000
          if level=accountlevel then                                    05280000
            begin   <<account entry>>                                   05282000
              dirread(element(agipntr),b,0,0); <<read index block>>     05284000
              if dbpcount<>0 then                                       05286000
                begin  <<reset count of # of people logged on>>         05288000
                  dbpcount := 0;                                        05290000
                  dbdirty := true;                                      05292000
                end;                                                    05294000
              if arq(parms) >= rel or arq(parms+14) <> 0 then           05296000
                begin  <<reload or recovery>>                           05298000
                  delement(adfscountd) := 0d;                           05300000
                  dadirty := true;                                      05302000
                  move arq(parms+10) := element,(4);                    05304000
                end;                                                    05306000
            end                                                         05308000
          else if level=grouplevel then                                 05310000
            begin  <<group entry>>                                      05312000
              if logical (element (glinkage).(pvf))            <<04733>>05314000
                 and element (x).(mvtabxf) <> 0 then           <<04733>>05316000
              begin  <<reset mvtabx & restore gfipntr>>        <<04733>>05318000
                  element (x).(mvtabxf) := 0;                  <<04733>>05320000
                  if element (gsavefipntr) <> 0 then           <<04733>>05322000
                   element (gfipntr) := element (gsavefipntr); <<04733>>05324000
                  element (gsavefipntr) := 0;                  <<04733>>05326000
                  element (gmountrefcntr) := 0;                <<04733>>05328000
                  dadirty := true;                             <<04733>>05330000
              end;                                             <<04733>>05332000
              dirread(element(gvsdipntr),b,0,0); <<vsd index>> <<04733>>05334000
              if dbpcount<>0 then                              <<04733>>05336000
                begin                                          <<04733>>05338000
                  dbpcount:=0;                                 <<04733>>05340000
                  dbdirty :=true;                              <<04733>>05342000
                end;                                           <<04733>>05344000
              dirread(element(gfipntr),b,0,0); <<read index block>>     05346000
              if dbpcount<>0 then                                       05348000
                begin                                                   05350000
                  dbpcount := 0;                                        05352000
                  dbdirty := true;                                      05354000
                end;                                                    05356000
              if arq(parms) >= rel or arq(parms+14) <> 0 then           05358000
                begin  <<reload or recovery>>                           05360000
                  @delementp1 := @element+1;                            05362000
                  delementp1(4) := 0d;  <<file space count>>            05364000
                  dadirty := true;                                      05366000
                  move arq(parms+6) := element,(4);                     05368000
                end;                                                    05370000
            end                                                         05372000
          else if level<>filelevel then errmessage(m275)       <<04733>>05374000
          else                                                          05376000
            begin  <<file entry>>                                       05378000
              if arq(parms) >= rel then <<reload>>                      05380000
              if logical(arq(parms+15)) then                            05382000
                begin  <<accountsonly - purge file>>                    05384000
                  move arq(parms+2) := element,(4);                     05386000
                  exchangedb(0);                                        05388000
                  tos := direcpurge(filetype,0,arq(parms+10),           05390000
                    arq(parms+6),arq(parms+2));                         05392000
                  if <> then direrror(*,bbuf);                          05394000
                  ddel;                                                 05396000
                  exchangedb(dirdstn);                                  05398000
                end                                                     05400000
              else                                                      05402000
                begin  <<set bit in file entry>>                        05404000
                  element(fvolpntrw).(8:1) := 1; <<file not found yet>> 05406000
                  x := parms+1;                                         05408000
                  arq(x) := arq(x)+1;  <<# of files in directory>>      05410000
                  dadirty := true;                                      05412000
                end                                                     05414000
              else                                                      05416000
                begin           << doing a recover   >>        <<04733>>05418000
                                <<   lost disc space >>        <<04733>>05420000
                  tos := element(fvolpntrw);                            05422000
                  volume := s0.(0:8);  <<vtab index>>                   05424000
                  tos := tos.(8:8);                                     05426000
                  tos := element(x:=x+1);                               05428000
                  discadr := tos;   <<disc address>>                    05430000
                  move arq(parms+2) := element,(4);                     05432000
                  exchangedb(0);                                        05434000
                  ldev:=vtab(volume*vtabsize+vtab12).vtabldev;          05436000
                  len := 1;                                             05438000
                                                               <<04733>>05440000
                << check to see if file label is bad or     >> <<04733>>05442000
                <<    is on a bad part of the disc.  if so, >> <<04733>>05444000
                <<    remove the file's directory entry     >> <<04733>>05446000
                                                               <<04733>>05448000
                  if (err'code := check'data'lost(true))       <<04733>>05450000
                                                <> 0 then      <<04733>>05452000
                     begin                                     <<04733>>05454000
                     remove(err'code);  << remove file      >> <<04733>>05456000
                     goto ok;           <<  directory entry >> <<04733>>05458000
                     end;                                      <<04733>>05460000
                                                               <<04733>>05462000
                << flab was set up by check'data'lost >>       <<04733>>05464000
                                                               <<04733>>05466000
                  sectors := 0d;                                        05468000
                  i := 0;                                               05470000
                  do                                                    05472000
                    begin  <<remove space for file's extents>>          05474000
                      err'code := 0;   << init. error code >>  <<04733>>05476000
                      tos := flabdbl(ext0+i);                           05478000
                      if = then begin ddel;goto nextextent;end;         05480000
                      volume := s1.(0:8);                               05482000
                      s1.(0:8) := 0;                                    05484000
                      discadr := tos;                                   05486000
                   tos:=vtab(volume*vtabsize+vtab12).vtabldev;          05488000
                      ldev := s0;                                       05490000
                      tos := 0;                                         05492000
                      tos := getextlen(i);                              05494000
                      assemble(ddup,dup);                               05496000
                      len := tos;                                       05498000
                      sectors := tos+sectors;                           05500000
                                                               <<04733>>05502000
                      << check to see if extent overlaps an >> <<04733>>05504000
                      << area of the disc which just lost   >> <<04733>>05506000
                      << data.  if so, save the file name   >> <<04733>>05508000
                      << (user has option to purge later)   >> <<04733>>05510000
                      << and continue checking all extents. >> <<04733>>05512000
                                                               <<04733>>05514000
                      if (err'code := check'data'lost(false))  <<04733>>05516000
                                                     <> 0 then <<04733>>05518000
                         begin                                 <<04733>>05520000
                         << remove duplicate entries first >>  <<04733>>05522000
                         remove'badfile(arq(parms+2));         <<04733>>05524000
                                                               <<04733>>05526000
                         << if unable to save file name,   >>  <<04733>>05528000
                         <<    we will purge it now.       >>  <<04733>>05530000
                                                               <<04733>>05532000
                         if add'badfile(arq(parms+2)) then     <<04733>>05534000
                            err'code := 0;                     <<04733>>05536000
                         end;                                  <<04733>>05538000
                                                               <<04733>>05540000
                      << remove the disc space for this     >> <<04733>>05542000
                      << extent.  if we can't get the space >> <<04733>>05544000
                      << back, it might be because the      >> <<04733>>05546000
                      << extent is on a track which was     >> <<04733>>05548000
                      << just deleted.                      >> <<04733>>05550000
                                                               <<04733>>05552000
                      remdiscspace(*,*,discadr);                        05554000
                      if <> then  <<couldn't remove space>>             05556000
                         err'code := 5;                        <<04733>>05558000
                                                               <<04733>>05560000
                      if err'code <> 0 then                    <<04733>>05562000
                        begin  <<purge file - return space>>   <<04733>>05564000
                                                               <<04733>>05566000
                          << remove file directory entry. >>   <<04733>>05568000
                          << if file is on list of bad    >>   <<04733>>05570000
                          << files, remove it.            >>   <<04733>>05572000
                                                               <<04733>>05574000
                          remove'badfile(arq(parms+2));        <<04733>>05576000
                          remove( err'code);                   <<04733>>05578000
                                                               <<04733>>05580000
                          k := -1;                                      05582000
                          while (k:=k+1) < i do                         05584000
                            begin  <<return space for extente>>         05586000
                              discadr := flabdbl(ext0+k);               05588000
                              if <> then                                05590000
                                begin                                   05592000
                                  tos := discadr0;                      05594000
                                  volume := s0.(0:8);                   05596000
                                  discadr0 := tos.(8:8);                05598000
                                  ldev := vtab(volume*vtabsize          05600000
                                    +vtab12).vtabldev;                  05602000
                                  retdiscspace(ldev,double(    <<04733>>05604000
                                    getextlen(k)),discadr);             05606000
                                  if <> then message(m328);    <<04733>>05608000
                                end;                                    05610000
                            end;                                        05612000
                          goto ok;                                      05614000
                        end;                                            05616000
                                                               <<04733>>05618000
  nextextent:                                                           05620000
                    end                                                 05622000
                  until (i:=i+1)>flnumexts;                             05624000
                  tos := direcadjust(sectors,arq(parms+10),             05626000
                    arq(parms+6));  <<adjust file space counts>>        05628000
                  if <> then direrror(*,bbuf);                          05630000
                  ddel;                                                 05632000
  ok:             exchangedb(dirdstn);                                  05634000
                end;                                                    05636000
            end;                                                        05638000
          directoryclean := 1;  <<continue scan>>                       05640000
      end <<directoryclean>> ;                                          05642000
          <<------------------------------------                        05644000
            clean up user entries in directory                          05646000
          ------------------------------------>>                        05648000
  integer procedure userclean(element,level,parms,garbage);             05650000
    value level,parms,garbage;                                          05652000
    array element;                                                      05654000
    integer level,parms;                                                05656000
    double garbage;                                                     05658000
    comment                                                             05660000
      scan directory. at account level and user level reset count       05662000
    of users logged on;                                                 05664000
      begin                                                             05666000
          if level=accountlevel then                                    05668000
            begin                                                       05670000
              dirread(element(auipntr),b,0,0);                          05672000
              if dbpcount<>0 then                                       05674000
                begin                                                   05676000
                  dbpcount := 0;                                        05678000
                  dbdirty := true;                                      05680000
                end;                                                    05682000
            end                                                         05684000
          else if level<>userlevel then errmessage(m276)       <<04733>>05686000
          else if element(ulogcount)<>0 then                            05688000
            begin                                                       05690000
              element(x) := 0;                                          05692000
              dadirty := true;                                          05694000
            end;                                                        05696000
          userclean := 1;                                               05698000
      end <<userclean>> ;                                               05700000
integer procedure set'1'mgr(element, level, parms, garbage);   <<04733>>05702000
  value level, parms, garbage;                                 <<04733>>05704000
  array element;                                               <<04733>>05706000
  integer level, parms;                                        <<04733>>05708000
  double garbage;                                              <<04733>>05710000
                                                               <<04733>>05712000
  comment                                                      <<04733>>05714000
    set logon count for manager.sys to minimum level of one    <<04733>>05716000
    so that user manager.sys can not be purged;                <<04733>>05718000
                                                               <<04733>>05720000
    begin                                                      <<04733>>05722000
      element(ulogcount) := 1;                                 <<04733>>05724000
      dadirty := true;                                         <<04733>>05726000
      set'1'mgr := %77;                                        <<04733>>05728000
    end;  << set'1'mgr >>                                      <<04733>>05730000
          <<------------------------------------>>             <<04733>>05732000
          <<clean up volume set definition entries in directory  rv.pv>>05734000
          <<---------------------------------->>               <<04733>>05736000
  integer procedure vsdclean (element,level,parms,garbage);    <<04733>>05738000
      value   level,parms,garbage;                             <<04733>>05740000
      array   element;                                         <<04733>>05742000
      integer level,parms;                                     <<04733>>05744000
      double  garbage;                                         <<04733>>05746000
      comment                                                  <<04733>>05748000
          scan directory for volume set definition entries     <<04733>>05750000
          and reset all but (0:1) of gvslinkagew and reset     <<04733>>05752000
          gvsdrefcnt words;                                    <<04733>>05754000
      begin                                                    <<04733>>05756000
          if level = vsdeflevel then                           <<04733>>05758000
          begin                                                <<04733>>05760000
              element (gvslinkagew).(1:15) := 0;               <<04733>>05762000
              element (gvsdrefcnt) := 0;                       <<04733>>05764000
              dadirty := true;                                 <<04733>>05766000
          end;                                                 <<04733>>05768000
          vsdclean := 1;  <<continue scan>>                    <<04733>>05770000
      end;<<of vsdclean>>                                      <<04733>>05772000
          <<-----------------------                                     05774000
            purge files not found                                       05776000
          ----------------------->>                                     05778000
  integer procedure filepurge(element,level,parms,garbage);             05780000
    value level,parms,garbage;                                          05782000
    array element;                                                      05784000
    integer level,parms;                                                05786000
    double garbage;                                                     05788000
      begin                                                             05790000
                                                               <<sy>>   05792000
        ext'dcl;                                               <<sy>>   05794000
        byte pointer bbuf := @buf';                            <<sy>>   05796000
        integer array arq(*)=q+0;                                       05798000
          parms := parms-arq;                                           05800000
          if level=accountlevel then move arq(parms+9) := element,(4)   05802000
          else if level=grouplevel then move arq(parms+5) := element,(4)05804000
          else if element(4).(8:1)=1 then                               05806000
            begin  <<purge file>>                                       05808000
              move arq(parms+1) := element,(4);                         05810000
              exchangedb(0);                                            05812000
              if listpurge then                                         05814000
                 printfname(arq(parms+1));                              05816000
              tos := direcpurge(filetype,0,arq(parms+9),arq(parms+5),   05818000
                arq(parms+1));                                          05820000
              if <> then direrror(*,bbuf);                              05822000
              ddel;                                                     05824000
              exchangedb(dirdstn);                                      05826000
              arq(x) := arq(parms)-1;                                   05828000
              if = then                                                 05830000
                begin  <<finished scan>>                                05832000
                  tos := 4;                                             05834000
                  goto ret;                                             05836000
                end;                                                    05838000
            end;                                                        05840000
          tos := 1;                                                     05842000
  ret:    filepurge := tos;                                             05844000
      end <<filepurge>> ;                                               05846000
end.  << intial utility procedures >>                                   05848000
