<< LINES .001/.009 ARE RESERVED FOR SYSTEMS INTEGRATION>>               00000001
$control adr, map             <<code is useless>>                       01000000
                                                                        01002000
<< store/restore -- module 06 >>                                        01004000
<< hp32002 mpe source c.01.00 >>                                        01006000
                                                                        01008000
$control errors = 50                                                    01010000
$control segment=main                                                   01012000
$control privileged                                                     01014000
$control define                                                         01015000
$thirty                                                                 01016000
                                                                        01018000
$copyright "COPYRIGHT (C)  HEWLETT-PACKARD CO. 1981 ",&                 01020000
$  "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",&          01022000
$  "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",&        01024000
$  "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",&    01026000
$  "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",&      01028000
$  "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."      01030000
                                                                        01032000
begin                                                                   01034000
                                                                        01036000
<<-------------------------------------------------------------         01038000
                                                                        01040000
                                                                        01042000
     xxxxx   xxxxx   xxxxx   xxxx    xxxxx              x               01044000
     x         x     x   x   x   x   x                 x                01046000
     x         x     x   x   x   x   x                x                 01048000
     xxxxx     x     x   x   xxxx    xxxxx           x                  01050000
         x     x     x   x   x  x    x              x                   01052000
         x     x     x   x   x   x   x             x                    01054000
     xxxxx     x     xxxxx   x   x   xxxxx        x                     01056000
                                                                        01058000
                                                                        01060000
     xxxx    xxxxx   xxxxx   xxxxx   xxxxx   xxxx    xxxxx              01062000
     x   x   x       x         x     x   x   x   x   x                  01064000
     x   x   x       x         x     x   x   x   x   x                  01066000
     xxxx    xxxxx   xxxxx     x     x   x   xxxx    xxxxx              01068000
     x  x    x           x     x     x   x   x  x    x                  01070000
     x   x   x           x     x     x   x   x   x   x                  01072000
     x   x   xxxxx   xxxxx     x     xxxxx   x   x   xxxxx              01074000
                                                                        01076000
                                                                        01078000
   written by:                                                          01080000
                                                                        01082000
      stan sieler    (1980 --> november 1981)                           01084000
                                                                        01086000
   restore written by:                                                  01088000
                                                                        01090000
      lou bershad    (1981 --> )                                        01092000
                                                                        01094000
                                                                        01096000
   (inspired, slightly, by the original store in module 52.)            01098000
---------------------------------------------------------->>            01100000
$page "SELECT COMPILER OPTIONS"                                         01102000
                                                                        01104000
<<-----------------------------------------------------                 01106000
                                                                        01108000
compiler ($) options used by this source:                               01110000
                                                                        01112000
   x1   flag that, when on, compiles debugging code                     01114000
        into the resultant usl/prog file.                               01116000
        note: resultant program file should not be                      01118000
              given to users!...it is dangerous!                        01120000
                                                                        01122000
   x2   flag that, when on, compiles code that allows the user to       01124000
        use a default tapename.  in order to parse this correctly       01126000
        indirect files will be referenced by  !filename instead of      01128000
        *filename.                                                      01130000
                                                                        01132000
   x3   flag that, when on, compiles some special                       01134000
        testing code into the resultant usl/prog,                       01136000
        this code is designed to be used by stan sieler                 01138000
        and includes such things as: opening and using                  01140000
        a file called storecat.sieler.mpe (or, if not                   01142000
        present, storecat.pub.sys) instead of using the                 01144000
        system message catalog for generating messages.                 01146000
        also added are new store/restore keyword                        01148000
        options:                                                        01150000
                                                                        01152000
           attio ... force, if possible, store to use                   01154000
                     the attachio method of writing to                  01156000
                     tape instead of the fwrite method,                 01158000
                     for all non-labelled tapes.                        01160000
                                                                        01162000
           lock ...  add keyword to control how files                   01164000
                     get locked during scanning phase.                  01166000
                     ***caution***                                      01168000
                                                                        01170000
           update... when any file is locked for storing,               01172000
                     this keyword will update its                       01174000
                     last access & modification dates to                01176000
                     today's date ... i.e: update the file.             01178000
------------------------------------------------------------>>          01180000
                                                                        01182000
$set x1 = off   << on = debugging code compiled in          >>          01184000
                                                                        01186000
$set x2 = on  << allow default tapefile name                >>          01188000
                                                                        01190000
$set x3 = off   << on = compile in stan's debugging stuff   >>          01192000
                                                                        01194000
$set x9 = on    << on = compile restore code >>                <<lb.rs>>01196000
$set x5 = off   << on = print statistics                    >>          01198000
<<$control hardwarn   >>     <<if on, treat all warnings as errors>>    01200000
                                                                        01202000
<<$control nolistif >>       <<if on, don't list $if lines>>            01204000
                                                                        01206000
<<control nolistomit >>     <<if on, don't list lines omitted by $if>>  01208000
$page "STORE PHILOSOPHY"                                                01210000
                                                                        01212000
<<--------------------------------------------------------------        01214000
                                                                        01216000
notes on error handling:                                                01218000
                                                                        01220000
   all error messages are generated and printed by this program.        01222000
   after a "fatal" error occurs, this program will (perhaps) inform     01224000
   the caller (either via mail or a jcw) and then terminates.           01226000
                                                                        01228000
   none of the error messages now in the ci message set of the          01230000
   system catalog are used by this program.  they should be removed     01232000
   when the old store/restore procedures are completely phased out.     01234000
                                                                        01236000
                                                                        01238000
philosophy (some...more is distributed throughout the source):          01240000
                                                                        01242000
   1) no calls to suddendeath.  period!                                 01244000
                                                                        01246000
   2) all errors (and their messages) are handled as closely            01248000
      as possible to the source of the error.  if a procedure           01250000
      detects an error, it calls sendmessage to print the               01252000
      error, and typically returns a failed result to its               01254000
      caller.                                                           01256000
                                                                        01258000
   3) few "magic" numbers appear anywhere other than in global          01260000
      equates/defines.                                                  01262000
                                                                        01264000
   4) it is considered an "error" if a call to store or                 01266000
      restore of valid syntax results in an empty set of                01268000
      files to store or restore.  this is becaue we assume              01270000
      that the reason store or restore is being called is               01272000
      to actually move/get one or more files...if zero are              01274000
      selected, then the "reason" was not fulfilled, hence              01276000
      an error.                                                         01278000
                                                                        01280000
------------------------------------------------------------>>          01282000
$page "GLOBAL DEBUGGING DECLARATIONS"                                   01284000
$set x8=off                                                             01284100
$set x6=off                                                             01284150
$include inclldt5                                                       01284200
$include incllpdt                                                       01284300
$include inclpxg                                                        01284400
$control adr                                                            01284900
                                                                        01286000
$if x1=on then                <<debugging code>>                        01288000
                                                                        01290000
logical                                                                 01292000
   debugging  :=0;                                                      01294000
                                                                        01296000
real                                                                    01298000
   debugpause:=1.0;                                                     01300000
                                                                        01302000
define                                                                  01304000
                                                                        01306000
   store'catalog'title = "STORECAT.PUB.SYS " #,                         01308000
   store2'catalog'title = "STORECAT.BERSHAD.MPE " #,                    01310000
                                                                        01312000
      <<don't use switch 2 until the help call is taken                 01314000
        out of mpe-iv!!!>>                                              01316000
                                                                        01318000
   debug'parms       = test'switch (01) and debugging #,                01320000
   debug'stepit      = test'switch (02) and debugging #,                01322000
   debug'sirs        = test'switch (03) and debugging #,                01324000
   debug'sendmessage = test'switch (04) and debugging #,                01326000
   debug'irestore    = test'switch (05) and debugging #,                01328000
   debug'lab'tape    = test'switch (06) and debugging #,                01330000
   debug'dir         = test'switch (07) and debugging #,                01332000
   debug'send'end    = test'switch (10) and debugging #,                01334000
   debug'thunk'store = test'switch (11) and debugging #,                01336000
   debug'write'tape  = test'switch (12) and debugging #,                01338000
   debug'disk        = test'switch (13) and debugging #,                01340000
   debug'errors      = test'switch (14) and debugging #,                01342000
   debug'fstore      = test'switch (15) and debugging #;                01344000
                                                                        01346000
      << *** declarations for debugging output *** >>                   01348000
                                                                        01350000
logical array                                                           01352000
   outputbuffer (0:65);                                                 01354000
                                                                        01356000
byte array                                                              01358000
   outputbuffer' (*) = outputbuffer (0);                                01360000
                                                                        01362000
byte pointer                                                            01364000
   pout;                                                                01366000
                                                                        01368000
define                                                                  01370000
   endsay =                                                             01372000
      ,2;                                                               01374000
      @pout:=tos;                                                       01376000
      end #,                                                            01378000
   say =                                                                01380000
      begin                                                             01382000
      move pout:=  #;                                                   01384000
                                                                        01386000
$if                           <<debugging code>>                        01388000
$page "INCLUDE FILES"                                                   01390000
                                                                        01392000
   define                                                               01394000
      readf    = 10:01 #,                                               01396000
      appendf  = 11:01 #,                                               01398000
      writef   = 12:01 #,                                               01400000
      lockf    = 13:01 #,                                               01402000
      executef = 14:01 #,                                               01404000
      savef    = 15:01 #;                                               01406000
                                                                        01408000
equate                                                                  01410000
   max'num'extents   = 32 ;  <<maximum number of extents>>              01412000
equate                                                                  01414000
   on    = 1,                                                           01416000
   off   = 0;                                                           01418000
equate                                                                  01420000
   delete    = 4,                                                       01422000
   perm      = 1,                                                       01424000
   ldtdstn     = %16,      <<ldt dst # >>                               01426000
   sectorsize = 128;                                                    01428000
define                                                                  01430000
   debug'raf = test'switch (13) and debugging #,                        01432000
   blanks'8   = "        "#;                                            01434000
logical array                                                           01440000
   ldt (*) = db + 0;                                           <<lb.rs>>01442000
define                                                                  01444000
   lpdt1    = lpdt' ( sub'ldn & lsl(1) + 1)   #;                        01446000
$page "GLOBAL DECLARATIONS"                                             01448000
integer                                                                 01450000
   max'xds'size   := %40000,  <<maximum usable xds>>      <<32640>>     01452000
   num'xds        := 3;       <<number of xds buffers to use>>  <<2>>   01454000
logical                                                                 01456000
   freeze'and'lock'xds := true; <<should we freeze/lock xds>> <<true>>  01458000
integer                                                                 01460000
   info'address   = q-5,      <<used for info= byte pointer>>           01462000
   info'length    = q-6,      <<used for info= length>>                 01464000
   parm           = q-4,      <<used for parm= >>                       01466000
   star                       := [8/"*", 8/" "],                        01468000
   store'catalog  := 0;       <<file number of store msg catalog>>      01470000
                                                                        01472000
logical                                                                 01474000
   using'driver := false;     <<if using driver then do not allow >>    01476000
                              <<sysdump or dbstore                >>    01478000
$page "GLOBAL EQUATES"                                                  01480000
equate                                                                  01482000
   file'part'size = 8,        <<number of chars in a file part>>        01484000
   file'part'words= 4,        <<number of words in a file part>>        01486000
   file'2'part'words = 2*file'part'words,                               01488000
   file'3'part'words = 3*file'part'words,                               01490000
   max'std'len    = ( 10  <<overhead>> <<max len of std-form title>>    01492000
                     + 2 + file'part'size    <<file part>>              01494000
                     + 1 + file'part'size    <<lock part>>              01496000
                     + 1 + file'part'size    <<group part>>             01498000
                     + 1 + file'part'size    <<acct part>>              01500000
                   <<+ 1 + file'part'size>>  <<family part>>            01502000
                   <<+ 1 + file'part'size>>  <<host part>>              01504000
                   <<+ 10 >>  ),       <<expansion!>>                   01506000
   max'std'len'words=((max'std'len+1)/2),                               01508000
   max'title'len  = (  1 + file'part'size    <<"*" & file part len>>    01510000
                     + 1 + file'part'size    <</lockword>>              01512000
                     + 1 + file'part'size    <<.group>>                 01514000
                     + 1 + file'part'size    <<.account>>               01516000
                     + 1 ),            <<trailing blank>>               01518000
   max'title'len'words = ((max'title'len+1)/2),                         01520000
   max'title'len2 = (max'title'len                                      01522000
                     + 1 + file'part'size    <<-file>>                  01524000
                     + 1 + file'part'size  <<.group...no lockword!>>    01526000
                     + 1 + file'part'size    <<.account>>               01528000
                     + 0 );            <<trailing blank added above>>   01530000
$page "GLOBAL DEFINES -- MISCELLANEOUS"                                 01532000
define                                                                  01534000
                                                                        01536000
         <<miscellaneous defines...(alphabetical) ...>>                 01538000
                                                                        01540000
   all'files      = -1d #,    <<unlock all files>>                      01542000
                                                                        01544000
   allocate'stack'space =                                               01546000
      assemble (adds 0) #,                                              01548000
                                                                        01550000
   allow'empty'fileset = true #,                                        01552000
                                                                        01554000
   attio'statusf  = (13:03) #,<<status field for attachio>>             01556000
                                                                        01558000
   build'tape'buffer =        <<allocate tape buffer on stack>>         01560000
      begin                                                             01562000
      push(s);                                                          01564000
      @tdbuf:=tos;                                                      01566000
      tos:=tape'recsize;                                                01568000
      assemble (adds 0);                                                01570000
      fill (tdbuf, tape'recsize, 0);                                    01572000
      end #,                                                            01574000
                                                                        01576000
   candidat'fsize       = 128d #,                                       01578000
                                                                        01580000
   candidat'recsize     = (look'patterns'length +              <<lb.rs>>01582000
                           file'part'words + 1) #,             <<lb.rs>>01583000
                                                               <<lb.rs>>01583010
   candidat'used        = candidat'buf (0) #,                  <<lb.rs>>01583100
                                                                        01584000
   check'break    =                                                     01586000
      begin                                                             01588000
      if requestservice then                                            01590000
         fail (sr'break'sensed);                                        01592000
      end #,                                                            01594000
                                                                        01596000
   default'g'num'fsize =        <<def recsize for good file>>  <<04965>>01598000
      (if sysdumping then 16000d else 4000d) #,                <<04965>>01598100
                                                                        01600000
   disable'arithmetic'traps =                                           01602000
      begin                                                             01604000
      push (status);                                                    01606000
      tos.(2:1):=0;           <<disable arithmetic traps>>              01608000
      set (status);                                                     01610000
      end #,                                                            01612000
                                                                        01614000
   devtypef       = (08:08) #,<<devinfo field for device type>>         01616000
                                                                        01618000
   duplicativebit = (14:01)#, <<bit in mode returned by who>>           01620000
                                                                        01622000
   enable'arithmetic'traps =                                            01624000
      begin                                                             01626000
      push (status);                                                    01628000
      tos.(2:1):=1;           <<enable arithmetic traps>>               01630000
      tos.(4:1):=0;           <<turn off overflow indicator>>           01632000
      set (status);                                                     01634000
      end #,                                                            01636000
                                                                        01638000
   file'vtab =                                                          01640000
      vtabinx (file'ldev, pvmvtabx) .(08:08)  #,                        01642000
                                                                        01644000
   flab'checksum  =                                                     01646000
      begin                                                             01648000
      x:=127;                                                           01650000
      tos:=-1;                                                          01652000
      do                                                                01654000
         begin                                                          01656000
         if x <> flchecksumx then                                       01658000
            if x <> flmiscx then                                        01660000
               if x <> flclidx then                                     01662000
                  tos:=tos xor flab'l(x);                               01664000
         x:=x-1;                                                        01666000
         end                                                            01668000
      until < ;                                                         01670000
      flchecksum:=tos;                                                  01672000
      end #,                                                            01674000
                                                                        01676000
   interactivebit = (15:01) #,<<bit in mode returned by who>>           01678000
                                                                        01680000
   is             = = #,                                                01682000
                                                                        01684000
   isnt           = <> #,                                               01686000
                                                                        01688000
                                                                        01734000
   move'from'tape'buff'to'flab =                                        01736000
      if using'attio then                                               01738000
         move'data'in (buffer'xds (curr'wait'buffer),          <<lb.rs>>01740000
                       buffer'offset (curr'wait'buffer),       <<lb.rs>>01741000
                       flab,                                   <<lb.rs>>01742000
                       file'label'size )                       <<lb.rs>>01743000
      else                                                              01744000
         move flab := tdbuf , (file'label'size) #,                      01746000
                                                               <<lb.rs>>01746090
   move'to'tape'label          =                               <<lb.rs>>01746100
      if using'attio then                                      <<lb.rs>>01746200
         move'data'in (buffer'xds (curr'wait'buffer),          <<lb.rs>>01746300
                       buffer'offset (curr'wait'buffer),       <<lb.rs>>01746310
                       tape'label,                             <<lb.rs>>01746400
                       tape'label'size )                       <<lb.rs>>01746410
      else                                                     <<lb.rs>>01746500
         move tape'label := tdbuf , (tape'label'size) #,       <<lb.rs>>01746600
                                                               <<lb.rs>>01746700
   move'to'tdbuf               =                               <<lb.rs>>01746800
      if using'attio then                                      <<lb.rs>>01746900
         move'data'in (buffer'xds (curr'wait'buffer),          <<lb.rs>>01747000
                       buffer'offset (curr'wait'buffer),       <<lb.rs>>01747100
                       tdbuf,                                  <<lb.rs>>01747200
                       3 * file'part'words) #,                 <<lb.rs>>01747300
                                                               <<lb.rs>>01747600
                                                                        01748000
   mvtabxf        = (8:8) #,  <<glinkage ????>>                         01750000
                                                                        01752000
   nonsystem'vs   = group'entry(glinkage).(pvf) = pv#,                  01754000
                                                                        01756000
   old'vtab       = vtabinx (old'ldev, pvmvtabx) #,                     01758000
                                                                        01760000
   opt'forward         =                                                01762000
$if x9=on then                                                          01764000
      option forward, uncallable                                        01766000
$if                                                                     01768000
$if x9=off then                                                         01770000
      option uncallable;                                                01772000
      begin                                                             01774000
      end                                                               01776000
$if                                                                     01778000
           #,                                                           01780000
                                                                        01782000
   opt'forward'vari    =                                                01784000
$if x9=on then                                                          01786000
      option forward, uncallable, variable                              01788000
$if                                                                     01790000
$if x9=off then                                                         01792000
      option uncallable, variable;                                      01794000
      begin                                                             01796000
      end                                                               01798000
$if                                                                     01800000
         #,                                                             01802000
                                                                        01804000
   opt'forward'priv    =                                                01806000
$if x9=on then                                                          01808000
      option forward, uncallable, privileged                            01810000
$if                                                                     01812000
$if x9=off then                                                         01814000
      option uncallable, privileged;                                    01816000
      begin                                                             01818000
      end                                                               01820000
$if                                                                     01822000
         #,                                                             01824000
                                                                        01826000
   pout'offset    = (@pout-@outputbuffer') #,                           01828000
                                                                        01830000
   pvf            = 0:1 #,                                              01832000
                                                                        01834000
   pv'filesize    = 2048d #,                                            01836000
                                                                        01838000
   read'good'file =                                                     01840000
      begin                                                             01842000
      fread (g'num, gbuf, g'recsize);                                   01844000
      if < then                                                         01846000
         file'fail (g'num, sr'g'read'fail);                             01848000
      end #,                                                            01850000
   recsize'flag   = (01:01)#, <<feq option bit for recsize>>            01852000
                                                                        01854000
   rewind'good'file=                                                    01856000
      begin                                                             01858000
      if fkontrol (g'num, rewind) = failed then                         01860000
         file'fail (no'file, sr'g'num'rewind); <<msg printed>>          01862000
      end #,                                                            01864000
                                                                        01866000
   send           = send'  #,                                           01868000
                                                                        01870000
   setxpxfixed    =                                                     01872000
      push(dl);                                                         01874000
      x:=tos-ps0(-2) #,       <<set x to point to pxfixed area>>        01876000
                                                                        01878000
   shrink'stack   =           <<restores original z>>                   01880000
      begin                                                             01882000
      if old'zsize <> 0 then                                            01884000
         zsize (old'zsize);                                             01886000
      end #,                                                            01888000
                                                                        01890000
   subtypef       = (05:03) #,<<devinfo field for subtype>>    <<06164>>01892000
                                                                        01894000
   tape'typef     = (05:11) #,<<tape type field in device info>>        01896000
                                                               <<04726>>01898000
   tape'close'disp= (if labeled then 1 else 3)  #,             <<04726>>01900000
                                                                        01902000
   unread'tape    = read'was'already'done :=true  #,                    01904000
                                                                        01906000
   update'good'file =                                                   01908000
      begin                                                             01910000
      fupdate (g'num, gbuf, g'recsize);                                 01912000
      if < then                                                         01914000
         file'fail (g'num, sr'g'update'fail);                           01916000
      end #,                                                            01918000
                                                                        01920000
                                                                        01924000
   want'jcw       = wants.(15:01) #,                                    01926000
                                                                        01928000
   want'mail      = wants.(14:01) #;                                    01930000
$page "GLOBAL EQUATES -- MISCELLANEOUS"                                 01932000
equate                                                                  01934000
   a'agipntr      =  4  ,     <<acct-group indx ptr offset>>   <<lb.rs>>01934500
   a'auipntr      =  5  ,                                      <<lb.rs>>01934600
   attio'bsf      = 8  ,                                       <<lb.rs>>01935000
   attio'bsr      = 12 ,                                       <<lb.rs>>01935100
   attio'eof      = 2  ,      <<attachio eof found         >>           01936000
   attio'good     = 1  ,                                                01938000
   attio'prior'error = %43,                                    <<lb.rs>>01939000
   attio'read     = 0  ,      <<attachio read function code>>           01940000
   attio'write    = 1  ,      <<attachio write function code>>          01942000
   attio'wtm      = 6  ,      <<attachio write tape mark func code>>    01944000
   attio'fsf      = 7  ,      <<attachio file skip forward func code>>  01946000
                                                                        01948000
   both'true      = %(2)11  , <<2 trues >>                              01950000
   bufstat'empty     = 0  ,   <<non-allocated xds>>                     01952000
   bufstat'allocated = 1  ,   <<xds has been allocated>>                01954000
   bufstat'locked    = 2  ,   <<xds has been locked>>                   01956000
   bufstat'frozen    = 3  ,   <<xds has been frozen>>                   01958000
                                                                        01960000
   caller'fopen      = 1  ,                                             01962000
   caller'fclose     = 2  ,                                             01964000
   candidat'blockfactor = 16  ,                                         01966000
   candidat'extents     = 1    ,                                        01968000
   ccg            = 0  ,                                                01970000
   ccl            = 1  ,                                                01972000
   cce            = 2  ,                                                01974000
   coldloadidn    = %1075  ,  <<absolute address of coldload id>>       01976000
   command'text'len    = 128 , <<one word shorter than we ...        >> 01978000
   command'text''len   = 256 , <<allocated, to serve as overflow area>> 01980000
   conddismount'bind = -3  ,                                            01982000
   condmount'bind    = -3  ,                                            01984000
   ctulv          = 1  ,      <<left tape cartridge>>                   01986000
   cturv          = 2  ,      <<right tape cartridge>>                  01988000
                                                                        01990000
   d'blockfactor  = 32 ,      <<direc file blockfactor>>                01992000
   d'recsize      = 12 ,      <<direc file record size>>                01994000
   d'blocksize    = d'recsize * d'blockfactor,                 <<lb.rs>>01995000
   default'tape'recsize=4096 ,<<default recsize for normal tape>>       01996000
   data'area'b    =  1  ,     <<for dirread and dirwrite>>     <<lb.rs>>01997000
   den'option     = 46  ,     <<ffileinfo option for density>>          01998000
   denviol        = 42  ,     <<file system err: density violation>>    02000000
   direc'max'recsize= 4096  , <<max size for directory records>>        02002000
   dirdst         = 20  ,     <<directory data segment #>>     <<lb.rs>>02003000
                                                                        02004000
   eotcode        = 23  ,     <<error code signifying end of tape>>     02006000
   err'bad'tape   = 1  ,      <<returned by tape'switch, start'volume>> 02008000
   err'ccl        = 1  ,                                                02010000
   err'ccg        = 2  ,                                                02012000
   err'wrong'tape = 2  ,      <<returned by tape'switch, start'volume>> 02014000
                                                                        02016000
   failed         = 0      ,  <<ret by various logical procs>> <<lb.rs>>02018000
   file'storing   = 2                   , << file is being stored>>     02020000
   file'restoring = 3                   , << file is being restored>>   02022000
   file'label'size = 128  ,   <<size, in words, of a file label>>       02024000
   file'size'minv = 1  ,      <<find actual number of in-use sectors>>  02026000
   file'size'maxv = 2  ,      <<find number of allocated sectors>>      02028000
   flabio'hard'err= 1  ,      <<flabio "hard error" return>>            02030000
   flabio'soft'err= 2  ,      <<flabio "soft error" return>>            02032000
   flabio'ok      = 0  ,      <<flabio "ok" return value>>              02034000
   fs'acct'disc                               = 50,                     02036000
   fs'dev'unavail                             = 55,                     02038000
   fs'dup'perm'file                           = 100,                    02040000
   fs'dup'temp'file                           = 101,                    02042000
   fs'err'recovered                           = 39,            <<04102>>02043000
   fs'file'accessed                           = 90,                     02044000
   fs'file'excl'acc                           = 91,                     02046000
   fs'group'disc                              = 61,                     02048000
   fs'lab'end'of'volume'set                   = 123,           <<lb.rs>>02048100
   fs'lockword'viol                           = 92,                     02050000
   fs'no'acct                                 = 50,                     02052000
   fs'no'file                                 = 52,                     02054000
   fs'no'group                                = 51,                     02056000
   fs'no'uv'cap                               = 112,                    02058000
   fs'out'of'disc'space                       = 46,                     02060000
   fs'security'viol                           = 93,                     02062000
   fs'vs'not'mounted                          = 113,                    02064000
                                                                        02066000
   good           = 1     ,   <<  good <==> not(failed)  >>    <<lb.rs>>02068000
   good'skipfile  = 3     ,   <<  good but skipfile used >>    <<lb.rs>>02068100
   good'skiprecord= 5     ,   <<  good but skiprecord used>>   <<lb.rs>>02068200
   got'sir        = true  ,   <<passed to the file label procs>>        02070000
                                                                        02072000
   item'devtype   = 41    ,   <<item number for ffileinfo >>            02074000
   item'devsubtype= 42    ,   <<item number for ffileinfo >>            02076000
   item'labaddr   = 19    ,   <<item number for ffileinfo >>            02078000
   item'ldev      = 50    ,   <<item number for ffileinfo >>            02078100
   item'virt      = 51    ,   <<item number for ffileinfo >>            02078200
                                                                        02080000
   jcw'restore'fail=1091  ,   <<value for cierror>>                     02082000
   jcw'store'fail = 1090  ,   <<value for cierror>>                     02084000
                                                                        02086000
   lock'file         = 1  ,   <<passed to lock'unlock'file>>            02088000
   lock'nowv         = 0  ,   <<lock files at start...normal way>>      02090000
   lock'delayv       = 1  ,   <<lock files when needed, if we can>>     02092000
   lock'waitv        = 2  ,   <<as above, but wait if needed to lock>>  02094000
   lock'nonev        = 3  ,   <<never lock...let user beware!>>         02096000
                                                                        02098000
   magtape           = 24  ,  <<device tape of "mag tape">>             02100000
   max'7970'recsize  = 4096  ,<<maximum recsize for normal tape>>       02102000
   max'7976'recsize  = 8192  ,<<maximum for 7976 tape>>                 02104000
   max'error'level   = 10,                                              02106000
   max'io            = 10  ,     <<maximum   of pending ios to tape>>   02108000
   max'num'xds       = 12,    <<must be greater than num'xds>>          02110000
   max'tape'buf'size = max'7976'recsize , <<maximum size of tdbuf>>     02112000
   max'pat'len       = 9 ,    <<maximum length of encoded pattern>>     02114000
      max'pat'len'2     = 2 * max'pat'len ,                             02116000
      max'pat'len'3     = 3 * max'pat'len ,                             02118000
      max'pat'len'4     = 4 * max'pat'len ,                             02120000
      max'pat'len'5     = 5 * max'pat'len ,                             02122000
      look'patterns'length = 6 * max'pat'len,                           02124000
   max'pause'loops= 200  ,    <<max   of pause loops in cxstore>>       02126000
   max'sdisc'recsize = 8192  ,<<maximum recsize for serial disc>>       02128000
   max'synch'files= 10  ,     <<max files to be skipped >>     <<lb.rs>>02129000
   min'stack'size = 4096   ,  <<minimum size of stack excluding tdbuf>> 02130000
   my'stack       = 0  ,      <<denotes original stack/db>>             02132000
                                                                        02134000
   no'file        = -1  ,     <<used to call fail subroutines>>         02136000
   nocreate       = -3  ,     <<return from check'direc >>              02138000
                                                                        02140000
   parm'restore   = 2  ,      <<parm meaning restore>>                  02142000
   parm'store     = 1  ,      <<parm meaning store>>                    02144000
   parm'dbstore   = 3  ,      <<parm meaning dbstore>>                  02146000
   parm'sysdump   = 4  ,      <<parm meaning sysdump>>                  02148000
   parm'dbrestore = 5  ,      <<parm meaning dbrestor>>                 02150000
   parm'reload    = 6  ,      <<parm meaning reload>>                   02152000
   ppr'len        = 31 ,                                                02154000
   procinfo'ret'size = 28,                                     <<04870>>02156000
   pv             = 1  ,      <<glinkage ????>>                         02158000
   pv'aoptions    = %104  ,   <<exc, read/write>>                       02160000
   pv'blockfactor = 4  ,                                                02162000
   pv'buffers     = 1  ,                                                02164000
   pv'extents'initial = 1  ,                                            02166000
   pv'extents'max = 32  ,                                               02168000
   pv'foptions    = %2000  ,  <<nofeq, fixed, filename, bin, new>>      02170000
   pv'recsize     = 9  ,      <<group+acct=4 wds, mvtabinx = 1 wd>>     02172000
   pvinx'acct     = 4  ,      <<index of acct info in pv records>>      02174000
   pvinx'group    = 0  ,      <<index of group info in pv records>>     02176000
   pvinx'pvinfo   = 8  ,      <<index of pvinfo in pv records>>         02178000
   pxfwcont       = 33  ,     <<offset in pxfixed of continue flag>>    02180000
                                                                        02182000
   restoringv     = 2  ,      <<we are doing a restore>>                02184000
                                                                        02186000
   sdisc          = 31  ,     <<device type of serial disc>>            02188000
   software'abort = 32  ,     <<filesys error caused by abortio>>       02190000
   storingv       = 1  ,      <<we are doing a store>>                  02192000
   stdlist'num    = 2  ,      <<usual file number of $stdlist>>         02194000
   subtype'7970   = 0  ,      <<subtype for hp7970 tape>>               02196000
   subtype'7976   = 1  ,      <<subtype for hp7976 tape>>               02198000
   sysdumpingv    = 3  ,      <<we are doing a sysdump>>                02200000
   sysdump'first'record'size=32, <<size of 1st rec of 1st sysdump reel>>02202000
                                                                        02204000
   tape'dir'recsize = 12  ,   <<  of words in tape directory recs>>     02206000
   tape'label'size  = 40  ,   <<  of words in tape label>>              02208000
   temp'rewind    = 2  ,      <<fclose disposition>>                    02210000
   type'7970      = %030  ,   <<subtype/type from device info>>         02212000
   type'7976      = %430  ,   <<subtype/type from device info>>         02214000
                                                                        02216000
   unlock'file    = 0  ,      <<passed to lock'unlock'file>>            02218000
                                                                        02220000
   version'1      = 1  ,      <<pre-mpe-2b store/restore tape>>         02222000
   version'2      = 2  ,      <<mpe2b-->mpe4 (mit ?) store tape>>       02224000
   version'3      = 3  ,      <<mpe4 (mit ?+) store tape>>              02226000
   vmax           = 8  ,      <<volume membership maximum>>             02228000
                                                                        02230000
   xds'overhead   = 0   ;     <<communication area in xds>>             02232000
$page "GLOBAL EQUATES -- MISCELLANEOUS"                                 02234000
equate                                                                  02236000
                                                                        02238000
      <<sirs...>>                                                       02240000
                                                                        02242000
   dsir           =  8,       <<directory sir>>                         02244000
   fisir          = 37,       <<file integrity sir>>                    02246000
                                                                        02248000
      <<mail equates...>>                                               02250000
                                                                        02252000
   mail'overall   = 0,        <<overall result= good/failed>>           02254000
   mail'why       = 1,        <<why error code (see below)>>            02256000
   mail'bad       = 2,        <<mail message index>>                    02258000
   mail'good      = 3,        <<# of files stored/restored>>            02260000
                                                                        02262000
   mail'length    = 4,        <<number of words in mail message>>       02264000
                                                                        02266000
   why'good       = 0,        <<no error found>>                        02268000
   why'syntax     = 1,        <<parsing syntax>>                        02270000
   why'opening'files=2,       <<opening utility files>>                 02272000
   why'indirect   = 3,        <<opening indirect file>>                 02274000
   why'opening'tape=4,        <<opening tape file>>                     02276000
   why'scanning   = 5,        <<scanning files to store/restore>>       02278000
   why'doing      = 6,        <<doing actual store/restore>>            02280000
                                                                        02282000
      <<fcontrol equates...>>                                           02284000
                                                                        02286000
   rewind         =  5,                                                 02288000
   weof           =  6,                                                 02290000
   fsf            =  7,                                                 02292000
   bsf            =  8,                                                 02294000
   rewind'unload  =  9,                                                 02296000
                                                                        02298000
                                                                        02300000
      <<account entry equates..>>                                       02302000
   a'sec'inx      = 26,                                                 02304000
   a'size         = 29,                                                 02306000
                                                                        02308000
      <<lock equates - flstorerestore..>>                               02310000
   no'lockv       = 0,                                                  02312000
   store'lockv    = 2,                                                  02314000
   restore'lockv  = 3,                                                  02316000
                                                                        02318000
      <<group entry equates..>>                                         02320000
                                                                        02322000
   namesize       = 4,                                                  02324000
   group'inx      = 0,                 <<name>>                         02326000
   gfipntr        = group'inx+namesize,<<file index pointer>>           02328000
   gpass          = gfipntr+1,         <<password>>                     02330000
   gdfscount      = gpass+namesize,    <<disc file space>>              02332000
   gdfslimit      = gdfscount+2,                                        02334000
   gcpucount      = gdfslimit+2,       <<cpu time>>                     02336000
   gcpulimit      = gcpucount+2,                                        02338000
   gcontimecount  = gcpulimit+2,                                        02340000
   gcontimelimit  = gcontimecount+2,                                    02342000
   g'sec          = gcontimelimit+2,                                    02344000
   gpurgeflagw    = g'sec,                                              02346000
   gcap           = g'sec+2,                                            02348000
   glinkage       = gcap+1,                                             02350000
   gvsdipntr      = glinkage+1,        <<vs def index pointer>>         02352000
   ghvsname       = gvsdipntr+1,       <<home vs name>>                 02354000
   ghvsaname      = ghvsname,          << "   "  acct name>>            02356000
   ghvsgname      = ghvsaname+namesize,<< "   "  grp  name>>            02358000
   ghvsvsname     = ghvsgname+namesize,<< "   "  vs   name>>            02360000
   ghvsvsname'    = ghvsvsname * 2,    << "   "  "    "   >>            02362000
   gsavefipntr    = ghvsvsname+namesize,<<saves gfipntr>>               02364000
   gmountrefcntr  = gsavefipntr+1,     <<mount use counter>>            02366000
   gspare         = gmountrefcntr+1,                                    02368000
   gsize          = gspare+1,                                           02370000
   gsize'd        = (gsize+1)/2,       <<used to declare double arr>>   02372000
                                                                        02374000
                                                                        02376000
      <<callers of cxstore/cxrestore...>>                               02378000
                                                                        02380000
   caller'ci      = 0,        <<caller is the ci>>                      02382000
   caller'ci'command = 1,     <<caller is the ci, from command int>>    02384000
   caller'sysdump = 2,        <<caller is sysdump>>                     02386000
   caller'dbstore = 3,        <<caller is dbstore>>                     02388000
                                                                        02390000
                                                                        02392000
      <<onerror equates...>>                                            02394000
                                                                        02396000
   onerr'quit     = 0,        <<terminate upon error>>                  02398000
   onerr'skipfile = 1,                                                  02400000
   onerr'skiprecord=2,                                                  02402000
   onerr'redo     = 3,                                                  02404000
   onerr'skip     = 4,                                                  02406000
                                                                        02408000
      <<parse'name equates...>>                                         02410000
                                                                        02412000
   pn'name'too'long         = 1,                                        02414000
   pn'empty'name            = 2,                                        02416000
   pn'back'illegal          = 3,                                        02418000
   pn'must'start'with'alpha = 4,                                        02420000
   pn'illegal'character     = 5,                                        02422000
   pn'wildcards'illegal     = 6,                                        02424000
                                                                        02426000
      <<recover'error equates...>>                                      02428000
   skippingv                = 0,                                        02430000
   readingv                 = 1;                                        02432000
                                                                        02434000
$page "GLOBAL DEFINES -- DIRECSCAN"                                     02436000
define                                                                  02438000
                                                                        02440000
         <<defines for type parameter to direcscan...>>                 02442000
                                                                        02444000
   allflag        = (09:1) #,                                           02446000
   endlevelf      = (10:3) #,                                           02448000
   endlevelfx     = (09:4) #,                                           02450000
   hitflag        = (05:1) #,                                           02452000
   startlevelf    = (13:3) #,                                           02454000
   tolevelf       = (06:3) #,                                           02456000
                                                                        02458000
         <<defines for starting a direcscan...>>                        02460000
                                                                        02462000
   start'acct     = 1 #,                                                02464000
   start'group    = 2 #,                                                02466000
   start'root     = 0 #,                                                02468000
                                                                        02470000
         <<endlevel defines...>>                                        02472000
                                                                        02474000
   filelevel      = 0 #,                                                02476000
   grouplevel     = 1 #,                                                02478000
   acctlevel      = 2 #,                                                02480000
   userlevel      = 3 #,                                                02482000
                                                                        02484000
         <<defines for terminating a direcscan...>>                     02486000
                                                                        02488000
   skipnode       = 2 #,                                                02490000
   skiptree       = 2 #,                                                02492000
   rc'stop        = 4 #;                                                02494000
$page "GLOBAL DEFINES -- SCANNER DEFINES"                               02496000
equate                                                                  02498000
                                                                        02500000
      <<scanner equates...>>                                            02502000
                                                                        02504000
         <<iclass/stepit values...>>                                    02506000
                                                                        02508000
   endlinev       = -1,       <<end-of-line encountered>>               02510000
   tokenv         = -2,       <<token (identifier) found>>              02512000
   numberv        = -3,       <<integer number found>>                  02514000
   specialv       = -4,       <<special character found>>               02516000
   stringv        = -5,       <<quoted string found>>                   02518000
   dnumberv       = -6,       <<double precision number found>>         02520000
   unknownv       = -7;       <<stepit not yet done, or did unstepit>>  02522000
                                                                        02524000
define                                                                  02526000
                                                                        02528000
         <<defines to simplify using the scanner...>>                   02530000
                                                                        02532000
   debug'scanner  = debug'scanner' #,                                   02534000
   stepit         = stepit' #,                                          02536000
   unstepit       =                                                     02538000
      begin                                                             02540000
      ilen:=0;                                                          02542000
      iclass:=unknownv;                                                 02544000
      subclass'd:=0d;                                                   02546000
      ileft:=inputlen-itemp'offset;                                     02548000
      end #;                                                            02550000
$page "GLOBAL DEFINES -- FILE LABEL DEFINES"                            02552000
define                                                                  02554000
         <<flab   (file label) defines...>>                             02556000
                                                                        02558000
   fl'group''inx  = 8 #,               <<byte inx of group name>>       02560000
   fl'acct''inx   = 16 #,              <<byte inx of acct name>>        02562000
   fl'sr'release'inx = 22 #,           <<security status word index>>   02564000
   flmiscx        = 28 #,              <<misc word index>>              02566000
   flchecksumx    = 34 #,              <<checksum index>>               02568000
   flclidx        = 35 #,              <<cold load index>>              02570000
                                                                        02572000
   fllocname      = flab  #,                                            02574000
   fllocname'     = flab' #,                                            02576000
   flgrpname      = flab   (4) #,                                       02578000
   flgrpname'     = flab'  (8) #,                                       02580000
   flacctname     = flab   (8) #,                                       02582000
   flacctname'    = flab'  (16) #,                                      02584000
   fluserid       = flab   (12) #,                                      02586000
   fluserid'      = flab'  (24) #,                                      02588000
   fllockword     = flab   (16) #,                                      02590000
   fllockword'    = flab'  (32) #,                                      02592000
   flsecmx        = flab'd (10) #,                                      02594000
   flsecmx1       = flab   (20) #,                                      02596000
   flsecmx2       = flab   (21) #,                                      02598000
   flsecword      = flab'l (22) #,                                      02600000
   flsecure       = flsecword.(15:01) #, <<1=secured, 0=released>>      02602000
   fl'sr'release  = flsecword.(14:01) #, << 1 = ;released on tape>>     02604000
   fl'sr'release'bit =        (14:01) #,                                02606000
   fl'bad'file    = flsecword.(13:01) #, <<1=file isn't here! >>        02608000
   fl'bad'file'bit=           (13:01) #,                                02610000
   flcreate       = flab'l (23) #,                                      02612000
   fllastacc      = flab'l (24) #,                                      02614000
   fllastmod      = flab'l (25) #,                                      02616000
   flfilecode     = flab   (26) #,                                      02618000
   flpvinfo       = flab   (27) #,                             <<lb.36>>02620000
   flusage        = flab'l (28) #,                                      02622000
   flstore        = flusage.(00:01) #, <<file being stored>>            02624000
   flrestore      = flusage.(01:01) #, <<file being restored>>          02626000
   flstorerestore = flusage.(00:02) #, <<file being stored/restored>>   02628000
   flloaded       = flusage.(02:01) #, <<file is loaded>>               02630000
   flsrl          = flusage.(00:03) #, <<store/restore/loaded>>         02632000
   flsrlx         = flusage.(00:04) #, <<store/restore/loaded/xeq>>     02634000
   fldevtype      = flusage.(08:06) #, <<device type>>                  02636000
   fldevsubtype   = flusage.(04:04) #, <<device subtype>>               02638000
   flwrite        = flusage.(14:01) #, <<file open for writing>>        02640000
   flread         = flusage.(15:01) #, <<file open for reading>>        02642000
   flrw           = flusage.(14:02) #, <<file open>>                    02644000
   fluserlbl      = flab'l (29) #,                                      02646000
   fluserlbl'avail= fluserlbl.(08:08) #,                                02648000
   flflim         = flab'd (15) #,                                      02650000
   flfcbvect      = flab'd (16) #,                             <<lb.36>>02651000
   flchecksum     = flab   (34) #,                                      02652000
   flclid         = flab   (35) #,                                      02654000
   flfoptions     = flab   (36) #,                                      02656000
   flrecsize      = flab   (37) #,                                      02658000
   flblksize      = flab   (38) #,                                      02660000
   fllayout       = flab   (39) #,                                      02662000
   flsectoff      = fllayout.(00:08) #, <<sector offset>>               02664000
   fldflags       = fllayout.(08:04) #, <<disk flags>>                  02666000
   flnumexts      = fllayout.(11:05) #, <<number of extents>>           02668000
   fllastextsize  = flab   (40) #,                                      02670000
   fllastextsize'd= double (logical (fllastextsize)) #,                 02672000
   flextsize      = flab   (41) #,                                      02674000
   flextsize'l    = flab'l (41) #,                                      02676000
   flextsize'd    = double (flextsize'l) #,                             02678000
   fleof          = flab'd (21) #,                                      02680000
   extmap'inx     = 44          #,                                      02682000
   flextmap       = flab   (44) #,                                      02684000
   extmap'inx'd   = 22          #,                                      02686000
   flextmap'd     = flab'd (22) #,                                      02688000
   flextmap'd'1   = flab'd (23) #,                                      02690000
   flalloctime    = flab'd (54) #,                                      02692000
   flallocdate    = flab   (110) #,                                     02694000
   flallocdate'l  = flab'l (110) #,                                     02696000
   flclass        = flab   (124) #,                                     02698000
   flclass'       = flab'  (248) #;                                     02700000
                                                                        02702000
                                                                        02704000
define                                                                  02706000
   old'lockword'      = old'flab'   (32)           #,                   02708000
   old'flsecmx        = old'flab'd  (10)           #,                   02710000
   old'secure         = old'flab'l (22).(15:01)    #,          <<lb.rs>>02711000
   old'fcode          = old'flab    (26)           #,                   02712000
   old'usage          = old'flab'l  (28)           #,                   02714000
   old'flstorerestore = old'usage.(00:02)          #,                   02716000
   old'flsrlx         = old'usage.(00:04)          #,                   02718000
   old'loaded         = old'usage.(02:01)          #,          <<lb.rs>>02720000
   old'excl'acc       = old'usage.(03:01)          #,          <<lb.rs>>02722000
   old'flrw           = old'usage.(14:02)          #,                   02724000
   old'writing        = old'flrw = 1               #,                   02726000
   old'reading        = old'flrw = 2               #,                   02728000
   old'rw             = old'flrw = 3               #,                   02730000
   old'flclid         = old'flab (35)              #,                   02732000
   old'numexts        = old'flab (39).(11:05)      #,                   02734000
   old'lastextsize    = old'flab'l (40)            #,                   02736000
   old'lastextsiz'd   = double (old'lastextsize)   #,                   02738000
   old'extsize        = old'flab'l (41)            #,                   02740000
   old'extsize'd      = double (old'extsize)       #,                   02742000
   old'extmapd        = old'flab'd (22)            #;                   02744000
$page "GLOBAL DEFINES -- STANDARD FORM FILE TITLES"                     02746000
define                                                                  02748000
         <<standard form title defines...>>                             02750000
                                                                        02752000
   std'len'total  = istd (00) #, <<integer: length in bytes, inclu>>    02754000
   std'version    = pstd (02) #,       <<std-form version id (=1) >>    02756000
   std'info       = pstd (03) #,       <<info bits:               >>    02758000
   std'backref    = std'info.(13:1) #, <<  1 = back referenced    >>    02760000
   std'dollar     = std'info.(14:1) #, <<  1 = dollar sign        >>    02762000
   std'wild       = std'info.(15:1) #, <<  1 = wildcards in title >>    02764000
   std'file'inx   = pstd (04) #,       <<byte index of file part  >>    02766000
   std'lock'inx   = pstd (05) #,       <<byte index of lock part  >>    02768000
   std'group'inx  = pstd (06) #,       <<byte index of group part >>    02770000
   std'acct'inx   = pstd (07) #,       <<byte index of acct part  >>    02772000
   std'family'inx = pstd (08) #,       <<byte index of family part>>    02774000
   std'host'inx   = pstd (09) #,       <<byte index of host part  >>    02776000
                                                                        02778000
   std'file'parts = pstd (std'file'inx-1)#,  <<# file parts  (:=1)>>    02780000
   std'file'info  = pstd (std'file'inx) #,   <<file info bits:    >>    02782000
   std'file'wild  = std'file'info.(8:1) #,   << 1 = wildcards     >>    02784000
   std'file'len   = std'file'info.(9:7) #,   << length (0 to 8)   >>    02786000
   std'part'lenf  = (9:7) #,                                            02788000
   std'file'      = pstd (std'file'inx+1) #, <<pointer to file txt>>    02790000
                                                                        02792000
   std'lock'info  = pstd (std'lock'inx) #,   <<lock info bits:    >>    02794000
   std'lock'wild  = std'lock'info.(8:1) #,   << 1 = wildcards     >>    02796000
   std'lock'len   = std'lock'info.(9:7) #,   << length (0 to 8)   >>    02798000
   std'lock'      = pstd (std'lock'inx+1) #, <<pointer to lock txt>>    02800000
                                                                        02802000
   std'group'info = pstd (std'group'inx) #,  <<group info bits:    >>   02804000
   std'group'wild = std'group'info.(8:1) #,  << 1 = wildcards     >>    02806000
   std'group'len  = std'group'info.(9:7) #,  << length (0 to 8)   >>    02808000
   std'group'     = pstd (std'group'inx+1) #,<<pointer to group txt>>   02810000
                                                                        02812000
   std'acct'info  = pstd (std'acct'inx) #,   <<acct info bits:    >>    02814000
   std'acct'wild  = std'acct'info.(8:1) #,   << 1 = wildcards     >>    02816000
   std'acct'len   = std'acct'info.(9:7) #,   << length (0 to 8)   >>    02818000
   std'acct'      = pstd (std'acct'inx+1) #, <<pointer to acct txt>>    02820000
                                                                        02822000
   std'family'info= pstd (std'family'inx) #, <<family info bits:  >>    02824000
   std'family'wild= std'family'info.(8:1) #, << 1 = wildcards     >>    02826000
   std'family'len = std'family'info.(9:7) #, << length (0 to 8)   >>    02828000
   std'family'    = pstd (std'family'inx+1)#,<<pntr to family txt >>    02830000
                                                                        02832000
   std'host'info  = pstd (std'host'inx) #,   <<host info bits:    >>    02834000
   std'host'wild  = std'host'info.(8:1) #,   << 1 = wildcards     >>    02836000
   std'host'len   = std'host'info.(9:7) #,   << length (0 to 8)   >>    02838000
   std'host'      = pstd (std'host'inx+1) #, <<pointer to host txt>>    02840000
                                                                        02842000
                                                                        02844000
   allow'imbedded'blanks'bit  = (00:01) #,                              02846000
   allow'lead'blanks'bit      = (01:01) #,                              02848000
                                                                        02850000
   allow'backref'bit          = (06:01) #,                              02852000
   allow'dollar'bit           = (07:01) #,                              02854000
   allow'wild'bit             = (08:01) #,                              02856000
 <<allow'file'bit             = (09:01) #,   always true!!>>            02858000
   allow'multi'file'parts'bit = (10:01) #,                              02860000
   allow'lock'bit             = (11:01) #,                              02862000
   allow'group'bit            = (12:01) #,                              02864000
   allow'acct'bit             = (13:01) #,                              02866000
   allow'family'bit           = (14:01) #,                              02868000
   allow'host'bit             = (15:01) #;                              02870000
$page "GLOBAL DEFINES -- PATTERN MATCHING"                              02872000
define                                                                  02874000
                                                                        02876000
   pat'max'firm      = 8 #,    <<max number of firm chars>>             02878000
   pat'max'part      = 8 #,    <<max number of pattern parts>>          02880000
                                                                        02882000
   patcharf          = (8:8) #,                                         02884000
   patlenf           = (2:6) #,                                         02886000
   pattypef          = (0:2) #;                                         02888000
                                                                        02890000
equate                                                                  02892000
                                                                        02894000
      <<values found in the pattypef field...>>                         02896000
                                                                        02898000
   anyonecharacterp  = 0,     <<a case statement in sub'match >>        02900000
   anycharactersp    = 1,     <<depends                       >>        02902000
   digitonlyp        = 2,     <<        on this               >>        02904000
   exactp            = 3,     <<                ordering!     >>        02906000
                                                                        02908000
      <<pattern'build errors...>>                                       02910000
                                                                        02912000
   pb'err'many'firm  = 1,     <<more than 8 'firm' chars were found>>   02914000
   pb'err'many'parts = 2;     <<more than 8 parts were found>>          02916000
$page "GLOBAL EQUATES -- GOOD FILE RECORDS"                             02918000
                                                                        02920000
<<the following is the layout of every record in the good               02922000
  file (whose file number is g'num)...                                  02924000
                                                                        02926000
   byte  integer  double     contents                                   02928000
   index index    index      of array...                                02930000
   ----- -------  ------    ----------------------------------          02932000
      -       -       0     ! file # (from 1 to #of file to be          02934000
                            ! stored/restored)...is a double            02936000
                            ! integer.                                  02938000
                            !---------------------------------          02940000
      -       2       -     ! reel number file is stored on ...         02942000
                            ! zero for restore.                         02944000
                            !---------------------------------          02946000
      -       3       -     ! sr flag bits:                             02948000
                            ! 15:01  1 = file is locked.                02950000
                            !        0 = file is unlocked.              02952000
                            !---------------------------------          02954000
      -       4       -     ! pvinfo and flags.                         02956000
                            ! (as returned by mount routine)            02958000
                            ! is 0 if not a private volume.             02960000
                            !---------------------------------          02962000
      -       5       -     ! ldev # of the file's label.               02964000
                            !---------------------------------          02966000
      -       -       3     ! address of file label (is a double        02968000
                            ! integer sector address).                  02970000
                            !---------------------------------          02972000
      16      8       4     ! file part (8 bytes, left justified,       02974000
                            ! blank filled).                            02976000
                            !---------------------------------          02978000
      24      12      6     ! group part (8 bytes...)                   02980000
                            !---------------------------------          02982000
      32      16      8     ! acct part (8 bytes...)                    02984000
                            !---------------------------------          02986000
                                                                        02988000
   the equates used to access byte items end with:  inx'                02990000
   those used to access integer items end with:     inx                 02992000
   those used for doubles:                          inx'd               02994000
                                                                        02996000
   ------------------------------------------------------------>>       02998000
                                                                        03000000
equate                                                                  03002000
   g'acct'inx     = 16,                                                 03004000
   g'acct'inx'    = 32,                                                 03006000
   g'address'inx'd=  3,                                                 03008000
   g'extsize'inx'd= 11,                                                 03010000
   g'file'inx     =  8,                                                 03012000
   g'file'inx'    = 16,                                                 03014000
   g'file'sectors'inx'd = 10,                                           03016000
   g'filenum'inx'd=  0,                                                 03018000
   g'flags'inx    =  3,                                                 03020000
   g'group'inx    = 12,                                                 03022000
   g'group'inx'   = 24,                                                 03024000
   g'ldev'inx     =  5,                                                 03026000
   g'pvinfo'inx   =  4,                                                 03028000
   g'reel'inx     =  2,                                                 03030000
   g'title'inx    =  8,                                                 03032000
   g'title'inx'   = g'file'inx',                                        03034000
                                                                        03036000
      <<------>>                                                        03038000
                                                                        03040000
   g'recsize      = 24;                                                 03042000
                                                                        03044000
define                                                                  03046000
   g'locked'bit   = gbuf (g'flags'inx).(15:01) #,                       03048000
   g'ignore'bit   = gbuf (g'flags'inx).(14:01) #,                       03050000
   g'purge'bit    = gbuf (g'flags'inx).(13:01) #;                       03050100
$page "ATTACHIO DCL'S"                                                  03052000
$if x9=on then                                                          03054000
      double array                                                      03056000
         io'queue'd    (0:max'io*max'num'xds);                          03058000
      double array                                             <<lb.rs>>03060000
         ioq'fsf'd      (0:1);                                 <<lb.rs>>03062000
                                                               <<lb.rs>>03063000
      integer array                                            <<lb.rs>>03063100
         ioq'fsf (*)   = ioq'fsf'd;                            <<lb.rs>>03063200
                                                                        03064000
      integer                                                           03066000
         curr'read'buffer,                                     <<lb.rs>>03068000
         curr'wait'buffer,                                     <<lb.rs>>03069000
         num'buffers,                                                   03072000
         fsf'seq;                                                       03074000
                                                                        03076000
      integer array                                                     03078000
         io'queue      (*)     = io'queue'd,                            03080000
         io'len        (0:max'io*max'num'xds),                          03082000
         buffer'xds    (0:max'io*max'num'xds),                          03084000
         buffer'offset (0:max'io*max'num'xds),                          03086000
         xds'num       (0:max'num'xds),                        <<lb.rs>>03087000
         xds'status    (0:max'num'xds);                        <<lb.rs>>03088000
$if                                                                     03090000
$page "DCL'S"                                                           03092000
integer array                                                           03094000
   command'text (0:command'text'len),                                   03096000
   curr'acct    (0:file'part'words-1),                                  03098000
   curr'group   (0:file'part'words-1),                                  03100000
   curr'file    (0:file'part'words-1),                                  03102000
   deviceinfo   (0:1+size'of'ldt'entry+size'of'lpdt'entry),    <<lb.rs>>03104000
   flab         (0:file'label'size+1),                                  03106000
   group'entry  (0:gsize),                                              03108000
   home'group   (0:file'part'words-1),                                  03110000
   last'acct    (0:file'part'words - 1),                                03112000
   last'user   (0:file'part'words - 1),                        <<lb.rs>>03113000
   last'group   (0:file'part'words - 1),                                03114000
   last'res'user  (0:file'part'words - 1),                     <<lb.rs>>03115000
   look'lock    (0:file'part'words - 1),                                03116000
   logon'acct   (0:file'part'words - 1),                                03118000
   logon'group  (0:file'part'words - 1),                                03120000
   logon'user   (0:file'part'words - 1),                                03122000
   look'patterns(0:6*max'pat'len),                                      03124000
   look'acct    (0:file'part'words - 1),                                03126000
   look'acct'pat (*) = look'patterns (max'pat'len'2),                   03128000
   look'file    (0:file'part'words - 1),                                03130000
   look'file'pat (*) = look'patterns (0),                               03132000
   look'group   (0:file'part'words - 1),                                03134000
   look'group'pat(*) = look'patterns (max'pat'len),                     03136000
   not'acct'pat  (*) = look'patterns (max'pat'len'5),                   03138000
   not'group'pat (*) = look'patterns (max'pat'len'4),                   03140000
   not'file'pat  (*) = look'patterns (max'pat'len'3),                   03142000
   old'flab     (0:file'label'size),                                    03144000
   res'title    (0:4*file'part'words),                                  03146000
   res'acct     (*) = res'title (file'2'part'words),                    03148000
   res'creator  (*) = res'title (file'3'part'words),                    03150000
   res'file     (*) = res'title ,                                       03152000
   res'group    (*) = res'title (file'part'words),                      03154000
   tape'label  (0:tape'label'size),                                     03156000
   tape'name   (0:file'part'words);                                     03158000
logical array                                                           03160000
   device     (0:file'part'words),                                      03162000
   flab'l     (*) = flab,                                               03164000
   old'flab'l (*) = old'flab,                                           03166000
   tape'label'l (*) = tape'label;                                       03168000
double array                                                            03170000
   flab'd      (*) = flab,                                              03172000
   group'entry'd (*) = group'entry,                                     03174000
   old'flab'd  (*) = old'flab;                                          03176000
byte array                                                              03178000
   command'text' (*) = command'text,                                    03180000
   curr'acct'    (*) = curr'acct,                                       03182000
   curr'group'   (*) = curr'group,                                      03184000
   curr'file'    (*) = curr'file,                                       03186000
   curr'title'   (0:max'std'len),                                       03188000
   device' (*)   = device,                                              03190000
   flab'   (*)   = flab,                                                03192000
   flab'lock'(*) = fllockword',                                         03194000
   group'entry'(*) = group'entry,                                       03196000
   home'group' (*) = home'group,                                        03198000
   last'acct'  (*) = last'acct,                                         03200000
   last'user' (*) = last'user,                                 <<lb.rs>>03201000
   last'group' (*) = last'group,                                        03202000
   last'res'user' (*) = last'res'user,                         <<lb.rs>>03203000
   last'title' (0:max'std'len),                                <<04871>>03204000
   look'lock'  (*) = look'lock,                                         03206000
   logon'acct' (*) = logon'acct,                                        03208000
   logon'group'(*) = logon'group,                                       03210000
   logon'user' (*) = logon'user,                                        03212000
   look'acct'  (*) = look'acct,                                         03214000
   look'file'  (*) = look'file,                                         03216000
   look'group' (*) = look'group,                                        03218000
   look'title' (0:max'std'len),                                <<04871>>03220000
   not'title'  (0:max'std'len),                                <<04871>>03222000
   old'flab'   (*) = old'flab,                                          03224000
   res'acct'   (*) = res'acct,                                          03226000
   res'creator'(*) = res'creator,                                       03228000
   res'file'   (*) = res'file,                                          03230000
   res'group'  (*) = res'group,                                         03232000
   tape'label' (*) = tape'label,                                        03234000
   tape'name'  (*) = tape'name;                                         03236000
$page "ZERO BUF"                                                        03238000
integer                                                                 03240000
   first'zeroed;                                                        03242000
double                                                                  03244000
   bad'file'count             := 0d,                                    03246000
   c'rec'count                := 0d,                                    03248000
   capability                 := 0d,                                    03250000
   curr'fileno                := 0d,                                    03252000
   failed'file'count          := 0d,                                    03254000
   file'address               := 0d,                                    03256000
   file'index'ptr             := 0d,                           <<lb.rs>>03257000
   file'max'sectors           := 0d,                                    03258000
   file'number                := 0d,                                    03260000
   file'sectors               := 0d,                                    03262000
   files'on'tape              := 0d,                                    03264000
   files'rejected             := 0d,                                    03266000
   files'rej'access           := 0d,                                    03268000
   files'rej'reload           := 0d,                                    03270000
   files'rej'title            := 0d,                                    03272000
   files'selected             := 0d,                                    03274000
   files'to'handle            := 0d,                                    03276000
   first'file'selected        := 0d,                                    03278000
   g'num'fsize                := 0d,                                    03280000
   g'security                 := 0d,                                    03282000
   good'file'count            := 0d,                                    03284000
   last'file'unlocked         := 0d,                                    03286000
   linkage                    := 0d,                                    03288000
   old'address                := 0d,                                    03290000
   old'sectors                := 0d,                                    03292000
   parms'tempd'1              := 0d,                                    03294000
   parms'tempd'2              := 0d,                                    03296000
   restored'count             := 0d,                                    03298000
   start'clock'time           := 0d,                                    03300000
   start'cpu'time             := 0d,                                    03302000
   subclass'd                 := 0d;                                    03304000
integer                                                                 03306000
   a'security                 := 0,                                     03308000
   alloc'exts                 := 0,                                     03310000
   bufno                      := 0,                                     03312000
   candidat                   := 0,                                     03314000
   cart'num                   := 0,                                     03316000
   cold'load'id               := 0,                                     03318000
   count'rewrites'cold'load'id:= 0,                                     03320000
   d'num                      := 0,                                     03322000
   dbstore'high               := 0,                            <<04870>>03324000
   dbstore'low                := 0,                            <<04870>>03326000
   density                    := 0,                                     03328000
                                                               <<lb.rs>>03330000
                                                               <<lb.rs>>03332000
                                                               <<lb.rs>>03334000
                                                               <<lb.rs>>03336000
   dsir'info                  := 0,                                     03338000
   e'num                      := 0,                                     03340000
   error'code                 := 0,                                     03342000
   error'info                 := 0,                                     03344000
   f'num                      := 0,                                     03346000
   file'addr'1                =  file'address,                          03348000
   file'addr'2                =  file'address + 1,                      03350000
   file'indx'1                =  file'index'ptr,               <<lb.rs>>03350100
   file'indx'2                =  file'index'ptr + 1,           <<lb.rs>>03350200
   file'ldev                  := 0,                                     03352000
   filecode'high              := 0,                                     03354000
   filecode'low               := 0,                                     03356000
   fileset'inx                := 0,                                     03358000
   fileset'number             := 0,                                     03360000
   fisir'info                 := 0,                                     03362000
   g'num                      := 0,                                     03364000
   i'num                      := 0,                                     03366000
   i'num'chars                := 0,                                     03368000
   i'num'recsize              := 0,                                     03370000
   iclass                     := 0,                                     03372000
   ileft                      := 0,                                     03374000
   ilen                       := 0,                                     03376000
   inputlen                   := 0,                                     03378000
   itemp'offset               := 0,                                     03380000
   last'group'error           := 0,                            <<lb.rs>>03381000
   linkage'1                  =  linkage,                               03382000
   linkage'2                  =  linkage + 1,                           03384000
   locking'type               := 0,                                     03386000
   mounted'volume'info        := 0,                                     03388000
   offline'num                := 0,                                     03390000
   offline'recsize            := 0,                                     03392000
   old'addr'1                 =  old'address,                           03394000
   old'fnum                   := 0,                                     03396000
   old'ldev                   := 0,                                     03398000
   old'zsize                  := 0,                                     03400000
   options'inx                := 0,                                     03402000
   outstanding'ios            := 0,                            <<lb.rs>>03403000
   parms'version              := 0,                                     03404000
   parms'tempd'1'1            =  parms'tempd'1,                         03406000
   parms'tempd'1'2            =  parms'tempd'1 + 1,                     03408000
   parms'tempd'2'1            =  parms'tempd'2,                         03410000
   parms'tempd'2'2            =  parms'tempd'2 + 1,                     03412000
   parms'tempi'1              := 0,                                     03414000
   parms'tempi'2              := 0,                                     03416000
   pv'num                     := 0,                                     03418000
   pv'info                    := 0,                                     03420000
   read'tape'len              := 0,                                     03422000
   rc'calls                   := 0,                                     03424000
   rc'error'code              := 0,                                     03426000
   rc'error'detail            := 0,                                     03428000
   recsize'init               := 0,                                     03430000
   s'r'status                 := 0,                                     03432000
   sp'pv                      := 0,                                     03434000
   subclass                   =  subclass'd,                            03436000
   syslist'num                := 0,                                     03438000
   syslist'recsize            := 0,                                     03440000
   t'num                      := 0,                                     03442000
   tape'ldev                  := 0,                                     03444000
   tape'recsize               := 0,                                     03446000
   tape'reel                  := 0,                                     03448000
   tape'version               := 0,                                     03450000
   todays'date                := 0;                                     03452000
logical                                                                 03454000
   adate'high                 := 0,                                     03456000
   adate'low                  := 0,                                     03458000
   capability'1               =  capability,                            03460000
   capability'2               =  capability + 1,                        03462000
   cartridge                  := 0,                                     03464000
   cdate'high                 := 0,                                     03466000
   cdate'low                  := 0,                                     03468000
   g'security'1               =  g'security,                            03470000
   g'security'2               =  g'security + 1,                        03472000
   group'index'ptr            := 0,                            <<lb.rs>>03473000
   mdate'high                 := 0,                                     03474000
   mdate'low                  := 0,                                     03476000
   mode                       := 0,                                     03478000
                                                               <<lb.rs>>03480000
   parms'byte'address         := 0,                                     03482000
   qp'type                    := 0,                                     03484000
   s'r'flags1                 := 0,                                     03486000
   s'r'flags2                 := 0,                                     03488000
   s'r'flags3                 := 0,                                     03490000
   s'r'flags4                 := 0,                                     03492000
   s'r'flags5                 := 0,                                     03494000
   s'r'flags6                 := 0,                                     03496000
   tape'aoptions              := 0,                                     03498000
   tape'density               := 0,                                     03500000
   tape'devinfo               := 0,                                     03502000
   tape'foptions              := 0,                                     03504000
   tape'inx                   := 0,                            <<lb.rs>>03506000
   user'index'ptr             := 0;                            <<lb.rs>>03507000
integer                                                                 03508000
   last'zeroed;                                                         03510000
integer array                                                           03512000
   zero'buf (*) = first'zeroed;                                         03514000
$page "GLOBAL DEFINES -- BASED ON FIELDS OF GLOBAL VARIABLES"           03516000
define                                                                  03518000
         <<pointers into the command>>                                  03520000
      itemp       = command'text' (itemp'offset) #,                     03522000
      itemp'1     = command'text' (itemp'offset+1)#,                    03524000
                                                                        03526000
         <<capabilities>>                                               03528000
      cap'sm      = capability'1.(0:1)          #,                      03530000
      cap'am      = capability'1.(1:1)          #,                      03532000
      cap'al      = capability'1.(2:1)          #,                      03534000
      cap'gl      = capability'1.(3:1)          #,                      03536000
      cap'di      = capability'1.(4:1)          #,                      03538000
      cap'op      = capability'1.(5:1)          #,                      03540000
      cap'sf      = capability'1.(15:1)         #,                      03542000
      cap'ba      = capability'2.(7:1)          #,                      03544000
      cap'ia      = capability'2.(8:1)          #,                      03546000
      cap'pm      = capability'2.(9:1)          #,                      03548000
                                                                        03550000
         <<save security bits>>                                         03552000
      save'any                   = g'security'2.(11:1)      #,          03554000
      save'account               = g'security'2.(12:1)      #,          03556000
      save'acct'lib              = g'security'2.(13:1)      #,          03558000
      save'group                 = g'security'2.(14:1)      #,          03560000
      save'group'lib             = g'security'2.(15:1)      #,          03562000
                                                                        03564000
         <<others>>                                                     03566000
      interactive = mode.interactivebit         #,                      03568000
      pvmvtabx    =    pv'info.(08:08)           #,                     03570000
$page "GLOBAL FLAGS"                                                    03572000
      ignore'priv'check'flag =s'r'flags1.(15:01)#,                      03574000
      nosoft'flag    = s'r'flags1.(14:01)       #,                      03576000
      keep'flag      = s'r'flags1.(13:01)       #,                      03578000
      backup'flag    = s'r'flags1.(12:01)       #,                      03580000
      olddate'flag   = s'r'flags1.(11:01)       #,                      03582000
      zero'dev'flag  = s'r'flags1.(10:01)       #,                      03584000
      show'flag      = s'r'flags1.(09:01)       #,                      03586000
         show'short'flag   = s'r'flags1.(08:01) #,                      03588000
         show'dates'flag   = s'r'flags1.(07:01) #,                      03590000
         show'security'flag= s'r'flags1.(06:01) #,                      03592000
         show'offline'flag = s'r'flags1.(05:01) #,                      03594000
         show'long'flag    = s'r'flags1.(04:01) #,                      03596000
      local'flag     = s'r'flags1.(03:01)       #,                      03598000
      release'flag   = s'r'flags1.(02:01)       #,                      03600000
      seen'show'long = s'r'flags1.(01:01)       #,                      03602000
      seen'show'short= s'r'flags1.(00:01)       #,                      03604000
                                                                        03606000
      seen'acct      = s'r'flags2.(15:01)       #,                      03608000
      seen'date      = s'r'flags2.(14:01)       #,                      03610000
      seen'dev       = s'r'flags2.(13:01)       #,                      03612000
      seen'files     = s'r'flags2.(12:01)       #,                      03614000
      seen'group     = s'r'flags2.(11:01)       #,                      03616000
      seen'keep      = s'r'flags2.(10:01)       #,                      03618000
      seen'local     = s'r'flags2.(09:01)       #,                      03620000
      seen'lock      = s'r'flags2.(08:01)       #,                      03622000
      seen'newdate   = s'r'flags2.(07:01)       #,                      03624000
      seen'nokeep    = s'r'flags2.(06:01)       #,                      03626000
      seen'olddate   = s'r'flags2.(05:01)       #,                      03628000
      seen'onerr     = s'r'flags2.(04:01)       #,                      03630000
      seen'release   = s'r'flags2.(03:01)       #,                      03632000
      seen'show      = s'r'flags2.(02:01)       #,                      03634000
      seen'density   = s'r'flags2.(01:01)       #,                      03636000
      seen'creator   = s'r'flags2.(00:01)       #,                      03638000
                                                                        03640000
      jcw'flag       = s'r'flags3.(15:01)       #,                      03642000
      seen'recsize   = s'r'flags3.(14:01)       #,                      03644000
      disc'exists    = s'r'flags3.(13:01)       #,                      03646000
      syslist'supplied=s'r'flags3.(12:01)       #,                      03648000
      need'to'reset'sm=s'r'flags3.(11:01)       #,                      03650000
      simple'tog     = s'r'flags3.(10:01)       #,                      03652000
      wide'syslist   = s'r'flags3.(09:01)       #,                      03654000
      update'tog     = s'r'flags3.(08:01)       #,                      03656000
      tape'null'tog  = s'r'flags3.(07:01)       #,                      03658000
      tape'sdisc'tog = s'r'flags3.(06:01)       #,                      03660000
      tape'cartridge'tog=s'r'flags3.(05:01)     #,                      03662000
      sm'tog         = s'r'flags3.(04:01)       #,                      03664000
      got'dsir       = s'r'flags3.(03:01)       #,                      03666000
      got'fisir      = s'r'flags3.(02:01)       #,                      03668000
      thunk'store'err= s'r'flags3.(01:01)       #,                      03670000
      break'msg'seen = s'r'flags3.(00:01)       #,                      03672000
                                                                        03674000
      syntax'tog     = s'r'flags4.(15:01)       #,                      03676000
      using'attio    = s'r'flags4.(14:01)       #,                      03678000
      using'filesys  = s'r'flags4.(13:01)       #,                      03680000
      a'7976         = s'r'flags4.(12:01)       #,                      03682000
      use'6250bpi    = s'r'flags4.(11:01)       #,                      03684000
      need'directory = s'r'flags4.(10:01)       #,                      03686000
      seen'attio     = s'r'flags4.(09:01)       #,                      03688000
      operator'abort = s'r'flags4.(08:01)       #,                      03690000
      mail'tog       = s'r'flags4.(07:01)       #,                      03692000
      dbstore'tog    = s'r'flags4.(06:01)       #,                      03694000
      file'was'opened= s'r'flags4.(05:01)       #,                      03696000
      old'copy'exists= s'r'flags4.(04:01)       #,                      03698000
      blank'creator  = s'r'flags4.(03:01)       #,                      03700000
      on'err         = s'r'flags4.(00:03)       #,                      03702000
                                                                        03704000
      blank'tape'name= s'r'flags5.(15:01)       #,                      03706000
      dont'chk'group = s'r'flags5.(14:01)       #,                      03708000
      dont'chk'user  = s'r'flags5.(13:01)       #,                      03710000
      dont'chk'acct  = s'r'flags5.(12:01)       #,                      03712000
      last'read'was'eof = s'r'flags5.(11:01)       #,                   03714000
      mounted'vs     = s'r'flags5.(10:01)       #,                      03716000
      seen'create    = s'r'flags5.(09:01)       #,                      03718000
         create'acct'flag  = s'r'flags5.(08:01) #,                      03720000
         create'group'flag = s'r'flags5.(07:01) #,                      03722000
         create'user'flag  = s'r'flags5.(06:01) #,                      03724000
      reel'1'mounted = s'r'flags5.(05:01)       #,                      03726000
      end'of'tape'set= s'r'flags5.(04:01)       #,                      03728000
      kill'restore   = s'r'flags5.(03:01)       #,                      03730000
      different'device= s'r'flags5.(02:01)      #,                      03732000
      old'file'is'open = s'r'flags5.(01:01)     #,                      03734000
      seen'time      = s'r'flags5.(00:01)       #,                      03736000
      seen'starthere = s'r'flags6.(15:01)       #,                      03738000
      read'was'already'done = s'r'flags6.(14:01)#,                      03740000
      last'file      = s'r'flags6.(13:01)       #,                      03742000
      eof'written    = s'r'flags6.(12:01)       #,                      03744000
      last'startio'wrote'eof  = s'r'flags6.(11:01)  #,                  03746000
      read'tape'eof  = s'r'flags6.(10:01)       #,                      03748000
      seen'high      = s'r'flags6.(09:01)       #,             <<04870>>03750000
      seen'low       = s'r'flags6.(08:01)       #,             <<04870>>03752000
      tapemark'written = s'r'flags6.(07:01)       #,           <<04996>>03754000
      dont'do'recovery = s'r'flags6.(06:01)       #,           <<04101>>03756000
      eof'read       = s'r'flags6.(05:01)       #,             <<lb.rs>>03758000
      last'reel'finished = s'r'flags6.(04:01)       #,         <<06361>>03760000
      virtdev        = s'r'flags6.(03:01)       #,                      03762000
      <<u n u s e d  = s'r'flags6.(02:01)       #,  >>                  03764000
      <<u n u s e d  = s'r'flags6.(01:01)       #,  >>                  03766000
      seen'purge     = s'r'flags6.(00:01)       #,                      03768000
      restoring      = (s'r'status = restoringv)#,                      03770000
      storing        = (s'r'status = storingv lor                       03772000
                        s'r'status = sysdumpingv) #,                    03774000
      sysdumping     = (s'r'status = sysdumpingv) #,                    03776000
$page "TAPE LABEL VARIABLES"                                            03778000
      labeled     = tape'foptions.(6:1)         #,                      03780000
      labeltext   = "STORE/RESTORE LABEL-HP/3000."#,  <<words 0..13>>   03782000
      tl'iibid    = tape'label'l  (14) #,                               03784000
      tl'iibid'   = tape'label'   (28) #,                               03786000
      tl'spantog  = tape'label'l  (16) #,                               03788000
      tl'chksum   = tape'label'l  (17) #,                               03790000
      tl'fileinx  = tape'label'l  (18) #,                               03792000
      tl'xfield   = tape'label'l  (21) #,                               03794000
      tl'zfield   = tape'label'l  (22) #,                               03796000
      last'reel   = ( tl'zfield = 1 )  #,                               03798000
      tl'reelnum  = tape'label    (23) #,                               03800000
      tl'reelnum' = tape'label'   (46) #,                               03802000
      tl'date     = tape'label'l  (24) #,                               03804000
      tl'date'    = tape'label'   (48) #,                               03806000
      tl'date'inx'=   48#,                                              03808000
      tl'hhmm     = tape'label'l  (25) #,                               03810000
      tl'hhmm'    = tape'label'   (50) #,                               03812000
      tl'sstt     = tape'label'l  (26) #,                               03814000
      tl'sstt'    = tape'label'   (52) #,                               03816000
      tl'recsize  = tape'label    (27) #,                               03818000
      tl'text'len'= 32#;                                                03820000
$page "STATISTICS VARIABLES"                                            03822000
$if x5=on then                                                          03824000
double                                                                  03826000
   new'disc'reads,                                                      03828000
   new'tape'writes,                                                     03830000
   new'total'extents,                                                   03832000
   old'disc'reads,                                                      03834000
   old'tape'writes,                                                     03836000
   old'total'extents;                                                   03838000
                                                                        03840000
define                                                                  03842000
   tape'write'sectors = 32d#,                                           03844000
   disc'read'sectors  = 192d#;                                          03846000
$if                                                                     03848000
$page "GLOBAL ADDRESS-EQUATED VARIABLES"                                03850000
      <<address equated variables...>>                                  03852000
                                                                        03854000
logical                                                                 03856000
   parmmask       = q-4;                                                03858000
                                                                        03860000
integer pointer                                                         03862000
   ps0            = s-0;                                                03864000
                                                                        03866000
integer array                                                           03868000
   db2(*)         = db+2,                                               03870000
   db11(*)        = db+11;                                     <<lb.rs>>03872000
$page "GLOBAL EQUATES -- CI ERROR MESSAGES"                             05000000
equate          <<ci error message equates>>                            05002000
                                                                        05004000
   first'real'msg               = 5000, <<first 'send'able message!>>   05006000
   sr'sd'error'base             = 5000,                                 05008000
                                                                        05010000
                                                                        05012000
                                                                        05014000
   sr'tape'write'fail           = 6000,                                 05016000
   sr'tape'special'char         = 6001, <<bad special chars>>           05018000
   sr'tape'must'start'with'alpha= 6002, <<it didnt!>>                   05020000
   sr'tape'name'too'long        = 6003, <<name > 8 chars>>              05022000
   sr'tape'back'reference'expected=6004,<<failed to find "*">>          05024000
   sr'tapename'expected         = 6005, <<user omitted the name>>       05026000
   sr'semi'expected             = 6006, <<illegal delimiter>>           05028000
   sr'candidat'full             = 6007,                                 05030000
   sr'files'equal               = 6008, <<need = after 'file'>>         05032000
   sr'file'count'expected       = 6009, <<expect val after "FILES=">>   05034000
   sr'unkoption                 = 6010, <<unknown keyword>>             05036000
   sr'restore'pattern'err       = 6012,                                 05038000
   sr'badsyslist                = 6014, <<unable to open syslist>>      05040000
   sr'insufstack                = 6015, <<too little stack for store>>  05042000
   sr'tfilfoption               = 6016, <<bad foptions on tape>>        05044000
   sr'tfilaoption               = 6017, <<bad aoptions on tape>>        05046000
   sr'xpcttapedev               = 6018, <<not a tape file>>             05048000
   sr'attio'fail                = 6020, <<attio on file label fail>>    05050000
   sr'public'tape               = 6021,                                 05052000
   sr'store'version             = 6022,                                 05054000
   sr'sectors'not'equal'0       = 6023,                                 05056000
   sr'directory'error           = 6024,                                 05058000
   sr'dev'class'invalid         = 6031,                                 05060000
   sr'dev'not'disc              = 6034,                                 05062000
   sr'creator'equal             = 6035, <<expectd '=' after creator>>   05064000
   sr'creator'invname           = 6036, <<bad format for creator>>      05066000
   sr'bad'operating'system      = 6037, <<op sys - store conf>><<lb.rs>>05067000
   rs'xpctsemic                 = 6040, <<need ; between options>>      05068000
   sr'creator'redundant         = 6041,                                 05070000
   sr'dev'equal                 = 6042,                                 05072000
   sr'dev'not'found             = 6043, <<expected dev name>>           05074000
   sr'dev'too'long              = 6044, << > 8 char in dev id>>         05076000
   sr'dev'special               = 6045, <<embedded special in dev>>     05078000
   sr'no'labeled'ds             = 6058,                                 05080000
   sr'date'ltgt                 = 6059, <<;date expect "<" or ">">>     05082000
   sr'recsizebad                = 6060, <<user-specified recsiz bad>>   05084000
   rs'unkoption                 = 6062, <<unknown keyword>>             05086000
   sr'bad'pnum                  = 6065, <<bad pnum parameter>>          05088000
   sr'tape'wildcards            = 6067, <<wildcards are illegal>>       05090000
   sr'ind'wildcards             = 6068, <<wildcards are illegal>>       05092000
   sr'ind'special'char          = 6069, <<bad special chars>>           05094000
   sr'ind'must'start'with'alpha = 6070, <<it didnt!>>                   05096000
   sr'ind'name'too'long         = 6071, <<name > 8 chars>>              05098000
   sr'ind'io'error              = 6072, <<i/o error on indirect>>       05100000
   sr'ind'name'expected         = 6073, <<indirect name expected>>      05102000
   sr'show'opt'unknown          = 6074, <<unknown show option>>         05104000
   sr'ind'open'failed           = 6075, <<indirect fopen failed>>       05106000
   sr'ind'fgetinfo              = 6076, <<indirect fgetinfo err>>       05108000
   sr'ind'empty                 = 6077, <<indirect file empty>>         05110000
   sr'ind'recsize'small         = 6078, <<indirect recsize small>>      05112000
   sr'ind'not'input             = 6079, <<indirect wasnt readable>>     05114000
   sr'break'sensed              = 6080, <<break was hit>>               05116000
   sr'ind'name'not'alone        = 6082, <<indirect name not alone>>     05118000
   sr'tape'fgetinfo'fail        = 6086,                                 05120000
   sr'tape'rewind'fail          = 6087,                                 05122000
   sr'g'num'rewind              = 6089,                                 05124000
   sr'cant'reopen'tape          = 6090, <<faild to reopen tape file>>   05126000
   sr'g'num'error               = 6091, <<good file error>>             05128000
   sr'bad'offline               = 6092, <<offline file was bad>>        05130000
   sr'cant'open'tape            = 6093, <<tape fopen failed>>           05132000
   sr'suddendeath               = 6098, <<suddendeath in store>>        05134000
   rs'suddendeath               = 6099, <<suddendeath in restore>>      05136000
   sr'lock'equal                = 6101,                                 05138000
   sr'lock'empty                = 6102,                                 05140000
   sr'lock'integrity            = 6103,                                 05142000
   sr'date'equal                = 6104,                                 05144000
   sr'onerr'equal               = 6105,                                 05146000
   sr'onerr'option'unknown      = 6106,                                 05148000
   sr'group'equal               = 6107,                                 05150000
   sr'acct'equal                = 6108,                                 05152000
   sr'group'invname             = 6109,                                 05154000
   sr'acct'invname              = 6110,                                 05156000
   sr'need'am                   = 6111,                                 05158000
   sr'need'sm                   = 6115,                                 05160000
   sr'dev'must'start'with'alpha = 6116,                                 05162000
   sr'dev'wildcards             = 6117,                                 05164000
   sr'dev'back'illegal          = 6118,                                 05166000
   rs'onerr'option'unknown      = 6119,                                 05168000
   sr'fileset'list'empty        = 6120,                                 05170000
   sr'g'num'full                = 6121,                                 05172000
   sr'date'all'0'or'non'0       = 6123,                                 05174000
   sr'invalid'day               = 6124,                                 05176000
   sr'invalid'month             = 6125,                                 05178000
   sr'invalid'year              = 6126,                                 05180000
   sr'slash'month'expected      = 6130,                                 05182000
   sr'slash'year'expected       = 6131,                                 05184000
   sr'day'too'big               = 6132,                                 05186000
   sr'number'too'big            = 6133,                                 05188000
   sr'dnumber'too'big           = 6134,                                 05190000
   sr'command'text'too'long     = 6135,                                 05192000
   sr'only'0'dev                = 6136,                                 05194000
   sr'bad'good'count            = 6137,                                 05196000
   sr'show'opt'expected         = 6138,                                 05198000
   sr'what'kind                 = 6139,                                 05200000
   sr'candidat'error            = 6140,                                 05202000
   sr'no'dollar'allowed         = 6141,                                 05204000
   sr'no'backref'allowed        = 6142,                                 05206000
   sr'failed'to'build'pattern   = 6143,                                 05208000
   sr's'2'd'failed              = 6144,                                 05210000
   sr'produceparms'failed       = 6145,                                 05212000
   sr'd'2's'failed              = 6146,                                 05214000
   sr'bad'acct'in'direcscan     = 6147,                                 05216000
   sr'bad'file'in'direcscan     = 6148,                                 05218000
   sr'bad'group'in'direcscan    = 6149,                                 05220000
   sr'warn'directorysearch'err  = 6150,                                 05222000
   rs'fileset'expected          = 6151,                                 05224000
   sr'acct'redundant            = 6152,                                 05226000
   sr'date'redundant            = 6153,                                 05228000
   sr'dev'redundant             = 6154,                                 05230000
   sr'files'redundant           = 6155,                                 05232000
   sr'group'redundant           = 6156,                                 05234000
   sr'keep'redundant            = 6157,                                 05236000
   sr'local'redundant           = 6158,                                 05238000
   sr'lock'redundant            = 6159,                                 05240000
   sr'newdate'redundant         = 6160,                                 05242000
   sr'nokeep'redundant          = 6161,                                 05244000
   sr'olddate'redundant         = 6162,                                 05246000
   sr'onerr'redundant           = 6163,                                 05248000
   sr'release'redundant         = 6164,                                 05250000
   sr'show'redundant            = 6165,                                 05252000
   sr'local'acct                = 6166,                                 05254000
   sr'local'group               = 6167,                                 05256000
   sr'nokeep'keep               = 6168,                                 05258000
   sr'keep'nokeep               = 6169,                                 05260000
   sr'group'local               = 6170,                                 05262000
   sr'acct'local                = 6171,                                 05264000
   sr'newdate'olddate           = 6172,                                 05266000
   sr'olddate'newdate           = 6173,                                 05268000
   rs'rewind'candidat'fail      = 6174,                                 05270000
   rs'read'candidat'fail        = 6175,                                 05272000
   rs'write'candidat'fail       = 6176,                                 05274000
   rs't'read'dir'fail           = 6177,                                 05276000
   rs't'fgetinfo'fail           = 6178,                                 05278000
   rs't'read'sr'label           = 6179,                                 05280000
   rs't'bad'recsize             = 6180,                                 05282000
   rs't'bad'blocksize           = 6181,                                 05284000
   rs't'got'2'eofs              = 6182,                                 05286000
   rs't'bsf'fail                = 6183,                                 05288000
   rs't'fsf'fail                = 6184,                                 05290000
   rs't'op'could'not'find'tape  = 6185,                                 05292000
   rs't'not'sr'label            = 6186,                                 05294000
   rs't'got'eof'not'sr'label    = 6187,                                 05296000
   rs't'bad'sr'label'recsize    = 6188,                                 05298000
   rs't'rewind'fail             = 6189,                                 05300000
   sr'g'num'sequence            = 6190,                                 05302000
   sr'g'read'fail               = 6191,                                 05304000
   sr'no'first'reel             = 6192,                                 05306000
   sr'no'next'reel              = 6193,                                 05308000
   sr'wt'directory              = 6194,                                 05310000
   sr'wt'get'status             = 6195,                                 05312000
   sr'wt'tape'label             = 6196,                                 05314000
   sr'wt'eof                    = 6197,                                 05316000
   sr'wt'label'tape             = 6199,                                 05318000
   sr'will're'store             = 6200,                                 05320000
   sr'cart'recsize'bad          = 6201,                                 05322000
   sr'density'redundant         = 6202,                                 05324000
   sr'density'equal             = 6203,                                 05326000
   sr'density'expected          = 6205,                                 05328000
   sr'recsize'redundant         = 6206,                                 05330000
   sr'recsize'equal             = 6207,                                 05332000
   sr'recsize'0                 = 6208,                                 05334000
   sr'recsize'expected          = 6209,                                 05336000
   sr'long'used                 = 6210,                                 05338000
   sr'short'used                = 6211,                                 05340000
   sr'wt'write1                 = 6212,                                 05342000
   rs'disabled                  = 6213,                                 05344000
   sr'wt'write3                 = 6214,                                 05346000
   sr'buffer'allocate'fail      = 6215,                                 05348000
   sr'buffer'freeze'fail        = 6216,                                 05350000
   sr'buffer'lock'fail          = 6217,                                 05352000
   sr'cant'recover'labeled'tapes= 6218,                                 05354000
   sr'operator'abort            = 6220,                                 05356000
   sr'sendmail'fail             = 6221,                                 05358000
   sr'null'cant'recover         = 6223,                                 05360000
   sr'ldev'equal                = 6224,                                 05362000
   sr'ldev'expected             = 6225,                                 05364000
   sr'pv'open'error             = 6226,                                 05366000
   sr'pv'rewind'fail            = 6227,                                 05368000
   sr'pv'write'fail             = 6228,                                 05370000
   sr'warn'aaa                  = 6229,                                 05372000
   sr'warn'aa                   = 6230,                                 05374000
   sr'warn'a                    = 6231,                                 05376000
   sr'warn'store'a              = 6232,                                 05378000
   sr'high'equal                = 6233,                        <<04870>>05380000
   sr'high'is'lower'than'low    = 6234,                        <<04870>>05382000
   sr'high'no'expected          = 6235,                        <<04870>>05384000
   sr'high'redundant            = 6236,                        <<04870>>05386000
   sr'low'equal                 = 6237,                        <<04870>>05388000
   sr'low'is'higher'than'high   = 6238,                        <<04870>>05390000
   sr'low'no'expected           = 6239,                        <<04870>>05392000
   sr'low'redundant             = 6240,                        <<04870>>05394000
   sr'dbstore'wo'high'and'low   = 6241,                        <<04870>>05396000
   sr'incorrect'number'of'files = 6242,                        <<04870>>05398000
   sr'checking'fathers'name     = 6243,                        <<04870>>05400000
   sr'dbstore'called'by'alien   = 6244,                        <<04870>>05402000
   sr'restart'tape              = 6245,                        <<04101>>05402010
   last'real'msg                = 6232,                                 05404000
   rs'synch'fsf                 = 9000,                                 05406000
   rs'onerr'skipfile            = 9001,                                 05408000
   rs'onerr'skiprecord          = 9002,                                 05410000
   rs'onerr'quit                = 9003,                                 05412000
   rs'synch'failed              = 9004,                                 05414000
   rs'd'file'error              = 9005,                                 05416000
   rs'synch'error               = 9006,                                 05418000
   rs'synch'eof                 = 9007,                                 05420000
   rs'd'num'error               = 9008,                                 05422000
   rs'eof'd'file                = 9009,                                 05424000
   rs'create'redundant          = 9010,                                 05426000
   rs'create'sm'or'am           = 9011,                                 05428000
   rs'create'sm                 = 9012,                                 05430000
   rs'create'opt'expected       = 9013,                                 05432000
   rs'create'opt'unknown        = 9014,                                 05434000
   rs'nexttapefile              = 9015,                        <<lb.rs>>05436000
   rs'mount'prev'fail           = 9016,                                 05438000
   rs'looking'for'eof           = 9017,                                 05440000
   rs'reading'first'record      = 9018,                                 05442000
   sr'g'update'fail             = 9019,                                 05444000
   rs'no'files'after'here       = 9020,                                 05446000
   sr'bad'tape                  = 9021,                                 05448000
   sr'take'it'off               = 9022,                                 05450000
   sr'not'part'of'tape'set      = 9023,                                 05452000
   sr'mount'next'reel           = 9024,                                 05454000
   sr'not'a'store'restore'tape  = 9025,                                 05456000
   sr'tape'of'same'set          = 9026,                                 05458000
   sr'mount'different'tape      = 9027,                                 05460000
   sr'tape'mount'fail           = 9028,                                 05462000
   rs'dir'find'old              = 9029,                                 05464000
   rs'unable'to'unlock'old'file = 9030,                        <<lb.rs>>05464100
   res'too'many'volume'sets     = 9037,                                 05466000
   rs'good'file'full            = 9038,                                 05468000
   rs't'trlbl'io'error          = 9039,                                 05470000
   rs'early'mount'failed        = 9040,                                 05472000
   rs't'io'unlab'tape'read      = 9042,                                 05474000
   rs't'eov'set                 = 9043,                                 05476000
   rs't'tape'dev'unavail        = 9044,                                 05478000
   rs't'eof'tape                = 9046,                                 05480000
   rs'mess'disc'lock            = 9047,                                 05482000
   rs'mess'tape'lock            = 9048,                                 05484000
   res'write'disc'fail          = 9049,                                 05486000
   rs'ffileinfo'failed          = 9050,                                 05488000
   sr'unable'to'start'reel      = 9051,                                 05490000
   sr'tim'start                 = 9052,                                 05490010
   sr'tim'before'fopen          = 9053,                                 05490020
   sr'tim'after'fopen           = 9054,                                 05490030
   sr'tim'after'directory       = 9055,                                 05490040
   sr'tim'start'of'tape         = 9056,                                 05490050
   sr'tim'done                  = 9057,                                 05490060
   sr'tim'before'rewind         = 9058,                                 05490070
   rs'attio'error               = 9059,                                 05490080
   rs'2'eofs                    = 9060,                        <<lb.rs>>05492000
   rs'io'read'unlab             = 9061,                        <<lb.rs>>05494000
   rs'io'skip'unlab             = 9062,                        <<lb.rs>>05496000
   rs'error'level'too'deep      = 9063,                        <<lb.rs>>05498000
   rs'd'read'fail               = 9064,                        <<lb.rs>>05500000
   rs'direcscan'error           = 9065,                        <<lb.rs>>05502000
   rs'fpoint'on'dir             = 9066,                        <<lb.rs>>05504000
   rs'fread'on'dir              = 9067,                        <<lb.rs>>05506000
   rs'not'found'on'tape         = 9068,                        <<lb.rs>>05508000
   rs'skipping'partial'file     = 9069,                        <<lb.rs>>05510000
   rs'io'read'lab               = 9070,                        <<lb.rs>>05510010
   rs'operator'reject           = 9071,                        <<lb.rs>>05510020
   rs'backing'up                = 9072,                        <<lb.rs>>05510030
   rs'unable'to'allocate'buffers= 9073,                        <<lb.rs>>05510040
   rs'look'for'eof              = 9074,                        <<lb.rs>>05510050
   sr'dir'bad'level             = 10011,                       <<lb.rs>>05510060
   sr'dir'lock'unxpctd          = 10012,                       <<lb.rs>>05510070
   rs'lockwords'different       = 9075,                                 05510080
   equate'holder                = -1;                                   05512000
$page "GLOBAL EQUATES -- STORE/RESTORE RUNTIME MESSAGES"                06000000
equate                                                                  06002000
      <<store/restore message sets... >>                                06004000
                                                                        06006000
   io'message'set   =  8,                                               06008000
   sr'message'set   = 29,                                      <<04975>>06010000
                                                                        06012000
      <<store/restore runtime message equates...>>                      06014000
                                                                        06016000
      <<note: all m'... numbers must be less than 1000!         >>      06018000
                                                                        06020000
      <<the m' equates are understood by sendmessage...they are         06022000
        not equates for accessing the message catalog!...since          06024000
        they are always accessed by name, the programmer need not       06026000
        not know what their actual "values" are!.  for ease of          06028000
        programming, they are declared below in alphabetic order.  >>   06030000
                                                                        06032000
   m'read'access'failure      = 0                        + 1,           06034000
   m'access'10'failure        = m'read'access'failure    + 1,           06036000
   m'acct'disc'space          = m'access'10'failure      + 1,           06038000
   m'acct'save'access         = m'acct'disc'space        + 1,           06040000
   m'adate'not'in'range       = m'acct'save'access       + 1,           06042000
   m'bad'irestore'title       = m'adate'not'in'range     + 1,           06044000
   m'blank'line               = m'bad'irestore'title     + 1,           06046000
   m'cant'purge'disc'file     = m'blank'line             + 1,           06048000
   m'cant'read'tape'file      = m'cant'purge'disc'file   + 1,           06050000
   m'cant'restore'this'file   = m'cant'read'tape'file    + 1,           06052000
   m'cdate'not'in'range       = m'cant'restore'this'file + 1,           06054000
   m'contained'tape'error     = m'cdate'not'in'range     + 1,  <<lb.rs>>06055000
   m'created'dir'entry        = m'contained'tape'error   + 1,  <<lb.rs>>06056000
   m'dateline                 = m'created'dir'entry      + 1,           06058000
   m'direc'no'room            = m'dateline               + 1,           06060000
   m'direc'unxpected'error    = m'direc'no'room          + 1,  <<lb.rs>>06062000
   m'direcscan'error          = m'direc'unxpected'error  + 1,  <<lb.rs>>06064000
   m'disk'read'failed         = m'direcscan'error        + 1,           06066000
   m'err'restoring'file       = m'disk'read'failed       + 1,           06068000
   m'err'storing'file         = m'err'restoring'file     + 1,           06070000
   m'error'acct'validation    = m'err'storing'file       + 1,           06072000
   m'error'group'validation   = m'error'acct'validation  + 1,           06074000
   m'error'user'validation    = m'error'group'validation + 1,           06076000
   m'file'excl'acc            = m'error'user'validation  + 1,           06078000
   m'file'lockword'wrong      = m'file'excl'acc          + 1,           06080000
   m'filecode'not'in'range    = m'file'lockword'wrong    + 1,           06082000
   m'flab'address'mismatch    = m'filecode'not'in'range  + 1,           06084000
   m'flab'checksum            = m'flab'address'mismatch  + 1,           06086000
   m'flab'title'mismatch      = m'flab'checksum          + 1,           06088000
   m'group'disc'space         = m'flab'title'mismatch    + 1,           06090000
   m'group'save'access        = m'group'disc'space       + 1,           06092000
   m'heading                  = m'group'save'access      + 1,           06094000
   m'keep'old'copy            = m'heading                + 1,           06096000
   m'loaded                   = m'keep'old'copy          + 1,           06098000
   m'lockword'viol            = m'loaded                  + 1,          06100000
   m'mdate'not'in'range       = m'lockword'viol          + 1,           06102000
   m'missing'eof              = m'mdate'not'in'range     + 1,           06104000
   m'mount'failed             = m'missing'eof            + 1,           06106000
   m'negative'filecode        = m'mount'failed           + 1,           06108000
   m'no'acct                  = m'negative'filecode      + 1,           06110000
   m'no'create                = m'no'acct                + 1,           06112000
   m'no'creator               = m'no'create              + 1,           06114000
   m'no'file                  = m'no'creator             + 1,           06116000
   m'no'group                 = m'no'file                + 1,           06118000
   m'no'files'to'restore      = m'no'group               + 1,           06120000
   m'no'files'to'store        = m'no'files'to'restore    + 1,           06122000
   m'nolock'write'failed      = m'no'files'to'store      + 1,           06124000
   m'not'all'sectors'written  = m'nolock'write'failed    + 1,           06126000
   m'not'on'tape              = m'not'all'sectors'written+ 1,           06128000
   m'nounlock'write'failed    = m'not'on'tape            + 1,           06130000
   m'open'fail                = m'nounlock'write'failed  + 1,           06132000
   m'open'for'read            = m'open'fail              + 1,           06134000
   m'open'for'restore         = m'open'for'read          + 1,           06136000
   m'open'for'rw              = m'open'for'restore       + 1,           06138000
   m'open'for'store           = m'open'for'rw            + 1,           06140000
   m'open'for'write           = m'open'for'store         + 1,           06142000
   m'out'of'disc'space        = m'open'for'write         + 1,           06144000
   m'pre'accross'accounts     = m'out'of'disc'space      + 1,           06146000
   m'pre'no'save'access       = m'pre'accross'accounts   + 1,           06148000
   m'prev'catastrophic        = m'pre'no'save'access     + 1,           06150000
   m'pv'dismount'fail         = m'prev'catastrophic      + 1,           06152000
   m'pv'mount'problem         = m'pv'dismount'fail       + 1,           06154000
   m'read'file'label'failed   = m'pv'mount'problem       + 1,           06156000
   m'reel'supplied            = m'read'file'label'failed + 1,           06158000
   m'res'acct'doesnt'exist    = m'reel'supplied          + 1,           06160000
   m'res'acct'verify          = m'res'acct'doesnt'exist  + 1,           06162000
   m'res'group'doesnt'exist   = m'res'acct'verify        + 1,           06164000
   m'res'group'verify         = m'res'group'doesnt'exist + 1,           06166000
   m'res'user'doesnt'exist    = m'res'group'verify       + 1,           06168000
   m'res'user'verify          = m'res'user'doesnt'exist  + 1,           06170000
   m'restore'preview          = m'res'user'verify        + 1,           06172000
   m'restore'summary          = m'restore'preview        + 1,           06174000
   m'restored                 = m'restore'summary        + 1,           06176000
   m'saving'file              = m'restored               + 1,           06178000
   m'security                 = m'saving'file            + 1,           06180000
   m'setting'eof              = m'security               + 1,           06182000
   m'store'summary            = m'setting'eof            + 1,           06184000
   m'synchronizing            = m'store'summary          + 1,           06186000
   m'stored                   = m'synchronizing          + 1,           06188000
   m't'eof'taperead           = m'stored                 + 1,           06190000
   m't'next'tape'file'error   = m't'eof'taperead         + 1,           06192000
   m't'trlbl'error            = m't'next'tape'file'error + 1,           06194000
   m'tape'bad'lockword        = m't'trlbl'error          + 1,           06196000
   m'tape'desired             = m'tape'bad'lockword      + 1,           06198000
   m'tape'version             = m'tape'desired           + 1,           06200000
   m'text                     = m'tape'version           + 1,           06202000
   m'time'info                = m'text                   + 1,           06204000
   m'title                    = m'time'info              + 1,  <<06156>>06205000
   m'w'creator'changed        = m'title                  + 1,  <<06156>>06206000
   m'disk'write'failed        = m'w'creator'changed      + 1,           06208000
   m'write'file'label'failed  = m'disk'write'failed      + 1,           06210000
   m'not'purged               = m'write'file'label'failed+ 1;           06210100
$page "GLOBAL EQUATES -- MISCELLANEOUS ERROR NUMBERS"                   06500000
equate                                                                  06502000
                                                                        06504000
      <<bad file title error message equates...>>                       06506000
                                                                        06508000
   filexpinvmonth    =  280,  <<bad no. for month>>                     06510000
   filexpnoslashmd   =  281,  <<no slash between month & day>>          06512000
   filexpinvday      =  282,  <<bad no. for day>>                       06514000
   filexpnoslashdy   =  284,  <<no slash between day & year>>           06516000
   filexpxtrndata    =  286,  <<extraneous data in date>>               06518000
                                                                        06520000
      <<error numbers for standard form conversion...>>                 06522000
                                                                        06524000
         <<from standard to display...>>                                06526000
                                                                        06528000
   de'standard'too'long =  1, <<resultant display title too long>>      06530000
   de'standard'empty    =  2, <<zero length file part in std title>>    06532000
                                                                        06534000
         <<from display to standard...>>                                06536000
                                                                        06538000
   se'part'too'long     =  1, <<part too long>>                         06540000
   se'zero'part         =  2, <<zero length part>>                      06542000
   se'wild'and'dollar   =  3, <<wildcard and $>>                        06544000
   se'wild'and'star     =  4, <<wildcard and *>>                        06546000
   se'first'not'letter  =  5, <<first char must be letter>>             06548000
   se'lockword'loc      =  6, <<bad place for lockword>>                06550000
   se'too'many'periods  =  7, <<too many periods>>                      06552000
   se'star'not'first    =  8, <<"*" must be first character>>           06554000
   se'dollar'not'first  =  9, <<"$" must be first character>>           06556000
   se'illegal'character = 10, <<invalid title character>>               06558000
   se'missing'parameters= 11, <<needed parameters were omitted>>        06560000
         <<errors from various allow bits ...>>                         06562000
   se'found'backref     = 12, <<backref found but not allowed!>>        06564000
   se'found'dollar      = 13, <<dollar found but not allowed!>>         06566000
   se'found'wild        = 14, <<found wildcards!>>                      06568000
   se'found'multi       = 15, <<multiple file parts found>>             06570000
   se'found'lock        = 16, <<found a lockword>>                      06572000
   se'found'group       = 17, <<found a group part>>                    06574000
   se'found'acct        = 18, <<found an acct>>                         06576000
   se'found'family      = 19, <<found a family part>>                   06578000
   se'found'host        = 20; <<found a host part>>                     06580000
                                                                        06582000
$page "INTRINSICS DECLARATIONS"                                         07000000
intrinsic                                                               07002000
   ascii,                                                               07004000
   binary,                                                              07006000
   calendar,                                                            07008000
   clock,                                                               07010000
   command,                                                             07012000
   dascii,                                                              07014000
   dbinary,                                                             07016000
   debug,                                                               07018000
   father,                                                     <<04870>>07020000
   fcheck,                                                              07022000
   fclose,                                                              07024000
   fcontrol,                                                            07026000
   ferrmsg,                                                             07027000
   ffileinfo,                                                           07028000
   fgetinfo,                                                            07030000
   findjcw,                                                             07032000
   fmtdate,                                                             07034000
   fopen,                                                               07036000
   fpoint,                                                              07038000
   fread,                                                               07040000
   freaddir,                                                   <<lb.rs>>07041000
   freadlabel,                                                          07042000
   frename,                                                             07044000
   fspace,                                                              07046000
   fupdate,                                                             07048000
   fwrite,                                                              07050000
   fwritelabel,                                                         07052000
   genmessage,                                                          07054000
   getprivmode,                                                         07056000
   getusermode,                                                         07058000
   mail,                                                                07060000
   pause,                                                               07062000
   print,                                                               07064000
   printop,                                                             07066000
   printfileinfo,                                                       07068000
   proctime,                                                            07070000
   putjcw,                                                              07072000
   quit,                                                       <<lb.rs>>07073000
   read,                                                                07074000
   readx,                                                               07076000
   receivemail,                                                         07078000
   sendmail,                                                            07080000
   timer,                                                               07082000
   who,                                                                 07084000
   zsize;                                                               07086000
$page "EXTERNAL PROCEDURES DECLARATIONS"                                07088000
logical procedure acccheck (level, anam, asec, gnam, gsec,              07090000
                            creator, fsec, userinfo);                   07092000
         value   level, asec, gsec, fsec;                               07094000
         integer level;                                                 07096000
         logical        asec;                                           07098000
         double               gsec, fsec;                               07100000
         byte array anam, gnam, creator, userinfo;                      07102000
         option external,                         variable;             07104000
                                                                        07106000
double procedure attachio (ldev, qmisc, dx, t, func, cnt,               07108000
                           p1, p2, flags);                              07110000
         value   ldev, qmisc, dx, t, func, cnt, p1, p2, flags;          07112000
         integer ldev, qmisc, dx, t, func, cnt, p1, p2, flags;          07114000
         option external;                                               07116000
                                                                        07118000
procedure date'line (string);                                           07120000
         byte array string;                                             07122000
         option external;                                               07124000
                                                                        07126000
double procedure direcadjust (numsects, dummy, a'name,                  07128000
                                 g'name, mvtabx);                       07130000
         value  numsects, dummy, mvtabx;                                07132000
         double numsects;                                               07134000
         integer          dummy, mvtabx;                                07136000
         array a'name, g'name;                                          07138000
         option external,                         variable;             07140000
                                                                        07142000
double procedure direcfind (type, linkage'indexp, a'name,               07144000
                            g'name, f'name, a);                         07146000
         value   type, linkage'indexp;                                  07148000
         integer type;                                                  07150000
         double        linkage'indexp;                                  07152000
         integer array a'name, g'name, f'name, a;                       07154000
         option external;                                               07156000
                                                                        07158000
double procedure direcfindfile (type, linkage'indexp, a'name,           07160000
                                g'name, f'name, preturn, mvtabx);       07162000
         value   type, mvtabx, linkage'indexp;                          07164000
         integer type, mvtabx;                                          07166000
         double                linkage'indexp;                          07168000
         array a'name, g'name, f'name, preturn;                         07170000
         option external,                         variable;             07172000
                                                                        07174000
double procedure direcinsert (type, linkage'indexp, a'name,             07176000
                              g'name, f'name, a, mvtabx);               07178000
         value   type, mvtabx, linkage'indexp;                          07180000
         integer type, mvtabx;                                          07182000
         double                linkage'indexp;                          07184000
         integer array a'name, g'name, f'name, a;                       07186000
         option external,                         variable;             07188000
                                                                        07190000
double procedure direcinsertfile (numsects, dummy, a'name,              07192000
                                  g'name, f'name, faddr, mvtabx);       07194000
         value  numsects, faddr, dummy, mvtabx;                         07196000
         double numsects, faddr;                                        07198000
         integer                 dummy, mvtabx;                         07200000
         array a'name, g'name, f'name;                                  07202000
         option external,                         variable;             07204000
                                                                        07206000
double procedure direcpurgefile (numsects, dummy, a'name, g'name,       07208000
                                 f'name, mvtabx);                       07210000
         value  numsects, dummy, mvtabx;                                07212000
         double numsects;                                               07214000
         integer          dummy, mvtabx;                                07216000
         array a'name, g'name, f'name;                                  07218000
         option external,                         variable;             07220000
                                                                        07222000
double procedure direcresetflag (type, linkage'indexp, a'name,          07224000
                                 g'name, f'name, mvtabx);               07226000
         value   type, mvtabx, linkage'indexp;                          07228000
         logical type, mvtabx;                                          07230000
         double                linkage'indexp;                          07232000
         array a'name, g'name, f'name;                                  07234000
         option external,                         variable;             07236000
                                                                        07238000
double procedure direcscan (type, linkage'indexp, a'name,               07240000
                     groupname, filename, recip, params, mvtabx);       07242000
         value   type, mvtabx, linkage'indexp;                          07244000
         integer type, mvtabx;                                          07246000
         double                linkage'indexp;                          07248000
         integer array a'name, groupname, filename, params;             07250000
         integer procedure recip;                                       07252000
         option external,                         variable;             07254000
                                                                        07256000
double procedure direcsetflag (type, linkage'indexp, a'name,            07258000
                               g'name, f'name, mvtabx);                 07260000
         value   type, mvtabx, linkage'indexp;                          07262000
         logical type, mvtabx;                                          07264000
         double                linkage'indexp;                          07266000
         array a'name, g'name, f'name;                                  07268000
         option external,                         variable;             07270000
                                                                        07272000
procedure dirread (pntr, which, excount, eemiscwd);            <<lb.rs>>07272100
         value pntr, which, excount,eemiscwd;                  <<lb.rs>>07272200
         logical pntr, which, eemiscwd;                        <<lb.rs>>07272300
         integer excount;                                      <<lb.rs>>07272400
         option external;                                      <<lb.rs>>07272500
                                                               <<lb.rs>>07272600
integer procedure dirmatch (genname, realname);                         07274000
         value        genname, realname;                                07276000
         byte pointer genname, realname;                                07278000
         option external;                                               07280000
                                                                        07282000
procedure dirwrite (which);                                    <<lb.rs>>07282100
         value which;                                          <<lb.rs>>07282200
         logical which;                                        <<lb.rs>>07282300
         option external;                                      <<lb.rs>>07282400
                                                               <<lb.rs>>07282500
integer procedure diskalloc (indx, numext, spacedata, pvinfo);          07284000
         value   indx, numext, pvinfo;                                  07286000
         integer indx, numext;                                          07288000
         logical               pvinfo;                                  07290000
         double array spacedata;                                        07292000
         option external;                                               07294000
                                                                        07296000
integer procedure diskdealloc (extsize, lastextsize, numexts, map);     07298000
         value   numexts, extsize, lastextsize;                         07300000
         integer numexts, extsize, lastextsize;                         07302000
         double array map;                                              07304000
         option external;                                               07306000
                                                                        07308000
integer procedure diskspace (ldev, nsect, diskaddr);                    07310000
         value   ldev, nsect;                                           07312000
         integer ldev;                                                  07314000
         double        nsect, diskaddr;                                 07316000
         option external;                                               07318000
                                                                        07320000
procedure dismount (vsname, vsgroup, vsacct, reqtype,                   07322000
                    pvinfo, some'other'pin);                            07324000
         value   pvinfo, some'other'pin;                                07326000
         integer pvinfo, some'other'pin, reqtype;                       07328000
         byte array vsname, vsgroup, vsacct;                            07330000
         option external,                         variable;             07332000
                                                                        07334000
integer procedure exchangedb (i);                                       07336000
         value   i;                                                     07338000
         integer i;                                                     07340000
         option external;                                               07342000
                                                                        07344000
integer procedure flabio (ldev, sector, func, file'label);              07346000
         value   ldev, sector, func;                                    07348000
         integer ldev,         func;                                    07350000
         double        sector;                                          07352000
         integer array file'label;                                      07354000
         option external;                                               07356000
                                                                        07358000
procedure flabioerr (flag,filenum,fganame);                             07360000
   value flag,filenum,fganame;                                          07362000
   logical flag;                                                        07364000
   integer filenum,fganame;                                             07366000
   option external, variable;                                           07368000
                                                                        07370000
integer procedure formsg (inbuff, setno, msgno, mask,                   07372000
            p1, p2, p3, p4, p5, outbuff, outbuffsize, outlen,           07374000
            dest, control);                                             07376000
         value   setno, msgno, outbuffsize, dest,                       07378000
                 mask, p1, p2, p3, p4, p5, control;                     07380000
         integer setno, msgno, outbuffsize, dest, outlen;               07382000
         logical mask, p1, p2, p3, p4, p5, control;                     07384000
         byte array inbuff, outbuff;                                    07386000
         option external;                                               07388000
                                                                        07390000
procedure freeze (en, test, pinx);                                      07392000
         value   en, test, pinx;                                        07394000
         integer en, pinx;                                              07396000
         logical test;                                                  07398000
         option external;                                               07400000
                                                                        07402000
logical procedure freply (message, length);                             07404000
         value   length;                                                07406000
         integer length;                                                07408000
         byte array message;                                            07410000
         option external;                                               07412000
                                                                        07414000
integer procedure genmsg (setno, msgno, mask, a, b, c, d, e,            07416000
                          dest, reply, buff, dst, iotype);              07418000
         value   setno, msgno, mask, a, b, c, d, e, dest, reply, buff,  07420000
               dst, iotype;                                             07422000
         logical setno, msgno, mask, a, b, c, d, e, dest, reply, buff,  07424000
               dst, iotype;                                             07426000
         option external,                         variable;             07428000
                                                                        07430000
procedure genmsgu (i, j);                                               07432000
         value     i, j;                                                07434000
         integer   i, j;                                                07436000
         option external;                                               07438000
                                                                        07440000
procedure get'filemnemonic (filecode, mnemonic, len);                   07442000
         integer filecode, len;                                         07444000
         byte array mnemonic;                                           07446000
         option external;                                               07448000
                                                                        07450000
integer procedure getdataseg (msize, vmsize);                           07452000
         value   msize, vmsize;                                         07454000
         integer msize, vmsize;                                         07456000
         option external;                                               07458000
                                                                        07460000
integer procedure getdevinfo (dev, info);                               07462000
         byte array dev;                                                07464000
         integer array info;                                            07466000
         option external;                                               07468000
                                                                        07470000
integer procedure getsir (a);                                           07472000
         value   a;                                                     07474000
         integer a;                                                     07476000
         option external;                                               07478000
                                                                        07480000
integer procedure iostat (stat);                                        07482000
         value   stat;                                                  07484000
         integer stat;                                                  07486000
         option external;                                               07488000
                                                                        07490000
logical procedure jobsessionmain;                                       07492000
         option external;                                               07494000
                                                                        07496000
integer procedure ldevtosubtype (ldev);                                 07498000
         value ldev;                                                    07500000
         integer ldev;                                                  07502000
         option external;                                               07504000
                                                                        07506000
integer procedure ldevtotype (ldev);                                    07508000
         value ldev;                                                    07510000
         integer ldev;                                                  07512000
         option external;                                               07514000
                                                                        07516000
procedure ldevtovtab (t, s, count, local);                              07518000
         value   count, local;                                          07520000
         integer count;                                                 07522000
         logical        local;                                          07524000
         double array t, s;                                             07526000
         option external;                                               07528000
                                                                        07530000
logical procedure ldirectf (fnum);                                      07532000
         value   fnum;                                                  07534000
         integer fnum;                                                  07536000
         option external;                                               07538000
                                                                        07540000
procedure lockseg (en, test, pinx);                                     07542000
         value   en, test, pinx;                                        07544000
         integer en, pinx;                                              07546000
         logical test;                                                  07548000
         option external;                                               07550000
                                                                        07552000
logical procedure lrelsw (fnum);                                        07554000
         value   fnum;                                                  07556000
         integer fnum;                                                  07558000
         option external;                                               07560000
                                                                        07562000
integer procedure lun (vtabinx, mvtabx);                                07564000
         value   vtabinx, mvtabx;                                       07566000
         integer vtabinx, mvtabx;                                       07568000
         option external;                                               07570000
                                                                        07572000
procedure mount (vsname, vsgroup, vsaccnt, reqtype, gen,                07574000
                 pvinfo, some'other'pin);                               07576000
         value   gen, some'other'pin;                                   07578000
         integer gen, some'other'pin, reqtype, pvinfo;                  07580000
         byte array vsname, vsgroup, vsaccnt;                           07582000
         option external,                         variable;             07584000
                                                                        07586000
integer procedure nexttapefile (fnum);                                  07588000
         integer fnum;                                                  07590000
         option external;                                               07592000
                                                                        07594000
procedure post'acb'error (filenum, theirstatus, error);                 07596000
         value   filenum, theirstatus, error;                           07598000
         integer filenum, error;                                        07600000
         logical theirstatus;                                           07602000
         option external;                                               07604000
                                                                        07606000
procedure procinfo (error1, error2, pin, option1, item1,       <<04870>>07608000
                                         option2, item2,       <<04870>>07610000
                                         option3, item3,       <<04870>>07612000
                                         option4, item4,       <<04870>>07614000
                                         option5, item5,       <<04870>>07616000
                                         option6, item6);      <<04870>>07618000
         value pin, option1, option2, option3, option4,        <<04870>>07620000
               option5, option6;                               <<04870>>07622000
         integer error1, error2, pin, option1, option2,        <<04870>>07624000
                 option3, option4, option5, option6;           <<04870>>07626000
         byte array item1, item2, item3, item4, item5, item6;  <<04870>>07628000
         option variable, external;                            <<04870>>07630000
logical procedure produceparms (leaflevel, qname, ppresult,             07632000
                               delim, errnum);                          07634000
         value   leaflevel, qname;                                      07636000
         integer leaflevel;                                             07638000
         byte pointer       qname;                                      07640000
         array ppresult;                                                07642000
         byte pointer delim;                                            07644000
         integer errnum;                                                07646000
         option external;                                               07648000
                                                                        07650000
                                                                        07652000
integer procedure reelswitch (ldev, rdwr);                              07654000
         value   ldev, rdwr;                                            07656000
         logical ldev;                                                  07658000
         integer       rdwr;                                            07660000
         option external;                                               07662000
                                                                        07664000
procedure reldataseg (en);                                              07666000
         value   en;                                                    07668000
         integer en;                                                    07670000
         option external;                                               07672000
                                                                        07674000
integer procedure return'disc'space (ldev, disc'address,       <<lb.rs>>07674100
                                     number'of'sectors);       <<lb.rs>>07674200
         value ldev, disc'address, number'of'sectors;          <<lb.rs>>07674300
         integer ldev;                                         <<lb.rs>>07674400
         double number'of'sectors, disc'address;               <<lb.rs>>07674500
         option external;                                      <<lb.rs>>07674600
                                                                        07676000
procedure relsir (a, b);                                                07678000
         value   a, b;                                                  07680000
         integer a, b;                                                  07682000
         option external;                                               07684000
                                                                        07686000
logical procedure requestservice;                                       07688000
         option external;                                               07690000
                                                                        07692000
procedure resetcritical (a);                                            07694000
         value   a;                                                     07696000
         logical a;                                                     07698000
         option external;                                               07700000
                                                                        07702000
logical procedure setcritical;                                          07704000
         option external;                                               07706000
                                                                        07708000
procedure unfreeze (en, test, pinx);                                    07710000
         value   en, test, pinx;                                        07712000
         integer en, pinx;                                              07714000
         logical test;                                                  07716000
         option external;                                               07718000
                                                                        07720000
procedure unlockseg (en, test, pinx);                                   07722000
         value   en, test, pinx;                                        07724000
         integer en, pinx;                                              07726000
         logical test;                                                  07728000
         option external;                                               07730000
                                                                        07732000
integer procedure vtabinx (lun, local);                                 07734000
         value   lun, local;                                            07736000
         integer lun;                                                   07738000
         logical      local;                                            07740000
         option external;                                               07742000
                                                                        07744000
procedure vtabtoldev (t, s, count, mvtabx);                             07746000
         value   count, mvtabx;                                         07748000
         integer count, mvtabx;                                         07750000
         double array t, s;                                             07752000
         option external;                                               07754000
                                                                        07756000
double procedure waitforio (ioqx);                                      07758000
         value   ioqx;                                                  07760000
         integer ioqx;                                                  07762000
         option external;                                               07764000
                                                                        07766000
integer procedure xdiskspace (ldev, nsect, diskaddr);                   07768000
         value   ldev, nsect, diskaddr;                                 07770000
         integer ldev;                                                  07772000
         double        nsect, diskaddr;                                 07774000
         option external;                                               07776000
                                                                        07778000
integer procedure xretpmask (n1, n2, n3, pmaskhi, pmasklo);             07780000
         logical pmaskhi, pmasklo;                                      07782000
         byte array n1, n2, n3;                                         07784000
         option external;                                               07786000
$page "FORWARD PROCEDURE DECLARATIONS"                                  08000000
procedure call'suddendeath (err);                                       08002000
         value err;                                                     08004000
         integer err;                                                   08006000
         option forward,  uncallable;                                   08008000
                                                                        08010000
procedure change'jit'acct (dstno, acctname);                            08012000
   value dstno;                                                         08014000
   integer dstno;                                                       08016000
   logical array acctname;                                              08018000
   opt'forward;                                                         08020000
                                                                        08038000
logical procedure check'for'dismount (old'pvinfo, curr'pvinfo,          08040000
                                  old'gbuf, err'code);                  08042000
         value   old'pvinfo, curr'pvinfo;                               08044000
         logical old'pvinfo, curr'pvinfo;                               08046000
         integer err'code;                                              08048000
         array   old'gbuf;                                              08050000
         option forward,  uncallable, privileged;                       08052000
                                                                        08054000
logical procedure check'store'restore'label;                            08056000
         option forward uncallable;                                     08058000
                                                                        08060000
logical procedure check'user(acctname,username,errcode);       <<lb.rs>>08060100
         byte array acctname, username;                        <<lb.rs>>08060200
         integer errcode;                                      <<lb.rs>>08060300
         option forward;                                       <<lb.rs>>08060400
                                                               <<lb.rs>>08060500
logical procedure checksum (buffer, len);                               08062000
         value   len;                                                   08064000
         integer len;                                                   08066000
         logical array buffer;                                          08068000
         option forward,  uncallable;                                   08070000
                                                                        08072000
procedure close'files (noshut);                                         08074000
         value                noshut;                                   08076000
         integer              noshut;                                   08078000
         option forward,  uncallable;                                   08080000
                                                                        08082000
integer procedure convert'se'to'cierr (error);                          08084000
         value   error;                                                 08086000
         integer error;                                                 08088000
         option forward,  uncallable;                                   08090000
                                                                        08092000
procedure cxstore'restore (p, stdlistnum, wants);                       08094000
         value   stdlistnum, wants;                                     08096000
         integer stdlistnum;                                            08098000
         logical wants;                                                 08100000
         byte array p;                                                  08102000
         option forward,  uncallable, privileged;                       08104000
                                                                        08106000
logical procedure direc'to'tape (tdbuf);                                08108000
         integer array tdbuf;                                           08110000
         option forward,  uncallable;                                   08112000
                                                                        08114000
logical procedure directorysearch (thunk);                              08116000
         logical procedure thunk;                                       08118000
         option forward,  uncallable;                                   08120000
                                                                        08122000
procedure dismount'private'volumes;                                     08124000
         option forward,  uncallable;                                   08126000
                                                                        08128000
logical procedure display'to'standard (pdis, pstd, error, char'inx,     08130000
                                       delims', allowed'items);         08132000
         value        pdis, pstd, delims', allowed'items;               08134000
         logical allowed'items;                                         08136000
         byte pointer pdis, pstd, delims';                              08138000
         integer      error, char'inx;                                  08140000
         option forward,  uncallable,             variable;             08142000
                                                                        08144000
procedure display'3'to'display (target,len,filename,           <<lb.rs>>08144100
                                groupname,acctname);           <<lb.rs>>08144110
         integer len;                                          <<lb.rs>>08144200
         byte array target, filename, groupname, acctname;     <<lb.rs>>08144300
         opt'forward;                                          <<lb.rs>>08144400
logical procedure display'3'to'standard (f', g', a',                    08146000
                                         pstd, error);                  08148000
         value pstd;                                                    08150000
         integer error;                                                 08152000
         byte pointer pstd;                                             08154000
         byte array f', g', a';                                         08156000
         option forward,  uncallable;                                   08158000
                                                                        08160000
procedure fill (a, count, what);                                        08162000
         value   count, what;                                           08164000
         logical count, what;                                           08166000
         integer array a;                                               08168000
         option forward,  uncallable;                                   08170000
                                                                        08172000
procedure fill' (a', count, what);                                      08174000
         value what, count;                                             08176000
         byte  what;                                                    08178000
         logical     count;                                             08180000
         byte array a';                                                 08182000
         option forward,  uncallable;                                   08184000
                                                                        08186000
integer procedure find'block'factor (error);                            08188000
         integer error;                                                 08190000
         option forward,  uncallable;                                   08192000
                                                                        08194000
double procedure find'file'size (typ, extent'sizes'd);                  08196000
         value   typ;                                                   08198000
         integer typ;                                                   08200000
         double array extent'sizes'd;                                   08202000
         option forward,  uncallable;                                   08204000
                                                                        08206000
logical procedure finish'reel (tdbuf, moredata);                        08208000
         value   moredata;                                              08210000
         logical moredata;                                              08212000
         integer array tdbuf;                                           08214000
         option forward,  uncallable;                                   08216000
                                                                        08218000
logical procedure fkontrol (fid, what);                                 08220000
         value   what;                                                  08222000
         integer what, fid;                                             08224000
         option forward,  uncallable;                                   08226000
                                                                        08228000
logical procedure frestore (tdbuf);                                     08230000
         integer array tdbuf;                                           08232000
         opt'forward'priv;                                              08234000
                                                                        08236000
logical procedure fstore (tdbuf);                                       08238000
         integer array tdbuf;                                           08240000
         option forward,  uncallable, privileged;                       08242000
                                                                        08244000
integer procedure get'jitdst;                                           08246000
   opt'forward;                                                         08248000
                                                                        08250000
procedure get'sirs (want'fisir, want'dsir);                             08252000
         value want'fisir, want'dsir;                                   08254000
         logical want'fisir, want'dsir;                                 08256000
         option forward,  uncallable;                                   08258000
                                                                        08260000
integer procedure get'next'volume (destination, distance);              08262000
         value destination;                                             08264000
         double destination, distance;                                  08266000
         opt'forward'priv;                                              08268000
                                                                        08270000
double procedure get'prior'labeled'volume;                              08272000
         opt'forward'priv;                                              08274000
                                                                        08276000
double procedure get'prior'unlabeled'volume;                            08278000
         opt'forward'priv;                                              08280000
                                                                        08282000
logical procedure irestore (tdbuf);                                     08284000
         integer array tdbuf;                                           08286000
         opt'forward'priv;                                              08288000
                                                               <<lb.rs>>08288100
procedure issue'ctrl (func);                                   <<lb.rs>>08288200
         value func;                                           <<lb.rs>>08288300
         logical func;                                         <<lb.rs>>08288400
         opt'forward;                                          <<lb.rs>>08288500
                                                               <<lb.rs>>08288600
                                                               <<lb.rs>>08288700
procedure issue'read (buffer, readlength, use'wait'io);        <<lb.rs>>08288800
         value readlength, use'wait'io;                        <<lb.rs>>08288900
         logical array buffer;                                 <<lb.rs>>08289000
         integer readlength;                                   <<lb.rs>>08289100
         logical use'wait'io;                                  <<lb.rs>>08289200
         opt'forward;                                          <<lb.rs>>08289300
                                                               <<lb.rs>>08289400
procedure issue'skip (use'wait'io);                            <<lb.rs>>08289500
         value use'wait'io;                                    <<lb.rs>>08289600
         logical use'wait'io;                                  <<lb.rs>>08289700
         opt'forward;                                          <<lb.rs>>08289800
                                                               <<lb.rs>>08289900
                                                                        08290000
procedure join'contiguous'extents (num'disj'exts, disj'ext'addr,        08292000
                                   disj'ext'len,  orig'extmap,          08294000
                                   orig'num'extents, extsize,  <<lb.rs>>08296000
                         last'extsize );                       <<lb.rs>>08297000
   value orig'num'extents, extsize, last'extsize;              <<lb.rs>>08298000
   integer num'disj'exts, orig'num'extents;                             08300000
   double array disj'ext'addr, disj'ext'len, orig'extmap;               08302000
   double extsize, last'extsize;                               <<lb.rs>>08303000
   option forward, uncallable;                                          08304000
integer procedure lock'directory;                              <<lb.rs>>08304100
         option forward;                                       <<lb.rs>>08304200
                                                               <<lb.rs>>08304300
logical procedure lock'unlock'file (setting, ldn, address,              08306000
                                    gotit);                             08308000
         value gotit, ldn, setting, address;                            08310000
         integer ldn, setting;                                          08312000
         double address;                                                08314000
         logical gotit;                                                 08316000
         option forward, uncallable, privileged;                        08318000
                                                               <<04101>>08318100
procedure mark'reel'bad;                                       <<04101>>08318200
         option forward;                                       <<04101>>08318300
                                                                        08320000
logical procedure mount'volume'set (vsgroup', vsacct', info);  <<lb.rs>>08320100
         integer info;                                         <<lb.rs>>08320200
         byte array vsgroup', vsacct';                         <<lb.rs>>08320300
         opt'forward;                                          <<lb.rs>>08320400
                                                               <<lb.rs>>08320500
procedure move'data'in (xds, inx, buf, len);                            08322000
         value   xds, inx, len;                                         08324000
         integer xds, inx, len;                                         08326000
         integer array buf;                                             08328000
         option forward,  uncallable, privileged;                       08330000
                                                                        08332000
procedure move'data'out (xds, inx, buf, len);                           08334000
         value   xds, inx, len;                                         08336000
         integer xds, inx, len;                                         08338000
         integer array buf;                                             08340000
         option forward,  uncallable, privileged;                       08342000
                                                                        08344000
logical procedure open'file (fileno,                                    08346000
                             desig, foptions, aoptions, recsize,        08348000
                             dev',                                      08350000
                             blockfactor, numbuffers, filesize,         08352000
                             numextents, initialloc);                   08354000
         value foptions, aoptions, recsize, blockfactor,                08356000
               numbuffers, filesize, numextents, initialloc;            08358000
         integer fileno;                                                08360000
         integer recsize, blockfactor, numbuffers,                      08362000
               numextents, initialloc;                                  08364000
         logical foptions, aoptions;                                    08366000
         byte array dev';                                               08368000
         integer array desig;                                           08370000
         double filesize;                                               08372000
         option forward,  uncallable,             variable;             08374000
                                                                        08376000
procedure outer'block (parm, info'length, info'address);                08378000
         value   parm, info'length, info'address;                       08380000
         integer parm, info'length, info'address;                       08382000
         option forward,  uncallable;                                   08384000
                                                                        08386000
logical procedure parse'date (pdate);                                   08388000
         logical pdate;                                                 08390000
         option forward,  uncallable;                                   08392000
                                                                        08394000
logical procedure parse'fileset;                                        08396000
         option forward,  uncallable, privileged;                       08398000
                                                                        08400000
integer procedure parse'name (ptr, len);                                08402000
         value   ptr, len;                                              08404000
         integer len;                                                   08406000
         byte pointer ptr;                                              08408000
         option forward,  uncallable;                                   08410000
                                                                        08412000
logical procedure parse'other'parms;                                    08414000
         option forward,  uncallable;                                   08416000
                                                                        08418000
logical procedure pattern'build (ptext, pattern, error);                08420000
         value        ptext;                                            08422000
         byte pointer ptext;                                            08424000
         integer error;                                                 08426000
         integer array pattern;                                         08428000
         option forward,  uncallable;                                   08430000
                                                                        08432000
logical procedure pattern'build'standard (pstd, f'pat, g'pat, a'pat,    08434000
                                          error);                       08436000
         value pstd;                                                    08438000
         byte pointer pstd;                                             08440000
         integer array f'pat, g'pat, a'pat;                             08442000
         integer error;                                                 08444000
         option forward,  uncallable;                                   08446000
                                                                        08448000
logical procedure pattern'match (ptext, pattern);                       08450000
         value        ptext;                                            08452000
         byte pointer ptext;                                            08454000
         integer array pattern;                                         08456000
         option forward,  uncallable;                                   08458000
                                                                        08460000
logical procedure pattern'match'standard (pstda, file'pat, group'pat,   08462000
                                          acct'pat, error);             08464000
         integer array file'pat, group'pat, acct'pat;                   08466000
         byte array pstda;                                              08468000
         integer error;                                                 08470000
         option forward,  uncallable;                                   08472000
                                                                        08474000
logical procedure pattern'3'match (f', g', a', file'pat, group'pat,     08476000
                                          acct'pat, error);             08478000
         integer array file'pat, group'pat, acct'pat;                   08480000
         byte array f', g', a';                                         08482000
         integer error;                                                 08484000
         option forward,  uncallable;                                   08486000
                                                                        08488000
procedure print'carrot (inx);                                           08490000
         value inx;                                                     08492000
         integer inx;                                                   08494000
         option forward,  uncallable;                                   08496000
                                                                        08498000
procedure print'file'error (fid);                                       08500000
         value   fid;                                                   08502000
         integer fid;                                                   08504000
         option forward,  uncallable;                                   08506000
                                                                        08508000
procedure read'all'attio;                                      <<lb.rs>>08508100
         opt'forward;                                          <<lb.rs>>08508400
                                                               <<lb.rs>>08508500
logical procedure read'disk (ldev, address, dst, buffer, len, iob);     08510000
         value   ldev, address, dst, buffer, len;  <<name iob;>>        08512000
         integer ldev, dst, buffer, len;                                08514000
         double  address, iob;                                          08516000
         option forward,  uncallable;                                   08518000
                                                                        08520000
logical procedure read'label (ldn, address, gotit);                     08522000
         value gotit, ldn, address;                                     08524000
         logical gotit;    <<if false, will do a getsir>>               08526000
         integer ldn;                                                   08528000
         double address;                                                08530000
         option forward,  uncallable, privileged;                       08532000
                                                                        08534000
logical procedure read'tape (tdbuf, gbuf);                              08536000
         integer array tdbuf, gbuf;                                     08538000
         opt'forward;                                                   08540000
                                                                        08542000
integer procedure recip'store (element, level, parms'offset, sir);      08544000
         value   level, parms'offset, sir;                              08546000
         integer level, parms'offset;                                   08548000
         double                       sir;                              08550000
         integer array element;                                         08552000
         option forward,  uncallable, privileged;                       08554000
                                                                        08556000
procedure release'sirs (rel'fisir, rel'dsir);                           08558000
         value rel'fisir, rel'dsir;                                     08560000
         logical rel'fisir, rel'dsir;                                   08562000
         option forward,  uncallable;                                   08564000
                                                                        08566000
logical procedure reopen'file (fileno,                                  08568000
                               desig, foptions, aoptions, recsize);     08570000
         value foptions, aoptions, recsize;                             08572000
         integer fileno, recsize;                                       08574000
         logical foptions, aoptions;                                    08576000
         integer array desig;                                           08578000
         option forward,  uncallable;                                   08580000
                                                                        08582000
logical procedure restore'a'file (tdbuf, gbuf,                          08584000
                                  jitdst                           );   08586000
         value jitdst;                                                  08588000
         integer jitdst;                                                08590000
         integer array tdbuf, gbuf;                                     08592000
         opt'forward;                                                   08594000
                                                                        08596000
logical procedure sendmessage (msgno, send'no'crlf,            <<lb.rs>>08598000
                               tell'to'op, string);            <<lb.rs>>08598100
         value   msgno, send'no'crlf, tell'to'op;                       08600000
         integer msgno;                                                 08602000
         logical send'no'crlf, tell'to'op;                              08604000
         byte array string;                                    <<lb.rs>>08605000
         option forward, variable, uncallable;                          08606000
                                                                        08608000
logical procedure standard'to'display (pstd, pdis, error, len);         08610000
         value        pstd, pdis;                                       08612000
         byte pointer pstd, pdis;                                       08614000
         integer error, len;                                            08616000
         option forward,  uncallable;                                   08618000
                                                                        08620000
logical procedure standard'to'3'display (pstd, f', g', a', error);      08622000
         value pstd;                                                    08624000
         integer error;                                                 08626000
         byte pointer pstd;                                             08628000
         byte array f', g', a';                                         08630000
         option forward,  uncallable;                                   08632000
procedure start'a'read (readlength);                           <<lb.rs>>08632100
         value readlength;                                     <<lb.rs>>08632200
         integer readlength;                                   <<lb.rs>>08632300
         opt'forward;                                          <<lb.rs>>08632400
                                                                        08634000
logical procedure start'reel (tdbuf, reel'num);                         08636000
         value   reel'num;                                              08638000
         integer reel'num;                                              08640000
         integer array tdbuf;                                           08642000
         option forward,  uncallable;                                   08644000
                                                                        08646000
integer procedure stepit';                                              08648000
         option forward,  uncallable;                                   08650000
                                                                        08652000
procedure strip'sequence'number (buf', len);                            08654000
         byte array buf';                                               08656000
         integer len;         <<name len;>>                             08658000
         option forward,  uncallable;                                   08660000
                                                                        08662000
logical procedure sub'match (ptext, actuallen, pattern, startpart);     08664000
         value   actuallen, startpart, ptext;                           08666000
         integer actuallen, startpart;                                  08668000
         byte pointer                  ptext;                           08670000
         integer array pattern;                                         08672000
         option forward,  uncallable;                                   08674000
                                                                        08676000
logical procedure tape'recsize'was'specified;                           08678000
         option forward,  uncallable;                                   08680000
                                                                        08682000
logical procedure test'switch (n);                                      08684000
         value   n;                                                     08686000
         integer n;                                                     08688000
         option forward,  uncallable;                                   08690000
                                                                        08692000
integer procedure thunk'store (element, level,                          08694000
                               sir'number, sir'info);                   08696000
         value   level, sir'number, sir'info;                           08698000
         integer level, sir'number, sir'info;                           08700000
         integer array element;                                         08702000
         option forward,  uncallable, privileged;                       08704000
                                                                        08706000
procedure unlock'files (what'files, pvinfo);                            08708000
         value   what'files, pvinfo;                                    08710000
         double  what'files;                                            08712000
         logical pvinfo;                                                08714000
         option forward,  uncallable, privileged;                       08716000
                                                               <<lb.rs>>08716100
integer procedure wait'for'all'attio;                          <<lb.rs>>08716200
         opt'forward;                                          <<lb.rs>>08716300
                                                                        08718000
                                                                        08730000
logical procedure write'label (ldn, address, gotit);                    08732000
         value gotit, ldn, address;                                     08734000
         logical gotit;                                                 08736000
         integer ldn;                                                   08738000
         double address;                                                08740000
         option forward,  uncallable, privileged;                       08742000
                                                                        08744000
logical procedure write'tape (wordc, buffer, ignore'eot, tdbuf,         08746000
                              last'write'of'file);                      08748000
         value   wordc, ignore'eot, last'write'of'file;                 08750000
         integer wordc;                                                 08752000
         logical        ignore'eot, last'write'of'file;                 08754000
         integer array buffer, tdbuf;                                   08756000
         option forward,  uncallable, privileged;                       08758000
                                                                        08760000
logical procedure write'tape'mark (errnum);                             08762000
         integer errnum;                                                08764000
         option forward,  uncallable, privileged;                       08766000
                                                                        08768000
$page                                                                   08770000
$if x1=on then                <<debugging code>>                        08772000
logical procedure affirm (yes, def);                                    08774000
         value def;                                                     08776000
         logical yes, def;                                              08778000
         option forward,  uncallable;                                   08780000
                                                                        08782000
procedure ahem;                                                         08784000
         option forward,  uncallable;                                   08786000
                                                                        08788000
procedure debug'scanner';                                               08790000
         option forward,  uncallable;                                   08792000
                                                                        08794000
procedure report'mismatch (element', pat);                              08796000
         byte array element';                                           08798000
         integer array pat;                                             08800000
         option forward,  uncallable;                                   08802000
                                                                        08804000
procedure say1 (char); value char; logical char;                        08806000
         option forward,  uncallable;                                   08808000
                                                                        08810000
procedure saybinary (n); value n; logical n;                            08812000
         option forward,  uncallable;                                   08814000
                                                                        08816000
procedure saydnum (n); value n; double n;                               08818000
         option forward,  uncallable;                                   08820000
                                                                        08822000
procedure saydoctal (dn); value dn; double dn;                          08824000
         option forward,  uncallable;                                   08826000
                                                                        08828000
procedure saynum (n); value n; integer n;                               08830000
         option forward,  uncallable;                                   08832000
                                                                        08834000
procedure sayoctal (n); value n; logical n;                             08836000
         option forward,  uncallable;                                   08838000
                                                                        08840000
procedure say'pattern (pat);                                            08842000
         integer array pat;                                             08844000
         option forward,  uncallable;                                   08846000
                                                                        08848000
procedure say'standard (pstd); value pstd; byte pointer pstd;           08850000
         option forward,  uncallable;                                   08852000
                                                                        08854000
logical procedure send';                                                08856000
         option forward,  uncallable;                                   08858000
                                                                        08860000
logical procedure sendstop;                                             08862000
         option forward,  uncallable;                                   08864000
                                                                        08866000
$if                           <<debugging code>>                        08868000
                                                                        08870000
$page ";MAIN=  SEND/AHEM --- DEBUGGING OUTPUT ROUTINES"                 10000000
$if x1=on then                <<debugging code>>                        10002000
                                                                        10004000
<<------------------------------------------------------------          10006000
                                                                        10008000
the following is a collection of procedures compiled only               10010000
when debugging is enabled.  these procedures facilitate                 10012000
input, output, and question asking.  procedures:                        10014000
                                                                        10016000
   affirm           gets a yes/no answer from the user                  10018000
   ahem             clears output buffer (outputbuffer', pout)          10020000
   say1             "SAYs" one character to output stream (pout)        10022000
   saybinary        says a number in binary (16 characters long)        10024000
   saydnum          says a signed double integer                        10026000
   saydoctal        says an octal number (11 characters long)           10028000
   saynum           says a signed integer (["-"], 1...5 digits)         10030000
   sayoctal         says an octal number (6 characters)                 10032000
   say'pattern      decodes and says a pattern                          10034000
   say'standard     decodes and says a standard form title              10036000
   send'            writes output text to stdlist.                      10038000
   sendstop         like send, but with a %320 carriage control         10040000
   report'mismatch  reports a mis-match between two patterns.           10042000
   test'switch      tests sense switch ... from 0 to 15.                10044000
   debug'scanner'   prints out scanner status when called               10046000
                                                                        10048000
------------------------------------------------------------->>         10050000
$page                                                                   10052000
$control segment=main                                                   10054000
<<***************************************************************>>     10056000
logical procedure affirm (yes, def);                                    10058000
         value           def;                                           10060000
         logical yes,    def;                                           10062000
   begin                                                                10064000
                                                                        10066000
   logical array                                                        10068000
      buf         (0:40),                                               10070000
      scratch     (0:4);                                                10072000
                                                                        10074000
   integer                                                              10076000
      alen        := 0,                                                 10078000
      i           := 0,                                                 10080000
      len         := 0;                                                 10082000
                                                                        10084000
   byte array                                                           10086000
      buf'        (*) = buf (0),                                        10088000
      scratch'    (*) = scratch (0);                                    10090000
                                                                        10092000
   byte array                                                           10094000
      answers' (*) = pb :=                                              10096000
         <<length, value, text, language...>>                           10098000
         1, 1, "Y",              <<english>>                            10100000
         2, 1, "YE",             <<english>>                            10102000
         3, 1, "YES",            <<english>>                            10104000
         1, 0, "N",              <<english no>>                         10106000
         2, 0, "NO",             <<english no>>                         10108000
         4, 0, "NEIN",           <<german no>>                          10110000
         2, 1, "OK",             <<english slang>>                      10112000
         2, 1, "SI",             <<spanish>>                            10114000
         2, 1, "JA",             <<german>>                             10116000
         3, 1, "OUI",            <<french>>                             10118000
         0;                                                             10120000
                                                                        10122000
                                                                        10124000
   affirm:=yes:=def;                                                    10126000
                                                                        10128000
         <<read input...>>                                              10130000
                                                                        10132000
   buf'(len:=readx(buf, -80)):=0;                                       10134000
                                                                        10136000
         <<find first non-blank...>>                                    10138000
                                                                        10140000
   while buf' = " " and len > 1 do                                      10142000
      begin                                                             10144000
      move buf'(0):=buf'(1), (len-1);                                   10146000
      buf'(len:=len-1):=0;                                              10148000
      end;                                                              10150000
                                                                        10152000
         <<find length of token...>>                                    10154000
                                                                        10156000
   move buf':=buf' while ans;     <<upshift>>                           10158000
   scan buf' until " ", 1;                                              10160000
   alen:=tos-logical(@buf');  <<length of token>>                       10162000
                                                                        10164000
   if len <= 0 then                                                     10166000
      return;                                                           10168000
                                                                        10170000
                  <<look up answer in answers' array...>>               10172000
                                                                        10174000
   len:=alen;     <<len is now the length of the token found>>          10176000
                                                                        10178000
   i:=0;                                                                10180000
   move scratch':=answers'(0),(1);                                      10182000
   alen:=scratch'(0);                                                   10184000
   move scratch'(0):=answers'(0), (alen+2);                             10186000
                                                                        10188000
   while alen <> 0 do                                                   10190000
      begin                                                             10192000
      if len = alen then     <<do lengths match?>>                      10194000
         begin                                                          10196000
         if buf' = scratch'(2), (alen) then                             10198000
            begin                                                       10200000
            affirm:=yes:= (scratch'(1) = 1);                            10202000
            return;                                                     10204000
            end;                                                        10206000
         end;                                                           10208000
      i:=i+alen+2;                                                      10210000
      move scratch'(0):=answers'(i),(1);                                10212000
      alen:=scratch'(0);                                                10214000
      move scratch'(0):=answers'(i),(alen+2);                           10216000
      end;                                                              10218000
                                                                        10220000
   end <<affirm proc>>;                                                 10222000
<<***************************************************************>>     10224000
procedure ahem;                                                         10226000
         option uncallable;                                             10228000
                                                                        10230000
   begin                                                                10232000
                                                                        10234000
   fill (outputbuffer, 66, "  ");                                       10236000
                                                                        10238000
   @pout:=@outputbuffer';                                               10240000
                                                                        10242000
   end <<ahem proc>>;                                                   10244000
<<**************************************************************>>      10246000
procedure say1 (char); value char; logical char;                        10248000
         option uncallable;                                             10250000
                                                                        10252000
   begin                                                                10254000
                                                                        10256000
   if char.(8:8) = 0 then                                               10258000
      char.(8:8):=char.(0:8);                                           10260000
                                                                        10262000
   if char.(8:8) = " " then                                             10264000
      if char.(0:8) <> 0 then                                           10266000
         char.(8:8):=char.(0:8);                                        10268000
                                                                        10270000
   pout:=char;                                                          10272000
                                                                        10274000
   @pout:=@pout(1);                                                     10276000
                                                                        10278000
   end <<say1 proc>>;                                                   10280000
<<***************************************************************>>     10282000
procedure saybinary (n); value n; logical n;                            10284000
         option uncallable;                                             10286000
                                                                        10288000
   begin                                                                10290000
                                                                        10292000
   integer                                                              10294000
      i;                                                                10296000
                                                                        10298000
   for i:=15 step -1 until 0 do                                         10300000
      begin                                                             10302000
      if n.(0:1) = 0 then                                               10304000
         say1 ("0")                                                     10306000
      else                                                              10308000
         say1("1");                                                     10310000
      n:=n & csl (1);                                                   10312000
      end;                                                              10314000
                                                                        10316000
   end <<saybinary proc>>;                                              10318000
<<***************************************************************>>     10320000
procedure saydnum (n); value n; double n;                               10322000
         option uncallable;                                             10324000
                                                                        10326000
   begin                                                                10328000
                                                                        10330000
   @pout:=@pout(dascii (n, 10, pout));                                  10332000
                                                                        10334000
   end <<saydnum proc>>;                                                10336000
<<***************************************************************>>     10338000
procedure saydoctal (dn); value dn; double dn;                          10340000
         option uncallable;                                             10342000
                                                                        10344000
   begin                                                                10346000
                                                                        10348000
   dascii(dn, 8, pout);       <<octal dascii always takes 11 spaces>>   10350000
                                                                        10352000
   @pout:=@pout(11);                                                    10354000
                                                                        10356000
   end <<sayoctal proc>>;                                               10358000
<<***************************************************************>>     10360000
procedure saynum (n); value n; integer n;                               10362000
         option uncallable;                                             10364000
                                                                        10366000
   begin                                                                10368000
                                                                        10370000
   if n < 0 then                                                        10372000
      say "-" endsay;                                                   10374000
                                                                        10376000
   @pout:=@pout(ascii(\n\,10,pout));                                    10378000
                                                                        10380000
   end <<saynum proc>>;                                                 10382000
<<***************************************************************>>     10384000
procedure sayoctal (n); value n; logical n;                             10386000
         option uncallable;                                             10388000
                                                                        10390000
   begin                                                                10392000
                                                                        10394000
   ascii(n, 8, pout);         <<octal ascii always takes 6 spaces>>     10396000
                                                                        10398000
   @pout:=@pout(6);                                                     10400000
                                                                        10402000
   end <<sayoctal proc>>;                                               10404000
<<***************************************************************>>     10406000
procedure say'pattern (pat);                                            10408000
         integer array pat;                                             10410000
                                                                        10412000
   begin                                                                10414000
                                                                        10416000
   integer                                                              10418000
      char        := 0,                                                 10420000
      inx         := 1,                                                 10422000
      len         := 0,                                                 10424000
      parts       := 0,                                                 10426000
      word        := 0;                                                 10428000
                                                                        10430000
   parts:=pat(0);                                                       10432000
                                                                        10434000
   while (parts:=parts-1) >= 0 do                                       10436000
      begin                                                             10438000
                                                                        10440000
      word:=pat(inx);                                                   10442000
      len:=word.patlenf;                                                10444000
      char:=word.patcharf;                                              10446000
                                                                        10448000
      if word.pattypef = anycharactersp then                            10450000
         len:=1;                                                        10452000
                                                                        10454000
      while (len:=len-1) >= 0 do                                        10456000
         say1 (char);                                                   10458000
                                                                        10460000
      inx:=inx+1;                                                       10462000
                                                                        10464000
      end                                                               10466000
                                                                        10468000
   end <<say'pattern proc>>;                                            10470000
<<***************************************************************>>     10472000
procedure say'standard (pstd); value pstd; byte pointer pstd;           10474000
                                                                        10476000
   begin                                                                10478000
                                                                        10480000
   integer                                                              10482000
      error,                                                            10484000
      len;                                                              10486000
                                                                        10488000
   if standard'to'display (pstd, pout, error, len) = failed then        10490000
      begin                                                             10492000
      say "***STD ERR " endsay;                                         10494000
      saynum(error);                                                    10496000
      say " AT " endsay;                                                10498000
      saynum(len);                                                      10500000
      end                                                               10502000
   else                                                                 10504000
      @pout:=@pout(len);                                                10506000
                                                                        10508000
   end <<say'standard proc>>;                                           10510000
<<***************************************************************>>     10512000
logical procedure send';                                                10514000
         option uncallable;                                             10516000
                                                                        10518000
   begin                                                                10520000
                                                                        10522000
   integer                                                              10524000
      i           := 0,                                                 10526000
      j           := 0;                                                 10528000
                                                                        10530000
   <<----------------->>                                                10532000
   <<------------------------->>                                        10534000
                                                                        10536000
   send':=false;                                                        10538000
                                                                        10540000
   print (outputbuffer, -pout'offset, 0);                               10542000
                                                                        10544000
   if <> then                                                           10546000
      send':=true;                                                      10548000
                                                                        10550000
   ahem;                                                                10552000
                                                                        10554000
   if debugging then                                                    10556000
      if debugpause > 0.0 and debug'send'end then                       10558000
         pause (debugpause);                                            10560000
                                                                        10562000
   end <<send' proc>>;                                                  10564000
<<***************************************************************>>     10566000
logical procedure sendstop;                                             10568000
         option uncallable;                                             10570000
                                                                        10572000
   begin                                                                10574000
                                                                        10576000
   sendstop:=false;                                                     10578000
                                                                        10580000
   print (outputbuffer, -pout'offset, %320);                            10582000
                                                                        10584000
   if <> then                                                           10586000
      sendstop:=true;                                                   10588000
                                                                        10590000
   ahem;                                                                10592000
                                                                        10594000
   end <<sendstop proc>>;                                               10596000
<<****************************************************************>>    10598000
procedure report'mismatch (element', pat);                              10600000
         byte array element';                                           10602000
         integer array pat;                                             10604000
                                                                        10606000
   begin                                                                10608000
                                                                        10610000
   say "MATCH FOR: " endsay;                                            10612000
   say element',(8) endsay;                                             10614000
   say " vs " endsay;                                                   10616000
   say'pattern (pat);                                                   10618000
                                                                        10620000
   send;                                                                10622000
                                                                        10624000
   end <<report'mismatch proc>>;                                        10626000
$page ";MAIN=  TEST'SWITCH --- DEBUGGING ROUTINE"                       10628000
$control segment=main                                                   10630000
<<**************************************************************>>      10632000
logical procedure test'switch (n);                                      10634000
         value   n;                                                     10636000
         integer n;                                                     10638000
   begin                                                                10640000
   logical                                                              10642000
      switches;                                                         10644000
                                                                        10646000
   assemble (rsw);                                                      10648000
   switches:=tos;                                                       10650000
   if switches.(8:1) = 1 then debug;                                    10652000
                                                                        10654000
   do                                                                   10656000
      switches:=switches & csl(1)                                       10658000
   until                                                                10660000
      (n:=n-1) < 0;                                                     10662000
                                                                        10664000
   test'switch:=switches;                                               10666000
                                                                        10668000
   end <<test'switch proc>>;                                            10670000
$page ";MAIN=  DEBUG'SCANNER'"                                          10672000
$control segment=main                                                   10674000
<<**********************************************************>>          10676000
procedure debug'scanner';                                               10678000
         option           uncallable;                                   10680000
   begin                                                                10682000
                                                                        10684000
                                                                        10686000
   say " ITEMP= '" endsay;                                              10688000
   say itemp,(ilen) endsay;                                             10690000
   say "', ILEN=" endsay;                                               10692000
   saynum (ilen);                                                       10694000
                                                                        10696000
   say ", ILEFT=" endsay;                                               10698000
   saynum (ileft);                                                      10700000
                                                                        10702000
   say ", ICLASS=" endsay;                                              10704000
   if iclass > 0 then                                                   10706000
      saynum (iclass)                                                   10708000
   else                                                                 10710000
      case \iclass\ of                                                  10712000
         begin                                                          10714000
         say1 ("0");                                                    10716000
         say "endline" endsay;                                          10718000
         say "token" endsay;                                            10720000
         say "number" endsay;                                           10722000
         say "special" endsay;                                          10724000
         say "string" endsay;                                           10726000
         say "dnumber" endsay;                                          10728000
         say "unknown" endsay;                                          10730000
         say "7" endsay                                                 10732000
         end;                                                           10734000
                                                                        10736000
   say ", SUBCLASS = " endsay;                                          10738000
                                                                        10740000
   if iclass is tokenv then                                             10742000
      if subclass <> 0 then                                             10744000
         if subclass is dnumberv then                                   10746000
            say " BIG DOUBLE" endsay                                    10748000
         else if subclass is numberv then                               10750000
            say " BIG SINGLE" endsay                                    10752000
         else                                                           10754000
            saynum (subclass)                                           10756000
      else                                                              10758000
         say "normal" endsay                                            10760000
   else if iclass is dnumberv then                                      10762000
      begin                                                             10764000
      saydnum (subclass'd);                                             10766000
      say1 ("D");                                                       10768000
      end                                                               10770000
   else                                                                 10772000
      saynum (subclass);                                                10774000
                                                                        10776000
   send;                                                                10778000
                                                                        10780000
   end <<debug'scanner' proc>>;                                         10782000
$if                           <<debugging code>>                        10784000
$page ";MAIN=  DO'MPE'COMMAND --- HANDLES ':' INPUT"                    10786000
$control segment=main                                                   10788000
<<************************************************************>>        10790000
logical procedure do'mpe'command (buf');                                10792000
         byte array buf';                                               10794000
                                                                        10796000
      <<--------------------------------------------------------        10798000
        does the mpe command pointed to by buf'.  if a colon            10800000
        starts the image, it is stripped off.  if the command           10802000
        fails, an error message is printed,                             10804000
        and a failed is returned.  if the command worked ok, a          10806000
        good is returned.                                               10808000
        ------------------------------------------------------>>        10810000
   begin                                                                10812000
                                                                        10814000
   integer                                                              10816000
      i,                                                                10818000
      j,                                                                10820000
      len;                                                              10822000
                                                                        10824000
   intrinsic                                                            10826000
      command;                                                          10828000
                                                                        10830000
   scan buf' until %15, 1;                                              10832000
   len:=tos-logical(@buf');                                             10834000
                                                                        10836000
   while (buf'(0) = ":") or (buf'(0) = " ") do                          10838000
      begin                                                             10840000
      move buf'(0):=buf'(1), (len);                                     10842000
      len:=len-1;                                                       10844000
      end;                                                              10846000
                                                                        10848000
   do'mpe'command:=good;      <<assume that it will work ok!>>          10850000
                                                                        10852000
   move buf':=buf' while ans;                                           10854000
                                                                        10856000
   command (buf', i, j);                                                10858000
                                                                        10860000
   if i<>0 then                                                <<04101>>10862000
      begin                                                             10864000
      genmsgu (2, \i\);         <<ci error message set>>       <<04983>>10866000
      if j > 20 then                                                    10868000
         genmsgu (8, j);      <<file sys error set>>                    10870000
      end;                                                              10872000
                                                                        10874000
   end <<do'mpe'command proc>>;                                         10876000
$page ";MAIN=  STORE'RESTORE'DRIVER"                                    10878000
$control segment=main                                                   10880000
<<***********************************************************>>         10882000
procedure store'restore'driver;                                         10884000
                                                                        10886000
   << this procedure is the program-mode driver for store               10888000
      and restore.  it is called when this program is run               10890000
      without an info parameter.  it merely loops, prompting            10892000
      the user for input (if interactive), and calls the                10894000
      procedure cxstore'restore with the input (unless this             10896000
      was compiled with debugging enabled, in which case it             10898000
      first checks to see if the input was a debugging command).        10900000
                                                                        10902000
      in batch mode, a double line of "#####..." is printed             10904000
      after every store/restore command.                                10906000
                                                                        10908000
      in either mode, the input text is examined for a                  10910000
      sequence number at the right hand side.  if the last              10912000
      8 characters are digits, they are stripped off.                   10914000
                                                                        10916000
      in either mode, the input is examined and any occurances          10918000
      of this procedure's prompt ("<--") are stipped off.    >>         10920000
                                                                        10922000
   begin                                                                10924000
                                                                        10926000
   integer array                                                        10928000
      buf         (0:140);                                              10930000
                                                                        10932000
   integer                                                              10934000
      len,                                                              10936000
      stdlistnum;                                                       10938000
                                                                        10940000
   logical                                                              10942000
      my'mode     := false,                                             10944000
      tf          := false;                                             10946000
                                                                        10948000
   byte array                                                           10950000
      buf'        (*) = buf (0);                                        10952000
                                                                        10954000
   byte                                                                 10956000
      char;                                                             10958000
                                                                        10960000
   <<-------------------->>                                             10962000
   subroutine check'options;                                            10964000
                                                                        10966000
      begin                                                             10968000
                                                                        10970000
$if x1=on then                <<debugging code>>                        10972000
      buf'(len):=0;                                                     10974000
      move buf':=buf' while ans;                                        10976000
                                                                        10978000
      if len > 1 then                                                   10980000
         move buf'(1):=buf'(1) while ans;                               10982000
      if len > 2 then                                                   10984000
         move buf'(2):=buf'(2) while ans;                               10986000
                                                                        10988000
      if buf' = "\DEBUG" then                                           10990000
         begin                                                          10992000
         debug;                                                         10994000
         return;                                                        10996000
         end;                                                           10998000
                                                                        11000000
      if buf'(1) = "+" then                                             11002000
         tf:=true                                                       11004000
                                                                        11006000
      else if buf'(1) = "-" then                                        11008000
         tf:=false                                                      11010000
                                                                        11012000
      else                                                              11014000
         begin                                                          11016000
         say "Expected a '+' or a '-' after the '\', found: '" endsay;  11018000
         say buf'(1),(1) endsay;                                        11020000
         say "'" endsay;                                                11022000
         send;                                                          11024000
         say "Or....expected \DEBUG" endsay;                            11026000
         send;                                                          11028000
         return;                                                        11030000
         end;                                                           11032000
                                                                        11034000
      char:=buf'(2);                                                    11036000
                                                                        11038000
      if char="D" then                                                  11040000
         debugging:=tf                                                  11042000
                                                                        11044000
      else if char="P" then                                             11046000
         if tf then                                                     11048000
            debugpause := 0.4                                           11050000
         else                                                           11052000
            debugpause := 0.0                                           11054000
                                                                        11056000
      else                                                              11058000
         begin                                                          11060000
         say "UNKNOWN OPTION: " endsay;                                 11062000
         say buf'(0),(3) endsay;                                        11064000
         say ", EXPECTED: D, P" endsay;                                 11066000
         send;                                                          11068000
         say "   D = DEBUGGING" endsay; send;                           11070000
         say "   P = PAUSE after DEBUGGING FWRITEs" endsay; send;       11072000
         send;                                                          11074000
         end;                                                           11076000
$if                           <<debugging code>>                        11078000
                                                                        11080000
      end <<check'options sub>>;                                        11082000
   <<----------------------->>                                          11084000
                                                                        11086000
   using'driver := true;                                                11088000
                                                                        11090000
   disable'arithmetic'traps;                                            11092000
                                                                        11094000
   if store'catalog <> 0 then                                           11096000
      genmessage (store'catalog, sr'message'set, sr'store'version)      11098000
   else                                                                 11100000
      genmsgu (sr'message'set, sr'store'version);                       11102000
                                                                        11104000
   enable'arithmetic'traps;                                             11106000
                                                                        11108000
$if x1=on then                <<debugging code>>                        11110000
   ahem;                                                                11112000
$if                           <<debugging code>>                        11114000
                                                                        11116000
   who (my'mode);                                                       11118000
                                                                        11120000
   if my'mode.interactivebit then                                       11122000
      stdlistnum:=0           <<syslist not opened yet>>                11124000
   else                                                                 11126000
      stdlistnum:=stdlist'num;      << "2" >>                           11128000
                                                                        11130000
   while true do                                                        11132000
      begin                                                             11134000
                                                                        11136000
      if my'mode.interactivebit then                                    11138000
         begin                                                          11140000
         move buf':="<--";                                              11142000
         print (buf, -3, %320);                                         11144000
         end;                                                           11146000
                                                                        11148000
      fill' (buf', 257, %15);                                           11150000
                                                                        11152000
      len:=readx (buf, -280);                                           11154000
                                                                        11156000
      if <> then                                                        11158000
         return;              <<exit procedure>>                        11160000
                                                                        11162000
            <<"take off" sequence number...>>                           11164000
                                                                        11166000
      strip'sequence'number (buf', len);                                11168000
                                                                        11170000
            <<delete the prompt (if any) from start...>>                11172000
                                                                        11174000
      while (buf' = "<--") do          <<the prompt!>>                  11176000
         begin                         <<strip the prompt...>>          11178000
         move buf'(0):=buf'(3),(len-3);                                 11180000
         len:=len-3;                                                    11182000
         end;                                                           11184000
                                                                        11186000
            <<delete any leading blanks...>>                            11188000
                                                                        11190000
      while (buf' = " ") and len > 0 do                                 11192000
         begin                                                          11194000
         move buf'(0):=buf'(1),(len-1);                                 11196000
         len:=len-1;                                                    11198000
         end;                                                           11200000
                                                                        11202000
      if not my'mode.duplicativebit then                                11204000
         print (buf, -len, 0);                                          11206000
                                                                        11208000
      buf'(len):=%15;                                                   11210000
                                                                        11212000
      if len > 0 then                                                   11214000
         begin                                                          11216000
                                                                        11218000
         move buf':=buf' while ans;                                     11220000
                                                                        11222000
         if buf' = "EXIT" then                                          11224000
            return            <<exit procedure>>                        11226000
                                                                        11228000
         else if buf' = ":" then                                        11230000
            do'mpe'command (buf')                                       11232000
                                                                        11234000
$if x1=on then                <<debugging code>>                        11236000
         else if buf'(0) = "\" then                                     11238000
            check'options                                               11240000
$if                           <<debugging code>>                        11242000
                                                                        11244000
         else                                                           11246000
            begin                                                       11248000
                                                                        11250000
            cxstore'restore (buf', stdlistnum, false);                  11252000
                                                                        11254000
            if (not my'mode.interactivebit) then                        11256000
               begin                                                    11258000
               fill' (buf', 72, "#");                                   11260000
               print (buf, -72, 0);                                     11262000
               print (buf, -72, 0);                                     11264000
               print (buf, 0, 0);                                       11266000
               end;                                                     11268000
            end;                                                        11270000
         end;                                                           11272000
      end;                                                              11274000
                                                                        11276000
   end <<store'restore'driver proc>>;                                   11278000
$page ";MAIN=  OUTER BLOCK"                                             11280000
$control segment=main                                                   11282000
<<***********************************************************>>         11284000
procedure outer'block (parm, info'length, info'address);                11286000
         value   parm, info'length, info'address;                       11288000
         integer parm, info'length, info'address;                       11290000
                                                                        11292000
   << this procedure decides whether the program was run                11294000
      with or without an info paramter.  if it has an                   11296000
      info parameter, store/restore is called with that                 11298000
      string and the program then terminates.  otherwise,               11300000
      it calls store'restore'driver to allow multiple                   11302000
      commands from the user.                                           11304000
                                                                        11306000
      the first action taken by this procedure is to open               11308000
      the message catalog.  this will disappear when the                11310000
      messages for store/restore are put back into the                  11312000
      system message catalog.                           >>              11314000
                                                                        11316000
   begin                                                                11318000
                                                                        11320000
   integer array                                                        11322000
      buf         (0: 170 + 10);                                        11324000
                                                                        11326000
   integer                                                              11328000
      i1;                                                               11330000
                                                                        11332000
   logical                                                              11334000
      wants       := false;   <<"want" flag bits for store/restore>>    11336000
                                                                        11338000
   byte array                                                           11340000
      buf'        (*) = buf (0);                                        11342000
                                                                        11344000
   byte pointer                                                         11346000
      ptr;                                                              11348000
                                                                        11350000
$if x1=on then                <<debugging code>>                        11352000
   if parm < 0 then                                                     11354000
      debugging:=true;                                                  11356000
$if                           <<debugging code>>                        11358000
                                                                        11360000
   parm:=\parm\;                                                        11362000
                                                                        11364000
   if parm = parm'store or parm = parm'restore then            <<lb.rs>>11366000
      want'jcw:=true                                                    11368000
   else if parm <> 0 then                                               11370000
      want'mail:=true;                                                  11372000
                                                                        11374000
$page                                                                   11376000
                                                                        11378000
         <<debugging...open a separate catalog file...>>                11380000
                                                                        11382000
$if x1=on then                <<debugging code>>                        11384000
                                                                        11386000
   ahem;                                                                11388000
                                                                        11390000
   move buf':=store'catalog'title;                                      11392000
   store'catalog:=fopen (buf', 5, %420);                                11394000
   if store'catalog <= 0 then                                           11396000
      begin                                                             11398000
      move buf':=store2'catalog'title;                                  11400000
      store'catalog:=fopen (buf', 5, %420);                             11402000
      end;                                                              11404000
                                                                        11406000
                                                                        11408000
   if store'catalog <= 0 then                                           11410000
      begin                                                             11412000
      say "Failed to open: " endsay;                                    11414000
      say store'catalog'title endsay;                                   11416000
      send;                                                             11418000
      printfileinfo (store'catalog);                                    11420000
      store'catalog:=0;                                                 11422000
      end                                                               11424000
   else                                                                 11426000
      begin                                                             11428000
                                                                        11430000
            <<see if file is mr & nobuf...>>                            11432000
                                                                        11434000
      i1:=0;                                                            11436000
                                                                        11438000
      fgetinfo (store'catalog, , , i1 <<aoptions>>);                    11440000
                                                                        11442000
      if i1.(07:01) = 0 or i1.(11:01) = 0 then                          11444000
         begin    <<either not nobuf or not mr>>                        11446000
         printfileinfo (store'catalog);                                 11448000
         fclose (store'catalog, 0, 0);                                  11450000
         store'catalog:=0;                                              11452000
         say "Bad catalog for STORE/RESTORE: " endsay;                  11454000
         say store'catalog'title endsay;                                11456000
         send;                                                          11458000
         say "Must be opened MR and NOBUF" endsay;                      11460000
         send;                                                          11462000
         end;                                                           11464000
      end;                                                              11466000
                                                                        11468000
   if debugging then                                                    11470000
      begin                                                             11472000
      say "STORE'CATALOG = " endsay;                                    11474000
      saynum (store'catalog);                                           11476000
      send;                                                             11478000
      end;                                                              11480000
$if                                                                     11482000
$page                                                                   11484000
                                                                        11486000
         <<if an info parameter was passed, interpret it and            11488000
           then quit...>>                                               11490000
                                                                        11492000
   if info'length > 0 then                                              11494000
      begin                      <<retrieve info= text...>>             11496000
                                                                        11498000
      @ptr:=info'address;        <<byte pointer at q-5>>                11500000
      move buf':=ptr,(info'length), 2; <<leave dest>>                   11502000
      move *:=(%15);             <<append a carriage return>>           11504000
                                                                        11506000
            <<invoke store or restore...>>                              11508000
                                                                        11510000
      cxstore'restore (buf', 0 <<stdlistnum>>, wants);                  11512000
                                                                        11514000
      end                                                               11516000
   else                                                                 11518000
      store'restore'driver;                                             11520000
                                                                        11522000
   end <<outer'block proc>>;                                            11524000
$control segment=titles                                                 15000000
$page ";TITLES=  PATTERN MATCHING ROUTINES"                             15002000
<< pattern...a pattern matcher that implements a fairly simple          15004000
   pattern matching scheme.  it matches a pattern versus a string       15006000
   of up to 8 characters.  wildcards, and their meanings, are:          15008000
         @        match from 0 to 8 characters.                         15010000
         ?        match any single character.                           15012000
         #        match any single digit (0..9).                        15014000
                                                                        15016000
   written by:  stan sieler   june, 1980                                15018000
                                                                        15020000
note: this source matches the file inclpat.sieler.mpe!                  15022000
                                                                        15024000
-------------------------------------------------------------------     15026000
                                                                        15028000
the following procedures are declared:                                  15030000
                                                                        15032000
      sub'match                                                         15034000
         ... used only by pattern'match.                                15036000
                                                                        15038000
      pattern'build                                                     15040000
         ... used by any user to build a pattern from a text            15042000
             string.  the comments further along in this file           15044000
             document the format of a "pattern".                        15046000
                                                                        15048000
      pattern'build'standard                                            15050000
         ... used by any user to build 3 patterns from a single         15052000
             standard form file title.  the 3 patterns returned         15054000
             are: file part pattern, group part pattern, and            15056000
             account part pattern.                                      15058000
                                                                        15060000
      pattern'match                                                     15062000
         ... used by any user (and by pattern'match'standard) to        15064000
             test a pattern versus a text string for "matching".        15066000
                                                                        15068000
      pattern'match'standard                                            15070000
         ... used by any user to test a set of 3 patterns to a          15072000
             standard form title.  the 3 patterns are: a file           15074000
             part pattern, a group part pattern, and an account         15076000
             part pattern.                                              15078000
>>                                                                      15080000
$page ";TITLES=  PATTERN MATCHER:   SUB'MATCH"                          15082000
$control segment=titles                                                 15084000
<<***************************************************************>>     15086000
logical procedure sub'match (ptext, actuallen, pattern, startpart);     15088000
         value ptext, actuallen, startpart;                             15090000
         integer actuallen, startpart;                                  15092000
         byte pointer ptext;                                            15094000
         integer array pattern;                                         15096000
      <<this routine attempts to match the remaining portion            15098000
        of the pattern versus the remaining portion of the              15100000
        original text.  if the match succeeds, good is                  15102000
        returned, otherwise failed.                                     15104000
        note: it is recursive!>>                                        15106000
   begin                                                                15108000
   integer                                                              15110000
      i,                                                                15112000
      len,                                                              15114000
      minlen,                                                           15116000
      number,                                                  <<04870>>15118000
      part,                                                             15120000
      parts;                                                            15122000
                                                                        15124000
   sub'match:=failed;                                                   15126000
                                                                        15128000
   minlen:=0;                                                           15130000
   parts:=pattern(0);                                                   15132000
   part:=startpart-1;                                                   15134000
                                                                        15136000
         <<determine minimum length that the rest of the                15138000
           pattern must be...>>                                         15140000
                                                                        15142000
   while (part:=part+1) <= parts do                                     15144000
      if (i:=pattern(part)).pattypef <> anycharactersp then             15146000
         minlen:=minlen+i.patlenf;                                      15148000
                                                                        15150000
         <<see if test string has any possible chance of matching       15152000
           pattern...>>                                                 15154000
                                                                        15156000
   if minlen > actuallen then                                           15158000
      return;                 <<failed>>                                15160000
                                                                        15162000
         <<loop thru easy parts, recursing to handle                    15164000
           complex parts ("@")...>>                                     15166000
                                                                        15168000
   part:=startpart-1;                                                   15170000
                                                                        15172000
   while (part:=part+1) <= parts do                                     15174000
      begin                                                             15176000
      i:=pattern(part);                                                 15178000
      len:=i.patlenf;         <<length of this part>>                   15180000
                                                                        15182000
      if (actuallen < len) and i.pattypef <> anycharactersp then        15184000
         return;              <<can't possibly match>>                  15186000
                                                                        15188000
      case i.pattypef of                                                15190000
         begin                                                          15192000
                                                                        15194000
         <<anyonecharacterp:>>                                          15196000
            ;                          <<valid match, by definition!>>  15198000
                                                                        15200000
         <<anycharactersp:>>                                            15202000
            begin                      <<match from 0 to actuallen>>    15204000
            if part = parts then                                        15206000
               begin                                                    15208000
               sub'match:=good;        <<is last part.>>                15210000
               return;                                                  15212000
               end;                                                     15214000
                  <<try matching with 0, 1, ..., actuallen chars...>>   15216000
            len:=actuallen-minlen;                                      15218000
            do                                                          15220000
               if sub'match (ptext(len), actuallen-len,                 15222000
                             pattern, part+1) = good then               15224000
                  begin                                                 15226000
                  sub'match:=good;     <<it worked!>>                   15228000
                  return;                                               15230000
                  end                                                   15232000
            until                                                       15234000
               (len:=len-1) < 0;                                        15236000
            return;                    <<it failed!>>                   15238000
            end;                                                        15240000
                                                                        15242000
         <<digitonlyp:>>                                                15244000
            begin                                                       15246000
            while (len:=len-1) >= 0 do                                  15248000
               if ptext(len) <> numeric then                            15250000
                  return;              <<not a digit!>>                 15252000
            len:=i.patlenf;                                             15254000
                                                               <<04870>>15256000
            if dbstore'tog and (len=2) then                    <<04870>>15258000
               begin                                           <<04870>>15260000
               number := 10 * (ptext-"0") + (ptext(1)-"0");    <<04870>>15262000
               if (number > dbstore'high) or                   <<04870>>15264000
                  (number < dbstore'low) then                  <<04870>>15266000
                     return;                                   <<04870>>15268000
               end;                                            <<04870>>15270000
            end;                                                        15272000
                                                                        15274000
         <<exactp:>>                                                    15276000
            begin                                                       15278000
            while (len:=len-1) >= 0 do                                  15280000
               if integer(ptext(len)) <> i.patcharf then                15282000
                  return;                 <<mismatched!>>               15284000
            len:=i.patlenf;                                             15286000
            end;                                                        15288000
         end;                                                           15290000
                                                                        15292000
      minlen:=minlen-len;              <<subtract # chars matched>>     15294000
      actuallen:=actuallen-len;        <<ditto>>                        15296000
      @ptext:=@ptext(len);             <<point to remainder of text>>   15298000
                                                                        15300000
      end;        <<end of while loop>>                                 15302000
                                                                        15304000
   if actuallen = 0 then                                                15306000
      sub'match:=good;                 <<matched ok!>>                  15308000
                                                                        15310000
   end <<sub'match proc>>;                                              15312000
$page ";TITLES=  PATTERN MATCHER:   PATTERN'BUILD"                      15314000
$control segment=titles                                                 15316000
<<***************************************************************>>     15318000
logical procedure pattern'build (ptext, pattern, error);                15320000
         value ptext;                                                   15322000
         integer error;                                                 15324000
         byte pointer ptext;                                            15326000
         integer array pattern;                                         15328000
      << this routine encodes a "pattern" into a special format for     15330000
        use by the procedure pattern'match.  (see the comment in        15332000
        that procedure for the layout of an encoded "pattern".)         15334000
                                                                        15336000
        this assumes ptext points to a string of 1 to pat'max'firm      15338000
        characters composed of (usually) a..z, a..z, 0..9, and          15340000
        "#?@".  this string is a "pattern".  pat'max'firm is usually    15342000
        8.  the first byte of the text is the length of the text,       15344000
        not self-inclusive.  thus the text "CAT#" would be represented  15346000
        as:  %4, "C", "A", "T", "#".                                    15348000
                                                                        15350000
        note: for compatibility with standard-form titles,              15352000
        only the bottom 7 bits of the length are used...thus,           15354000
        a pointer like:   %(2)10000011, "C", "?", "#"                   15356000
        can be passed into pattern'build without having to              15358000
        zap the wildcard bit.                                           15360000
                                                                        15362000
        if more than pat'max'part parts are found in the pattern text,  15364000
        the routine result will be failed and error will be set         15366000
        to pb'err'many'parts.  pat'max'part is usually 8.               15368000
                                                                        15370000
        if the pattern text contains more than pat'max'firm "firm"      15372000
        characters, a failed will be returned and error will be         15374000
        set to pb'err'many'firm.  pat'max'firm is usually 8.            15376000
        a "firm" character is any character that matches at least       15378000
        1 character (i.e: any character other than "@" is a "firm"      15380000
        character).                                                     15382000
                                                                        15384000
        if no error is found, good is returned and error:=0.            15386000
                                                                        15388000
        pattern must be at least 9 words long, even though a short      15390000
        pattern wont use all 9 words.  pattern is zeroed at the         15392000
        start of the routine.                                           15394000
                                                                        15396000
        note that the pattern text is not shifted to uppercase!         15398000
                                                                  >>    15400000
      <<---------------------------------------------------------->>    15402000
   begin                                                                15404000
                                                                        15406000
   integer                                                              15408000
      i,                                                                15410000
      firmcount   := 0,       <<number of "firm" chars seen>>           15412000
      len,                                                              15414000
      part        := 0,       <<number of parts seen>>                  15416000
      textleft;                                                         15418000
                                                                        15420000
   byte array                                                           15422000
      text'copy'  (0:64);     <<holds a copy of ptext(1...)>>           15424000
                                                                        15426000
   label                                                                15428000
      end'pattern'build;                                                15430000
                                                                        15432000
   <<------------------->>                                              15434000
   subroutine fail (n); value n; integer n;                             15436000
      begin                                                             15438000
      pattern'build:=failed;                                            15440000
      error:=n;                                                         15442000
      go end'pattern'build;                                             15444000
      end <<fail sub>>;                                                 15446000
   <<------------------->>                                              15448000
                                                                        15450000
   error:=0;                                                            15452000
                                                                        15454000
   fill (pattern, pat'max'part + 1, 0);                                 15456000
                                                                        15458000
   textleft:=integer(ptext).(9:7);     <<only use bottom 7 bits>>       15460000
                                                                        15462000
   move text'copy':=ptext(1),(textleft), 2;                             15464000
   move *:=0;                          <<append a stopper>>             15466000
   @ptext:=@text'copy';                                                 15468000
                                                                        15470000
   while textleft > 0 do                                                15472000
      begin                                                             15474000
                                                                        15476000
      part:=part+1;                                                     15478000
      if part > pat'max'part then                                       15480000
         fail (pb'err'many'parts);                                      15482000
                                                                        15484000
      if ptext = "?" then              <<match any 1 character>>        15486000
         begin                <<count number of contiguous "?"...>>     15488000
         scan ptext while "?",1;       <<leave pointer>>                15490000
         len:=tos-logical(@ptext);     <<number of "?">>                15492000
         pattern(part).patlenf := len;                                  15494000
         pattern(part).patcharf:="?";                                   15496000
         pattern(part).pattypef:= anyonecharacterp;                     15498000
         firmcount:=firmcount+len;                                      15500000
         end                                                            15502000
                                                                        15504000
      else if ptext = "#" then         <<match digit>>                  15506000
         begin                <<count number of contiguous "#"...>>     15508000
         scan ptext while "#",1;       <<leave pointer>>                15510000
         len:=tos-logical(@ptext);     <<number of "#">>                15512000
         pattern(part).patlenf := len;                                  15514000
         pattern(part).patcharf:= "#";                                  15516000
         pattern(part).pattypef:= digitonlyp;                           15518000
         firmcount:=firmcount + len;                                    15520000
         end                                                            15522000
                                                                        15524000
      else if ptext = "@" then   <<matches any number of characters>>   15526000
         begin                <<count number of contiguous "@"...>>     15528000
         scan ptext while "@",1;       <<leave pointer>>                15530000
         len:=tos-logical(@ptext);     <<number of "?">>                15532000
         pattern(part).patlenf := len;                                  15534000
         pattern(part).patcharf:="@";                                   15536000
         pattern(part).pattypef:= anycharactersp;                       15538000
         end                                                            15540000
                                                                        15542000
      else                    <<not a pattern match character...>>      15544000
         begin                                                          15546000
         i:=integer(ptext);                                             15548000
         scan ptext while i, 1;                                         15550000
         len:=tos-logical(@ptext);                                      15552000
         pattern(part).patlenf := len;                                  15554000
         pattern(part).patcharf:= integer(ptext);                       15556000
         pattern(part).pattypef:= exactp;                               15558000
         firmcount:=firmcount+len;                                      15560000
         end;                                                           15562000
                                                                        15564000
      if firmcount > pat'max'firm then                                  15566000
         fail (pb'err'many'firm);                                       15568000
                                                                        15570000
      @ptext:=@ptext+len;                                               15572000
      textleft:=textleft-len;                                           15574000
      end;                                                              15576000
                                                                        15578000
   pattern(0):=part;          <<remember how many parts in pattern.>>   15580000
                                                                        15582000
   pattern'build:=good;                                                 15584000
                                                                        15586000
end'pattern'build:                                                      15588000
                                                                        15590000
   end <<pattern'build proc>>;                                          15592000
$page ";TITLES=  PATTERN MATCHER:   PATTERN'BUILD'STANDARD"             15594000
$control segment=titles                                                 15596000
<<***************************************************************>>     15598000
logical procedure pattern'build'standard (pstd, f'pat, g'pat, a'pat,    15600000
                                          error);                       15602000
         value pstd;                                                    15604000
         byte pointer pstd;                                             15606000
         integer array f'pat, g'pat, a'pat;                             15608000
         integer error;                                                 15610000
      <<-------------------------------------------------------->>      15612000
      << this routine takes the file, group, and acct parts from>>      15614000
      << the standard form title pstd and converts them into    >>      15616000
      << three patterns: f'pat, g'pat, and a'pat.  if a part in >>      15618000
      << pstd is empty, its corresponding pattern will be empty.>>      15620000
      << good is returned if all 3 patterns are built ok,       >>      15622000
      << otherwise failed is returned and error is set to 1, 2, >>      15624000
      << or 3 depending on which part failed to parse as a valid>>      15626000
      << pattern (the file=1, group=2, or acct=3).              >>      15628000
      <<-------------------------------------------------------->>      15630000
   begin                                                                15632000
                                                                        15634000
   label                                                                15636000
      end'proc;                                                         15638000
                                                                        15640000
   <<--------------->>                                                  15642000
   subroutine fail (n); value n; integer n;                             15644000
      begin                                                             15646000
      error:=n;                                                         15648000
      pattern'build'standard:=failed;                                   15650000
      go end'proc;                                                      15652000
      end <<fail sub>>;                                                 15654000
   <<--------------->>                                                  15656000
                                                                        15658000
   pattern'build'standard:=good;                                        15660000
                                                                        15662000
   move f'pat:=(0,0);                                                   15664000
   move g'pat:=(0,0);                                                   15666000
   move a'pat:=(0,0);                                                   15668000
   error:=0;                                                            15670000
                                                                        15672000
   if std'file'inx > 0 then                                             15674000
      if pattern'build (pstd(std'file'inx), f'pat, error)               15676000
            = failed then                                               15678000
         fail (1);                                                      15680000
                                                                        15682000
   if std'group'inx > 0 then                                            15684000
      if pattern'build (pstd(std'group'inx), g'pat, error)              15686000
            = failed then                                               15688000
         fail (2);                                                      15690000
                                                                        15692000
   if std'acct'inx > 0 then                                             15694000
      if pattern'build (pstd(std'acct'inx), a'pat, error)               15696000
            = failed then                                               15698000
         fail (3);                                                      15700000
                                                                        15702000
end'proc:                                                               15704000
                                                                        15706000
   end <<pattern'build'standard proc>>;                                 15708000
$page ";TITLES=  PATTERN MATCHER:   PATTERN'MATCH"                      15710000
$control segment=titles                                                 15712000
<<***************************************************************>>     15714000
logical procedure pattern'match (ptext, pattern);                       15716000
         value ptext;                                                   15718000
         byte pointer ptext;                                            15720000
         integer array pattern;                                         15722000
      <<this routine compares the pattern in pattern to the             15724000
        title in ptext.  byte(0) of ptext is the text length            15726000
        (0 to pat'max'firm (usually 8)).  only the bottom 7             15728000
        bits of the length are used...this maintains compatibility      15730000
        with standard-form titles, which may use the eighth bit         15732000
        as a wildcard flag.                                             15734000
                                                                        15736000
        if the text in ptext matches the pattern in pattern,            15738000
        a good is returned, otherwise a failed.                         15740000
                                                                        15742000
        the layout of pattern is:                                       15744000
            pattern (0) = number of parts in the pattern.               15746000
            pattern (1..pattern(0)) = separate pattern parts.           15748000
        each pattern part is a single word (16 bits) that looks         15750000
        like:                                                           15752000
              0  1  2    7  8        15                                 15754000
            +------+------+--+--------+                                 15756000
            ! part ! part ! part      !                                 15758000
            ! type !length! character !                                 15760000
            !      !      !           !                                 15762000
            +------+------+-----------+                                 15764000
        field names:                                                    15766000
             pattypef = (0:2)  patlenf = (2:6)  patcharf = (8:8)        15768000
char:   possible types:          meanings:                              15770000
                                                                        15772000
  ?        anyonecharacterp      match any sequence of patlenf          15774000
                                 characters.                            15776000
                                                                        15778000
  @        anycharactersp        match any number of characters.        15780000
                                 patlenf is disregarded, but happens    15782000
                                 to be the number of contiguous         15784000
                                  "@"'s found in the original           15786000
                                 pattern.                               15788000
                                                                        15790000
  #        digitonlyp            match any sequence of patlenf          15792000
                                 digits.                                15794000
                                                                        15796000
  a..z,    exactp                match the exact ascii character        15798000
  a..z, 0..9, ...                that is found in patlenf field.        15800000
                                                                        15802000
      a pattern text of:  ca?d#@ would be represented as:               15804000
                                                                        15806000
         6, (exactp, 1, "C"), (exactp, 1, "A"),                         15808000
            (anyonecharacterp, 1, "?"), (exactp, 1, "D"),               15810000
            (digitonlyp, 1, "#"), (anycharactersp, 1, "@")              15812000
                                                                        15814000
      a pattern text of:  ??@@aa would be represented as:               15816000
                                                                        15818000
         3, (anyonecharacterp, 2, "?"), (anycharactersp, 2, "@"),       15820000
            (exactp, 2, "A")                                            15822000
                                                                >>      15824000
   <<----------------------------------------------------------->>      15826000
   begin                                                                15828000
                                                                        15830000
   pattern'match:=sub'match (ptext(1),                                  15832000
                             integer(ptext).(9:7),                      15834000
                             pattern, 1);                               15836000
                                                                        15838000
   end <<pattern'match proc>>;                                          15840000
$page ";TITLES=  PATTERN MATCHER:   PATTERN'MATCH'STANDARD"             15842000
$control segment=titles                                                 15844000
<<***************************************************************>>     15846000
logical procedure pattern'match'standard (pstda, file'pat, group'pat,   15848000
                                          acct'pat, error);             15850000
         integer array file'pat, group'pat, acct'pat;                   15852000
         byte array pstda;                                              15854000
         integer error;                                                 15856000
      <<-------------------------------------------------->>            15858000
      << this routine matches the standard-form name found>>            15860000
      << in pstd to the file,group&account patterns found >>            15862000
      << in file'pat, group'pat, acct'pat.   if all match,>>            15864000
      << a good is returned, otherwise a failed will be   >>            15866000
      << returned and the parameter error will be set to  >>            15868000
      << 1 if the file part did not match, 2 if the group >>            15870000
      << part did not match, and 3 if the acct part did   >>            15872000
      << not match.                                       >>            15874000
      <<                                                  >>            15876000
      << if the file (or group (or acct)) part is empty,  >>            15878000
      << (i.e: std'file'inx = 0), then it will only match >>            15880000
      << an empty pattern (i.e: file'pat(0) = 0)          >>            15882000
      <<-------------------------------------------------->>            15884000
   begin                                                                15886000
                                                                        15888000
   integer                                                              15890000
      acctinx,                                                          15892000
      fileinx,                                                          15894000
      groupinx;                                                         15896000
                                                                        15898000
   byte pointer                                                         15900000
      pstd;                                                             15902000
                                                                        15904000
   label                                                                15906000
      proc'exit;                                                        15908000
                                                                        15910000
   <<---------->>                                                       15912000
   subroutine fail (n); value n; integer n;                             15914000
                                                                        15916000
      begin                                                             15918000
                                                                        15920000
      pattern'match'standard:=failed;                                   15922000
                                                                        15924000
      error:=n;                                                         15926000
                                                                        15928000
      go proc'exit;                                                     15930000
                                                                        15932000
      end <<fail sub>>;                                                 15934000
   <<---------->>                                                       15936000
                                                                        15938000
   @pstd:=@pstda;                                                       15940000
                                                                        15942000
   acctinx:= std'acct'inx;                                              15944000
   groupinx:=std'group'inx;                                             15946000
   fileinx:= std'file'inx;                                              15948000
                                                                        15950000
   if fileinx = 0 and file'pat (0) <> 0 then                            15952000
      fail (1);                                                         15954000
                                                                        15956000
   if pattern'match (pstd(fileinx), file'pat) = failed then             15958000
      fail (1);                                                         15960000
                                                                        15962000
   if groupinx = 0 and group'pat(0) <> 0 then                           15964000
      fail (2);                                                         15966000
                                                                        15968000
   if pattern'match (pstd(groupinx), group'pat) = failed then           15970000
      fail (2);                                                         15972000
                                                                        15974000
   if acctinx = 0 and acct'pat(0) <> 0 then                             15976000
      fail (3);                                                         15978000
                                                                        15980000
   if pattern'match (pstd(acctinx), acct'pat) = failed then             15982000
      fail (3);                                                         15984000
                                                                        15986000
   pattern'match'standard:=good;                                        15988000
                                                                        15990000
proc'exit:                                                              15992000
                                                                        15994000
   end <<pattern'match'standard proc>>;                                 15996000
$page ";TITLES=  PATTERN MATCHER:   PATTERN'3'MATCH"                    15998000
$control segment=titles                                                 16000000
<<***************************************************************>>     16002000
logical procedure pattern'3'match (f', g', a', file'pat, group'pat,     16004000
                                          acct'pat, error);             16006000
         integer array file'pat, group'pat, acct'pat;                   16008000
         byte array f', g', a';                                         16010000
         integer error;                                                 16012000
      <<-------------------------------------------------->>            16014000
      << this routine matches the three 8-byte titles in  >>            16016000
      << f', g', and a' to the 3 patterns found in arrays >>            16018000
      << file'pat, group'pat, acct'pat.   if all match,   >>            16020000
      << a good is returned, otherwise a failed will be   >>            16022000
      << returned and the parameter error will be set to  >>            16024000
      << 1 if the file part did not match, 2 if the group >>            16026000
      << part did not match, and 3 if the acct part did   >>            16028000
      << not match.                                       >>            16030000
      <<-------------------------------------------------->>            16032000
   begin                                                                16034000
                                                                        16036000
   integer                                                              16038000
      len;                                                              16040000
                                                                        16042000
   byte array                                                           16044000
      scratch'    (0:pat'max'firm + 1);   <<a file part + 2>>           16046000
                                                                        16048000
   label                                                                16050000
      proc'exit;                                                        16052000
                                                                        16054000
   <<---------->>                                                       16056000
   subroutine fail (n); value n; integer n;                             16058000
                                                                        16060000
      begin                                                             16062000
                                                                        16064000
      pattern'3'match:=failed;                                          16066000
                                                                        16068000
      error:=n;                                                         16070000
                                                                        16072000
      go proc'exit;                                                     16074000
                                                                        16076000
      end <<fail sub>>;                                                 16078000
                                                                        16080000
   <<---------->>                                                       16082000
   subroutine matchit (n, part', pat);                                  16084000
            value      n;                                               16086000
            integer    n;                                               16088000
            byte array    part';                                        16090000
            integer array        pat;                                   16092000
      begin                                                             16094000
                                                                        16096000
      move scratch'(1):=part', (pat'max'firm);                          16098000
                                                                        16100000
      scan scratch'(1) until " ", 1;                                    16102000
      len:=tos-logical(@scratch'(1));                                   16104000
      scratch'(0):=len;       <<'simple' standard form>>                16106000
                                                                        16108000
      if pattern'match (scratch', pat) = failed then                    16110000
         fail (n);                                                      16112000
                                                                        16114000
      end <<matchit sub>>;                                              16116000
   <<----------->>                                                      16118000
                                                                        16120000
   fill' (scratch', pat'max'firm + 2, " ");                             16122000
                                                                        16124000
   matchit (1, f', file'pat);                                           16126000
                                                                        16128000
   matchit (2, g', group'pat);                                          16130000
                                                                        16132000
   matchit (3, a', acct'pat);                                           16134000
                                                                        16136000
   pattern'3'match:=good;                                               16138000
                                                                        16140000
proc'exit:                                                              16142000
                                                                        16144000
   end <<pattern'3'match proc>>;                                        16146000
$page ";TITLES=  STANDARD FORM ROUTINES"                                16148000
<<                                                                      16150000
*******************************************************************     16152000
                                                                        16154000
   standard'to'display  and  display'to'standard                        16156000
                                                                        16158000
   designed and written in 1980 by stan sieler.                         16160000
   enhanced in 1981 by stan sieler.                                     16162000
                                                                        16164000
note: this source matches the file inclstd.sieler.mpe!                  16166000
                                                                        16168000
-------------------------------------------------------------------     16170000
                                                                        16172000
the following procedures are declared in this include file:             16174000
                                                                        16176000
      display'to'standard                                               16178000
         ... this routine converts a display form file title            16180000
         into a standard form title.  this routine documents the        16182000
         format of a standard form title.                               16184000
                                                                        16186000
      display'3'to'standard                                             16188000
         ... this routine converts 3 8-byte arrays (which are           16190000
         a file name, group name, and account name) into a              16192000
         standard form title.                                           16194000
                                                                        16196000
      standard'to'display                                               16198000
         ... this routine converts a standard form title into           16200000
         a display form title.                                          16202000
                                                                        16204000
      standard'to'3'display                                             16206000
         ... this routine converts a standard form title into           16208000
         three 8-byte arrays, which are: file name, group name          16210000
         and account name.                                              16212000
                                                                        16214000
-------------------------------------------------------------------     16216000
>>                                                                      16218000
$page ";TITLES=  STANDARD FORM:   DISPLAY'TO'STANDARD"                  16220000
$control segment=titles                                                 16222000
<<***************************************************************>>     16224000
logical procedure display'to'standard (pdis, pstd, error, char'inx,     16226000
                                       delims', allowed'items);         16228000
            value pdis, pstd, delims', allowed'items;                   16230000
            integer error, char'inx;                                    16232000
            logical allowed'items;                                      16234000
            byte pointer pdis, pstd, delims';                           16236000
            option variable;                                            16238000
   <<this routine converts a display form file title into               16240000
     a standard form file title.  if an error occurs, the error         16242000
     number is reported in error.                                       16244000
     parameters:                                                        16246000
                                                                        16248000
      pdis:  byte pointer, points to a file title (with or              16250000
         without wildcards or group or account.  terminated by          16252000
         a blank!                                                       16254000
         may not be omitted.                                            16256000
                                                                        16258000
      pstd:  byte pointer, will hold standard form title.  as           16260000
         such, must hold at least max'std'len characters!               16262000
         this will be filled with zeroes at start of routine.           16264000
         may not be omitted.                                            16266000
                                                                        16268000
      error: integer, call by reference.                                16270000
         this is initialized to zero at entry.                          16272000
         may not be omitted.                                            16274000
                                                                        16276000
      char'inx: integer, call by reference.                             16278000
         in the event of an error, this is the index of the             16280000
         offending character in pdis.                                   16282000
         in the event of a successful conversion, this is the           16284000
         index of the first character after the file title,             16286000
         presumably the blank that trails it.  it therefore             16288000
         is equivalent to the length of the display form title.         16290000
         may not be omitted.                                            16292000
                                                                        16294000
      delims': byte pointer, call by value.                             16296000
         contains a sequence of characters that are valid to            16298000
         terminate a file title with.  delims' (0) is the count of      16300000
         the number of valid delimiters.  thus, to allow a file title   16302000
         to be delimited by blank, comma, semicolon, or minus, one      16304000
         would use:  move delims':=(%4, " ,;-");   or                   16306000
         (%4, "-; ,").                                                  16308000
         note: this cannot be used to prevent letters/digits/wildcards  16310000
         from being part of a title!                                    16312000
         defaults to:   (%6, "-; ,", %15, 0).                           16314000
                                                                        16316000
      allowed'items: logical, call by value.                            16318000
         contains bits that determine what types of titles are          16320000
         allowed.                                                       16322000
         defaults to: all possibilities allowed except                  16324000
                      imbedded blanks.                                  16326000
                                                                        16328000
   result:                                                              16330000
      failed if an error occurs,                                        16332000
      good if no error.   (good <==> not failed)                        16334000
   -----------------------------------------------------------          16336000
                                                                        16338000
   standard form file title layout:                                     16340000
                                                                        16342000
   byte array:           #bytes  byte index    define to access:        16344000
                                             (using byte pointer        16346000
      +------------------+                    pstd)                     16348000
      ! total length     !    2     0             std'len'total         16350000
      ! (self inclusive) !                                              16352000
      ! (units are bytes)!                                              16354000
      !(note: this field !                                              16356000
      ! is 2 bytes long!)!                                              16358000
      +------------------+                                              16360000
      ! standard-form    !    1     2             std'version           16362000
      ! version          !                                              16364000
      ! (usually = 1)    !                                              16366000
      +------------------+                                              16368000
      ! information byte !    1     3             std'info              16370000
      ! bits: (8..15)    !                                              16372000
      ! 8 = r e s e r v e!  \                                           16374000
      ! 9 = r e s e r v e!   \                                          16376000
      !10 = r e s e r v e!    >   set to 0.                             16378000
      !11 = r e s e r v e!   /                                          16380000
      !12 = r e s e r v e!  /                                           16382000
      !13 = backreference!                        std'backref           16384000
      !14 = dollar       !                        std'dollar            16386000
      !15 = wildcards    !                        std'wild              16388000
      +------------------+                                              16390000
      !index of file part!    1     4             std'file'inx          16392000
      ! in this array    !                                              16394000
      !(if zero, part was!                                              16396000
      !not found)        !                                              16398000
      +------------------+                                              16400000
      !index of lockword !    1     5             std'lock'inx          16402000
      !part in this array!                                              16404000
      +------------------+                                              16406000
      !index of group    !    1     6             std'group'inx         16408000
      !part in this array!                                              16410000
      +------------------+                                              16412000
      !index of acct part!    1     7             std'acct'inx          16414000
      !in this array     !                                              16416000
      +------------------+                                              16418000
      !reserved, := 0    !    1     8             std'host'inx          16420000
      !  (host name)     !                                              16422000
      +------------------+                                              16424000
      !reserved, := 0    !    1     9             std'pv'inx            16426000
      !(private volume   !                                              16428000
      ! (family) name    !                                              16430000
      +------------------+                                              16432000
              ...                                                       16434000
      +------------------+                                              16436000
      ~ dont count on the~                                              16438000
      ~ next part being  ~                                              16440000
      ~ right after the  ~                                              16442000
      ~ above info!!!!   ~                                              16444000
      +------------------+                                              16446000
              ...                                                       16448000
      +------------------+                                              16450000
      ! reserved, := 1   !    1     std'file'inx-1                      16452000
      ! (number of parts !                        std'file'parts        16454000
      ! in file name)    !                                              16456000
      +------------------+                                              16458000
      !file part info:   !    1     std'file'inx  std'file'info         16460000
      !bit 8 = wildcards !                        std'file'wild         16462000
      !bit 9..15= length !                        std'file'len          16464000
      +------------------+                                              16466000
      !file part text... !    0..8  std'file'inx+1                      16468000
      !up to 8 characters!                        std'file'             16470000
      !in length, no fill!                                              16472000
      !characters at end.!                                              16474000
      +------------------+                                              16476000
              ...                                                       16478000
      +------------------+                                              16480000
      ! (second, third...!    0..???                                    16482000
      ! 'nth' file parts !                                              16484000
      ! will follow this !                                              16486000
      ! someday).        !                                              16488000
      +------------------+                                              16490000
              ...                                                       16492000
      +------------------+                                              16494000
      !lock part info:   !    1     std'lock'inx  std'lock'info         16496000
      !bit 8 = wildcards !                        std'lock'wild         16498000
      !bit 9..15= length !                        std'lock'len          16500000
      +------------------+                                              16502000
      !lock part text... !    0..8  std'lock'inx+1                      16504000
      !up to 8 characters!                        std'lock'             16506000
      !in length, no fill!                                              16508000
      !characters at end.!                                              16510000
      +------------------+                                              16512000
              ...                                                       16514000
      +------------------+                                              16516000
      !group part info:  !    1     std'group'inx std'group'info        16518000
      !bit 8 = wildcards !                        std'group'wild        16520000
      !bit 9..15= length !                        std'group'len         16522000
      +------------------+                                              16524000
      !group part text...!    0..8  std'group'inx+1                     16526000
      !up to 8 characters!                        std'group'            16528000
      !in length, no fill!                                              16530000
      !characters at end.!                                              16532000
      +------------------+                                              16534000
              ...                                                       16536000
      +------------------+                                              16538000
      !acct part info:   !    1     std'acct'inx  std'acct'info         16540000
      !bit 8 = wildcards !                        std'acct'wild         16542000
      !bit 9..15= length !                        std'acct'len          16544000
      +------------------+                                              16546000
      !acct part text... !    0..8  std'acct'inx+1                      16548000
      !up to 8 characters!                        std'acct'             16550000
      !in length, no fill!                                              16552000
      !characters at end.!                                              16554000
      +------------------+                                              16556000
              ...                                                       16558000
      ~~~~~~~~~~~~~~~~~~~~                                              16560000
      ~ the following    ~                                              16562000
      ~ two parts are not~                                              16564000
      ~ yet implemented, ~                                              16566000
      ~ but have been    ~                                              16568000
      ~ defined to allow ~                                              16570000
      ~later enhancements~                                              16572000
      ~~~~~~~~~~~~~~~~~~~~                                              16574000
              ...                                                       16576000
      +------------------+                                              16578000
      !family part info: !    1     std'family'inx std'family'info      16580000
      !bit 8 = wildcards !                        std'family'wild       16582000
      !bit 9..15= length !                        std'family'len        16584000
      +------------------+                                              16586000
      !family part text..!    0..8  std'family'inx+1                    16588000
      !up to 8 characters!                        std'family'           16590000
      !in length, no fill!                                              16592000
      !characters at end.!                                              16594000
      +------------------+                                              16596000
              ...                                                       16598000
      +------------------+                                              16600000
      !host part info:   !    1     std'host'inx  std'host'info         16602000
      !bit 8 = wildcards !                        std'host'wild         16604000
      !bit 9..15= length !                        std'host'len          16606000
      +------------------+                                              16608000
      !host part text... !    0..8  std'host'inx+1                      16610000
      !up to 8 characters!                        std'host'             16612000
      !in length, no fill!                                              16614000
      !characters at end.!                                              16616000
      +------------------+                                              16618000
                                                                        16620000
   ----------------------------------------------------------->>        16622000
   begin                                                                16624000
                                                                        16626000
   label                                                                16628000
      xit;                                                              16630000
                                                                        16632000
   byte array                                                           16634000
      default'delims' (0:6),                                            16636000
      dummy'(0:1) = q;                                                  16638000
                                                                        16640000
   logical                                                              16642000
      bitmask     = q - 4,                                              16644000
      char'type   := false,                                             16646000
      default'allowed'items,                                            16648000
      digit       := false,                                             16650000
      done        := false,                                             16652000
      letter      := false,                                             16654000
      wild        := false,                                             16656000
      wild'part   := false;                                             16658000
                                                                        16660000
   integer                                                              16662000
      delim'inx   := 0,   <<used to index through delims'>>             16664000
      part'inx    := 0,   <<index of info for current part>>            16666000
      part'len    := 0,   <<length of current part>>                    16668000
      state       := 0,   <<0, 1, 2, 3: file, lock, group, acct>>       16670000
      total'len   := 0;   <<cumulative length of std title thus far>>   16672000
                                                                        16674000
   byte                                                                 16676000
      char;                                                             16678000
                                                                        16680000
   define                                                               16682000
      state'file  = 0 #,                                                16684000
      state'lock  = 1 #,                                                16686000
      state'group = 2 #,                                                16688000
      state'acct  = 3 #;                                                16690000
                                                                        16692000
   <<---------------------->>                                           16694000
   subroutine err (n); value n; integer n;                              16696000
      begin                                                             16698000
                                                                        16700000
      error:= n;                                                        16702000
      display'to'standard:=failed;                                      16704000
      go xit;                                                           16706000
                                                                        16708000
      end <<err sub>>;                                                  16710000
   <<--------------------->>                                            16712000
   subroutine append'char;                                              16714000
      begin                                                             16716000
                                                                        16718000
            <<see if we can suppress a duplicate "@"...>>               16720000
                                                                        16722000
      if wild and char="@" and part'len > 1 and                         16724000
              pstd(total'len) = "@" then                                16726000
      else                                                              16728000
         begin                         <<nope...can't suppress it...>>  16730000
         total'len:=total'len+1;                                        16732000
         if (part'len:=part'len+1) > 8 then                             16734000
            err (se'part'too'long);       <<part too long>>             16736000
                                                                        16738000
         pstd(total'len):=char;                                         16740000
         end;                                                           16742000
                                                                        16744000
      end <<append'char sub>>;                                          16746000
   <<------------------------->>                                        16748000
   logical subroutine check'delim;                                      16750000
      begin                                                             16752000
                                                                        16754000
      delim'inx:=delims'(0)+1;                                          16756000
                                                                        16758000
      while (delim'inx:=delim'inx-1) > 0 do                             16760000
         if delims'(delim'inx) = char then                              16762000
            begin                                                       16764000
            check'delim:=good;                                          16766000
            return;                                                     16768000
            end;                                                        16770000
                                                                        16772000
      check'delim:=failed;                                              16774000
                                                                        16776000
      end <<check'delim sub>>;                                          16778000
   <<------------------------>>                                         16780000
   subroutine classify'char;                                            16782000
      begin                                                             16784000
                                                                        16786000
      char:=pdis(char'inx);                                             16788000
                                                                        16790000
            <<classify the character...>>                               16792000
                                                                        16794000
      wild:=digit:=letter:=false;                                       16796000
                                                                        16798000
      if char = alpha then                                              16800000
         begin                                                          16802000
         letter:=true;                 <<lowercase a..z>>               16804000
            <<upcase it...>>                                            16806000
         dummy'(0):=char;                                               16808000
         move dummy':=dummy' while as;   <<upshift 1 character>>        16810000
         char:=dummy'(0);                                               16812000
         end                                                            16814000
      else if char = numeric then                                       16816000
         digit:=true                   <<digit from 0..9>>              16818000
      else if char="@" or char="?" or char="#" then                     16820000
         wild:=true;                   <<wildcard>>                     16822000
                                                                        16824000
      end <<classify'char sub>>;                                        16826000
   <<--------------------->>                                            16828000
   subroutine close'part;                                               16830000
      begin                                                             16832000
                                                                        16834000
      if part'len = 0 then                                              16836000
         err (se'zero'part);           <<zero length part>>             16838000
                                                                        16840000
      case state of                                                     16842000
         begin                                                          16844000
                                                                        16846000
         <<state'file:>>                                                16848000
            begin                                                       16850000
            std'file'wild:=wild'part;                                   16852000
            std'file'len:=part'len;                                     16854000
            end;                                                        16856000
                                                                        16858000
         <<state'lock:>>                                                16860000
            begin                                                       16862000
            std'lock'wild:=wild'part;                                   16864000
            std'lock'len:=part'len;                                     16866000
            end;                                                        16868000
                                                                        16870000
         <<state'group:>>                                               16872000
            begin                                                       16874000
            std'group'wild:=wild'part;                                  16876000
            std'group'len:=part'len;                                    16878000
            end;                                                        16880000
                                                                        16882000
         <<state'acct:>>                                                16884000
            begin                                                       16886000
            std'acct'wild:=wild'part;                                   16888000
            std'acct'len:=part'len;                                     16890000
            end                                                         16892000
         end;                                                           16894000
                                                                        16896000
      end <<close'part sub>>;                                           16898000
   <<--------------------->>                                            16900000
   subroutine look'at'char;                                             16902000
      begin                                                             16904000
                                                                        16906000
      if wild then                                                      16908000
         begin                         <<wildcard found>>               16910000
         wild'part:=true;                                               16912000
         std'wild:=true;                                                16914000
                                                                        16916000
         if logical(std'dollar) then                                    16918000
            err (se'wild'and'dollar);  <<wildcard and $>>               16920000
                                                                        16922000
         if logical(std'backref) then                                   16924000
            err (se'wild'and'star);    <<wildcard and *>>               16926000
                                                                        16928000
         if part'len=0 and char="#" then                                16930000
            err (se'first'not'letter); <<first char not letter>>        16932000
         end                                                            16934000
                                                                        16936000
      else if part'len=0 and digit then                                 16938000
         err (se'first'not'letter);    <<first char not letter>>        16940000
                                                                        16942000
      append'char;                                                      16944000
                                                                        16946000
      end <<look'at'char sub>>;                                         16948000
   <<--------------------->>                                            16950000
   subroutine start'part;                                               16952000
      begin                                                             16954000
                                                                        16956000
      part'inx:= (total'len:=total'len+1);                              16958000
                                                                        16960000
      case state of                                                     16962000
         begin                                                          16964000
                                                                        16966000
         <<state'file:>>                                                16968000
            begin                                                       16970000
            pstd(part'inx):=1;                                          16972000
            part'inx:= (total'len:=total'len+1);                        16974000
            std'file'inx:=part'inx;                                     16976000
            end;                                                        16978000
                                                                        16980000
         <<state'lock:>>                                                16982000
            std'lock'inx:=part'inx;                                     16984000
                                                                        16986000
         <<state'group:>>                                               16988000
            std'group'inx:=part'inx;                                    16990000
                                                                        16992000
         <<state'acct:>>                                                16994000
            std'acct'inx:=part'inx;                                     16996000
                                                                        16998000
         end;                                                           17000000
                                                                        17002000
      wild'part:=false;                                                 17004000
      part'len:=0;                                                      17006000
                                                                        17008000
      end <<start'part sub>>;                                           17010000
   <<--------------------->>                                            17012000
                                                                        17014000
   if bitmask.(10:04) <> %17 then                                       17016000
      err (se'missing'parameters);                                      17018000
                                                                        17020000
   if not bitmask.(14:01) then                                          17022000
      begin                                                             17024000
      @delims':=@default'delims';                                       17026000
      move delims':=(%6, " ,;-", %15, 0);                               17028000
      end;                                                              17030000
                                                                        17032000
   default'allowed'items:=%177777;          <<all bits on>>             17034000
                                                                        17036000
   if not bitmask.(15:01) then                                          17038000
      allowed'items:=default'allowed'items;                             17040000
                                                                        17042000
   display'to'standard:=good;                                           17044000
                                                                        17046000
   pstd(0):=0;                                                          17048000
   move pstd(1):=pstd(0),(max'std'len-1);                               17050000
                                                                        17052000
   error:=0;                                                            17054000
   dummy'(1):=0;                                                        17056000
   std'version:=1;            <<this is version 1 of std form>>         17058000
   total'len:=10-1;           <<first available index-1>>               17060000
                                                                        17062000
   state:=state'file;                                                   17064000
                                                                        17066000
   start'part;                                                          17068000
                                                                        17070000
   char'inx:=0;                                                         17072000
                                                                        17074000
   if allowed'items.allow'lead'blank'bit then                           17076000
      while pdis(char'inx) = " " do                                     17078000
         char'inx:=char'inx + 1;                                        17080000
                                                                        17082000
   done:=false;                                                         17084000
                                                                        17086000
   while not done do                                                    17088000
      begin                                                             17090000
                                                                        17092000
            <<setup & classify char...>>                                17094000
                                                                        17096000
      classify'char;                                                    17098000
                                                                        17100000
            <<look at the character...>>                                17102000
                                                                        17104000
      if wild or letter or digit then                                   17106000
         look'at'char                                                   17108000
                                                                        17110000
      else if char = "." or char = "/" then                             17112000
         begin                                                          17114000
         close'part;                   <<close off current part>>       17116000
         if char = "/" then                                             17118000
            if state <> state'file then                                 17120000
               err (se'lockword'loc)   <<bad place for lockword>>       17122000
            else                                                        17124000
               state:=state'lock                                        17126000
         else if state = state'file then                                17128000
            state:=state'group         <<dot moves from file->group>>   17130000
         else if state = state'lock then                                17132000
            state:=state'group         <<dot moves from lock->group>>   17134000
         else if state = state'group then                               17136000
            state:=state'acct          <<dot moves from group->acct>>   17138000
         else                                                           17140000
            err (se'too'many'periods); <<too many periods>>             17142000
         start'part;                   <<setup next part>>              17144000
         end                                                            17146000
                                                                        17148000
      else if char = "*" then                                           17150000
         begin                                                          17152000
         if logical(std'backref) then                                   17154000
            err (se'star'not'first);  <<second "*" we have seen>>       17156000
         std'backref:=true;                                             17158000
         if state <> state'file or part'len <> 0 or                     17160000
               logical(std'dollar) then                                 17162000
            err (se'star'not'first);   <<"*" must be first char>>       17164000
         end                                                            17166000
                                                                        17168000
      else if char = "$" then                                           17170000
         begin                                                          17172000
         if logical(std'dollar) then                                    17174000
            err (se'dollar'not'first); <<second $ we have seen>>        17176000
         std'dollar:=true;                                              17178000
         if state <> state'file or part'len <> 0 or                     17180000
               logical(std'backref) then                                17182000
            err (se'dollar'not'first); <<"$" must be first char>>       17184000
         end                                                            17186000
                                                                        17188000
      else if check'delim = good then                                   17190000
         done:=true                                                     17192000
                                                                        17194000
      else                                                              17196000
         err (se'illegal'character);   <<invalid title character>>      17198000
                                                                        17200000
      if not done then                                                  17202000
         char'inx:=char'inx+1;                                          17204000
                                                                        17206000
      end;                                                              17208000
                                                                        17210000
   close'part;                                                          17212000
                                                                        17214000
   total'len:=total'len+1;                                              17216000
   pstd(0):=total'len.(0:8);                                            17218000
   pstd(1):=total'len.(8:8);                                            17220000
                                                                        17222000
         <<we now have a valid title...see if the user supplied         17224000
           any portions that the programmer did not want...>>           17226000
                                                                        17228000
   if allowed'items <> default'allowed'items then                       17230000
      begin                                                             17232000
                                                                        17234000
      if not allowed'items.allow'backref'bit then                       17236000
         if std'backref = 1 then                                        17238000
            err (se'found'backref);                                     17240000
                                                                        17242000
      if not allowed'items.allow'dollar'bit  then                       17244000
         if std'dollar = 1 then                                         17246000
            err (se'found'dollar);                                      17248000
                                                                        17250000
      if not allowed'items.allow'wild'bit    then                       17252000
         if std'wild = 1 then                                           17254000
            err (se'found'wild);                                        17256000
                                                                        17258000
      if not allowed'items.allow'multi'file'parts'bit  then             17260000
         if std'file'parts > 1 then                                     17262000
            err (se'found'multi);                                       17264000
                                                                        17266000
      if not allowed'items.allow'lock'bit    then                       17268000
         if std'lock'inx > 0 then                                       17270000
            err (se'found'lock);                                        17272000
                                                                        17274000
      if not allowed'items.allow'group'bit   then                       17276000
         if std'group'inx > 0 then                                      17278000
            err (se'found'group);                                       17280000
                                                                        17282000
      if not allowed'items.allow'acct'bit    then                       17284000
         if std'acct'inx > 0 then                                       17286000
            err (se'found'acct);                                        17288000
                                                                        17290000
      if not allowed'items.allow'family'bit  then                       17292000
         if std'family'inx > 0 then                                     17294000
            err (se'found'family);                                      17296000
                                                                        17298000
      if not allowed'items.allow'host'bit    then                       17300000
         if std'host'inx > 0 then                                       17302000
            err (se'found'host);                                        17304000
      end;                                                              17306000
                                                                        17308000
xit:                                                                    17310000
                                                                        17312000
   end <<display'to'standard proc>>;                                    17314000
$page ";TITLES=  STANDARD FORM:   DISPLAY'3'TO'STANDARD"                17316000
$control segment=titles                                                 17318000
<<***************************************************************>>     17320000
logical procedure display'3'to'standard (f', g', a',                    17322000
                                         pstd, error);                  17324000
            value pstd;                                                 17326000
            integer error;                                              17328000
            byte pointer pstd;                                          17330000
            byte array f', g', a';                                      17332000
   <<this routine converts a display form file title into               17334000
     a standard form file title.  if an error occurs, the error         17336000
     number is reported in error.                                       17338000
     parameters:                                                        17340000
                                                                        17342000
      f', g', a': byte arrays.                                          17344000
         these hold the file, group, and account parts ... up to        17346000
         8 bytes each, blank filled.  a part exactly 8 bytes long       17348000
         will not have a blank at the end.                              17350000
                                                                        17352000
      pstd:  byte pointer, will hold standard form title.  as           17354000
         such, must hold at least max'std'len characters!               17356000
         this will be filled with zeroes at start of routine.           17358000
                                                                        17360000
      error: integer, call by reference.                                17362000
         this is initialized to zero at entry.                  >>      17364000
      <<-------------------------------------------------------->>      17366000
   begin                                                                17368000
                                                                        17370000
   integer                                                              17372000
      char'inx,                                                         17374000
      error1,                                                           17376000
      len;                                                              17378000
                                                                        17380000
   byte array                                                           17382000
      delims'      (0:1),                                               17384000
      pdis        (0:max'title'len+1),                                  17386000
      temp        (0:8);                                                17388000
                                                                        17390000
   byte pointer                                                         17392000
      p;                                                                17394000
                                                                        17396000
   <<-------------------->>                                             17398000
   subroutine append (part', tail);                                     17400000
            value tail;                                                 17402000
            byte array part';                                           17404000
            byte tail;                                                  17406000
      begin                                                             17408000
                                                                        17410000
      move temp:=part',(8);                                             17412000
      scan temp until "  ",1;          <<leave dest pointer>>           17414000
      len:=tos-logical(@temp);         <<number of non-blanks>>         17416000
      move p:=temp,(len),2;            <<leave new p>>                  17418000
      @p:=tos;                                                          17420000
      p:=tail;                                                          17422000
      @p:=@p+1;                                                         17424000
                                                                        17426000
      end <<append sub>>;                                               17428000
   <<---------------------->>                                           17430000
                                                                        17432000
   move delims':=(1, " ");                                              17434000
   temp(8):=" ";                                                        17436000
                                                                        17438000
         <<place file.group.acct in pdis...>>                           17440000
                                                                        17442000
   @p:=@pdis;                                                           17444000
   append (f', ".");                                                    17446000
   append (g', ".");                                                    17448000
   append (a', " ");                                                    17450000
                                                                        17452000
   display'3'to'standard := display'to'standard (pdis, pstd, error,     17454000
                                                 char'inx, delims');    17456000
                                                                        17458000
   end <<display'3'to'standard proc>>;                                  17460000
$page ";TITLES=  STANDARD FORM:   STANDARD'TO'DISPLAY"                  17462000
$control segment=titles                                                 17464000
<<***************************************************************>>     17466000
logical procedure standard'to'display (pstd, pdis, error, len);         17468000
            value pstd, pdis;                                           17470000
            integer error, len;                                         17472000
            byte pointer pstd, pdis;                                    17474000
   begin                                                                17476000
   integer                                                              17478000
      part'len;                                                         17480000
   label                                                                17482000
      xit;                                                              17484000
   <<------------------>>                                               17486000
   subroutine err (n); value n; integer n;                              17488000
      begin                                                             17490000
                                                                        17492000
      error:=n;                                                         17494000
      standard'to'display:=failed;                                      17496000
      go xit;                                                           17498000
                                                                        17500000
      end <<err sub>>;                                                  17502000
   <<------------------->>                                              17504000
   subroutine append'char (char); value char; byte char;                17506000
      begin                                                             17508000
                                                                        17510000
      pdis(len):=char;                                                  17512000
      len:=len+1;                                                       17514000
      if len > max'title'len then                                       17516000
         err (de'standard'too'long);                                    17518000
                                                                        17520000
      end <<append'char sub>>;                                          17522000
   <<------------------>>                                               17524000
   subroutine append'part (char, inx); value char, inx;                 17526000
            byte char;                                                  17528000
            integer inx;                                                17530000
      begin                                                             17532000
                                                                        17534000
      if char <> " " then                                               17536000
         append'char (char);                                            17538000
                                                                        17540000
      part'len:=pstd(inx).std'part'lenf;                                17542000
      while part'len > 0 do                                             17544000
         begin                                                          17546000
         inx:=inx+1;                                                    17548000
         part'len:=part'len-1;                                          17550000
         append'char (pstd(inx));                                       17552000
         end;                                                           17554000
                                                                        17556000
      end <<append'part sub>>;                                          17558000
   <<---------------------->>                                           17560000
                                                                        17562000
   error:=0;                                                            17564000
                                                                        17566000
   len:=0;                                                              17568000
                                                                        17570000
   if logical(std'backref) then                                         17572000
      append'char ("*")                                                 17574000
   else if logical(std'dollar) then                                     17576000
      append'char ("$");                                                17578000
                                                                        17580000
   if std'file'inx = 0 then                                             17582000
      err (de'standard'empty)                                           17584000
   else                                                                 17586000
      append'part (" ", std'file'inx);                                  17588000
                                                                        17590000
   if std'lock'inx > 0 then                                             17592000
      append'part ("/", std'lock'inx);                                  17594000
                                                                        17596000
   if std'group'inx > 0 then                                            17598000
      append'part (".", std'group'inx);                                 17600000
                                                                        17602000
   if std'acct'inx > 0 then                                             17604000
      append'part (".", std'acct'inx);                                  17606000
                                                                        17608000
   append'char (" ");                                                   17610000
   len:=len-1;                <<dont count trailing blank>>             17612000
                                                                        17614000
   standard'to'display := good;                                         17616000
                                                                        17618000
xit:                                                                    17620000
                                                                        17622000
   end <<standard'to'display proc>>;                                    17624000
$page ";TITLES=  STANDARD FORM:   STANDARD'TO'3'DISPLAY"                17626000
$control segment=titles                                                 17628000
<<***************************************************************>>     17630000
logical procedure standard'to'3'display (pstd, f', g', a', error);      17632000
         value pstd;                                                    17634000
         integer error;                                                 17636000
         byte pointer pstd;                                             17638000
         byte array f', g', a';                                         17640000
   begin                                                                17642000
                                                                        17644000
   integer                                                              17646000
      len;                                                              17648000
                                                                        17650000
   equate                                                               17652000
      max'part'len = 8;                                                 17654000
                                                                        17656000
   label                                                                17658000
      proc'exit;                                                        17660000
                                                                        17662000
   <<-------------->>                                                   17664000
   subroutine fail (n); value n; integer n;                             17666000
                                                                        17668000
      begin                                                             17670000
                                                                        17672000
      standard'to'3'display:=failed;                                    17674000
                                                                        17676000
      error:=n;                                                         17678000
                                                                        17680000
      go proc'exit;                                                     17682000
                                                                        17684000
      end <<fail sub>>;                                                 17686000
   <<-------------->>                                                   17688000
                                                                        17690000
   error:=0;                                                            17692000
   move f':="        ";                                                 17694000
   move g':=f',(8);                                                     17696000
   move a':=f',(8);                                                     17698000
                                                                        17700000
   if std'file'inx > 0 then                                             17702000
      if (len:=std'file'len) > max'part'len then                        17704000
         fail (de'standard'too'long)                                    17706000
      else                                                              17708000
         move f':=std'file',(len);                                      17710000
                                                                        17712000
   if std'group'inx > 0 then                                            17714000
      if (len:=std'group'len) > max'part'len then                       17716000
         fail (de'standard'too'long)                                    17718000
      else                                                              17720000
         move g':=std'group',(len);                                     17722000
                                                                        17724000
   if std'acct'inx > 0 then                                             17726000
      if (len:=std'acct'len) > max'part'len then                        17728000
         fail (de'standard'too'long)                                    17730000
      else                                                              17732000
         move a':=std'acct',(len);                                      17734000
                                                                        17736000
   standard'to'3'display:=good;                                         17738000
                                                                        17740000
proc'exit:                                                              17742000
                                                                        17744000
   end <<standard'to'3'display proc>>;                                  17746000
$page ";STORMISC=  CALL'SUDDENDEATH"                                    20000000
$control segment=stormisc                                               20002000
<<****************************************************************>>    20004000
procedure call'suddendeath (err);                                       20006000
         value err;                                                     20008000
         integer err;                                                   20010000
         option uncallable;                                             20012000
   begin                                                                20014000
                                                                        20016000
   intrinsic                                                            20018000
      terminate;                                                        20020000
                                                                        20022000
                                                                        20024000
   error'code:=err;                                                     20026000
                                                                        20028000
   if storing then                                                      20030000
      sendmessage (sr'suddendeath)                                      20032000
   else                                                                 20034000
      sendmessage (rs'suddendeath);                                     20036000
                                                                        20038000
   terminate;                                                           20040000
                                                                        20042000
   end <<call'suddendeath proc>>;                                       20044000
$page ";STORMISC=  CHECK'STORE'RESTORE'LABEL"                           20046000
$control segment=stormisc                                               20048000
<<***************************************************************>>     20050000
logical procedure check'store'restore'label;                            20052000
         option uncallable;                                             20054000
                                                                        20056000
         <<--------------------------------------------------->>        20058000
         << this routine is called to determine if the tape is          20060000
            a valid store/restore tape.  the acceptable format          20062000
            is:                                                         20064000
                                                                        20066000
                  [misc]                                                20068000
                  eof                                                   20070000
                  [misc]                                                20072000
                  eof                                                   20074000
                  store/restore label-hp/3000.                          20076000
                     (note: the above text occupies words               20078000
                      0 thru 13 of the first record after the           20080000
                      second eof!)                                      20082000
                                                                        20084000
            after the "." in the above text, one of the                 20086000
            following 3 things may follow:                              20088000
                                                                        20090000
            version#  text       meaning                                20092000
            -------- -------  ---------------                           20094000
                                                                        20096000
               3     "VIIB+"  --> indicates a s/r tape of vintage       20098000
                                  mpe-iv (e mit) thru ...?              20100000
               2     "VIIB"   --> indicates a s/r tape of vintage       20102000
                                  mpe2b thru mpe-iv (d mit)             20104000
               1     other    --> indicates a pre-mpe2b s/r tape.       20106000
            -------------------------------------------------->>        20108000
   begin                                                                20110000
                                                                        20112000
                                                                        20114000
   integer                                                              20116000
      len         := 0;       <<length of data read>>                   20118000
                                                                        20120000
   logical                                                              20122000
      do'fread    := false;                                             20124000
                                                                        20126000
   label                                                                20128000
      end'check'store'restore'label;                                    20130000
                                                                        20132000
   <<-------->>                                                         20134000
   <<  fail  >>                                                         20136000
   <<-------->>                                                         20138000
                                                                        20140000
   subroutine fail (n);                                                 20142000
            value   n;                                                  20144000
            integer n;                                                  20146000
      begin                                                             20148000
                                                                        20150000
      check'store'restore'label:=failed;                                20152000
                                                                        20154000
      if n <> 0 then                                                    20156000
         sendmessage (n);                                               20158000
                                                                        20160000
      go end'check'store'restore'label;                                 20162000
                                                                        20164000
      end <<fail sub>>;                                                 20166000
                                                                        20168000
   <<------------->>                                                    20170000
   <<  file'fail  >>                                                    20172000
   <<------------->>                                                    20174000
                                                                        20176000
   subroutine file'fail (fid, n);                                       20178000
            value        fid, n;                                        20180000
            integer      fid, n;                                        20182000
      begin                                                             20184000
                                                                        20186000
      parms'tempi'1 := error'code;                             <<lb.rs>>20187800
                                                               <<lb.rs>>20187900
      if fid = t'num and using'attio then                      <<lb.rs>>20188000
         sendmessage (rs'attio'error)                          <<lb.rs>>20188200
      else                                                     <<lb.rs>>20188300
         print'file'error (fid);                               <<lb.rs>>20188400
                                                               <<lb.rs>>20188500
                                                                        20190000
      fail (n);                                                         20192000
                                                                        20194000
      end <<file'fail sub>>;                                            20196000
                                                                        20198000
   <<----------------->>                                                20200000
                                                                        20202000
   check'store'restore'label:=good;                                     20204000
   tape'version:=version'2;                                             20206000
                                                                        20208000
$if x1=on then                <<debugging code>>                        20210000
   if debugging then                                                    20212000
      begin                                                             20214000
      say "STARTED CHECK'STORE'RESTORE'LABEL" endsay;                   20216000
      send;                                                             20218000
      end;                                                              20220000
$if                           <<debugging code>>                        20222000
                                                                        20224000
         << (position tape) read s/r label...>>                         20226000
                                                                        20228000
   if labeled then                                                      20230000
      begin                                                             20232000
$if x1=on then                                                          20234000
      if debug'lab'tape then                                            20236000
         begin                                                          20238000
         say "ABOUT TO DO LRELSW IN CHECK'STORE'RESTORE'LABEL" endsay;  20240000
         send;                                                          20242000
         end;                                                           20244000
$if                                                                     20246000
      lrelsw (t'num);       <<turn on store tape flag>>                 20248000
      len:=tape'label'size;                                             20250000
$if x1=on then                                                          20252000
      if debug'lab'tape then                                            20254000
         begin                                                          20256000
         say "ABOUT TO DO FREADLABEL IN CHECK'STORE'RESTORE" endsay;    20258000
         send;                                                          20260000
         end;                                                           20262000
$if                                                                     20264000
      freadlabel (t'num, tape'label, tape'label'size);                  20266000
      if < then                                                         20268000
         file'fail (t'num, rs't'read'sr'label);                         20270000
      end                                                               20272000
                                                                        20274000
   else                                                                 20276000
      begin                                                             20278000
         issue'read (tape'label, tape'label'size + 1, true);   <<lb.rs>>20280000
         len := read'tape'len;                                 <<lb.rs>>20281000
                                                               <<lb.rs>>20282000
         if error'code <> 0 then                               <<lb.rs>>20284000
            file'fail (t'num, rs't'read'sr'label);             <<lb.rs>>20286000
                                                               <<lb.rs>>20287000
         if read'tape'eof then                                 <<lb.rs>>20288000
            begin                                                       20290000
$if x1=on then                <<debugging code>>                        20292000
            if debugging then                                           20294000
               begin                                                    20296000
               say "PROBABLY FIRST REEL OF STORE - FSF1 ALREADY DONE"   20298000
                                                             endsay;    20300000
               send;                                                    20302000
               say "FSF2" endsay;                                       20304000
               send;                                                    20306000
               end;                                                     20308000
$if                           <<debugging code>>                        20310000
               reel'1'mounted := true;                                  20312000
               issue'skip (true);                              <<lb.rs>>20314000
               if error'code <> 0 then                         <<lb.rs>>20315000
                  file'fail (t'num, rs't'fsf'fail);            <<lb.rs>>20316000
               do'fread := true;                                        20318000
            end                                                         20320000
         else if len <> tape'label'size then                            20322000
            begin                                                       20324000
$if x1=on then                <<debugging code>>                        20326000
            if debugging then                                           20328000
               begin                                                    20330000
               say "SYSDUMP TAPE - FSF1" endsay;                        20332000
               send;                                                    20334000
               end;                                                     20336000
$if                           <<debugging code>>                        20338000
               reel'1'mounted := true;                                  20340000
               issue'skip (true);                              <<lb.rs>>20342000
               if error'code <> 0 then                         <<lb.rs>>20343000
                  file'fail (t'num, rs't'fsf'fail);            <<lb.rs>>20344000
$if x1=on then                <<debugging code>>                        20346000
               if debugging then                                        20348000
                  begin                                                 20350000
                  say "FSF2" endsay;                                    20352000
                  send;                                                 20354000
                  end;                                                  20356000
$if                           <<debugging code>>                        20358000
               issue'skip (true);                              <<lb.rs>>20360000
               if error'code <> 0 then                         <<lb.rs>>20361000
                  file'fail (t'num, rs't'fsf'fail);            <<lb.rs>>20362000
               do'fread := true;                                        20364000
            end;                                                        20366000
         if do'fread then                                               20368000
            begin                                                       20370000
               issue'read (tape'label,tape'label'size+1,true); <<lb.rs>>20372000
               len := read'tape'len;                           <<lb.rs>>20373000
                                                               <<lb.rs>>20374000
               if error'code <> 0 then                         <<lb.rs>>20376000
                  file'fail (t'num, rs't'read'sr'label);       <<lb.rs>>20378000
                                                               <<lb.rs>>20379000
                                                                        20380000
               if read'tape'eof then                           <<lb.rs>>20382000
                  fail (rs't'got'eof'not'sr'label);            <<lb.rs>>20384000
            end;                                                        20386000
$if x1=on then                <<debugging code>>                        20388000
      if debugging then                                                 20390000
         begin                                                          20392000
         say "   READ LEN=" endsay;                                     20394000
         saynum (len);                                                  20396000
         say ", TEXT = " endsay;                                        20398000
         send;                                                          20400000
         say tape'label',(len) endsay;                                  20402000
         send;                                                          20404000
         end;                                                           20406000
$if                           <<debugging code>>                        20408000
      if len <> tape'label'size then                                    20410000
         fail (rs't'bad'sr'label'recsize);                              20412000
      end;                                                              20414000
                                                                        20416000
                                                                        20418000
   if tape'label' <> labeltext then                                     20420000
      fail (rs't'not'sr'label);                                         20422000
                                                                        20424000
   if tl'iibid' = "VIIB+" then                                          20426000
      tape'version:=version'3                                           20428000
   else if tl'iibid' = "VIIB" then                                      20430000
      tape'version:=version'2                                           20432000
   else                                                                 20434000
      tape'version:=version'1;                                          20436000
                                                                        20438000
   << for labeled tapes, if the first file is a continuation of >>      20440000
   << a file started on the last reel, then that file preceeds  >>      20442000
   << the directory.  we must skip it.                          >>      20444000
   if labeled and (tl'reelnum <> 1) and (tl'spantog) then               20446000
      if nexttapefile(t'num) <> 0 then                                  20448000
         fail (rs't'read'sr'label);                                     20450000
                                                                        20452000
$if x1=on then                <<debugging code>>                        20454000
   if debugging then                                                    20456000
      begin                                                             20458000
      say "Version = " endsay;                                          20460000
      saynum (tape'version);                                            20462000
      send;                                                             20464000
      end;                                                              20466000
$if                           <<debugging code>>                        20468000
                                                                        20470000
end'check'store'restore'label:                                          20472000
                                                                        20474000
$if x1=on then                <<debugging code>>                        20476000
   if debugging then                                                    20478000
      begin                                                             20480000
      say "END CHECK'STORE'RESTORE'LABEL" endsay;                       20482000
      send;                                                             20484000
      end;                                                              20486000
$if                           <<debugging code>>                        20488000
                                                                        20490000
   end <<check'store'restore'label proc>>;                              20492000
$page ";SECURITY=  CHECK'VALID'ACCT ... VALIDATES AN ACCOUNT"           20494000
$page ";STORMISC=  CHECKSUM"                                            20496000
$control segment=stormisc                                               20498000
<<***************************************************************>>     20500000
logical procedure checksum (buffer, len);                               20502000
         value   len;                                                   20504000
         integer len;                                                   20506000
         logical array buffer;                                          20508000
         option uncallable;                                             20510000
   begin                                                                20512000
                                                                        20514000
   logical                                                              20516000
      temp'checksum := -1;                                              20518000
                                                                        20520000
   while (len:=len-1) >= 0 do                                           20522000
      temp'checksum:=temp'checksum xor buffer(len);                     20524000
                                                                        20526000
   checksum:=temp'checksum;                                             20528000
                                                                        20530000
   end <<checksum proc>>;                                               20532000
$page ";STORMISC=  CLOSE'FILES"                                         20534000
$control segment=stormisc                                               20536000
<<***************************************************************>>     20538000
procedure close'files (noshut);                                         20540000
         value                noshut;                                   20542000
         integer              noshut;                                   20544000
      <<close all files if they are open except for the one             20546000
        specified by noshut.   >>                                       20548000
   begin                                                                20550000
                                                                        20552000
                                                                        20554000
   if candidat <> 0 and candidat <> noshut then                         20556000
      fclose (candidat, 0, 0);                                          20558000
                                                                        20560000
   if e'num <> 0 and e'num <> noshut then                               20562000
         fclose (e'num, 0, 0);                                          20564000
                                                                        20566000
   if g'num <> 0 and g'num <> noshut then                               20568000
      fclose (g'num, 0, 0);                                             20570000
                                                                        20572000
   if i'num <> 0 and i'num <> noshut then                               20574000
      fclose (i'num, 0, 0);                                             20576000
                                                                        20578000
   if offline'num <> 0 and offline'num <> noshut then                   20580000
      fclose (offline'num, 0, 0);                                       20582000
                                                                        20584000
   if syslist'num <> 0 and syslist'num <> noshut                        20586000
            and syslist'num <> 2                                        20588000
            and not syslist'supplied then                               20590000
      fclose (syslist'num, 0, 0);                                       20592000
                                                                        20594000
   if t'num <> 0 and t'num <> noshut then                               20596000
      fclose (t'num, tape'close'disp ,0);                      <<04726>>20598000
                                                                        20600000
   if d'num <> 0 and d'num <> noshut then                               20602000
      fclose (d'num, 0, 0);                                             20604000
                                                                        20606000
   end <<close'files proc>>;                                            20608000
$page ";STORMISC=  CONVERT'SE'TO'CIERR --- STANDARD FORM ERRORS"        20610000
$control segment=stormisc                                               20612000
<<***************************************************************>>     20614000
integer procedure convert'se'to'cierr (error);                          20616000
         value error;                                                   20618000
         integer error;                                                 20620000
         option uncallable;                                             20622000
   begin                                                                20624000
         <<converts the std'se'... error number to the equivalent       20626000
           ci error number>>                                            20628000
                                                                        20630000
$if x1=on then                <<debugging code>>                        20632000
   if debugging then                                                    20634000
      begin                                                             20636000
      say "CONVERT'SE'TO'CIERR (" endsay;                               20638000
      saynum (error);                                                   20640000
      say ") --> " endsay;                                              20642000
      end;                                                              20644000
$if                           <<debugging code>>                        20646000
                                                                        20648000
   error:=sr'sd'error'base + error;                                     20650000
                                                                        20652000
$if x1=on then                <<debugging code>>                        20654000
   if debugging then                                                    20656000
      begin                                                             20658000
      saynum (error);                                                   20660000
      send;                                                             20662000
      end;                                                              20664000
$if                           <<debugging code>>                        20666000
                                                                        20668000
   convert'se'to'cierr := error;                                        20670000
                                                                        20672000
   end <<convert'se'to'cierr proc>>;                                    20674000
$page ";STORMISC=  DIRECTORYSEARCH --- SEARCHES DIRECTORY TREE"         20676000
$control segment=stormisc                                               20678000
<<***************************************************************>>     20680000
logical procedure directorysearch (thunk);                              20682000
         logical procedure thunk;                                       20684000
         option uncallable;                                             20686000
      <<assumes that a file title is in look'title' (standard           20688000
        form, with a group & account part always specified!!).          20690000
        calls produceparms to get the correct starting indices          20692000
        that direcscan requires.  note that all parameters have         20694000
        already been parsed by the time this routine is called.>>       20696000
   begin                                                                20698000
                                                                        20700000
                                                                        20702000
   double                                                               20704000
      dr;                                                               20706000
                                                                        20708000
   integer array                                                        20710000
      ppresult    (0:ppr'len);                                          20712000
                                                                        20714000
   integer                                                              20716000
      dr'1        = dr+0,                                               20718000
      dr'2        = dr+1,                                               20720000
      err         := 0,       <<used for s->d, d->s>>                   20722000
      i,                                                                20724000
      j,                                                                20726000
      len,                                                              20728000
      mvtabx:=0,                                                        20730000
      type;                                                             20732000
                                                                        20734000
   byte array                                                           20736000
      fileset'    (0:max'title'len+2),                                  20738000
      ppresult'   (*) = ppresult (0),                                   20740000
      scratch'    (0:63);                                               20742000
                                                                        20744000
   byte pointer                                                         20746000
      delim,                                                            20748000
      pp,                                                               20750000
      pstd;                                                             20752000
                                                                        20754000
   label                                                                20756000
      end'directorysearch;                                              20758000
                                                                        20760000
   <<----------------------------->>                                    20762000
   <<  fail                       >>                                    20764000
   <<----------------------------->>                                    20766000
                                                                        20768000
   subroutine fail (n);                                                 20770000
            value n;                                                    20772000
            integer n;                                                  20774000
      begin                                                             20776000
                                                                        20778000
      directorysearch:=failed;                                          20780000
                                                                        20782000
      if n <> 0 then                                                    20784000
         begin                                                          20786000
         sendmessage (n);                                               20788000
         sendmessage (sr'warn'directorysearch'err);                     20790000
         end;                                                           20792000
                                                                        20794000
$if x1=on then                <<debugging code>>                        20796000
      if debugging then                                                 20798000
         begin                                                          20800000
         say "DIRECTORYSEARCH FAIL # " endsay;                          20802000
         saynum (n);                                                    20804000
         send;                                                          20806000
         end;                                                           20808000
$if                           <<debugging code>>                        20810000
                                                                        20812000
      go end'directorysearch;                                           20814000
                                                                        20816000
      end <<fail sub>>;                                                 20818000
                                                                        20820000
   <<----------------------------->>                                    20822000
   << initialize'directorysearch  >>                                    20824000
   <<----------------------------->>                                    20826000
                                                                        20828000
   subroutine initialize'directorysearch;                               20830000
      begin                                                             20832000
                                                                        20834000
      directorysearch:=good;                                            20836000
                                                                        20838000
            <<initialize some variables...>>                            20840000
                                                                        20842000
      mounted'volume'info := 0;                                         20844000
      sp'pv := 0;                                                       20846000
      @delim:=@scratch';                                                20848000
      @pstd:=@look'title';                                              20850000
                                                                        20852000
            <<and some arrays...>>                                      20854000
                                                                        20856000
      fill' (scratch', 32, " ");                                        20858000
      fill (ppresult, ppr'len+1, 0);                                    20860000
                                                                        20862000
                                                                        20864000
$if x1=on then                <<debugging code>>                        20866000
      if debugging then                                                 20868000
         begin                                                          20870000
         say "ENTERED DIRECTORYSEARCH"endsay;                           20872000
         send;                                                          20874000
         end;                                                           20876000
$if                           <<debugging code>>                        20878000
                                                                        20880000
            <<set up look'file, look'group,  and look'acct              20882000
              for direcscan...look'lock already setup     >>            20884000
                                                                        20886000
            <<convert the standard form title in look'title'            20888000
              into 3 file'part'size byte arrays....>>                   20890000
                                                                        20892000
      standard'to'3'display (look'title',                               20894000
            look'file', look'group', look'acct', err);                  20896000
                                                                        20898000
      if look'acct' = " " then                                          20900000
         move curr'acct':=logon'acct',(file'part'size)                  20902000
      else                                                              20904000
         move curr'acct':=look'acct',(file'part'size);                  20906000
                                                                        20908000
      if look'group = " " then                                          20910000
         move curr'group':=logon'group',(file'part'size)                20912000
      else                                                              20914000
         move curr'group':=look'group',(file'part'size);                20916000
                                                                        20918000
      move curr'file':=look'file',(file'part'size);                     20920000
                                                                        20922000
            <<convert curr'file, 'group, 'acct into std form...>>       20924000
                                                                        20926000
      display'3'to'standard (curr'file', curr'group', curr'acct',       20928000
                             curr'title', error'code);                  20930000
                                                                        20932000
            <<setup fileset' for produceparms...>>                      20934000
                                                                        20936000
      if standard'to'display (look'title', fileset', error'code, len)   20938000
            = failed then                                               20940000
         fail (sr's'2'd'failed);                                        20942000
                                                                        20944000
      move fileset'(len):=(";",%15);                                    20946000
                                                                        20948000
      end <<initialize'directorysearch sub>>;                           20950000
   <<------------------------------>>                                   20952000
                                                                        20954000
   initialize'directorysearch;                                          20956000
                                                                        20958000
$if x1=on then                <<debugging code>>                        20960000
   if debugging and false then                                          20962000
      begin                                                             20964000
      say "CALL PRODUCEPARMS...@FILESET'=" endsay;                      20966000
      sayoctal(@fileset');                                              20968000
      say ", @DELIM=" endsay;                                           20970000
      sayoctal(@delim);                                                 20972000
      send;                                                             20974000
      say "   FILESET'=" endsay;                                        20976000
      say fileset',(len+2) endsay;                                      20978000
      send;                                                             20980000
      end;                                                              20982000
$if                           <<debugging code>>                        20984000
                                                                        20986000
   error'code:=0;                                                       20988000
   disable'arithmetic'traps;                                            20990000
                                                                        20992000
   tos:=produceparms (0, fileset', ppresult, delim, error'code);        20994000
                                                                        20996000
   enable'arithmetic'traps;                                             20998000
                                                                        21000000
   if not tos then                                                      21002000
      begin                                                             21004000
$if x1=on then                <<debugging code>>                        21006000
      if debugging then                                                 21008000
         begin                                                          21010000
         say "PRODUCEPARMS FAILED, ERR= #" endsay;                      21012000
         saynum(error'code);                                            21014000
         say " @FILESET'=" endsay; sayoctal (@fileset');                21016000
         say " @DELIM=" endsay; sayoctal (@delim);                      21018000
         send;                                                          21020000
         end;                                                           21022000
$if                           <<debugging code>>                        21024000
      fail (sr'produceparms'failed);                                    21026000
      end;                                                              21028000
                                                                        21030000
$if x1=on then                <<debugging code>>                        21032000
   if debugging and false then                                          21034000
      begin                                                             21036000
      say "ARET = " endsay; saynum(error'code);                         21038000
      send;                                                             21040000
      say "@DELIM = " endsay; saynum(@delim);                           21042000
      say ", @SCRATCH' = " endsay; saynum(@scratch');                   21044000
      send;                                                             21046000
      say "SCRATCH' = " endsay; say scratch',(31) endsay;               21048000
      send;                                                             21050000
      say "PPRESULT = " endsay;                                         21052000
      @pp:=@ppresult';                                                  21054000
      say "0    " endsay;                                               21056000
      for i:=0 step 1 until ppr'len do                                  21058000
         begin                                                          21060000
         sayoctal (ppresult(i));                                        21062000
         say " " endsay;                                                21064000
         if i mod 4 = 2 then                                            21066000
            begin                                                       21068000
            if i=2 then                                                 21070000
               j:=6                                                     21072000
            else                                                        21074000
               j:=8;                                                    21076000
            while (j:=j-1) >= 0 do                                      21078000
               begin                                                    21080000
               if pp=" " then                                           21082000
                  pout:=" "                                             21084000
               else if pp=special then                                  21086000
                  pout:="."                                             21088000
               else                                                     21090000
                  pout:=pp;                                             21092000
               @pout:=@pout+1;                                          21094000
               @pp:=@pp+1;                                              21096000
               end;                                                     21098000
            send;                                                       21100000
            saynum (i+1);                                               21102000
            @pout:=@outputbuffer'(5);                                   21104000
            end;                                                        21106000
         end;                                                           21108000
      send;                                                             21110000
      send;                                                             21112000
      end;                                                              21114000
$if                           <<debugging code>>                        21116000
                                                                        21118000
   type:=ppresult(2);                                                   21120000
   type.(5:1):=1;             <<set hit flag>>                          21122000
   type.(13:3):=0;            <<set level for direcscan>>               21124000
   dr'1:=ppresult(0).mvtabxf; <<linkage  (??)>>                         21126000
   dr'2:=ppresult(1);         <<indexp   (??)>>                         21128000
   thunk'store'err:=false;                                              21130000
                                                                        21132000
   get'sirs (true, false);      <<get fisir only>>                      21134000
                                                                        21136000
   disable'arithmetic'traps;                                            21138000
                                                                        21140000
   dr:=direcscan (type,                                                 21142000
                  dr,                                                   21144000
                  look'acct,  <<account name>>                          21146000
                  look'group, <<group name>>                            21148000
                  look'file,  <<file name>>                             21150000
                  thunk,      <<routine>>                               21152000
                  mvtabx);                                              21154000
                                                                        21156000
   if <> then                 <<problem with direcscan>>                21158000
      begin                                                             21160000
                                                                        21162000
      enable'arithmetic'traps;                                          21164000
      release'sirs (got'fisir, got'dsir);                               21166000
                                                                        21168000
            <<dont report 'file not found' or 'acct not                 21170000
              found' or 'group not found' as an error...>>              21172000
                                                                        21174000
      if dr'2 <> 2 or not ( 0 <= dr'1 <= 2) then                        21176000
         fail (sr'directory'error)                                      21178000
                                                                        21180000
      else if show'flag or std'wild = 0 then                            21182000
         begin                                                          21184000
$if x1=on then                <<debugging code>>                        21186000
         if debugging then                                              21188000
            begin                                                       21190000
            say "DR'2 = 2, DR'1 = " endsay; saynum (dr'1);              21192000
            send;                                                       21194000
            say "LOOK = " endsay; say'standard(look'title');send;       21196000
            say "CURR = " endsay; say'standard(curr'title');send;       21198000
            end;                                                        21200000
$if                           <<debugging code>>                        21202000
                                                                        21204000
         move curr'title':=look'title', (max'std'len);                  21206000
         if dr'1 = 0 then                                               21208000
            sendmessage (m'no'file)                                     21210000
         else if dr'1 = 1 then                                          21212000
            sendmessage (m'no'group)                                    21214000
         else                                                           21216000
            sendmessage (m'no'acct);                                    21218000
         end;                                                           21220000
      end                                                               21222000
                                                                        21224000
   else                                                                 21226000
      begin                                                             21228000
      release'sirs (got'fisir, got'dsir);                               21230000
      enable'arithmetic'traps;                                          21232000
      end;                                                              21234000
                                                                        21236000
   if thunk'store'err then                                              21238000
      fail (0);               <<already printed error msg>>             21240000
                                                                        21242000
end'directorysearch:                                                    21244000
                                                                        21246000
$if x1=on then                <<debugging code>>                        21248000
   if debugging then                                                    21250000
      begin                                                             21252000
      say "EXIT DIRECTORYSEARCH" endsay;                                21254000
      send;                                                             21256000
      end;                                                              21258000
$if                           <<debugging code>>                        21260000
                                                                        21262000
   end <<directorysearch proc>>;                                        21264000
$page ";STORMISC=  DISMOUNT'PRIVATE'VOLUMES"                            21266000
$control segment=stormisc                                               21268000
<<***************************************************************>>     21270000
procedure dismount'private'volumes;                                     21272000
                                                                        21274000
      <<dismount all private volumes mounted by store...                21276000
        done by rewinding and reading the pv file, which                21278000
        has one record per mount.  entries in the file are              21280000
        accessed via the defines: pvinx'acct, pvinx'group,              21282000
        and pvinx'pvinfo, which are declared globally.    >>            21284000
                                                                        21286000
   begin                                                                21288000
                                                                        21290000
                                                                        21292000
   integer array                                                        21294000
      pvbuf       (0:pv'recsize-1);                                     21296000
                                                                        21298000
   integer                                                              21300000
      hvsind      := 0,       <<parameter to dismount>>                 21302000
      rec         := -1,      <<record # we are on, 0 based>>           21304000
      reqtype     := 0;       <<request type for dismount>>             21306000
                                                                        21308000
   logical                                                              21310000
      done        := false;   <<true when eof hit on pv file>>          21312000
                                                                        21314000
   byte array                                                           21316000
      pvbuf'      (*) = pvbuf (0),                                      21318000
      scratch'    (0:2*file'part'size+1);                               21320000
                                                                        21322000
   label                                                                21324000
      end'dismount'private'volumes;                                     21326000
                                                                        21328000
   <<-------->>                                                         21330000
   <<  fail  >>                                                         21332000
   <<-------->>                                                         21334000
                                                                        21336000
   subroutine fail (n);                                                 21338000
            value   n;                                                  21340000
            integer n;                                                  21342000
                                                                        21344000
      begin                                                             21346000
                                                                        21348000
      sendmessage (n);                                                  21350000
                                                                        21352000
      go end'dismount'private'volumes;                                  21354000
                                                                        21356000
      end <<fail sub>>;                                                 21358000
   <<--------------------->>                                            21360000
                                                                        21362000
                                                                        21364000
$if x1=on then                <<debugging code>>                        21366000
   if debugging then                                                    21368000
      begin                                                             21370000
      say "DISMOUNT'PRIVATE'VOLUMES started" endsay;                    21372000
      send;                                                             21374000
      end;                                                              21376000
$if                           <<debugging code>>                        21378000
                                                                        21380000
   if pv'num <= 0 then                                                  21382000
      return;                                                           21384000
                                                                        21386000
   fpoint (pv'num, 0d);       <<rewind the file>>                       21388000
                                                                        21390000
   if <> then                                                           21392000
      fail (sr'pv'rewind'fail);                                         21394000
                                                                        21396000
                                                                        21398000
   while not done do                                                    21400000
      begin                                                             21402000
                                                                        21404000
      rec:=rec+1;                                                       21406000
                                                                        21408000
      fread (pv'num, pvbuf, pv'recsize);                                21410000
                                                                        21412000
      if <> then                                                        21414000
         done:=true                                                     21416000
                                                                        21418000
      else                                                              21420000
         begin                                                          21422000
         reqtype:=conddismount'bind;                                    21424000
         hvsind:="* ";                                                  21426000
                                                                        21428000
$if x1=on then                <<debugging code>>                        21430000
         if debugging then                                              21432000
            begin                                                       21434000
            say "dismount: " endsay;                                    21436000
            say pvbuf', (2*file'part'size) endsay;                      21438000
            say ", pvinfo = %" endsay;                                  21440000
            sayoctal (pvbuf(pvinx'pvinfo));                             21442000
            send;                                                       21444000
            end;                                                        21446000
$if                           <<debugging code>>                        21448000
         dismount (hvsind,                                              21450000
                   pvbuf(pvinx'group),                                  21452000
                   pvbuf(pvinx'acct),                                   21454000
                   reqtype,                                             21456000
                   pvbuf(pvinx'pvinfo) );                               21458000
         if <> then                                                     21460000
            begin                                                       21462000
            move scratch':=pvbuf'(2*pvinx'group),(file'part'size), 2;   21464000
            move *:=".", 2;                                             21466000
            move *:=pvbuf'(2*pvinx'acct),(file'part'size), 2;           21468000
            parms'tempi'1:=@scratch';           <<byte pointer addr>>   21470000
            parms'tempi'2:=2*file'part'size+1;  <<length of text>>      21472000
            sendmessage (m'pv'dismount'fail);                           21474000
            end;                                                        21476000
         end;                                                           21478000
      end;                                                              21480000
                                                                        21482000
   if pv'num <> 0 then                                                  21484000
      fclose (pv'num, 0, 0);                                            21486000
                                                                        21488000
end'dismount'private'volumes:                                           21490000
                                                                        21492000
$if x1=on then                <<debugging code>>                        21494000
   if debugging then                                                    21496000
      begin                                                             21498000
      say "end DISMOUNT'PRIVATE'VOLUMES" endsay;                        21500000
      send;                                                             21502000
      end;                                                              21504000
$if                           <<debugging code>>                        21506000
                                                                        21508000
   end <<dismount'private'volumes proc>>;                               21510000
$page ";STORMISC=  FILL --- FILLS WORD-ORIENTED ARRAYS WITH DATA"       21512000
$control segment=stormisc                                               21514000
<<***************************************************************>>     21516000
procedure fill (a, count, what);                                        21518000
         value   count, what;                                           21520000
         logical count, what;                                           21522000
         integer array a;                                               21524000
         option uncallable;                                             21526000
                                                                        21528000
   begin                                                                21530000
                                                                        21532000
   if count > 0 then                                                    21534000
      begin                                                             21536000
      a(0):=what;                                                       21538000
      if count > 1 then                                                 21540000
         move a(1):=a(0),(count-1);                                     21542000
      end;                                                              21544000
                                                                        21546000
   end <<fill proc>>;                                                   21548000
$page ";STORMISC=  FILL' --- FILLS WORD-ORIENTED ARRAYS WITH DATA"      21550000
$control segment=stormisc                                               21552000
<<***************************************************************>>     21554000
procedure fill' (a', count, what);                                      21556000
         value   count, what;                                           21558000
         logical count;                                                 21560000
         byte array a';                                                 21562000
         byte    what;                                                  21564000
         option uncallable;                                             21566000
   begin                                                                21568000
                                                                        21570000
   if count > 0 then                                                    21572000
      begin                                                             21574000
      a'(0):=what;                                                      21576000
      if count > 1 then                                                 21578000
         move a'(1):=a'(0),(count-1);                                   21580000
      end;                                                              21582000
                                                                        21584000
   end <<fill' proc>>;                                                  21586000
$page ";STORMISC=  FIND'BLOCK'FACTOR --- FILE SIZE ROUTINE"             21588000
$control segment=stormisc                                               21590000
<<***************************************************************>>     21592000
integer procedure find'block'factor (error);                            21594000
         integer error;                                                 21596000
         option uncallable;                                             21598000
   begin                                                                21600000
                                                                        21602000
                                                                        21604000
   integer                                                              21606000
      i;                                                                21608000
                                                                        21610000
   logical                                                              21612000
      blkf,                   <<number of records per block>>           21614000
      blksize,                <<number of bytes in a block>>            21616000
      recsize;                <<number of bytes in a record>>           21618000
                                                                        21620000
   double                                                               21622000
      blksize'd,              <<number of bytes in a blk for rio files>>21624000
      recsize'd;              <<number of bytes in a rec for rio files>>21626000
                                                                        21628000
   error:=0;                                                            21630000
                                                                        21632000
   if flfoptions.(2:3) = 2 then         << rio file >>                  21634000
      begin                                                             21636000
         << rio files have a very special format.                       21638000
            at the end of each block is a bit map which                 21640000
            tells if each record in the block is allocated.             21642000
            the blocksize in bytes of a rio file is                     21644000
               (recsize in bytes)*(blockfactor) + blockfactor/8         21646000
            so the blockfactor of a rio file is                         21648000
               (8 * blksize in bytes) / ((8*recsize in bytes) + 1)    >>21650000
                                                                        21652000
                                                                        21654000
         blksize'd := double(flblksize) & dasl(3);                      21656000
         if flrecsize = 0 then recsize'd := 256d                        21658000
         else if flrecsize < 0 then recsize'd:=double(-flrecsize)       21660000
         else recsize'd := double (flrecsize*2);                        21662000
         recsize'd := (recsize'd & dasl(3)) + 1d;                       21664000
         blkf := integer(blksize'd / recsize'd);                        21666000
      end                                                               21668000
   else if flfoptions.(8:2) = 1 then     <<variable file...>>           21670000
      blkf:=1                                                           21672000
                                                                        21674000
   else                                                                 21676000
      begin                                                             21678000
            <<get record size in positive bytes...>>                    21680000
                                                                        21682000
      if (i:=flrecsize) < 0 then                                        21684000
         recsize:=logical(\i\)      <<convert to positive>>             21686000
      else if i = 0 then                                                21688000
         recsize:=256               <<zero implies 1 sector  ??!!>>     21690000
      else                                                              21692000
         recsize:=logical(i)*2;     <<convert words to bytes>>          21694000
                                                                        21696000
            <<convert bytes to higher even value, if odd...>>           21698000
                                                                        21700000
      if recsize mod 2 = 1 then                                         21702000
         recsize:=recsize+1;        <<note: doesnt assume               21704000
                                      any particular bit layout!>>      21706000
                                                                        21708000
            <<convert blocksize to positive bytes, divide by            21710000
              recsize ... this give the blocking factor                 21712000
              ...should be an integer !!>>                              21714000
                                                                        21716000
      blksize:=flblksize*2;                                             21718000
                                                                        21720000
      blkf:=logical(blksize/recsize);  <<# of records per block>>       21722000
                                                                        21724000
      if blkf * recsize <> blksize then                                 21726000
         begin                                                          21728000
$if x1=on then                <<debugging code>>                        21730000
         if debugging then                                              21732000
            begin                                                       21734000
            say "   FLBLKSIZE=" endsay; saynum(flblksize);              21736000
                                say " words" endsay;       send;        21738000
            say "   BLKSIZE  =" endsay; saynum(blksize);                21740000
                                say " bytes" endsay;       send;        21742000
            say "   FLRECSIZE=" endsay; saynum(flrecsize);              21744000
                                say " -bytes?" endsay;     send;        21746000
            say "   RECSIZE  =" endsay; saynum(recsize);                21748000
                                say " bytes" endsay;       send;        21750000
            say "   BLKF     =" endsay; saynum(blkf);                   21752000
                                say " records" endsay;     send;        21754000
            say "   BLKF*RCSZ=" endsay; saynum(blkf*recsize);           21756000
                                say " records" endsay;     send;        21758000
            end;                                                        21760000
$if                           <<debugging code>>                        21762000
                                                                        21764000
         error:=1;                  <<non-integral block factor>>       21766000
         end;                                                           21768000
                                                                        21770000
      end;                                                              21772000
                                                                        21774000
   find'block'factor:=blkf;                                             21776000
                                                                        21778000
   end <<find'block'factor proc>>;                                      21780000
$page ";STORMISC=  FIND'FILE'SIZE --- FILE SIZE ROUTINE"                21782000
$control segment=stormisc                                               21784000
<<***************************************************************>>     21786000
double procedure find'file'size (typ, extent'sizes'd);                  21788000
         value   typ;                                                   21790000
         integer typ;                                                   21792000
         double array extent'sizes'd;                                   21794000
<<--------------------------------------------------------------->>     21796000
<< find'file'size calculates the size of a file in sectors.       >>    21798000
<< it is passed the file label and an option (typ) that tells it  >>    21800000
<< whether to determine the number of sectors in use (used by     >>    21802000
<< store) or the number of sectors allocated (used by restore).   >>    21804000
<<                                                                >>    21806000
<< typ defaults to file'size'minv, which is what store passes.    >>    21808000
<<                                                                >>    21810000
<< the extent'sizes'd array will be filled with the size of each  >>    21812000
<< allocated extent.                                              >>    21814000
<<---------------------------------------------------------------->>    21816000
                                                                        21818000
   begin                                                                21820000
                                                                        21822000
                                                                        21824000
   double                                                               21826000
      blks,                   <<number of blocks in the file>> <<06124>>21827000
      d,                                                                21828000
      sectors'max,                                                      21830000
      sectors'min;                                                      21832000
                                                                        21834000
   integer                                                              21836000
      eof'extent'size,                                                  21838000
      eof'extents,                                                      21840000
      i,                                                                21842000
      last'extent'seen;       <<last allocated extent>>                 21844000
                                                                        21846000
   logical                                                              21848000
      blkf,                   <<number of records per block>>           21850000
      sectors'per'block;                                                21854000
                                                                        21856000
   double pointer                                                       21858000
      fl'extmap'd   := @flextmap'd;                                     21860000
                                                                        21862000
   <<-------------------->>                                             21864000
   <<  find'max'filesize >>                                             21866000
   <<-------------------->>                                             21868000
                                                                        21870000
   subroutine find'max'filesize;                                        21872000
                                                                        21874000
      begin                                                             21876000
                                                                        21878000
$if x1=on then                <<debugging code>>                        21880000
      if debugging then                                                 21882000
         begin                                                          21884000
         say "   Find max sectors = " endsay;                           21886000
         end;                                                           21888000
$if                           <<debugging code>>                        21890000
                                                                        21892000
      i:=-1;                                                            21894000
      last'extent'seen:=0;                                              21896000
      sectors'max:=0d;                                                  21898000
      d:=flextsize'd;                                                   21900000
                                                                        21902000
            <<loop running i from 0 to flnumexts ...                    21904000
              note that if we have, say, 5 extents in a                 21906000
              file flnumexts = 4.                  >>                   21908000
                                                                        21910000
      while (i:=i+1) <= flnumexts do                                    21912000
         begin                                                          21914000
         if fl'extmap'd (i) <> 0d then                                  21916000
            begin                                                       21918000
                  <<if this is the last extent, change d                21920000
                    to be fllastextsize...               >>             21922000
                                                                        21924000
            if i = flnumexts then                                       21926000
               d:=fllastextsize'd;                                      21928000
                                                                        21930000
$if x1=on then                <<debugging code>>                        21932000
      if debugging then                                                 21934000
         begin                                                          21936000
         say "(FLEXTSIZE = " endsay;                                    21938000
         saydnum (d);                                                   21940000
         say1 (")");                                                    21942000
         send;                                                          21944000
         end;                                                           21946000
$if                           <<debugging code>>                        21948000
                                                                        21950000
            extent'sizes'd(i):=d;                                       21952000
            sectors'max:=sectors'max + d;                               21954000
            last'extent'seen:=i;                                        21956000
            end;                                                        21958000
         end;                                                           21960000
                                                                        21962000
$if x1=on then                <<debugging code>>                        21964000
      if debugging then                                                 21966000
         begin                                                          21968000
         saydnum (sectors'max);                                         21970000
         send;                                                          21972000
         end;                                                           21974000
$if                           <<debugging code>>                        21976000
                                                                        21978000
      end <<find'max'filesize sub>>;                                    21980000
                                                                        21982000
   <<--------------------->>                                            21984000
   <<  find'min'filesize  >>                                            21986000
   <<--------------------->>                                            21988000
                                                                        21990000
   subroutine find'min'filesize;                                        21992000
                                                                        21994000
      begin                                                             21996000
                                                                        21998000
      find'max'filesize;      <<fills extent'sizes'd array>>            22000000
                                                                        22002000
$if x1=on then                <<debugging code>>                        22004000
      if debugging then                                                 22006000
         begin                                                          22008000
         say "   Find min sectors = " endsay;                           22010000
         end;                                                           22012000
$if                           <<debugging code>>                        22014000
                                                                        22016000
      if flfoptions.(08:02) = 1 then                                    22018000
         begin                         <<variable format file>>         22020000
         sectors'min:=sectors'max;                                      22022000
         return;                                                        22024000
         end;                                                           22026000
                                                                        22028000
      blkf:=find'block'factor (i);                                      22030000
                                                                        22032000
      d:=fleof;                        <<not variable format file.>>    22034000
                                                                        22036000
                                                                        22038000
      blks:=d / double (blkf);          <<number of blocks>>   <<06124>>22040000
      if (d mod double(blkf)) <> 0d then                       <<06124>>22042000
         blks:=blks+1d;       <<last block is partially full>> <<06124>>22044000
                                                                        22046000
      sectors'per'block:=(flblksize+127)/128;                           22048000
                                                                        22050000
      sectors'min:= blks                                       <<06124>>22052000
                      * double(logical(sectors'per'block))              22054000
                      + double(logical(flsectoff));                     22056000
                                                                        22058000
          << the following code has been added to find'min'filesize >>  22060000
          << to avoid including non-allocated extents.  the code    >>  22062000
          << finds the extent in which eof occurs and how far into  >>  22064000
          << that extent the eof occurs.  then it loops subtracting >>  22066000
          << non-allocated extents                                  >>  22068000
                                                                        22070000
                                                                        22072000
      eof'extents := ((sectors'min - 1d) // flextsize'l);               22074000
      eof'extent'size := ((sectors'min - 1d) modd flextsize'l) + 1;     22076000
                                                                        22078000
      i := -1;                                                          22080000
      while (i:=i+1) < eof'extents do                                   22082000
         if extent'sizes'd (i) = 0d then                                22084000
            sectors'min := sectors'min - flextsize'd;                   22086000
                                                                        22088000
      if extent'sizes'd (eof'extents) = 0d then                         22090000
          sectors'min := sectors'min - double (eof'extent'size);        22092000
                                                                        22094000
$if x1=on then                <<debugging code>>                        22096000
      if debugging then                                                 22098000
         begin                                                          22100000
         saydnum (sectors'min);                                         22102000
         send;                                                          22104000
         end;                                                           22106000
$if                           <<debugging code>>                        22108000
                                                                        22110000
      end <<find'min'filesize sub>>;                                    22112000
   <<----------------------------->>                                    22114000
                                                                        22116000
   i:=32;                                                               22118000
   while (i:=i-1) >= 0 do                                               22120000
      extent'sizes'd(i):=0d;                                            22122000
                                                                        22124000
   if typ = file'size'maxv then                                         22126000
      begin                                                             22128000
      find'max'filesize;                                                22130000
      find'file'size:=sectors'max;                                      22132000
      end                                                               22134000
                                                                        22136000
   else <<if typ = file'size'minv then>>                                22138000
      begin                                                             22140000
      find'min'filesize;                                                22142000
      find'file'size:=sectors'min;                                      22144000
      end;                                                              22146000
                                                                        22148000
   end <<find'file'size proc>>;                                         22150000
$page ";STORMISC=  FKONTROL --- ROUTINE TO DO FCONTROLS"                22152000
$control segment=stormisc                                               22154000
<<***************************************************************>>     22156000
logical procedure fkontrol (fid, what);                                 22158000
         value   what;                                                  22160000
         integer what, fid;                                             22162000
                                                                        22164000
   begin                                                                22166000
                                                                        22168000
   integer                                                              22170000
      dummy'i        := 0;                                     <<05016>>22172000
                                                                        22174000
   fkontrol:=good;                                                      22176000
                                                                        22178000
   fcontrol (fid, what, dummy'i);                                       22180000
   if <> or (what = weof) then                                 <<05016>>22180900
      fcheck (fid, dummy'i);                                   <<05016>>22181000
   if dummy'i = fs'err'recovered then                          <<04102>>22181100
      dummy'i := 0;                                            <<04102>>22181200
                                                                        22182000
   if dummy'i <> 0 then                                        <<04102>>22184000
      begin                                                             22186000
                                                                        22188000
$if x1=on then                <<debugging code>>                        22190000
      if debugging then                                                 22192000
         begin                                                          22194000
         say "FKONTROL (" endsay;                                       22196000
         saynum (fid);                                                  22198000
         say ", %" endsay;                                              22200000
         sayoctal (what);                                               22202000
         say ") failed!...file info = " endsay;                         22204000
         send;                                                          22206000
         end;                                                           22208000
$if                           <<debugging code>>                        22210000
      fkontrol:=failed;                                                 22212000
      end;                                                              22214000
                                                                        22216000
   end <<fkontrol proc>>;                                               22218000
$page ";STORMISC=  GET'SIRS --- GETS FILE INTEGRITY & DIRECTORY SIRS"   22220000
$control segment=stormisc                                               22222000
<<***************************************************************>>     22224000
procedure get'sirs (want'fisir, want'dsir);                             22226000
         value want'fisir, want'dsir;                                   22228000
         logical want'fisir, want'dsir;                                 22230000
         option uncallable;                                             22232000
                                                                        22234000
   begin                                                                22236000
                                                                        22238000
                                                                        22240000
$if x1=on then                <<debugging code>>                        22242000
   if debug'sirs then                                                   22244000
      begin                                                             22246000
      say "GET'SIRS (" endsay; saynum(want'fisir.(15:01));              22248000
      say ", " endsay; saynum (want'dsir.(15:01)); say1 (")");          22250000
      say "   have: " endsay;                                           22252000
      if got'fisir then say "FISIR  " endsay;                           22254000
      if got'dsir then begin say "DSIR (info=" endsay;                  22256000
         saynum (dsir'info); say1 (")"); end;                           22258000
      send;                                                             22260000
      debug;                                                            22262000
      end;                                                              22264000
$if                           <<debugging code>>                        22266000
                                                                        22268000
   if want'fisir and got'dsir and not got'fisir then                    22270000
      begin                                                             22272000
$if x1=on then                <<debugging code>>                        22274000
      if debugging then                                                 22276000
         begin                                                          22278000
         say "   WANT'FISIR, GOT DSIR...RELEASING DSIR" endsay;         22280000
         send;                                                          22282000
         end;                                                           22284000
$if                           <<debugging code>>                        22286000
      relsir (dsir, dsir'info);                                         22288000
$if x1=on then                <<debugging code>>                        22290000
      if debug'sirs then                                                22292000
         begin                                                          22294000
         say "released" endsay;                                         22296000
         send;                                                          22298000
         debug;                                                         22300000
         end;                                                           22302000
$if                           <<debugging code>>                        22304000
      got'dsir:=false;                                                  22306000
      want'dsir:=true;                                                  22308000
      end;                                                              22310000
                                                                        22312000
   if want'fisir then                                                   22314000
      begin                                                             22316000
$if x1=on then                <<debugging code>>                        22318000
      if debugging then                                                 22320000
         begin                                                          22322000
         say "   GETSIR (FISIR)" endsay;                                22324000
         send;                                                          22326000
         end;                                                           22328000
$if                           <<debugging code>>                        22330000
      if got'fisir then                                                 22332000
         begin                                                          22334000
$if x1=on then                <<debugging code>>                        22336000
         if debugging then                                              22338000
            begin                                                       22340000
            say "...already had it!" endsay;                            22342000
            end;                                                        22344000
$if                           <<debugging code>>                        22346000
         end                                                            22348000
      else                                                              22350000
         fisir'info:=getsir(fisir);                                     22352000
      got'fisir:=true;                                                  22354000
$if x1=on then                <<debugging code>>                        22356000
      if debugging then                                                 22358000
         begin                                                          22360000
         say "...got FISIR!" endsay;                                    22362000
         send;                                                          22364000
         if debug'sirs then debug;                                      22366000
         end;                                                           22368000
$if                           <<debugging code>>                        22370000
      end;                                                              22372000
                                                                        22374000
   if want'dsir then                                                    22376000
      begin                                                             22378000
$if x1=on then                <<debugging code>>                        22380000
      if debugging then                                                 22382000
         begin                                                          22384000
         say "   GETSIR (DSIR)" endsay;                                 22386000
         send;                                                          22388000
         end;                                                           22390000
$if                           <<debugging code>>                        22392000
      if got'dsir then                                                  22394000
         begin                                                          22396000
$if x1=on then                <<debugging code>>                        22398000
         if debugging then                                              22400000
            begin                                                       22402000
            say "...already had it!" endsay;                            22404000
            end;                                                        22406000
$if                           <<debugging code>>                        22408000
         end                                                            22410000
      else                                                              22412000
         dsir'info:=getsir(dsir);                                       22414000
      got'dsir:=true;                                                   22416000
$if x1=on then                <<debugging code>>                        22418000
      if debugging then                                                 22420000
         begin                                                          22422000
         say "...got DSIR!" endsay;                                     22424000
         send;                                                          22426000
         if debug'sirs then debug;                                      22428000
         end;                                                           22430000
$if                           <<debugging code>>                        22432000
      end;                                                              22434000
                                                                        22436000
$if x1=on then                <<debugging code>>                        22438000
   if debug'sirs then                                                   22440000
      begin                                                             22442000
      say "   got the sirs" endsay;                                     22444000
      send;                                                             22446000
      debug;                                                            22448000
      end;                                                              22450000
$if                           <<debugging code>>                        22452000
                                                                        22454000
   end <<get'sirs proc>>;                                               22456000
$page ";STOREMISC= JOIN'CONTIGUOUS'EXTENTS"                             22458000
$control segment=stormisc                                               22460000
procedure join'contiguous'extents (num'disj'exts, disj'ext'addr,        22462000
                                   disj'ext'len , orig'extmap,          22464000
                                   orig'num'extents, extsize,  <<lb.rs>>22466000
                                   last'extsize);              <<lb.rs>>22467000
   value orig'num'extents, extsize, last'extsize;              <<lb.rs>>22468000
   integer num'disj'exts, orig'num'extents;                             22470000
   double array                                                         22472000
      disj'ext'addr,                                                    22474000
      disj'ext'len,                                                     22476000
      orig'extmap;                                                      22478000
   double                                                      <<lb.rs>>22478100
      extsize,                                                 <<lb.rs>>22478200
      last'extsize;                                            <<lb.rs>>22478300
   option uncallable;                                                   22480000
                                                                        22482000
<<                                                                      22484000
   this procedure takes all occurences of two or more contiguous        22486000
   extents and joins them together to create a new extent map.          22488000
   this extent map is returned in disj'ext'addr.  since the length      22490000
   of the newly formed extents may differ the lengths of each           22492000
   extent is returned in disj'ext'len.  the number of the new           22494000
   extents is returned in num'disj'exts.  the original extent map       22496000
   is passed in orig'extmap.                                            22498000
>>                                                                      22500000
                                                                        22502000
begin                                                                   22504000
   integer i;                                                           22506000
                                                                        22508000
   num'disj'exts := 0;                                                  22510000
   disj'ext'addr (0) := orig'extmap (0);                                22512000
   disj'ext'len  (0) := extsize;                               <<lb.rs>>22514000
                                                                        22516000
   i := 0;                                                              22518000
   while ( i:=i+1 ) < orig'num'extents do                               22520000
      begin                                                             22522000
         if orig'extmap (i-1) + extsize = orig'extmap (i) then <<lb.rs>>22524000
            if i = orig'num'extents - 1 then                   <<lb.rs>>22526000
               disj'ext'len (num'disj'exts) :=                          22528000
                  disj'ext'len (num'disj'exts) + last'extsize  <<lb.rs>>22530000
            else                                                        22532000
               disj'ext'len (num'disj'exts) :=                          22534000
                  disj'ext'len (num'disj'exts) + extsize       <<lb.rs>>22536000
         else if orig'extmap (i) <> 0d then                             22538000
            begin                                                       22540000
               num'disj'exts := num'disj'exts + 1;                      22542000
               disj'ext'addr (num'disj'exts) := orig'extmap (i);        22544000
               if i = orig'num'extents - 1 then                <<lb.rs>>22546000
                  disj'ext'len (num'disj'exts) := last'extsize <<lb.rs>>22548000
               else                                                     22550000
                  disj'ext'len (num'disj'exts) := extsize;     <<lb.rs>>22552000
            end;                                                        22554000
      end;                                                              22556000
                                                                        22558000
$if x1=on then                                                          22560000
   if debugging then                                                    22562000
      begin                                                             22564000
         i := -1;                                                       22566000
         while (i:=i+1) <= num'disj'exts do                             22568000
            begin                                                       22570000
               say "DISJOINT EXTENT #" endsay;                          22572000
               saynum (i);                                              22574000
               say " AT ADDRESS %" endsay;                              22576000
               saydoctal (disj'ext'addr(i));                            22578000
               say " FOR " endsay;                                      22580000
               saydnum (disj'ext'len(i));                               22582000
               send;                                                    22584000
            end;                                                        22586000
      end;                                                              22588000
$if                                                                     22590000
end;                                                                    22592000
$page ";STORMISC=  LOCK'UNLOCK'FILE --- FILE LABEL ROUTINES"            22594000
$control segment=stormisc                                               22596000
<<***************************************************************>>     22598000
logical procedure lock'unlock'file (setting, ldev,                      22600000
                                    address, gotit);                    22602000
         value gotit, ldev, setting, address;                           22604000
         integer ldev, setting;                                         22606000
         logical gotit;                                                 22608000
         double address;                                                22610000
         option privileged, uncallable;                                 22612000
                                                                        22614000
      << this routine attempts to set the store bit in the              22616000
         file label to setting, which is either unlock'file or          22618000
         lock'file.                                                     22620000
         to accomplish this, it is passed the ldev and address          22622000
         of the disc to read/write.                                     22624000
         it is also passed an array in which to stuff the               22626000
         file label.                                                    22628000
         if gotit is true, then we already have the file sir.           22630000
         if the setting of the store bit fails for any reason,          22632000
         a result of failed is returned.                                22634000
         >>                                                             22636000
   begin                                                                22638000
                                                                        22640000
                                                                        22642000
   double                                                               22644000
      iob;                                                              22646000
                                                                        22648000
   integer                                                              22650000
      local'fisir'info,                                                 22652000
      x           := 0;       <<used by flab'checksum>>                 22654000
                                                                        22656000
   lock'unlock'file:=failed;                                            22658000
                                                                        22660000
   if not gotit then                                                    22662000
      local'fisir'info:=getsir (fisir);      <<get file label sir>>     22664000
                                                                        22666000
         <<read the file label from disc...>>                           22668000
                                                                        22670000
   if read'label (ldev, address, got'sir) = failed then                 22672000
      begin                                                             22674000
      if not gotit then                                                 22676000
         relsir (fisir, local'fisir'info);   <<release label sir>>      22678000
      return;                                                           22680000
      end;                                                              22682000
                                                                        22684000
   flstore:=setting;        <<lock/unlock file>>                        22686000
                                                                        22688000
   if update'tog then                                                   22690000
      fllastacc:=todays'date;                                           22692000
                                                                        22694000
   flab'checksum;                                                       22696000
                                                                        22698000
         <<write the file label to disc...>>                            22700000
                                                                        22702000
   lock'unlock'file:=                                                   22704000
      write'label (ldev, address, got'sir);                             22706000
                                                                        22708000
   if not gotit then                                                    22710000
      relsir (fisir, local'fisir'info);      <<release label sir>>      22712000
                                                                        22714000
   end <<lock'unlock'file proc>>;                                       22716000
$page ";STORMISC=  MOVE'DATA'IN --- MOVE FROM XDS TO STACK"             22718000
$control segment=stormisc                                               22720000
<<***************************************************************>>     22722000
procedure move'data'in (xds, inx, buf, len);                            22724000
         value   xds, inx, len;                                         22726000
         integer xds, inx, len;                                         22728000
         integer array buf;                                             22730000
         option uncallable, privileged;                                 22732000
                                                                        22734000
      <<this routine moves len words from the data segment              22736000
        xds, starting at offset inx, into the buffer buf.  >>           22738000
                                                                        22740000
   begin                                                                22742000
                                                                        22744000
   tos:=@buf;                 <<destination address>>                   22746000
   tos:=xds;                  <<source dst number>>                     22748000
   tos:=inx;                  <<starting offset into segment>>          22750000
   tos:=len;                  <<number of words to transfer>>           22752000
   assemble (mfds);                                                     22754000
                                                                        22756000
   end <<move'data'in proc>>;                                           22758000
$page ";STORMISC=  MOVE'DATA'OUT --- MOVE FROM XDS TO STACK"            22760000
$control segment=stormisc                                               22762000
<<***************************************************************>>     22764000
procedure move'data'out (xds, inx, buf, len);                           22766000
         value   xds, inx, len;                                         22768000
         integer xds, inx, len;                                         22770000
         integer array buf;                                             22772000
         option uncallable, privileged;                                 22774000
                                                                        22776000
      <<this routine moves len words into the data segment              22778000
        xds, starting at offset inx, from the buffer buf.  >>           22780000
                                                                        22782000
   begin                                                                22784000
                                                                        22786000
   tos:=xds;                  <<destination xds>>                       22788000
   tos:=inx;                  <<index into xds>>                        22790000
   tos:=@buf;                 <<source of data in stack>>               22792000
   tos:=len;                  <<number of words to transfer>>           22794000
   assemble (mtds);                                                     22796000
                                                                        22798000
   end <<move'data'out proc>>;                                          22800000
$page ";STORMISC=  OPEN'FILE --- FILE OPENING ROUTINE"                  22802000
$control segment=stormisc                                               22804000
<<***************************************************************>>     22806000
logical procedure open'file (fileno,                                    22808000
                             desig, foptions, aoptions, recsize,        22810000
                             dev',                                      22812000
                             blockfactor, numbuffers, filesize,         22814000
                             numextents, initialloc);                   22816000
         value foptions, aoptions, recsize, blockfactor,                22818000
               numbuffers, filesize, numextents, initialloc;            22820000
         integer fileno, recsize, blockfactor, numbuffers,              22822000
               numextents, initialloc;                                  22824000
         logical foptions, aoptions;                                    22826000
         byte array dev';                                               22828000
         integer array desig;                                           22830000
         double filesize;                                               22832000
         option variable, uncallable;                                   22834000
                                                                        22836000
      << this routine calls fopen with whatever parameters it is >>     22838000
      << given.                                                  >>     22840000
      <<                                                         >>     22842000
      << desig is a file title, terminated by a blank.           >>     22844000
      << if fopen returns cce, the result is good;               >>     22846000
      << otherwise failed is returned and error'info is set to   >>     22848000
      << err'ccl for a "<" error, and to err'ccg for a ">" error;>>     22850000
      << error'code is set to the number returned by fcheck.     >>     22852000
                                                                        22854000
   begin                                                                22856000
                                                                        22858000
                                                                        22860000
   integer                                                              22862000
      len         := 0;       <<length of file name>>                   22864000
                                                                        22866000
   byte array                                                           22868000
      actual'dev' (0:8),                                                22870000
      desig'      (*) = desig (0);                                      22872000
                                                                        22874000
   error'code:=error'info:=0;                                           22876000
   open'file:=good;                                                     22878000
                                                                        22880000
   if not parmmask.(15:1) then                                          22882000
      initialloc:=1;                                                    22884000
                                                                        22886000
   if not parmmask.(14:1) then                                          22888000
      numextents:=8;                                                    22890000
                                                                        22892000
   if not parmmask.(13:1) then                                          22894000
      filesize:=1023d;                                                  22896000
                                                                        22898000
   if not parmmask.(12:1) then         <<2 buf, 1 copy, outpri 8>>      22900000
      numbuffers:=%(2)1000000000100010;                                 22902000
                                                                        22904000
$if x1=on then                <<debugging code>>                        22906000
   if debugging then                                                    22908000
      begin                                                             22910000
      say "      OPEN'FILE (" endsay;                                   22912000
      say desig',(8) endsay;                                            22914000
      say ")" endsay;                                                   22916000
      send;                                                             22918000
      end;                                                              22920000
$if                           <<debugging code>>                        22922000
                                                                        22924000
   if parmmask.(10:1) then                                              22926000
      move actual'dev':=dev',(9)                                        22928000
   else                                                                 22930000
      move actual'dev':="DISC ";                                        22932000
                                                                        22934000
   scan desig' until " ", 1;                                            22936000
   len:=tos-logical(@desig');          <<length of title>>              22938000
                                                                        22940000
   if parmmask.(11:1) then    <<blockfactor specified>>                 22942000
      fileno:=fopen (desig', foptions, aoptions, recsize,               22944000
                     actual'dev', <<formmsg>>, <<userlabels>>,          22946000
                     blockfactor, numbuffers, filesize,                 22948000
                     numextents, initialloc)                            22950000
                                                                        22952000
   else                       <<blockfactor not specified>>             22954000
      fileno:=fopen (desig', foptions, aoptions, recsize,               22956000
                     actual'dev', <<formmsg>>, <<userlabels>>,          22958000
                     <<blockfactor>>, numbuffers, filesize,             22960000
                     numextents, initialloc);                           22962000
                                                                        22964000
   if > then                                                            22966000
      begin                                                             22968000
      error'info:=err'ccg;                                              22970000
      fcheck (fileno, error'code);                                      22972000
$if x1=on then                <<debugging code>>                        22974000
      if debugging then                                                 22976000
         begin                                                          22978000
         say "    -->   >   ERR# = " endsay;                            22980000
         saynum (error'code);                                           22982000
         send;                                                          22984000
         end;                                                           22986000
$if                           <<debugging code>>                        22988000
      parms'tempi'1:=@desig';                                           22990000
      parms'tempi'2:=len;      <<title is len chars long>>              22992000
      sendmessage (m'open'fail);                                        22994000
      open'file:=failed;                                                22996000
      end                                                               22998000
   else if < then                                                       23000000
      begin                                                             23002000
      error'info:=err'ccl;                                              23004000
      fcheck (fileno, error'code);                                      23006000
$if x1=on then                <<debugging code>>                        23008000
      if debugging then                                                 23010000
         begin                                                          23012000
         say "    -->   <   ERR# = " endsay;                            23014000
         saynum (error'code);                                           23016000
         send;                                                          23018000
         end;                                                           23020000
$if                           <<debugging code>>                        23022000
      parms'tempi'1:=@desig';                                           23024000
      parms'tempi'2:=len;      <<title is len chars long>>              23026000
      sendmessage (m'open'fail);                                        23028000
      open'file:=failed;                                                23030000
      end                                                               23032000
   else                                                                 23034000
      begin                                                             23036000
$if x1=on then                <<debugging code>>                        23038000
      if debugging then                                                 23040000
         begin                                                          23042000
         say "    -->   =   FILE#= " endsay;                            23044000
         saynum (fileno);                                               23046000
         send;                                                          23048000
         end;                                                           23050000
$if                           <<debugging code>>                        23052000
      end;                                                              23054000
                                                                        23056000
   end <<open'file proc>>;                                              23058000
$page ";STORMISC=  PARSE'DATE -- PARSES THE DATE KEYWORD"               23060000
$control segment=stormisc                                               23062000
<<***************************************************************>>     23064000
logical procedure parse'date (pdate);                                   23066000
         logical pdate;                                                 23068000
         option uncallable;                                             23070000
   << this routine checks the string pointed to by the scanner to >>    23072000
   << extract a date of the form mm/dd/yy from it.  if the string >>    23074000
   << is not a valid date (or 0/0/0), an error message is printed.>>    23076000
   << the routine result is good if no errors, otherwise          >>    23078000
   << a failed is returned.                                       >>    23080000
   << (a good date will be encoded in the format istore expects.) >>    23082000
                                                                        23084000
   begin                                                                23086000
                                                                        23088000
                                                                        23090000
   integer                                                              23092000
      day         := 0,                                                 23094000
      month       := 0,                                                 23096000
      year        := 0,                                                 23098000
      maxdays;        <<used to cope with leap year complications>>     23100000
                                                                        23102000
   integer array              <<cumulative days at month end...>>       23104000
      dayspermonth (*) = pb :=     0,  31,  59,  90, 120, 151,          23106000
                                 181, 212, 243, 273, 304, 334;          23108000
                                                                        23110000
   integer array                                                        23112000
      montharr (*) = pb:=     <<days of each month>>                    23114000
         0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31;             23116000
                                                                        23118000
   label                                                                23120000
      end'parse'date;                                                   23122000
                                                                        23124000
   <<------------------------>>                                         23126000
   subroutine fail (n);                                                 23128000
            value   n;                                                  23130000
            integer n;                                                  23132000
      begin                                                             23134000
                                                                        23136000
      if n <> 0 then                                                    23138000
         begin                                                          23140000
         print'carrot (itemp'offset);                                   23142000
         sendmessage (n);                                               23144000
         end;                                                           23146000
                                                                        23148000
      parse'date:=failed;                                               23150000
                                                                        23152000
      go end'parse'date;                                                23154000
                                                                        23156000
      end <<fail sub>>;                                                 23158000
   <<------------------------->>                                        23160000
                                                                        23162000
   parse'date:=good;                                                    23164000
                                                                        23166000
   pdate:=0;                                                            23168000
                                                                        23170000
         <<assume stepit has been done already!>>                       23172000
                                                                        23174000
   if iclass isnt numberv or subclass > 12 or subclass < 0 then         23176000
      fail (sr'invalid'month);            <<bad mm field>>              23178000
                                                                        23180000
   month:=subclass;                                                     23182000
                                                                        23184000
   if stepit is endlinev or itemp <> "/" then                           23186000
      fail (sr'slash'month'expected);                                   23188000
                                                                        23190000
   if stepit isnt numberv or subclass > 31 or subclass < 0 then         23192000
      fail (sr'invalid'day);                                            23194000
                                                                        23196000
   day:=subclass;                                                       23198000
                                                                        23200000
   if stepit is endlinev or itemp <> "/" then                           23202000
      fail (sr'slash'year'expected);                                    23204000
                                                                        23206000
   if stepit isnt numberv or subclass < 0 or subclass > 99 then         23208000
      fail (sr'invalid'year);                                           23210000
                                                                        23212000
   year:=subclass;                                                      23214000
                                                                        23216000
   if month = 0 or day = 0 or year = 0 then                             23218000
      begin                                                             23220000
      if (month+day+year) <> 0 then                                     23222000
         fail (sr'date'all'0'or'non'0);                                 23224000
      end                                                               23226000
   else                                                                 23228000
      begin                                                             23230000
      maxdays:=montharr(month)  +      <<leap year correction...>>      23232000
            (if year mod 4 = 0 and month = 2 then 1 else 0);            23234000
      if day > maxdays then                                             23236000
         fail (sr'day'too'big);   <<day too big for month>>             23238000
      end;                                                              23240000
                                                                        23242000
         <<convert date to format istore likes...>>                     23244000
                                                                        23246000
   pdate.(0:7):=year;                                                   23248000
   if month > 0 then                                                    23250000
      pdate.(7:9):=dayspermonth(month-1) + day +                        23252000
            (if (year mod 4)=0 and month>2 then 1 else 0);              23254000
                                                                        23256000
   parse'date:=good;                                                    23258000
                                                                        23260000
end'parse'date:                                                         23262000
                                                                        23264000
   end <<parse'date proc>>;                                             23266000
$page ";TITLES=  PARSE'FILESET --- FILESET PARSER FOR S/R"              23268000
$control segment=titles                                                 23270000
<<***************************************************************>>     23272000
logical procedure parse'fileset;                                        23274000
         option privileged, uncallable;                                 23276000
                                                                        23278000
      << parses the fileset pointed to by the scanner.                  23280000
         this fileset, if valid, is transformed into a standard form    23282000
         file title and stored into look'title'.  this will always      23284000
         result in a fully qualified file title, even if the user       23286000
         didn't specify group and/or account (we use the logon          23288000
         group/account as defaults). >>                                 23290000
                                                                        23292000
      <<it will disallow any file title beginning with a "*"            23294000
        or a "$".  (these titles, where they are allowed, are           23296000
        handled slightly specially externally.) >>                      23298000
                                                                        23300000
   begin                                                                23302000
                                                                        23304000
                                                                        23306000
   integer                                                              23308000
      char'inx    := 0;                                                 23310000
                                                                        23312000
   byte array                                                           23314000
      delims'     (0:6),                                                23316000
      tfile'      (0:8),                                                23318000
      tgroup'     (0:8);                                                23320000
                                                                        23322000
   byte pointer                                                         23324000
      pstd;                                                             23326000
                                                                        23328000
   label                                                                23330000
      end'parse'fileset;                                                23332000
                                                                        23334000
   <<----------------------->>                                          23336000
   <<  fail                 >>                                          23338000
   <<----------------------->>                                          23340000
                                                                        23342000
   subroutine fail (errnum, inx);                                       23344000
            value   errnum, inx;                                        23346000
            integer errnum, inx;                                        23348000
      begin                                                             23350000
                                                                        23352000
$if x1=on then                <<debugging code>>                        23354000
      if debugging then                                                 23356000
         begin                                                          23358000
         say "   FAIL of PARSE'FILESET (" endsay;                       23360000
         saynum (errnum); say ", " endsay; saynum (inx);                23362000
         say1 (")");                                                    23364000
         send;                                                          23366000
         end;                                                           23368000
$if                           <<debugging code>>                        23370000
                                                                        23372000
      print'carrot (inx);                                               23374000
                                                                        23376000
      error'code:=errnum;                                               23378000
                                                                        23380000
      sendmessage (errnum);                                             23382000
                                                                        23384000
      error'code:=0;          <<prevents caller from printing           23386000
                                a duplicate error message>>             23388000
                                                                        23390000
      parse'fileset:=failed;                                            23392000
                                                                        23394000
      go end'parse'fileset;                                             23396000
                                                                        23398000
      end <<fail sub>>;                                                 23400000
                                                                        23402000
   <<------------------------>>                                         23404000
   <<  make'fully'qualified  >>                                         23406000
   <<------------------------>>                                         23408000
                                                                        23410000
   subroutine make'fully'qualified (pstd);                              23412000
            value         pstd;                                         23414000
            byte pointer  pstd;                                         23416000
      begin                                                             23418000
                                                                        23420000
            <<if the group or account wasn't specified, append          23422000
              the logon group (or account)...>>                         23424000
                                                                        23426000
      if (std'group'inx = 0) or (std'acct'inx = 0) then                 23428000
         begin                                                          23430000
                                                                        23432000
               <<blank out 2 temp arrays...>>                           23434000
                                                                        23436000
         fill' (tfile', file'part'size, " ");                           23438000
         fill' (tgroup', file'part'size, " ");                          23440000
                                                                        23442000
               <<set up the file part...>>                              23444000
                                                                        23446000
         move tfile':=std'file', (std'file'len);                        23448000
                                                                        23450000
               <<set up the group part (from pstd if present,           23452000
                 otherwise from logon group...>>                        23454000
                                                                        23456000
         if std'group'inx = 0 then                                      23458000
            move tgroup':= logon'group', (file'part'size)               23460000
         else                                                           23462000
            move tgroup':= std'group', (std'group'len);                 23464000
                                                                        23466000
               << (use the logon account...if we got here at all,       23468000
                  no account part existed)...convert the 3 arrays       23470000
                  into a standard form title...>>                       23472000
                                                                        23474000
         if display'3'to'standard (tfile', tgroup', logon'acct',        23476000
                                  pstd, error'code)                     23478000
               = failed then  <<note: err shouldnt be possible>>        23480000
            fail (convert'se'to'cierr(error'code), itemp'offset);       23482000
         end;                                                           23484000
                                                                        23486000
      end <<make'fully'qualified sub>>;                                 23488000
   <<---------------------------------->>                               23490000
                                                                        23492000
   error'code:=0;                                                       23494000
   parse'fileset:=failed;                                               23496000
                                                                        23498000
$if x1=on then                <<debugging code>>                        23500000
   if debugging then                                                    23502000
      begin                                                             23504000
      say "PARSE'FILESET:  " endsay;                                    23506000
      debug'scanner;                                                    23508000
      end;                                                              23510000
$if                           <<debugging code>>                        23512000
                                                                        23514000
         <<initialize standard form titles and patterns for the         23516000
           'search' and 'exception' titles...>>                         23518000
                                                                        23520000
   fill' (look'title', max'std'len, 0);   <<empty std form title>>      23522000
   fill' (not'title',  max'std'len, 0);   <<empty std form title>>      23524000
   fill  (look'lock,   file'part'words, "  ");                          23526000
                                                                        23528000
   pattern'build'standard (look'title', look'file'pat,                  23530000
                           look'group'pat, look'acct'pat, error'code);  23532000
   pattern'build'standard (not'title', not'file'pat,                    23534000
                           not'group'pat, not'acct'pat, error'code);    23536000
                                                                        23538000
         <<build delimiters array with the following                    23540000
           delimiters:  semicolon, comma, space,                        23542000
                        return, and (this time) dash ...                23544000
           note: the dash must be the last delimiter!  >>               23546000
                                                                        23548000
   move delims':=(%6, "!;, ", %15, "-");          <<!indirect>>         23550000
                                                                        23552000
         <<parse title...note that we are guaranteed that one           23554000
           of the five delimiters above will be found, the              23556000
           carriage return is always at the end of the text!>>          23558000
                                                                        23560000
         <<also, it is assumed that a stepit has been done              23562000
           prior to calling this procedure, so itemp is                 23564000
           valid!                                        >>             23566000
                                                                        23568000
   @pstd:=@look'title';                                                 23570000
                                                                        23572000
         <<"empty" filesets require special handling...                 23574000
           the are allowed only as in:  store ;*t                       23576000
           restore *t     restore *t;     restore *t;;                  23578000
           and not in:   store a,,b;*t                >>                23580000
                                                                        23582000
   if itemp = ";" or iclass is endlinev then                            23584000
      if allow'empty'fileset                                            23586000
          <<and itemp'offset = fileset'inx>> then                       23588000
         begin                <<got an empty fileset...>>               23590000
         if restoring then                                              23592000
            if cap'sm or cap'op then                                    23594000
               begin                                                    23596000
               print'carrot (itemp'offset);                             23598000
               sendmessage (sr'warn'aaa);                               23600000
               move tfile':="@.@.@ ";                                   23602000
               end                                                      23604000
            else if cap'am then                                         23606000
               begin                                                    23608000
               print'carrot (itemp'offset);                             23610000
               sendmessage (sr'warn'aa);                                23612000
               move tfile':="@.@ ";                                     23614000
               end                                                      23616000
            else                                                        23618000
               begin                                                    23620000
               print'carrot (itemp'offset);                             23622000
               sendmessage (sr'warn'a);                                 23624000
               move tfile':="@ ";                                       23626000
               end                                                      23628000
         else                                                           23630000
            begin                                                       23632000
            print'carrot (itemp'offset);                                23634000
            sendmessage (sr'warn'store'a);                              23636000
            move tfile' := "@ ";                                        23638000
            end;                                                        23640000
         display'to'standard (tfile', look'title',                      23642000
                       error'code, char'inx, delims');                  23644000
         char'inx:=0;         <<length of token at itemp>>              23646000
         end                                                            23648000
      else                                                              23650000
$if x2=off then                                                         23652000
         fail (sr'fileset'list'empty, itemp'offset)                     23654000
$if                                                                     23656000
   else                                                                 23658000
      begin                   <<d-->s...>>                              23660000
      if display'to'standard (itemp, look'title', error'code,           23662000
                              char'inx, delims')                        23664000
            = failed then                                               23666000
         fail (convert'se'to'cierr (error'code),                        23668000
               itemp'offset+char'inx);                                  23670000
      end;                                                              23672000
                                                                        23674000
         <<extract lockword...>>                                        23676000
                                                                        23678000
   if std'lock'inx <> 0 then                                            23680000
      move look'lock':=std'lock', (std'lock'len);                       23682000
                                                                        23684000
         <<do some validity checking...>>                               23686000
                                                                        23688000
   if std'dollar = 1 then                                               23690000
      fail (sr'no'dollar'allowed, itemp'offset);                        23692000
                                                                        23694000
   if std'backref = 1 then                                              23696000
      fail (sr'no'backref'allowed, itemp'offset);                       23698000
                                                                        23700000
   ilen:=char'inx;            <<length returned by d-->s>>              23702000
   stepit;                    <<get the next non-blank!>>               23704000
                                                                        23706000
         <<turn file title into a fully qualified file title...>>       23708000
                                                                        23710000
   make'fully'qualified (look'title');                                  23712000
                                                                        23714000
   if (std'wild = 0) or (dbstore'tog) then                     <<04870>>23716000
      simple'tog:=1           <<no wildcards in search title>>          23718000
   else                                                                 23720000
      simple'tog:=0;          <<wildcards are in search title>>         23722000
                                                                        23724000
   if pattern'build'standard (look'title', look'file'pat,               23726000
                           look'group'pat, look'acct'pat, error'code)   23728000
         = failed then        <<shouldnt be possible>>                  23730000
      fail (sr'failed'to'build'pattern, itemp'offset);                  23732000
                                                                        23734000
$if x1=on then                <<debugging code>>                        23736000
   if debugging then                                                    23738000
      begin                                                             23740000
      say "LOOK'TITLE = " endsay;                                       23742000
      say'standard (look'title');                                       23744000
      say ", PATTERNS = " endsay;                                       23746000
      send;                                                             23748000
      say "File:    " endsay;                                           23750000
      say'pattern (look'file'pat);                                      23752000
      if look'lock' <> " " then                                         23754000
         begin                                                          23756000
         say "  / " endsay;                                             23758000
         say look'lock', (file'part'size) endsay;                       23760000
         end;                                                           23762000
      send;                                                             23764000
      say "Group:   " endsay;                                           23766000
      say'pattern (look'group'pat);                                     23768000
      send;                                                             23770000
      say "Account: " endsay;                                           23772000
      say'pattern (look'acct'pat);                                      23774000
      send;                                                             23776000
                                                                        23778000
      say "Token now: " endsay;                                         23780000
      say itemp,(ilen) endsay;                                          23782000
      send;                                                             23784000
      end;                                                              23786000
$if                           <<debugging code>>                        23788000
                                                                        23790000
         <<see if an exception title was specified...>>                 23792000
                                                                        23794000
   if itemp <> "-" then                                                 23796000
      begin                            <<no exception fileset..exit>>   23798000
      parse'fileset := good;                                            23800000
      return;                                                           23802000
      end;                                                              23804000
                                                                        23806000
         <<extract the exception fileset...>>                           23808000
                                                                        23810000
   stepit;                    <<get past the "-">>                      23812000
                                                                        23814000
   @pstd:= @not'title';                                                 23816000
   delims'(0):=delims'(0) - 1;      <<same as before, but no "-">>      23818000
                                                                        23820000
   if display'to'standard (itemp, not'title',                           23822000
                           error'code, char'inx, delims')               23824000
                                                                        23826000
         = failed then                                                  23828000
      fail (convert'se'to'cierror (error'code), itemp'offset+char'inx); 23830000
                                                                        23832000
   if std'dollar = 1 then                                               23834000
      fail (sr'no'dollar'allowed, itemp'offset);                        23836000
                                                                        23838000
   if std'backref = 1 then                                              23840000
      fail (sr'no'backref'allowed, itemp'offset);                       23842000
                                                                        23844000
         <<if no group and/or account was specified for the             23846000
           exception title, we must append our logon group and          23848000
           account...>>                                                 23850000
                                                                        23852000
   make'fully'qualified (not'title');                                   23854000
                                                                        23856000
   if pattern'build'standard (not'title', not'file'pat,                 23858000
                           not'group'pat, not'acct'pat, error'code)     23860000
            = failed then                                               23862000
      fail (sr'failed'to'build'pattern, itemp'offset);                  23864000
                                                                        23866000
   ilen:=char'inx;                                                      23868000
   stepit;                                                              23870000
                                                                        23872000
   parse'fileset:=good;                                                 23874000
                                                                        23876000
end'parse'fileset:                                                      23878000
                                                                        23880000
   end <<parse'fileset proc>>;                                          23882000
$page ";TITLES=  PARSE'NAME --- SIMPLE NAME PARSER FOR STORE/RESTORE"   23884000
$control segment=titles                                                 23886000
<<***************************************************************>>     23888000
integer procedure parse'name (ptr, len);                                23890000
      value   ptr, len;                                                 23892000
      integer len;                                                      23894000
      byte pointer ptr;                                                 23896000
      option uncallable;                                                23898000
                                                                        23900000
         <<parse the file part pointed to by ptr, which is len          23902000
           characters long.  if no error occurs, a 0 is returned.       23904000
           a back reference (*) is allowed, but wildcards (@,           23906000
           #, ?) are not. >>                                            23908000
   begin                                                                23910000
   integer                                                              23912000
      n = parse'name;                                                   23914000
   label                                                                23916000
      end'parse'name;                                                   23918000
   <<----------------------->>                                          23920000
   subroutine fail (n); value n; integer n;                             23922000
      begin                                                             23924000
      parse'name:=n;                                                    23926000
      go end'parse'name;                                                23928000
      end <<fail sub>>;                                                 23930000
   <<----------------------->>                                          23932000
                                                                        23934000
   parse'name := 0;                                                     23936000
                                                                        23938000
$if x1=on then                <<debugging code>>                        23940000
   if debugging then                                                    23942000
      begin                                                             23944000
      say "PARSE'NAME OF '" endsay;                                     23946000
      say ptr,(len) endsay;                                             23948000
      say "'" endsay;                                                   23950000
      end;                                                              23952000
$if                           <<debugging code>>                        23954000
                                                                        23956000
   if len <= 0 then                                                     23958000
      fail (pn'empty'name);                                             23960000
                                                                        23962000
   if ptr="*" then                                                      23964000
      begin                                                             23966000
      @ptr:=@ptr(1);                                                    23968000
      len:=len-1;                                                       23970000
      if len <= 0 then                                                  23972000
         fail (pn'empty'name);                                          23974000
      end;                                                              23976000
                                                                        23978000
   if len > file'part'size then                                         23980000
      fail (pn'name'too'long);                                          23982000
                                                                        23984000
   if ptr = alpha then               <<name starts with alpha...ok>>    23986000
   else if ptr="?" or ptr="@" then   <<name starts with wildcard...>>   23988000
      fail (pn'wildcards'illegal)          <<wildcards are illegal!>>   23990000
   else                              <<found something else...>>        23992000
      fail (pn'must'start'with'alpha);     <<but it wasnt an alpha!>>   23994000
                                                                        23996000
         <<check to see that all len characters are legal...>>          23998000
                                                                        24000000
   while len > 0 do                                                     24002000
      begin                                                             24004000
      if ptr = alpha then                                               24006000
      else if ptr = numeric then                                        24008000
      else if ptr = "?" or ptr = "#" or ptr = "@" then                  24010000
         fail (pn'wildcards'illegal)                                    24012000
      else                                                              24014000
         fail (pn'illegal'character);                                   24016000
      @ptr:=@ptr(1);                                                    24018000
      len:=len-1;                                                       24020000
      end;                                                              24022000
                                                                        24024000
end'parse'name:                                                         24026000
                                                                        24028000
$if x1=on then                <<debugging code>>                        24030000
   if debugging then                                                    24032000
      begin                                                             24034000
      say "  --> " endsay;                                              24036000
      saynum(n);                                                        24038000
      send;                                                             24040000
      end;                                                              24042000
$if                           <<debugging code>>                        24044000
                                                                        24046000
   end <<parse'name proc>>;                                             24048000
$page ";PARSE=  PARSE'OTHER'PARMS --- PARAM PARSER FOR S/R"             24050000
$control segment=parse                                                  24052000
<<***************************************************************>>     24054000
logical procedure parse'other'parms;                                    24056000
         option uncallable;                                             24058000
                                                                        24060000
      << sets various bits in the s'r'flags words.;                     24062000
         also returns information via parms.                            24064000
                                                                        24066000
         a result of good means no problems were found. >>              24068000
                                                                        24070000
   begin                                                                24072000
                                                                        24074000
                                                                        24076000
   logical                                                              24078000
      pdate       := 0,                                                 24080000
      use'adate   := 2;       << 2 = haven't seen "DATE" yet>>          24082000
                                                                        24084000
   byte array                                                           24086000
      scratch'    (0:file'part'size-1);                                 24088000
                                                                        24090000
   label                                                                24092000
      end'parse'other'parms;                                            24094000
                                                                        24096000
   <<------------------->>                                              24098000
   subroutine err (errnum);                                             24100000
         value   errnum;                                                24102000
         integer errnum;                                                24104000
      begin                                                             24106000
            <<this will set parse'other'parms                           24108000
              to failed and go to the end of the routine.>>             24110000
                                                                        24112000
      if errnum <> 0 then                                               24114000
         begin                                                          24116000
         print'carrot (itemp'offset);                                   24118000
         sendmessage (errnum);                                          24120000
         end;                                                           24122000
                                                                        24124000
      parse'other'parms:=failed;      <<indicates an error>>            24126000
                                                                        24128000
      go end'parse'other'parms;                                         24130000
                                                                        24132000
      end <<err sub>>;                                                  24134000
                                                                        24136000
   <<------------------->>                                              24138000
   subroutine warn (n);                                                 24140000
           value    n;                                                  24142000
           integer  n;                                                  24144000
      begin                                                             24146000
                                                                        24148000
      sendmessage (n);                                                  24150000
                                                                        24152000
      end <<warn sub>>;                                                 24154000
                                                                        24156000
   <<------------------->>                                              24158000
   subroutine unknown'option;                                           24160000
                                                                        24162000
      begin                                                             24164000
                                                                        24166000
      if storing then                                                   24168000
         err (sr'unkoption)                                             24170000
      else                                                              24172000
         err (rs'unkoption);                                            24174000
                                                                        24176000
      end <<unknown'option sub>>;                                       24178000
                                                                        24180000
   <<------------------->>                                              24182000
   subroutine assure'restoring;                                         24184000
                                                                        24186000
      begin                                                             24188000
                                                                        24190000
            <<we get here because we found a keyword used only          24192000
              by restore.  therefore, we now check to see if it is      24194000
              a store or sysdump command using this keyword;  if        24196000
              it is, we tell the user that this is an unknown           24198000
              store option...>>                                         24200000
                                                                        24202000
      if not restoring then                                             24204000
         err (sr'unkoption);                                            24206000
                                                                        24208000
      end <<assure'restoring sub>>;                                     24210000
                                                                        24212000
   <<------------------->>                                              24214000
   subroutine assure'storing;                                           24216000
                                                                        24218000
      begin                                                             24220000
                                                                        24222000
            <<we get here because we found a keyword used only          24224000
              by store.  therefore, we now check to see if it is        24226000
              a restore command using this store-only keyword;  if      24228000
              it is, we tell the user that this is an unknown           24230000
              restore option...>>                                       24232000
                                                                        24234000
      if not storing then        <<store or sysdump ok>>                24236000
         err (rs'unkoption);                                            24238000
                                                                        24240000
      end <<assure'storing sub>>;                                       24242000
                                                                        24244000
   <<------------------->>                                              24246000
   subroutine assure'sysdumping;                                        24248000
                                                                        24250000
      begin                                                             24252000
                                                                        24254000
            <<we get here because we found a keyword used only          24256000
              by sysdump.  therefore, we now check to see if it is      24258000
              a being used by store or restore.  if                     24260000
              it is, we tell the user that this is an unknown           24262000
               store / restore option...>>                              24264000
                                                                        24266000
      if not sysdumping then     <<store or restore bad>>               24268000
         unknown'option;                                                24270000
                                                                        24272000
      end <<assure'storing sub>>;                                       24274000
                                                                        24276000
   <<------------------->>                                     <<04870>>24278000
   subroutine assure'dbstoring;                                <<04870>>24280000
                                                               <<04870>>24282000
      begin                                                    <<04870>>24284000
                                                               <<04870>>24286000
           <<we get here because we found a keyword used only>><<04870>>24288000
           <<by dbstore.  therefore, we now check to see if  >><<04870>>24290000
           <<it is being used by store or restore.  if       >><<04870>>24292000
           <<it is, we tell the user that this is an unknown >><<04870>>24294000
           << store / restore option...                      >><<04870>>24296000
                                                               <<04870>>24298000
      if not dbstore'tog then     <<store or restore bad>>     <<04870>>24300000
         unknown'option;                                       <<04870>>24302000
                                                               <<04870>>24304000
      end <<assure'dbstoring sub>>;                            <<04870>>24306000
   <<------------------->>                                              24308000
   subroutine get'file'part (err1, err2);                               24310000
            value   err1, err2;                                         24312000
            integer err1, err2;                                         24314000
      begin                                                             24316000
                                                                        24318000
      stepit;                                                           24320000
      if itemp <> "=" then                                              24322000
         err (err1);                                                    24324000
                                                                        24326000
      stepit;                                                           24328000
                                                                        24330000
      if itemp = "*" then                                               24332000
         err (err2);                                                    24334000
                                                                        24336000
      if parse'name (itemp, ilen) > 0 then                              24338000
         err (err2);                                                    24340000
                                                                        24342000
      end <<get'file'part sub>>;                                        24344000
   <<------------------->>                                              24346000
                                                                        24348000
   parse'other'parms := good;            <<assume no problems>>         24350000
                                                                        24352000
   itemp'offset:=options'inx;                                           24354000
   unstepit;                                                            24356000
   stepit;                                                              24358000
                                                                        24360000
$if x1=on then                <<debugging code>>                        24362000
   if debugging then                                                    24364000
      begin                                                             24366000
      say "INSIDE PARSEOTHER" endsay;                                   24368000
      debug'scanner;                                                    24370000
      end;                                                              24372000
$if                           <<debugging code>>                        24374000
                                                                        24376000
   while iclass isnt endlinev do                                        24378000
      begin                                                             24380000
                                                                        24382000
            <<allow redundant semicolons...>>                           24384000
                                                                        24386000
      while itemp = ";" do                                              24388000
         if stepit is endlinev then                                     24390000
            go end'parse'other'parms;                                   24392000
                                                                        24394000
$if x1=on then                <<debugging code>>                        24396000
      if debugging then                                                 24398000
         begin                                                          24400000
         say "   IN LOOP"endsay;                                        24402000
         debug'scanner;                                                 24404000
         end;                                                           24406000
$if                           <<debugging code>>                        24408000
                                                                        24410000
         <<---------- acct parm ------------->>                         24412000
                                                                        24414000
      if ilen = 7 and itemp = "ACCOUNT" or                              24416000
              ilen = 4 and itemp = "ACCT"    then                       24418000
         begin                                                          24420000
$if x3 = off then             <<don't allow unless stan's debugging>>   24422000
         assure'restoring;                                              24424000
$if                                                                     24426000
                                                                        24428000
         if seen'acct then                                              24430000
            err (sr'acct'redundant);                                    24432000
                                                                        24434000
         if seen'local then                                             24436000
            err (sr'local'acct);                                        24438000
                                                                        24440000
         get'file'part (sr'acct'equal, sr'acct'invname);                24442000
                                                                        24444000
         move res'acct':=itemp,(ilen);                                  24446000
                                                                        24448000
               <<do security check for account.  (see   >>              24450000
               <<if user is specifying logon account)...>>              24452000
                                                                        24454000
         if not cap'sm then                                             24456000
            if scratch' <> logon'acct', (file'part'size) then           24458000
               err (sr'need'sm);                                        24460000
                                                                        24462000
         seen'acct:=true;                                               24464000
                                                                        24466000
         end                                                            24468000
                                                                        24470000
$if x3=on then                <<stan's stuff>>                          24472000
      else if ilen = 5 and itemp = "ATTIO" then                         24474000
         seen'attio:=true                                               24476000
$if                           <<stan's stuff>>                          24478000
         <<---------- create parm ---------->>                          24480000
                                                                        24482000
      else if ilen = 6 and itemp = "CREATE" then                        24484000
         begin                                                          24486000
                                                                        24488000
         assure'restoring;                                              24490000
                                                                        24492000
         if not(cap'sm) and not(cap'am) then                            24494000
            err (rs'create'sm'or'am);                                   24496000
                                                                        24498000
         if seen'create then                                            24500000
            warn (rs'create'redundant);                                 24502000
                                                                        24504000
         seen'create := true;                                           24506000
                                                                        24508000
         stepit;                                                        24510000
                                                                        24512000
         if itemp = "=" then                                            24514000
            begin                                                       24516000
            do                                                          24518000
               begin                                                    24520000
                                                                        24522000
               stepit;                                                  24524000
                                                                        24526000
                     <<if iclass <> tokenv, we got a definite           24528000
                       error..>>                                        24530000
                                                                        24532000
               if iclass isnt tokenv then                               24534000
                  err (rs'create'opt'expected);                         24536000
                                                                        24538000
               if (ilen = 4 land itemp = "ACCT") or                     24540000
                  (ilen = 7 land itemp = "ACCOUNT") then                24542000
                     begin                                              24544000
                        if not cap'am then                              24546000
                           err (rs'create'sm);                          24548000
                        create'acct'flag:=true;                         24550000
                     end                                                24552000
                                                                        24554000
               else if ilen = 5 and itemp = "GROUP" then                24556000
                     create'group'flag:=true                            24558000
                                                                        24560000
               else if ilen = 7 and itemp = "CREATOR" then              24562000
                  create'user'flag:=true                                24564000
                                                                        24566000
                                                                        24568000
               else                                                     24570000
                  err (rs'create'opt'unknown);                          24572000
                                                                        24574000
                     <<allow ",", ";", or end-of-line...>>              24576000
                                                                        24578000
               stepit;                                                  24580000
                                                                        24582000
               end                                                      24584000
            until                                                       24586000
               itemp <> ",";                                            24588000
            end                                                         24590000
         else                                                           24592000
            begin                                                       24594000
               if cap'sm then                                           24596000
                  begin                                                 24598000
                  create'acct'flag := true;                             24600000
                  end;                                                  24602000
               if cap'am then                                           24604000
                  begin                                                 24606000
                  create'group'flag := true;                            24608000
                  create'user'flag  := true;                            24610000
                  end;                                                  24612000
            end;                                                        24614000
                                                                        24616000
                                                                        24618000
               <<we are either pointing at a semicolon (good)           24620000
                 an end-of-line (good) or something else (bad)...       24622000
                 so we unstepit so that the outer block will            24624000
                 re-examine the token...>>                              24626000
                                                                        24628000
         unstepit;                                                      24630000
                                                                        24632000
         end                                                            24634000
                                                                        24636000
         <<---------- creator parm ------->>                            24638000
                                                                        24640000
      else if ilen = 7 and itemp = "CREATOR" then                       24642000
         begin                                                          24644000
                                                                        24646000
         assure'restoring;                                              24648000
                                                                        24650000
         if seen'creator then                                           24652000
            err (sr'creator'redundant);                                 24654000
                                                                        24656000
               <<do further security checks in cxstorerestore>>         24658000
                                                                        24660000
         stepit;                                                        24662000
         if itemp <> "=" then                                  <<lb.rs>>24664000
            begin                                              <<lb.rs>>24664100
            unstepit;                                          <<lb.rs>>24664200
            blank'creator := true;                             <<lb.rs>>24664300
            end                                                <<lb.rs>>24664400
         else                                                           24666000
            begin                                                       24668000
               unstepit;                                                24670000
               get'file'part (sr'creator'equal, sr'creator'invname);    24672000
               move res'creator' := itemp,(ilen);                       24674000
            end;                                                        24676000
                                                                        24678000
                                                                        24680000
         seen'creator:=true;                                            24682000
                                                                        24684000
         end                                                            24686000
                                                                        24688000
         <<---------- date parm ---------->>                            24690000
                                                                        24692000
      else if ilen = 4 and itemp = "DATE"  or                           24694000
            ilen = 5 and itemp = "DATES" then                           24696000
         begin                                                          24698000
         assure'storing;                                                24700000
                                                                        24702000
         stepit;                                                        24704000
                                                                        24706000
         if seen'date then             <<already specified...>>         24708000
            warn (sr'date'redundant);                                   24710000
                                                                        24712000
         if itemp = "<" then                                            24714000
            use'adate:=true                                             24716000
         else if itemp = ">" then                                       24718000
            use'adate:=false                                            24720000
         else                 <<unexpected delimiter>>                  24722000
            err (sr'date'ltgt);                                         24724000
                                                                        24726000
         stepit;          <<check for equal sign>>                      24728000
                                                                        24730000
         if itemp <> "=" then                                           24732000
            err (sr'date'equal);                                        24734000
                                                                        24736000
                              <<check for valid date...>>               24738000
         stepit;                                                        24740000
                                                                        24742000
         if parse'date (pdate) = failed then                            24744000
            err (0);                                                    24746000
                                                                        24748000
         if use'adate then                                              24750000
            adate'high := pdate                                         24752000
         else                                                           24754000
            mdate'low := pdate;                                         24756000
                                                                        24758000
         seen'date:=true;                                               24760000
                                                                        24762000
         end                                                            24764000
                                                                        24766000
         <<---------- density parm ---------->>                         24768000
                                                                        24770000
      else if ilen = 7 and itemp = "DENSITY" or                         24772000
              ilen = 3 and itemp = "DEN" then                           24774000
         begin                                                          24776000
                                                                        24778000
         assure'sysdumping;                                             24780000
                                                                        24782000
         if seen'density then                                           24784000
            err (sr'density'redundant);                                 24786000
                                                                        24788000
         stepit;                                                        24790000
                                                                        24792000
         if itemp <> "=" then                                           24794000
            err (sr'density'equal);                                     24796000
                                                                        24798000
         stepit;                                                        24800000
                                                                        24802000
         if iclass is numberv then                                      24804000
            begin                                                       24806000
          <<if subclass = 0 then                                        24808000
               err (sr'density'0); >>                                   24810000
            density:=subclass;                                          24812000
            end                                                         24814000
         else                                                           24816000
            err (sr'density'expected);                                  24818000
                                                                        24820000
         seen'density:=true;                                            24822000
         end                                                            24824000
                                                                        24826000
         <<---------- dev parm ---------->>                             24828000
                                                                        24830000
      else if ilen = 3 and itemp = "DEV" then                           24832000
         begin                                                          24834000
                                                                        24836000
         assure'restoring;    <<someday, allow for store>>              24838000
                                                                        24840000
         if seen'dev then                                               24842000
            warn (sr'dev'redundant);                                    24844000
                                                                        24846000
         stepit;                                                        24848000
                                                                        24850000
         if itemp <> "=" then                                           24852000
            err (sr'dev'equal);                                         24854000
                                                                        24856000
         stepit;                                                        24858000
                                                                        24860000
         if iclass is numberv and ilen < 9 then                         24862000
            begin                                                       24864000
            if subclass = 0 then                                        24866000
               zero'dev'flag:=true                                      24868000
            else if storing then                                        24870000
               err (sr'only'0'dev);                                     24872000
            end                                                         24874000
         else if storing then                                           24876000
            err (sr'only'0'dev)                                         24878000
         else                                                           24880000
            begin                                                       24882000
            case parse'name (itemp, ilen) of                            24884000
               begin                                                    24886000
                                                                        24888000
               <<pn'ok: (0) >>                                          24890000
                  ;                                                     24892000
                                                                        24894000
               <<pn'name'too'long:  (1) >>                              24896000
                  err (sr'dev'too'long);                                24898000
                                                                        24900000
               <<pn'empty'name:     (2) >>                              24902000
                  err (sr'dev'not'found);                               24904000
                                                                        24906000
               <<pn'back'illegal:   (3) >>                              24908000
                  err (sr'dev'back'illegal);                            24910000
                                                                        24912000
               <<pn'must'start'with'alpha: (4) >>                       24914000
                  err (sr'dev'must'start'with'alpha);                   24916000
                                                                        24918000
               <<pn'illegal'character: (5) >>                           24920000
                  err (sr'dev'special);                                 24922000
                                                                        24924000
               <<pn'wildcards'illegal: (6) >>                           24926000
                  err (sr'dev'wildcards)                                24928000
               end;                                                     24930000
            end;                                                        24932000
                                                                        24934000
         seen'dev:=true;                                                24936000
                                                                        24938000
         if zero'dev'flag then                                          24940000
            move device':="DISC", 2                                     24942000
         else                                                           24944000
            move device':=itemp,(ilen), 2;                              24946000
         move *:=" ";                                                   24948000
                                                                        24950000
               <<validate device'...>>                                  24952000
                                                                        24954000
         if getdevinfo (device', deviceinfo) <> 0 then                  24956000
            err (sr'dev'class'invalid);                                 24958000
                                                                        24960000
         if deviceinfo (1).(10:3) <> 0 then       <<not disk>> <<lb.rs>>24962000
            err (sr'dev'not'disc);                                      24964000
                                                                        24966000
         end                                                            24968000
                                                                        24970000
         <<---------- files parm ---------->>                           24972000
                                                                        24974000
      else if ilen = 5 and itemp = "FILES" then                         24976000
         begin                                                          24978000
         if seen'files then             <<redundant specification>>     24980000
            warn (sr'files'redundant);                                  24982000
                                                                        24984000
         stepit;                                                        24986000
                                                                        24988000
         if itemp <> "=" then       <<missing count>>                   24990000
            err (sr'files'equal);                                       24992000
                                                                        24994000
         if stepit is numberv then                                      24996000
            g'num'fsize:=double(subclass)                               24998000
         else if iclass is dnumberv then                                25000000
            g'num'fsize:=subclass'd                                     25002000
         else if iclass is tokenv then                                  25004000
            if subclass is dnumberv then                                25006000
               err (sr'number'too'big)                                  25008000
            else if subclass is dnumberv then                           25010000
               err (sr'dnumber'too'big)                                 25012000
            else                                                        25014000
               err (sr'file'count'expected)                             25016000
         else                                                           25018000
            err (sr'file'count'expected);                               25020000
                                                                        25022000
         if g'num'fsize <= 0d then                                      25024000
            err (sr'file'count'expected);                               25026000
                                                                        25028000
         seen'files:=true;                                              25030000
                                                                        25032000
         end                                                            25034000
                                                                        25036000
         <<---------- group parm ------------>>                         25038000
                                                                        25040000
      else if ilen = 5 and itemp = "GROUP" then                         25042000
         begin                                                          25044000
$if x3 = off then             <<don't allow unless stan's debugging>>   25046000
         assure'restoring;                                              25048000
$if                                                                     25050000
                                                                        25052000
         if seen'group then                                             25054000
            err (sr'group'redundant);                                   25056000
                                                                        25058000
         if seen'local then                                             25060000
            err (sr'local'group);                                       25062000
                                                                        25064000
         get'file'part (sr'group'equal, sr'group'invname);              25066000
                                                                        25068000
         move res'group':=itemp,(ilen);                                 25070000
                                                                        25072000
               <<do security check...see if user has                    25074000
                 specified his/her logon group...    >>                 25076000
                                                                        25078000
         if not (cap'sm lor cap'am) then                                25080000
            if logon'group' <> res'group', (file'part'size) then        25082000
               err (sr'need'am);                                        25084000
                                                                        25086000
         seen'group:=true;                                              25088000
                                                                        25090000
         end                                                            25092000
         <<---------- high  parm ---------->>                  <<04870>>25094000
                                                               <<04870>>25096000
      else if ilen = 4 and itemp = "HIGH" then                 <<04870>>25098000
         begin                                                 <<04870>>25100000
                                                               <<04870>>25102000
         assure'dbstoring;                                     <<04870>>25104000
                                                               <<04870>>25106000
         if seen'high  then     <<redundant specification>>    <<04870>>25108000
            warn (sr'high'redundant);                          <<04870>>25110000
                                                               <<04870>>25112000
         stepit;                                               <<04870>>25114000
                                                               <<04870>>25116000
         if itemp <> "=" then       <<missing count>>          <<04870>>25118000
            err (sr'high'equal);                               <<04870>>25120000
                                                               <<04870>>25122000
         if stepit is numberv then                             <<04870>>25124000
            dbstore'high := subclass                           <<04870>>25126000
         else                                                  <<04870>>25128000
            err (sr'high'no'expected);                         <<04870>>25130000
                                                                        25132000
                                                               <<04870>>25134000
         if (dbstore'high < 0) or (dbstore'high > 99) then     <<04870>>25136000
            err (sr'high'no'expected);                         <<04870>>25138000
                                                               <<04870>>25140000
         if (dbstore'high < dbstore'low) then                  <<04870>>25142000
            err (sr'high'is'lower'than'low);                   <<04870>>25144000
                                                               <<04870>>25146000
         seen'high :=true;                                     <<04870>>25148000
                                                               <<04870>>25150000
         end                                                   <<04870>>25152000
                                                               <<04870>>25154000
         <<---------- keep parm ---------->>                            25156000
                                                                        25158000
      else if ilen = 4 and itemp = "KEEP" then                          25160000
         begin                                                          25162000
         assure'restoring;                                              25164000
                                                                        25166000
         if seen'keep then                                              25168000
            sendmessage (sr'keep'redundant);                            25170000
                                                                        25172000
         if seen'nokeep then                                            25174000
            err (sr'nokeep'keep);                                       25176000
                                                                        25178000
         keep'flag:= 1;                                                 25180000
                                                                        25182000
         seen'keep:=true;                                               25184000
                                                                        25186000
         end                                                            25188000
                                                                        25190000
         <<---------- ldev ---------->>                                 25192000
                                                                        25194000
      else if ilen = 4 and itemp = "LDEV" then                          25196000
         begin                                                          25198000
         assure'sysdumping;                                             25200000
                                                                        25202000
         stepit;                                                        25204000
                                                                        25206000
         if itemp <> "=" then                                           25208000
            err (sr'ldev'equal);                                        25210000
                                                                        25212000
         if stepit isnt numberv then                                    25214000
            err (sr'ldev'expected);                                     25216000
                                                                        25218000
         tape'ldev:=subclass;                                           25220000
         end                                                            25222000
                                                                        25224000
         <<---------- local ------------->>                             25226000
                                                                        25228000
      else if ilen = 5 and itemp = "LOCAL" then                         25230000
         begin                                                          25232000
$if x3 = off then             <<don't allow unless stan's debugging>>   25234000
         assure'restoring;                                              25236000
$if                                                                     25238000
         local'flag:=1;       <<don't bother checking for prior local>> 25240000
                                                                        25242000
         if seen'local then                                             25244000
            sendmessage (sr'local'redundant);                           25246000
                                                                        25248000
         if seen'group then                                             25250000
            err (sr'group'local);     <<group specified>>               25252000
                                                                        25254000
         if seen'acct then                                              25256000
            err (sr'acct'local);                                        25258000
                                                                        25260000
               <<setup res'group', and res'acct'...>>                   25262000
                                                                        25264000
         move res'group':=logon'group',(file'part'size);                25266000
         move res'acct':=logon'acct',(file'part'size);                  25268000
                                                                        25270000
         seen'local:=true;                                              25272000
                                                                        25274000
         end                                                            25276000
                                                                        25278000
$if x3=on then                <<stan's stuff>>                          25280000
         <<---------- lock parm ---------->>                            25282000
                                                                        25284000
      else if ilen = 4 and itemp = "LOCK" then                          25286000
         begin                                                          25288000
         if seen'lock then                                              25290000
            sendmessage (sr'lock'redundant);                            25292000
                                                                        25294000
         stepit;                                                        25296000
                                                                        25298000
         if itemp <> "=" then                                           25300000
            err (sr'lock'equal);                                        25302000
                                                                        25304000
         if stepit is endlinev then                                     25306000
            err (sr'lock'empty);                                        25308000
                                                                        25310000
         if ilen = 5 and itemp = "DELAY" then                           25312000
            locking'type := lock'delayv                                 25314000
                                                                        25316000
         else if ilen = 4 and itemp = "WAIT" then                       25318000
            locking'type := lock'waitv                                  25320000
                                                                        25322000
         else if ((ilen = 2) land (itemp = "NO"))                       25324000
              or ((ilen = 4) land (itemp = "NONE")) then                25326000
            begin                                                       25328000
            locking'type := lock'nonev;                                 25330000
            sendmessage (sr'lock'integrity);                            25332000
            end                                                         25334000
         else                                                           25336000
            err (sr'lock'empty);                                        25338000
                                                                        25340000
         seen'lock:=true;                                               25342000
                                                                        25344000
         end                                                            25346000
$if                           <<stan's stuff>>                          25348000
         <<---------- low  parm ---------->>                   <<04870>>25350000
                                                               <<04870>>25352000
      else if ilen = 3 and itemp = "LOW" then                  <<04870>>25354000
         begin                                                 <<04870>>25356000
                                                               <<04870>>25358000
         assure'dbstoring;                                     <<04870>>25360000
                                                               <<04870>>25362000
         if seen'low   then  <<redundant specification>>       <<04870>>25364000
            warn (sr'low'redundant);                           <<04870>>25366000
                                                               <<04870>>25368000
         stepit;                                               <<04870>>25370000
                                                               <<04870>>25372000
         if itemp <> "=" then       <<missing count>>          <<04870>>25374000
            err (sr'low'equal);                                <<04870>>25376000
                                                               <<04870>>25378000
         if stepit is numberv then                             <<04870>>25380000
            dbstore'low := subclass                            <<04870>>25382000
         else                                                  <<04870>>25384000
            err (sr'low'no'expected);                          <<04870>>25386000
                                                               <<04870>>25388000
         if (dbstore'low < 0) or (dbstore'low > 99) then       <<04870>>25390000
            err (sr'low'no'expected);                          <<04870>>25392000
                                                               <<04870>>25394000
         if (dbstore'high < dbstore'low) then                  <<04870>>25396000
            err (sr'low'is'higher'than'high);                  <<04870>>25398000
                                                               <<04870>>25400000
         seen'low :=true;                                      <<04870>>25402000
                                                               <<04870>>25404000
         end                                                   <<04870>>25406000
                                                               <<04870>>25408000
         <<---------- newdate parm ---------->>                         25410000
                                                                        25412000
      else if ilen = 7 and itemp = "NEWDATE" then                       25414000
         begin                         <<opposite of olddate>>          25416000
         assure'restoring;                                              25418000
         if seen'olddate then                                           25420000
            err (sr'olddate'newdate);                                   25422000
         if seen'newdate then                                           25424000
            warn (sr'newdate'redundant);                                25426000
         olddate'flag:= 0;                                              25428000
         seen'newdate:=true;                                            25430000
         end                                                            25432000
                                                                        25434000
         <<---------- nokeep parm ----------->>                         25436000
                                                                        25438000
      else if ilen = 6 and itemp = "NOKEEP" then                        25440000
         begin                                                          25442000
         assure'restoring;                                              25444000
         if seen'keep then                                              25446000
            err (sr'keep'nokeep);                                       25448000
         if seen'nokeep then                                            25450000
            warn (sr'nokeep'redundant);                                 25452000
         keep'flag:=0;                                                  25454000
         seen'nokeep:=true;                                             25456000
         end                                                            25458000
                                                                        25460000
         <<---------- olddate parm ---------->>                         25462000
                                                                        25464000
      else if ilen = 7 and itemp = "OLDDATE" then                       25466000
         begin                                                          25468000
         assure'restoring;                                              25470000
         if seen'newdate then                                           25472000
            err (sr'newdate'olddate);                                   25474000
         if seen'olddate then                                           25476000
            warn (sr'olddate'redundant);                                25478000
         olddate'flag:= 1;                                              25480000
         seen'olddate:=true;                                            25482000
         end                                                            25484000
                                                                        25486000
         <<---------- onerror/onerr parm ------->>                      25488000
                                                                        25490000
      else if ilen = 7 and itemp = "ONERROR" or                         25492000
              ilen = 5 and itemp = "ONERR" then                         25494000
         begin                                                          25496000
                                                                        25498000
         stepit;                                                        25500000
                                                                        25502000
         if seen'onerr then                                             25504000
            warn (sr'onerr'redundant);                                  25506000
                                                                        25508000
         if itemp <> "=" then                                           25510000
            err (sr'onerr'equal);                                       25512000
                                                                        25514000
         stepit;                                                        25516000
                                                                        25518000
         if ilen = 4 and itemp = "QUIT" then                            25520000
            on'err:= onerr'quit                                         25522000
         else if ilen = 4 and itemp = "REDO" then                       25524000
            begin                                                       25526000
            assure'storing;                                             25528000
            on'err:= onerr'redo;                                        25530000
            end                                                         25532000
         else if ilen = 4 and itemp = "SKIP" then                       25534000
            begin                                                       25536000
            assure'restoring;                                           25538000
            on'err:= onerr'skipfile;                                    25540000
            end                                                         25542000
         else if ilen = 8 and itemp = "SKIPFILE" then                   25544000
            begin                                                       25546000
            assure'restoring;                                           25548000
            on'err:= onerr'skipfile;                                    25550000
            end                                                         25552000
         else if ilen = 10 and itemp = "SKIPRECORD" then                25554000
            begin                                                       25556000
            assure'restoring;                                           25558000
            on'err:= onerr'skipfile;                                    25560000
            end                                                         25562000
         else if restoring then                                         25564000
            err (rs'onerr'option'unknown)                               25566000
         else                                                           25568000
            err (sr'onerr'option'unknown);                              25570000
                                                                        25572000
         seen'onerr:=true;                                              25574000
                                                                        25576000
         end                                                            25578000
                                                                        25580000
         <<---------- recsize parm ---------->>                         25582000
                                                                        25584000
      else if ilen = 7 and itemp = "RECSIZE" then                       25586000
         begin                                                          25588000
                                                                        25590000
         assure'sysdumping;                                             25592000
                                                                        25594000
         if seen'recsize then                                           25596000
            err (sr'recsize'redundant);                                 25598000
                                                                        25600000
         stepit;                                                        25602000
                                                                        25604000
         if itemp <> "=" then                                           25606000
            err (sr'recsize'equal);                                     25608000
                                                                        25610000
         stepit;                                                        25612000
                                                                        25614000
         if iclass is numberv then                                      25616000
            begin                                                       25618000
            if subclass = 0 then                                        25620000
               err (sr'recsize'0);                                      25622000
            recsize'init:=subclass;                                     25624000
            end                                                         25626000
         else                                                           25628000
            err (sr'recsize'expected);                                  25630000
                                                                        25632000
         seen'recsize:=true;                                            25634000
         end                                                            25636000
                                                                        25638000
         <<---------- purge   parm ---------->>                         25638100
                                                                        25638200
      else if ilen = 5 and itemp = "PURGE" then                         25638300
         begin                                                          25638400
         assure'storing;                                                25638500
         seen'purge := true;                                            25638600
         end                                                            25638700
                                                                        25638800
         <<---------- release parm ---------->>                         25640000
                                                                        25642000
      else if ilen = 7 and itemp = "RELEASE" then                       25644000
         begin                                                          25646000
         assure'storing;                                                25648000
         if seen'release then                                           25650000
            warn (sr'release'redundant);                                25652000
         release'flag:=1;                                               25654000
         seen'release:=true;                                            25656000
         end                                                            25658000
                                                                        25660000
         <<---------- show parm ---------->>                            25662000
                                                                        25664000
      else if ilen = 4 and itemp = "SHOW" then                          25666000
         begin                                                          25668000
                                                                        25670000
         if seen'show then                                              25672000
            warn (sr'show'redundant);                                   25674000
                                                                        25676000
         show'flag:=1;                                                  25678000
                                                                        25680000
         stepit;                                                        25682000
                                                                        25684000
         if itemp = "=" then                                            25686000
            begin                                                       25688000
            do                                                          25690000
               begin                                                    25692000
               stepit;                                                  25694000
                                                                        25696000
                     <<if iclass <> tokenv, we got a definite           25698000
                       error..>>                                        25700000
                                                                        25702000
               if iclass isnt tokenv then                               25704000
                  err (sr'show'opt'expected);                           25706000
                                                                        25708000
               if ilen = 5 and itemp = "DATES" then                     25710000
                  show'dates'flag:=true                                 25712000
                                                                        25714000
               else if ilen = 4 and itemp = "LONG" then                 25716000
                  begin                                                 25718000
                  if seen'show'short then                               25720000
                     sendmessage (sr'short'used)                        25722000
                  else                                                  25724000
                     begin                                              25726000
                     show'long'flag:=true;                              25728000
                     seen'show'long:=true;                              25730000
                     end;                                               25732000
                  end                                                   25734000
                                                                        25736000
               else if ilen = 7 and itemp = "OFFLINE" then              25738000
                  show'offline'flag:=true                               25740000
                                                                        25742000
               else if ilen = 8 and itemp = "SECURITY" then             25744000
                  show'security'flag:=true                              25746000
                                                                        25748000
               else if ilen = 5 and itemp = "SHORT" then                25750000
                  begin                                                 25752000
                  if seen'show'long then                                25754000
                     sendmessage (sr'long'used)                         25756000
                  else                                                  25758000
                     begin                                              25760000
                     show'short'flag:=true;                             25762000
                     seen'show'short:=true;                             25764000
                     end;                                               25766000
                  end                                                   25768000
                                                                        25770000
               else                                                     25772000
                  err (sr'show'opt'unknown);                            25774000
                                                                        25776000
                     <<allow ",", ";", or end-of-line...>>              25778000
                                                                        25780000
               stepit;                                                  25782000
                                                                        25784000
               end                                                      25786000
            until                                                       25788000
               itemp <> ",";                                            25790000
            end;                                                        25792000
                                                                        25794000
               <<we are either pointing at a semicolon (good)           25796000
                 an end-of-line (good) or something else (bad)...       25798000
                 so we unstepit so that the outer block will            25800000
                 re-examine the token...>>                              25802000
                                                                        25804000
         unstepit;                                                      25806000
                                                                        25808000
         seen'show:=true;                                               25810000
                                                                        25812000
         end                                                            25814000
                                                                        25816000
         <<---------- starthere parm-------->>                          25818000
      else if ilen = 9 and itemp = "STARTHERE" then                     25820000
         begin                                                          25822000
         assure'restoring;                                              25824000
         seen'starthere := true;                                        25826000
         end                                                            25828000
                                                                        25830000
         <<---------- syntax parm ---------->>                          25832000
                                                                        25834000
      else if ilen = 6 and itemp = "SYNTAX" then                        25836000
         syntax'tog:=true                                               25838000
                                                                        25840000
         <<---------- time parm   ---------------->>                    25844000
                                                                        25846000
      else if ilen = 4 and itemp = "TIME" then                          25848000
         seen'time := true                                              25850000
                                                                        25852000
$if x3=on then                                                          25853000
         <<---------- update parm ---------------->>                    25854000
                                                                        25856000
      else if ilen = 6 and itemp = "UPDATE" then                        25858000
         update'tog:=true                                               25860000
$if                           <<stan's stuff>>                          25862000
                                                                        25864000
         <<---------- unknown parm ---------->>                         25866000
                                                                        25868000
      else if iclass is tokenv then                                     25870000
         unknown'option                                                 25872000
      else                                                              25874000
         err (sr'semi'expected);                                        25876000
                                                                        25878000
                                                                        25880000
            <<we just parsed an option.  options must be followed       25882000
              by either a semicolon (;) or and end-of-line...>>         25884000
                                                                        25886000
      if stepit isnt endlinev then                                      25888000
         if itemp <> ";" then                                           25890000
            err (sr'semi'expected)                                      25892000
         else                                                           25894000
            stepit;           <<get token after ";">>                   25896000
                                                                        25898000
                                                                        25900000
      end;                                                              25902000
                                                                        25904000
                                                                        25906000
end'parse'other'parms:                                                  25908000
                                                                        25910000
         <<if the user is interactive and has a small line              25912000
           width (which he/she usually will) and has not                25914000
           explicitly said show=long, but has requested show,           25916000
           then we want to give him/her one line outputs, which         25918000
           requires the short flag to be set!...>>                      25920000
                                                                        25922000
   if show'flag and not show'long'flag then                             25924000
      if \syslist'recsize\ < 99 and mode.interactivebit then            25926000
         show'short'flag:=true;                                         25928000
                                                                        25930000
   end <<parse'other'parms proc>>;                                      25932000
$page ";STORMISC=  PRINT'CARROT --- PRINTS THE INPUT BUFFER AND A CARAT"25934000
$control segment=stormisc                                               25936000
<<***************************************************************>>     25938000
procedure print'carrot (inx);                                           25940000
         value inx;                                                     25942000
         integer inx;                                                   25944000
         option uncallable;                                             25946000
   begin                                                                25948000
                                                                        25950000
                                                                        25952000
   integer array                                                        25954000
      line        (0:36);            <<72 chars + 1 word>>              25956000
                                                                        25958000
   integer                                                              25960000
      left'to'print,                                                    25962000
      len;                                                              25964000
                                                                        25966000
   byte array                                                           25968000
      line'     (*) = line (0);                                         25970000
                                                                        25972000
   byte pointer                                                         25974000
      pt;                                                               25976000
                                                                        25978000
   <<--------------->>                                                  25980000
   subroutine print'line;                                               25982000
                                                                        25984000
      begin                                                             25986000
                                                                        25988000
      scan line' until 0, 1;                                            25990000
      len:=tos-logical(@line');                                         25992000
                                                                        25994000
      if syslist'num <> 0 then                                          25996000
         fwrite (syslist'num, line, -len, 0);                           25998000
                                                                        26000000
      if offline'num <> 0 then                                          26002000
         fwrite (offline'num, line, -len, 0);                           26004000
                                                                        26006000
      fill (line, 37, 0);                                               26008000
                                                                        26010000
      end <<print'line sub>>;                                           26012000
   <<---------------->>                                                 26014000
                                                                        26016000
   fill (line, 37, 0);                                                  26018000
                                                                        26020000
   left'to'print:=inputlen;                                             26022000
                                                                        26024000
$if x1=on then                <<debugging code>>                        26026000
   if debugging then                                                    26028000
      begin                                                             26030000
      say "PRINT'CARROT ... " endsay;                                   26032000
      say "LEFT'TO'PRINT=" endsay;                                      26034000
      saynum(left'to'print);                                            26036000
      say ", INX=" endsay;                                              26038000
      saynum (inx);                                                     26040000
      send;                                                             26042000
      end;                                                              26044000
$if                           <<debugging code>>                        26046000
                                                                        26048000
   @pt:=@command'text';                                                 26050000
                                                                        26052000
   while left'to'print > 0 do                                           26054000
      begin                                                             26056000
$if x1=on then                <<debugging code>>                        26058000
      if debugging then                                                 26060000
         begin                                                          26062000
         say "LEFT'TO'PRINT=" endsay;                                   26064000
         saynum (left'to'print);                                        26066000
         send;                                                          26068000
         end;                                                           26070000
$if                           <<debugging code>>                        26072000
      if (len:=left'to'print) > 72 then                                 26074000
         len:=72;                                                       26076000
      move line':=pt,(len);                                             26078000
      @pt:=@pt(len);                                                    26080000
      left'to'print:=left'to'print-len;                                 26082000
      print'line;                                                       26084000
      end;                                                              26086000
                                                                        26088000
         <<now print the carat... iff inx >= 0!!! ...>>                 26090000
                                                                        26092000
   if inx > inputlen then                                               26094000
      left'to'print:=inputlen + 1                                       26096000
   else                                                                 26098000
      left'to'print:=inx;                                               26100000
                                                                        26102000
$if x1=on then                <<debugging code>>                        26104000
   if debugging then                                                    26106000
      begin                                                             26108000
      say "NOW DO CARROT..." endsay;                                    26110000
      send;                                                             26112000
      end;                                                              26114000
$if                           <<debugging code>>                        26116000
                                                                        26118000
   while left'to'print >= 0 do                                          26120000
      begin                                                             26122000
$if x1=on then                <<debugging code>>                        26124000
      if debugging then                                                 26126000
         begin                                                          26128000
         say "LEFT'TO'PRINT=" endsay;                                   26130000
         saynum (left'to'print);                                        26132000
         send;                                                          26134000
         end;                                                           26136000
$if                           <<debugging code>>                        26138000
                                                                        26140000
      if left'to'print < 72 then                                        26142000
         begin                                                          26144000
         fill' (line, left'to'print, " ");                              26146000
         move line'(left'to'print):=("^", 0);                           26148000
         end;                                                           26150000
                                                                        26152000
      left'to'print:=left'to'print - 72;                                26154000
                                                                        26156000
      print'line;                                                       26158000
      end;                                                              26160000
                                                                        26162000
$if x1=on then                <<debugging code>>                        26164000
   if debugging then                                                    26166000
      begin                                                             26168000
      say "END PRINT'CARROT" endsay;                                    26170000
      send;                                                             26172000
      end;                                                              26174000
$if                           <<debugging code>>                        26176000
                                                                        26178000
   end <<print'carrot proc>>;                                           26180000
$page ";STORMISC=  PRINT'FILE'ERROR --- PRINTS FILE I/O ERRORS"         26182000
$control segment=stormisc                                               26184000
<<***************************************************************>>     26186000
procedure print'file'error (fid);                                       26188000
         value   fid;                                                   26190000
         integer fid;                                                   26192000
   begin                                                                26194000
                                                                        26196000
                                                                        26198000
   integer                                                              26200000
      err         := 0;                                                 26202000
                                                                        26204000
$if x1=on then                <<debugging code>>                        26206000
   if debugging then                                                    26208000
      begin                                                             26210000
      say "PRINT'FILE'ERROR (" endsay;                                  26212000
      saynum (fid);                                                     26214000
      say1 (")");                                                       26216000
      send;                                                             26218000
      end;                                                              26220000
$if                           <<debugging code>>                        26222000
                                                                        26224000
   fcheck (fid, err);                                                   26226000
                                                                        26228000
   if = then                                                            26230000
      begin                                                             26232000
      disable'arithmetic'traps;                                         26234000
      if stdlist'num > 0 then                                           26236000
         genmsg (io'message'set, err, %133333, , , , , ,                26238000
                 -stdlist'num);                                         26240000
      if offline'num > 0 then                                           26242000
         genmsg (io'message'set, err, %133333, , , , , ,                26244000
                 -offline'num);                                         26246000
      end;                                                              26248000
                                                                        26250000
   end <<print'file'error proc>>;                                       26252000
$page                                                                   26252010
$control segment=stormisc                                               26252020
procedure purge'files;                                                  26252030
                                                                        26252040
   ! this procedure purges files that were successfully                 26252050
   ! stored when the purge option is set.  the good file                26252060
   ! is rewound and each record is read from it.  if the                26252070
   ! purge bit is set (the file was stored correctly) then              26252080
   ! the file is opened with write access.  if the open                 26252090
   ! succeeds then the file is closed with disp=purge                   26252100
   ! if the purge succeeds then ok, otherwise close the                 26252110
   ! file as it previously existed.  if the open or close-purge         26252120
   ! fail then a message is sent to the user saying that the            26252130
   ! file was not purged and the file system error message              26252140
   ! explaining why it was not purged.                                  26252150
                                                                        26252160
begin                                                                   26252170
   byte array                                                           26252180
      filename' (0:5*file'part'size);                                   26252190
                                                                        26252200
   logical array                                                        26252210
      gbuf    (0:g'recsize);                                            26252220
                                                                        26252230
   byte array                                                           26252240
      gbuf'   (*)  = gbuf;                                              26252250
                                                                        26252260
   integer                                                              26252270
      len;                                                              26252280
                                                                        26252290
   logical                                                              26252300
      purge'worked;                                                     26252310
                                                                        26252320
   subroutine file'fail (fid, msgn);                                    26252330
      value fid, msgn;                                                  26252340
      integer fid, msgn;                                                26252350
   begin                                                                26252360
      if fid <> no'file then                                            26252370
         print'file'error (fid);                                        26252380
                                                                        26252390
      if msgn <> 0 then                                                 26252400
         sendmessage (msgn);                                            26252410
                                                                        26252420
      goto end'purge'files;                                             26252430
   end;                                                                 26252440
   if not seen'purge then                                               26252441
      return;                                                           26252442
                                                                        26252450
   rewind'good'file;                                                    26252460
                                                                        26252470
   read'good'file;                                                      26252480
                                                                        26252490
   while = do                                                           26252500
      begin                                                             26252510
                                                                        26252520
$if x1=on then                                                          26252530
      if debugging then                                                 26252540
         say gbuf' (g'title'inx'), (3*file'part'size) endsay;           26252550
$if                                                                     26252560
                                                                        26252570
      if g'purge'bit then                                               26252580
         begin                                                          26252590
                                                                        26252600
$if x1=on then                                                          26252610
         if debugging then                                              26252620
            say " PURGING " endsay;                                     26252630
$if                                                                     26252640
                                                                        26252650
         display'3'to'display (filename', len,                          26252660
                               gbuf' (g'file'inx'),                     26252670
                               gbuf' (g'group'inx'),                    26252680
                               gbuf' (g'acct'inx'));                    26252690
                                                                        26252700
         filename' (len) := " ";                                        26252710
                                                                        26252720
         purge'worked := false;                                         26252730
                                                                        26252740
         parms'tempi'1 := fopen (filename',                             26252750
                                 %2001,                                 26252760
                                 %101);                                 26252770
                                                                        26252780
         if = then                                                      26252790
            begin                                                       26252800
                                                                        26252810
$if x1=on then                                                          26252820
            if debugging then                                           26252830
               say " - FILE OPENED " endsay;                            26252840
$if                                                                     26252850
                                                                        26252860
            fclose (parms'tempi'1, 4, 0);                               26252870
            if = then                                                   26252880
               begin                                                    26252890
               purge'worked := true;                                    26252900
                                                                        26252910
$if x1=on then                                                          26252920
               if debugging then                                        26252930
                  say " - FILE PURGED " endsay;                         26252940
$if                                                                     26252950
                                                                        26252960
               end                                                      26252970
                                                                        26252980
            else                                                        26252990
               fclose (parms'tempi'1, 0, 0);                            26253000
            end;                                                        26253010
                                                                        26253020
         if not purge'worked then                                       26253030
            sendmessage (m'not'purged);                                 26253040
                                                                        26253050
$if x1=on then                                                          26253060
         if debugging then                                              26253061
            send;                                                       26253070
$if                                                                     26253080
                                                                        26253090
         end;                                                           26253095
      read'good'file;                                                   26253100
      end;                                                              26253110
                                                                        26253120
end'purge'files:                                                        26253130
                                                                        26253140
end;                                                                    26253150
$page ";STORMISC=  READ'DISK --- JACKET FOR ATTACHIO DISK READ"         26254000
$control segment=stormisc                                               26256000
<<***************************************************************>>     26258000
logical procedure read'disk (ldev, address, dst, buffer, len, iob);     26260000
         value   ldev, address, dst, buffer, len;  <<name iob;>>        26262000
         integer ldev, dst, buffer, len;                                26264000
         double  address, iob;                                          26266000
         option privileged, uncallable;                                 26268000
                                                                        26270000
         <<this routine reads the specified number of                   26272000
           words/bytes from disk to the designated buffer.              26274000
           (if len >= 0, is in units of words; if < 0, is               26276000
           in units of bytes.)                                          26278000
           if dst = 0, then buffer is a db relative stack               26280000
           address; if dst > 0 then buffer is the offset into           26282000
           the data segment.>>                                          26284000
                                                                        26286000
   begin                                                                26288000
                                                                        26290000
   double                                                               26292000
      local'iob   := 0d;                                                26294000
                                                                        26296000
   integer                                                              26298000
      a1          = address + 0,                                        26300000
      a2          = address + 1,                                        26302000
      attio'status= local'iob + 0;                                      26304000
                                                                        26306000
$if x1=on then                <<debugging code>>                        26308000
   if debug'disk then                                                   26310000
      begin                                                             26312000
      say "READ'DISK (" endsay;                                         26314000
      saynum (ldev);                                                    26316000
      say1 ("%");                                                       26318000
      saydoctal (address);                                              26320000
      say " -> " endsay;                                                26322000
      saynum (dst);                                                     26324000
      say " @ %" endsay;                                                26326000
      sayoctal (buffer);                                                26328000
      say " for " endsay;                                               26330000
      saynum (len);                                                     26332000
      send;                                                             26334000
      end;                                                              26336000
$if                           <<debugging code>>                        26338000
                                                                        26340000
         <<read from disk...for explanation of attachio                 26342000
           parameters, see i/o system ims...>>                          26344000
                                                                        26346000
   disable'arithmetic'traps;                                            26348000
                                                                        26350000
   local'iob:=attachio (                                                26352000
                  ldev,                                                 26354000
                  0,          <<qmisc>>                                 26356000
                  dst,        << 0 = stack, >0 = dst>>                  26358000
                  buffer,     <<offset into stack/dst of data>>         26360000
                  attio'read, << 0 = read, 1 = write>>                  26362000
                  len,        << # of words to read>>                   26364000
                  a1,         << top half of disc address>>             26366000
                  a2,         << bottom half of disc address>>          26368000
                  1);         << request=blocked...wait til done>>      26370000
                                                                        26372000
   iob:=local'iob;                                                      26374000
                                                                        26376000
   if attio'status.attio'statusf = attio'good then                      26378000
      read'disk:=good                                                   26380000
   else                                                                 26382000
      read'disk:=failed;                                                26384000
                                                                        26386000
$if x1=on then                <<debugging code>>                        26388000
   if debug'disk then                                                   26390000
      begin                                                             26392000
      say "   READ'DISK --> " endsay;                                   26394000
      say1 ("%");                                                       26396000
      sayoctal (attio'status);                                          26398000
      say " (status=" endsay;                                           26400000
      saynum (attio'status.attio'statusf);                              26402000
      say1 (")");                                                       26404000
      send;                                                             26406000
      end;                                                              26408000
$if                           <<debugging code>>                        26410000
                                                                        26412000
   <<enable'arithmetic'traps;  ... not done because the                 26414000
     procedure exit will restore them to the caller's                   26416000
     old state.>>                                                       26418000
                                                                        26420000
   end <<read'disk proc>>;                                              26422000
$page ";STORMISC=  READ'LABEL --- FILE LABEL ROUTINES"                  26424000
$control segment=stormisc                                               26426000
<<***************************************************************>>     26428000
logical procedure read'label (ldev, address, gotit);                    26430000
         value gotit, ldev, address;                                    26432000
         logical gotit;    <<if false, will do a getsir>>               26434000
         integer ldev;                                                  26436000
         double address;                                                26438000
         option privileged, uncallable;                                 26440000
                                                                        26442000
      <<this procedures reads the file label without doing a            26444000
        flabio.  why? because the caller (thunk'store), does            26446000
        extensive checking on the label, and reports the                26448000
        exact error that was found.  flabio merely reports              26450000
        two flavors of error: hard (label was incorrect somehow)        26452000
        and soft (disc read error).                             >>      26454000
                                                                        26456000
   begin                                                                26458000
                                                                        26460000
                                                                        26462000
   double                                                               26464000
      iob         := 0d;                                                26466000
                                                                        26468000
   integer                                                              26470000
      local'fisir'info;                                                 26472000
                                                                        26474000
   if not gotit then                                                    26476000
      local'fisir'info:=getsir (fisir);      <<get file label sir>>     26478000
                                                                        26480000
         <<read the file label from disc...>>                           26482000
                                                                        26484000
   read'label:=read'disk (ldev, address, my'stack, @flab,               26486000
                          file'label'size, iob);                        26488000
                                                                        26490000
   if not gotit then                                                    26492000
      relsir (fisir, local'fisir'info);   <<release label sir>>         26494000
                                                                        26496000
   end <<read'label proc>>;                                             26498000
$page ";STORMISC=  RELEASE'SIRS --- RELEASE FILE-INTEG&DIRECTORY SIR"   26500000
$control segment=stormisc                                               26502000
<<***************************************************************>>     26504000
procedure release'sirs (rel'fisir, rel'dsir);                           26506000
         value   rel'fisir, rel'dsir;                                   26508000
         logical rel'fisir, rel'dsir;                                   26510000
         option uncallable;                                             26512000
                                                                        26514000
   begin                                                                26516000
                                                                        26518000
                                                                        26520000
$if x1=on then                <<debugging code>>                        26522000
   if debugging then                                                    26524000
      begin                                                             26526000
      say "   RELEASE'SIRS (" endsay;                                   26528000
      if rel'fisir then                                                 26530000
         say "FISIR" endsay;                                            26532000
      if rel'fisir and rel'dsir then                                    26534000
         say ", " endsay;                                               26536000
      if rel'dsir then                                                  26538000
         say "DSIR" endsay;                                             26540000
      say1 (")");                                                       26542000
      say "   have: " endsay;                                           26544000
      if got'fisir then say "FISIR " endsay;                            26546000
      if got'dsir then                                                  26548000
         begin                                                          26550000
         say "DSIR (info=" endsay; saynum(dsir'info);                   26552000
         say1 (")");                                                    26554000
         end;                                                           26556000
      send;                                                             26558000
                                                                        26560000
      if debug'sirs then                                                26562000
         debug;                                                         26564000
      end;                                                              26566000
$if                           <<debugging code>>                        26568000
                                                                        26570000
   if rel'dsir and got'dsir then                                        26572000
      begin                                                             26574000
      relsir (dsir, dsir'info);                                         26576000
$if x1=on then                <<debugging code>>                        26578000
      if debug'sirs then                                                26580000
         begin                                                          26582000
         say "...rel DSIR" endsay;                                      26584000
         send;                                                          26586000
         debug;                                                         26588000
         end;                                                           26590000
$if                           <<debugging code>>                        26592000
      got'dsir:=false;                                                  26594000
      end;                                                              26596000
                                                                        26598000
   if rel'fisir and got'fisir then                                      26600000
      begin                                                             26602000
      relsir (fisir, fisir'info);                                       26604000
$if x1=on then                <<debugging code>>                        26606000
      if debug'sirs then                                                26608000
         begin                                                          26610000
         say "...rel FISIR" endsay;                                     26612000
         send;                                                          26614000
         debug;                                                         26616000
         end;                                                           26618000
$if                           <<debugging code>>                        26620000
      got'fisir:=false;                                                 26622000
      end;                                                              26624000
                                                                        26626000
   end <<release'sirs proc>>;                                           26628000
$page ";STORMISC=  REOPEN'FILE --- FILE OPENING ROUTINE"                26630000
$control segment=stormisc                                               26632000
<<***************************************************************>>     26634000
logical procedure reopen'file (fileno,                                  26636000
                               desig, foptions, aoptions, recsize);     26638000
         value foptions, aoptions, recsize;                             26640000
         integer fileno, recsize;                                       26642000
         logical foptions, aoptions;                                    26644000
         integer array desig;                                           26646000
         option uncallable;                                             26648000
      <<This routine FCLOSEs the file FILENO with a "close, no          26650000
        rewind" command.  It the re-opens the file.  If the FOPEN       26652000
        fails, failed is returned, error'info is set to either          26654000
        err'ccl or err'ccg and error'code is set to the error           26656000
        number (as given by fcheck).  if the fopen succeeds,            26658000
        good is returned, and error'code and error'info are set         26660000
        to 0.>>                                                         26662000
   begin                                                                26664000
                                                                        26666000
                                                                        26668000
   byte array                                                           26670000
      desig'      (*) = desig (0);                                      26672000
                                                                        26674000
   reopen'file:=good;                                                   26676000
   error'code:=error'info:=0;                                           26678000
                                                                        26680000
   fclose (fileno, 3, 0);     <<close, no rewind>>                      26682000
                                                                        26684000
   fileno:=fopen (desig', foptions, aoptions, recsize);                 26686000
                                                                        26688000
   if > then                                                            26690000
      begin                                                             26692000
      error'info:=err'ccg;    <<shouldn't happen>>                      26694000
      fcheck (fileno, error'code);                                      26696000
      parms'tempi'1:=@desig';                                           26698000
      parms'tempi'2:=24;      <<title is 24 chars long>>                26700000
      sendmessage (m'open'fail);                                        26702000
      reopen'file:=failed;                                              26704000
      end                                                               26706000
   else if < then                                                       26708000
      begin                                                             26710000
      error'info:=err'ccl;                                              26712000
      fcheck (fileno, error'code);                                      26714000
      parms'tempi'1:=@desig';                                           26716000
      parms'tempi'2:=24;      <<title is 24 chars long>>                26718000
      sendmessage (m'open'fail);                                        26720000
      reopen'file:=failed;                                              26722000
      end;                                                              26724000
                                                                        26726000
   end <<reopen'file proc>>;                                            26728000
$page ";STORMISC=  STEPIT' --- THE SCANNER"                             26730000
$control segment=stormisc                                               26732000
<<***************************************************************>>     26734000
integer procedure stepit';                                              26736000
         option uncallable;                                             26738000
   begin                                                                26740000
                                                                        26742000
   <<--------------------------------------------------------           26744000
      this is the scanner!                                              26746000
                                                                        26748000
      uses:                                                             26750000
         itemp    a byte pointer (sort of)                              26752000
                  pointing to the first character of the current        26754000
                  token.                                                26756000
                                                                        26758000
         itemp'offset controls where itemp points...this kludge         26760000
                  was used to convert stepit from a routine that        26762000
                  operates on globals to one that has all of its        26764000
                  parameters passed thru store/restore's parms          26766000
                  array.                                                26768000
                  itemp'offset ranges from 0 to inputlen.               26770000
                  thus, itemp always points within command'text'.       26772000
                                                                        26774000
         iclass   the class of the current token, valid classes         26776000
                  are:                                                  26778000
                     endlinev  ... itemp = %15 (carriage return)        26780000
                     tokenv    ... itemp points to a token of           26782000
                        length ilen.  tokens are letter strings,        26784000
                        alphanumeric strings (beginning with a          26786000
                        letter), or either of the above with an         26788000
                        asterisk in front (*).  thus, the               26790000
                        following are tokens: a, ab, abcd4z,            26792000
                        *a, *a, *a4; and the following are not:         26794000
                        *, 5, $a, 5a, 5a, *5, *5a, a#b.                 26796000
                                                                        26798000
         ilen     the length of the current token, number, or           26800000
                  special character, or string.                         26802000
                                                                        26804000
         subclass extra information.  if iclass = numberv, then         26806000
                  this is the actual binary value.  if iclass =         26808000
                  dnumberv, then subclass'd has the double              26810000
                  integer value.  if iclass is stringv, then            26812000
                  subclass is ilen-2 (i.e: the length without the       26814000
                  (") characters.                                       26816000
                                                                        26818000
         inputlen this is the number of characters in command'text',    26820000
                  exclusive of the carriage-return.  it is never        26822000
                  altered by stepit'.                                   26824000
                                                                        26826000
      deduces:                                                          26828000
         ileft    the number of characters between itemp and            26830000
                  the end of input, inclusive of the character          26832000
                  pointed to by itemp, exclusive of the carriage        26834000
                  return.  thus, if "A",%15 is left, and itemp          26836000
                  points to "A", then ileft = 1.                        26838000
                  note: ileft <--> inputlen-itemp'offset.               26840000
                                                                        26842000
      note 1:                                                           26844000
                                                                        26846000
         the word 'token' is often used in this program.  it            26848000
         is defined as: an entity returned by stepit.  thus,            26850000
         the following are each examples of a single token:             26852000
                                                                        26854000
               a  abw   a   a1  a1bd   &  9   90   ^   /   *a   *a4     26856000
                                                                        26858000
         and the following are each examples of contiguous              26860000
         character strings that are 2 tokens:                           26862000
                                                                        26864000
               a#   a#   $a   $a   8a   @l   l@   //   :=   ()          26866000
                                                                        26868000
         the word 'token' and the iclass of tokenv should not           26870000
         be confused.  tokenv should probably have been called          26872000
         identifierv, but was not for historical reasons.               26874000
                                                                        26876000
      note 2:                                                           26878000
                                                                        26880000
         tokens (iclass = tokenv) are automatically upshifted.          26882000
         numbers are automatically converted to single precision        26884000
         integers if possible, otherwise they are treated as            26886000
         doubles.  a "D" appearing after a number will force it         26888000
         to be returned as a double word value (dnumberv).              26890000
         (if a "D" is found, the value of ilen includes it.)            26892000
         if a number is too big for a double, iclass will be            26894000
         tokenv and subclass will be dnumberv.  (normally,              26896000
         subclass for tokens is 0.)                                     26898000
                                                                        26900000
      note 3:                                                           26902000
                                                                        26904000
         the text is assumed to have a carriage return as a             26906000
         delimiter.  repeated calls on stepit when the prior call       26908000
         resulted in endlinev will also return endlinev.                26910000
                                                                        26912000
         stepit's result is a copy of iclass, thus the two              26914000
         statements:                                                    26916000
               stepit; if iclass is endlinev ...                        26918000
         and                                                            26920000
               if stepit is endlinev ...                                26922000
         are equivalent.                                                26924000
                                                                        26926000
      -------------------------------------------------------->>        26928000
                                                                        26930000
                                                                        26932000
   integer                                                              26934000
      i,                                                                26936000
      len;                                                              26938000
                                                                        26940000
   byte pointer                                                         26942000
      copy'itemp,                                                       26944000
      ptr;                                                              26946000
                                                                        26948000
   define                                                               26950000
      input'stopper = %15 #;    <<carriage return>>                     26952000
                                                                        26954000
   label                                                                26956000
      end'stepit;                                                       26958000
                                                                        26960000
   <<--------------->>                                                  26962000
   <<  bump'itemp   >>                                                  26964000
   <<--------------->>                                                  26966000
                                                                        26968000
   subroutine bump'itemp (n);                                           26970000
            value   n;                                                  26972000
            integer n;                                                  26974000
      begin                                                             26976000
                                                                        26978000
      itemp'offset:=integer(logical(itemp'offset)+logical(n));          26980000
                                                                        26982000
      ileft:=inputlen - itemp'offset;                                   26984000
                                                                        26986000
            <<guarantee that we won't overflow our text buffer...>>     26988000
                                                                        26990000
      if itemp'offset > inputlen or ileft <= 0 then                     26992000
         begin                                                          26994000
         itemp'offset:=inputlen;          <<point to %15>>              26996000
         itemp:=%15;       <<probably not needed>>                      26998000
         ileft:=0;                                                      27000000
         end;                                                           27002000
                                                                        27004000
      @copy'itemp:=@itemp;                                              27006000
                                                                        27008000
      end <<bump'itemp sub>>;                                           27010000
                                                                        27012000
   <<--------------->>                                                  27014000
   <<  return'them  >>                                                  27016000
   <<--------------->>                                                  27018000
                                                                        27020000
   subroutine return'them (ic, sc, l);                                  27022000
            value   ic, sc, l;                                          27024000
            integer ic, sc, l;                                          27026000
      begin                                                             27028000
                                                                        27030000
      iclass:=ic;                                                       27032000
      ilen:=l;                                                          27034000
      subclass:=sc;                                                     27036000
      stepit':=ic;                                                      27038000
                                                                        27040000
      go end'stepit;                                                    27042000
                                                                        27044000
      end <<return'them sub>>;                                          27046000
                                                                        27048000
   <<------------------>>                                               27050000
   <<  return'endline  >>                                               27052000
   <<------------------>>                                               27054000
                                                                        27056000
   subroutine return'endline;                                           27058000
      begin                                                             27060000
                                                                        27062000
      ilen:=0;                                                          27064000
                                                                        27066000
      return'them (endlinev, 0, 0);                                     27068000
                                                                        27070000
      end <<return'endline sub>>;                                       27072000
                                                                        27074000
   <<------------------>>                                               27076000
   <<  return'special  >>                                               27078000
   <<------------------>>                                               27080000
                                                                        27082000
   subroutine return'special;                                           27084000
      begin                                                             27086000
                                                                        27088000
      return'them (specialv, itemp, 1);                                 27090000
                                                                        27092000
      end <<return'special sub>>;                                       27094000
                                                                        27096000
   <<--------------->>                                                  27098000
   <<  scan'number  >>                                                  27100000
   <<--------------->>                                                  27102000
                                                                        27104000
   subroutine scan'number;                                              27106000
      begin                                                             27108000
                                                                        27110000
      move itemp:=itemp while n, 1;      <<leave dest pointer>>         27112000
      len:=logical(tos)-logical(@itemp);                                27114000
      ilen:=len;                                                        27116000
                                                                        27118000
      if copy'itemp(len) = "D" then                                     27120000
         ilen:=ilen+1;                                                  27122000
                                                                        27124000
      subclass'd:=dbinary (itemp, len);                                 27126000
                                                                        27128000
      if <> then                    <<number too big!>>                 27130000
         return'them (tokenv, dnumberv, len);                           27132000
                                                                        27134000
      if subclass'd <= 32767d and copy'itemp(len) <> "D" then           27136000
         begin           <<small enough to be single word...>>          27138000
         subclass:=integer(subclass'd);                                 27140000
         return'them (numberv, subclass, ilen);                         27142000
         end;                                                           27144000
                                                                        27146000
      return'them (dnumberv, subclass, ilen);                           27148000
                                                                        27150000
      end <<scan'number sub>>;                                          27152000
                                                                        27154000
   <<--------------->>                                                  27156000
   <<  scan'string  >>                                                  27158000
   <<--------------->>                                                  27160000
                                                                        27162000
   subroutine scan'string;                                              27164000
      begin                                                             27166000
                                                                        27168000
      i.(8:8):="""";                                                    27170000
      i.(0:8):=input'stopper;          <<usually a carriage return>>    27172000
      scan copy'itemp(1) until i, 1;    <<leave byte address>>          27174000
      @ptr:=tos;                       <<pick up pointer>>              27176000
                                                                        27178000
      if ptr = """" then               <<found trailing quote...>>      27180000
         begin                                                          27182000
         len:=(logical(@ptr)-logical(@itemp)) - logical(1);             27184000
               <<length, including quotes>>                             27186000
         return'them (stringv, len-2, len);                             27188000
         end                                                            27190000
      else                                                              27192000
         return'special;                                                27194000
                                                                        27196000
      end <<scan'string sub>>;                                          27198000
                                                                        27200000
   <<-------------->>                                                   27202000
   <<  scan'token  >>                                                   27204000
   <<-------------->>                                                   27206000
                                                                        27208000
   subroutine scan'token;                                               27210000
      begin                                                             27212000
            <<see how many of the first 'ilen' chars are                27214000
              alphanumeric...>>                                         27216000
                                                                        27218000
      if itemp = "*" then              <<a back reference!>>            27220000
         move copy'itemp(1):=copy'itemp(1) while ans, 1                 27222000
      else                                                              27224000
         move copy'itemp(0):=copy'itemp(0) while ans, 1;                27226000
                                                                        27228000
      len:=logical(tos)-logical(@copy'itemp);     <<# chars moved>>     27230000
                                                                        27232000
      return'them (tokenv, 0, len);                                     27234000
                                                                        27236000
      end <<scan'token sub>>;                                           27238000
                                                                        27240000
   <<--------------->>                                                  27242000
   <<  skip'blanks  >>                                                  27244000
   <<--------------->>                                                  27246000
                                                                        27248000
   subroutine skip'blanks;                                              27250000
      begin                                                             27252000
            <<find first non-blank...scan until " " or %15...>>         27254000
                                                                        27256000
      if itemp = " " then                                               27258000
         begin                                                          27260000
         scan itemp while "  ",1;      <<leave byte address>>           27262000
         len:=logical(tos)-logical(@itemp);                             27264000
         bump'itemp (len);             <<itemp points to 1st non " ">>  27266000
         end;                                                           27268000
                                                                        27270000
      if itemp = input'stopper then    <<is anything left?>>            27272000
         return'endline;                                                27274000
                                                                        27276000
      end <<skip'blanks sub>>;                                          27278000
                                                                        27280000
   <<------------------>>                                               27282000
   <<  skip'old'token  >>                                               27284000
   <<------------------>>                                               27286000
                                                                        27288000
   subroutine skip'old'token;                                           27290000
      begin                                                             27292000
                                                                        27294000
      bump'itemp (ilen);                                                27296000
                                                                        27298000
      if itemp = input'stopper then                                     27300000
         return'endline;                                                27302000
                                                                        27304000
      end <<skip'old'token sub>>;                                       27306000
                                                                        27308000
   <<--------------------------->>                                      27310000
                                                                        27312000
   skip'old'token;                                                      27314000
                                                                        27316000
   skip'blanks;                                                         27318000
                                                                        27320000
         <<examine the token...>>                                       27322000
                                                                        27324000
   if "A" <= itemp and itemp <= "Z" then                                27326000
      scan'token                                                        27328000
                                                                        27330000
   else if "a" <= itemp and itemp <= "z"then                            27332000
      scan'token                                                        27334000
                                                                        27336000
   else if itemp = "*" then                                             27338000
      if    "A" <= copy'itemp(1) and copy'itemp(1) <= "Z" or            27340000
            "a" <= copy'itemp(1) and copy'itemp(1) <= "z" then          27342000
         scan'token                                                     27344000
      else                                                              27346000
         return'special                                                 27348000
                                                                        27350000
   else if "0" <= itemp and itemp <= "9" then                           27352000
      scan'number                                                       27354000
                                                                        27356000
   else if itemp="""" then                                              27358000
      scan'string                                                       27360000
                                                                        27362000
   else                                                                 27364000
      return'special;                                                   27366000
                                                                        27368000
end'stepit:                                                             27370000
                                                                        27372000
$if x1=on then                <<debugging code>>                        27374000
   if debugging and debug'stepit then                                   27376000
      begin                                                             27378000
      say "STEPIT': " endsay;                                           27380000
      debug'scanner;                                                    27382000
      end;                                                              27384000
$if                           <<debugging code>>                        27386000
                                                                        27388000
   end <<stepit' proc>>;                                                27390000
$page ";STORMISC=  STRIP'SEQUENCE'NUMBER --- UTILITY"                   27392000
$control segment=stormisc                                               27394000
<<***************************************************************>>     27396000
procedure strip'sequence'number (buf', len);                            27398000
         byte array buf';                                               27400000
         integer len;         <<name len;>>                             27402000
         option privileged, uncallable;                                 27404000
                                                                        27406000
   << this procedure examines the last 8 characters of the              27408000
      text in buf'.  if they are all digits, it is considered           27410000
      to be a "sequence number", and len will be reduced by 8.          27412000
                                                             >>         27414000
   begin                                                                27416000
                                                                        27418000
   byte pointer                                                         27420000
      p;                      <<points along buf'>>                     27422000
                                                                        27424000
   byte                                                                 27426000
      save'char;              <<character at buf'(len)>>                27428000
                                                                        27430000
                                                                        27432000
         <<if we don't have at least 9 characters, then                 27434000
           we arbitrarily state that there is no sequence               27436000
            number!...>>                                                27438000
                                                                        27440000
   if len > 8 then                                                      27442000
      begin                                                             27444000
                                                                        27446000
            <<save the character after the len characters               27448000
              in buf'...>>                                              27450000
                                                                        27452000
      save'char:=buf'(len);                                             27454000
                                                                        27456000
            <<smash buf'(len) to a non-digit...>>                       27458000
                                                                        27460000
      buf'(len):=0;                                                     27462000
                                                                        27464000
            <<find out how many digits there are, starting              27466000
              at the first of the last 8 characters...>>                27468000
                                                                        27470000
      @p:=@buf'(len-8);                                                 27472000
                                                                        27474000
      move p:=p while n, 1;   <<leave dest address>>                    27476000
                                                                        27478000
            <<restore the smashed character...>>                        27480000
                                                                        27482000
      buf'(len):=save'char;                                             27484000
                                                                        27486000
            <<see how many digits there were...>>                       27488000
                                                                        27490000
      if tos - logical(@p) = 8 then                                     27492000
         len:=len-8;          <<aha...a sequence number!>>              27494000
      end;                                                              27496000
                                                                        27498000
   end <<strip'sequence'number proc>>;                                  27500000
$page ";STORMISC=  TAPE'RECSIZE'WAS'SPECIFIED --- UTILITY"              27502000
$control segment=stormisc                                               27504000
<<***************************************************************>>     27506000
logical procedure tape'recsize'was'specified;                           27508000
         option privileged, uncallable;                                 27510000
                                                                        27512000
   <<--------------------------------------------------------------     27514000
                                                                        27516000
      this procedure handles a kludge which is relevant only to         27518000
   those programs/procedures which open a new store tape.               27520000
                                                                        27522000
      the calling procedure opens the store/restore tape (serial        27524000
   disc) file with a block size of 4096 words.  however, for 6250       27526000
   bpi tapes which use the attachio algorithm, the default block        27528000
   size really wants to be 8192 words.  (default here means that the    27530000
   user has not used a file equation to specify the file's block        27532000
   size.)  in this case, the caller must signal fstore/irestore         27534000
   that the block size returned by fgetinfo (4096 words) should be      27536000
   ignored and that the actual block size should be 8192 words.         27538000
   this procedure sets a flag when it detects this situation.           27540000
                                                                        27542000
   (the attachio algorithm is: use multiple parallel writes             27544000
   via attachio to write data to the tape.  the normal algorithm        27546000
   is to use fwrite to write data to the tape.)                         27548000
                                                                        27550000
   input:                                                               27552000
      parms --- defines the "global" environment...used various         27554000
                tape attributes like: ldev, density, name.              27556000
                                                                        27558000
   result:                                                              27560000
      false ---  the user has not specified a recsize for the           27562000
                 tape file.                                             27564000
                 (in this case, if the tape was a local & unlabeled     27566000
                 7976, store will write to it via attachio in blocks    27568000
                 of 8192 words rather than 4096 words.)                 27570000
                                                                        27572000
      true  ---  a recsize was specified by the user.                   27574000
                                                                        27576000
   note: the numbers "4096" and "8192" do not appear as magic           27578000
   numbers in the real code...default'tape'recsize is used              27580000
   instead of 4096, and max'7976'recsize is used instead of             27582000
   8192.                                                                27584000
                                                                        27586000
   called by:  cxstore'restore                                          27588000
                                                                        27590000
   db must be at stack !!                                               27592000
                                                                        27594000
   ------------------------------------------------------------>>       27596000
                                                                        27598000
   begin                                                                27600000
                                                                        27602000
                                                                        27604000
   integer                                                              27606000
      i;                      <<scratch integer>>                       27608000
                                                                        27610000
   logical                                                              27612000
      maskhi,                 <<1st word of feq option bits>>           27614000
      masklow;                <<2nd word of feq option bits>>           27616000
                                                                        27618000
   byte pointer                                                         27620000
      desig';                 <<points at tape name>>                   27622000
                                                                        27624000
   byte                                                                 27626000
      dummy'      := " ";     <<dummy for xretpmask>>                   27628000
                                                                        27630000
                                                                        27632000
         <<initialization -- no errors/no special case>>                27634000
                                                                        27636000
                                                                        27638000
   @desig':=@tape'name';                                                27640000
   if desig' = "*" then                                                 27642000
      @desig':=@desig'(1);    <<skip the "*">>                          27644000
                                                                        27646000
         <<call xretpmask...if a non-zero value is returned,            27648000
           the it could not find a file equation...>>                   27650000
                                                                        27652000
   if xretpmask (desig', dummy', dummy',                                27654000
                 maskhi, masklow) <> 0 then                             27656000
      tape'recsize'was'specified := false                               27658000
   else                                                                 27660000
      tape'recsize'was'specified := maskhi.recsize'flag;                27662000
                                                                        27664000
   end <<tape'recsize'was'specified proc>>;                             27666000
$page ";STORMISC=  UNLOCK'FILES --- UNLOCK FILES LOCKED BY STORE"       27668000
$control segment=stormisc                                               27670000
<<***************************************************************>>     27672000
procedure unlock'files (what'files, pvinfo);                            27674000
         value   what'files, pvinfo;                                    27676000
         double  what'files;                                            27678000
         logical pvinfo;                                                27680000
         option privileged, uncallable;                                 27682000
   <<-------------------------------------------------------------->>   27684000
   <<                                                                   27686000
      unlock'files is a routine which is invoked to unlock a subset     27688000
      of the files still locked by store.                               27690000
                                                                        27692000
      it will unlock all of the files from file #1 (in disk record 0)   27694000
      to file number what'files.  if what'files = 0d, then no files     27696000
      will be unlocked;  if what'files = -1d, then all files will be    27698000
      unlocked.  (the unlock is done by reading the good file           27700000
      to get the information about the files.)                          27702000
                                                                        27704000
           any file which was already unlocked will not be              27706000
      unlocked again.  (this is detected by checking a bit              27708000
      in the g'flags'inx word, called: g'locked'bit.)                   27710000
      after unlocking, we set the record's bit, so we won't try         27712000
      to unlock the same file later (which would cause                  27714000
      problems if a different copy of store/restore had                 27716000
      subsequently relocked it!).                               >>      27718000
    <<---------------------------------------------------------->>      27720000
                                                                        27722000
   begin                                                                27724000
                                                                        27726000
                                                                        27728000
   double array                                                         27730000
      gbuf'd      (0:g'recsize/2);                                      27732000
                                                                        27734000
   double                                                               27736000
      addr        := 0d,                                                27738000
      fileno      := 0d;                                                27740000
                                                                        27742000
   integer                                                              27744000
      err'code    := 0,                                                 27746000
      ldev        := 0;                                                 27748000
                                                                        27750000
   integer array                                                        27752000
      gbuf        (*) = gbuf'd (0),                                     27754000
      old'gbuf    (0:g'recsize-1);                                      27756000
                                                                        27758000
   byte array                                                           27760000
      gbuf'       (*) = gbuf (0);                                       27762000
                                                                        27764000
                                                                        27766000
$if x1=on then                <<debugging code>>                        27768000
   if debugging then                                                    27770000
      begin                                                             27772000
      send;                                                             27774000
      say "********* UNLOCK'FILES (" endsay;                            27776000
      saydnum (what'files);                                             27778000
      say ") *********" endsay;                                         27780000
      send;                                                             27782000
      send;                                                             27784000
      end;                                                              27786000
$if                           <<debugging code>>                        27788000
                                                                        27790000
   if what'files = 0d or g'num <= 0 then                                27792000
      return;                                                           27794000
                                                                        27796000
   fpoint (g'num, last'file'unlocked);                                  27798000
   if <> then return;                                                   27800000
                                                                        27802000
         <<loop thru g'num...>>                                         27804000
                                                                        27806000
   fileno := last'file'unlocked;                                        27808000
   while true do                                                        27810000
      begin                                                             27812000
                                                                        27814000
      fileno:=fileno + 1d;                                              27816000
      if what'files <> all'files then                                   27818000
         if fileno > what'files then                                    27820000
            begin                                                       27822000
            last'file'unlocked := what'files;                           27824000
            return;                                                     27826000
            end;                                                        27828000
                                                                        27830000
      fread (g'num, gbuf, g'recsize);                                   27832000
                                                                        27834000
      if <> then                                                        27836000
         begin                                                          27838000
         if > then               <<eof>>                                27840000
            check'for'dismount (pvinfo, 0, old'gbuf, err'code);         27842000
         return;                                                        27844000
         end;                                                           27846000
                                                                        27848000
      addr:=gbuf'd(g'address'inx'd);                                    27850000
      ldev:=gbuf(g'ldev'inx);                                           27852000
                                                                        27854000
$if x1=on then                <<debugging code>>                        27856000
      if debugging then                                                 27858000
         begin                                                          27860000
         say "   Unlock: " endsay;                                      27862000
         say gbuf'(g'title'inx'), (3*file'part'size) endsay;            27864000
         say " @ " endsay;                                              27866000
         saynum (ldev);                                                 27868000
         say "%" endsay;                                                27870000
         saydoctal (addr);                                              27872000
         if g'locked'bit = 0 then                                       27874000
            say " **not locked**" endsay;                               27876000
         send;                                                          27878000
         end;                                                           27880000
$if                           <<debugging code>>                        27882000
                                                                        27884000
      if g'locked'bit = 1 then                                          27886000
         begin                                                          27888000
                                                                        27890000
         check'for'dismount (pvinfo, gbuf(g'pvinfo'inx),                27892000
                         old'gbuf, err'code);                           27894000
                                                                        27896000
         move old'gbuf:=gbuf, (g'recsize);                              27898000
         pvinfo:=gbuf(g'pvinfo'inx);                                    27900000
                                                                        27902000
         lock'unlock'file (unlock'file, ldev,                           27904000
                           addr, not got'sir);                          27906000
                                                                        27908000
               <<we got a record ok, now mark it as having been         27910000
                 unlocked (so we won't try again later on)...>>         27912000
                                                                        27914000
         g'locked'bit:=0;                                               27916000
                                                                        27918000
         fupdate (g'num, gbuf, g'recsize);                              27920000
                                                                        27922000
         end;                                                           27924000
                                                                        27926000
      end;                                                              27928000
                                                                        27930000
   end <<unlock'files proc>>;                                           27932000
$page ";STORMISC=  WRITE'LABEL --- FILE LABEL ROUTINES"                 27934000
$control segment=stormisc                                               27936000
<<***************************************************************>>     27938000
logical procedure write'label (ldev, address, gotit);                   27940000
         value gotit, ldev, address;                                    27942000
         logical gotit;                                                 27944000
         integer ldev;                                                  27946000
         double address;                                                27948000
         option privileged, uncallable;                                 27950000
                                                                        27952000
   begin                                                                27954000
                                                                        27956000
                                                                        27958000
   integer                                                              27960000
      local'fisir'info;                                                 27962000
                                                                        27964000
   if not gotit then                                                    27966000
      local'fisir'info:=getsir (fisir);      <<get file label sir>>     27968000
                                                                        27970000
         <<write the file label to disc...>>                            27972000
                                                                        27974000
   if flabio (ldev, address, attio'write, flab) = flabio'ok then        27976000
      write'label:=good                                                 27978000
   else                                                                 27980000
      write'label:=failed;                                              27982000
                                                                        27984000
   if not gotit then                                                    27986000
      relsir (fisir, local'fisir'info);   <<release label sir>>         27988000
                                                                        27990000
   end <<write'label proc>>;                                            27992000
$page ";CXSTORE=  CXSTORE'RESTORE --- STORE/RESTORE COMMAND EXECUTOR"   30000000
$control segment=cxstore                                                30002000
<<**************************************************************>>      30004000
procedure cxstore'restore (p, stdlistnum, wants);                       30006000
         value   stdlistnum, wants;                                     30008000
         integer stdlistnum;                                            30010000
         logical wants;                                                 30012000
         byte array p;                                                  30014000
         option privileged, uncallable;                                 30016000
                                                                        30018000
                                                                        30020000
<<--------------------------------------------------------------->>     30022000
<< cxstore'restore ...                                           >>     30024000
<< is invoked indirectly by the command interpreter of mpe when  >>     30026000
<< a store command is encountered.  the parameter p              >>     30028000
<< is a byte array containing the entire parameter list to the   >>     30030000
<< store command, in exactly the format in which the user        >>     30032000
<< specified it, except that the command interpreter has resolved>>     30034000
<< continuation lines.  cxstore'restore sees p as one logical    >>     30036000
<< string consisting of up to about 250 characters.  the command >>     30038000
<< interpreter ensures that the last character of the string is  >>     30040000
<< a carriage return.  the length restriction is imposed solely  >>     30042000
<< by the ci and the mycommand intrinsic.                        >>     30044000
<<--------------------------------------------------------------->>     30046000
<<                                                                      30048000
   the syntax of the store command is as follows:                       30050000
                                                                        30052000
              *indirect                                                 30054000
     :store                        ;*dest ...                           30056000
             fileset[,fileset]...                                       30058000
                                                                        30060000
                   dates     dates                                      30062000
                   offline   offline                                    30064000
     ... [;show [=[short   [,short    ...]]]]    ...                    30066000
                   security  security                                   30068000
                                                                        30070000
                   <=mm/dd/yy                                           30072000
     ... [;date[s]            ]    ...                                  30074000
                   >=mm/dd/yy                                           30076000
                                                                        30078000
     ... [;files = count ]                                              30080000
                                                                        30082000
                                                                        30084000
   --------------------------------------------------------------       30086000
                                                                        30088000
      for the format of a logical record on the good file (g'num),      30090000
      see the comment in the globals section declaring                  30092000
         the indices into gbuf!                                         30094000
                                                                  >>    30096000
   <<------------------------------------------------------------->>    30098000
                                                                        30100000
   begin                                                                30102000
                                                                        30104000
                                                                        30106000
                                                                        30108000
   real                                                                 30110000
      secs        := 0.1;     <<pause time for send'mail'to'parent>>    30112000
                                                                        30114000
   double                                                               30116000
      i'num'recs  := 0d,                                                30118000
      temp'd;                                                           30120000
                                                                        30122000
   integer array                                                        30124000
      candidat'buf  (0:candidat'recsize),                               30126000
      formal'name   (0:file'part'words),                                30128000
      indirect'name (0:file'part'words),                                30130000
      reply'message (0:mail'length-1);                                  30132000
                                                                        30134000
   integer pointer                                                      30136000
      tdbuf        := 0;                                                30138000
                                                                        30140000
   integer                                                              30142000
      dummy'i,                                                          30144000
      fathers'pin,                                             <<04870>>30146000
      g'num'extents:= 1,      <<number of sectors for good file>>       30148000
      i           := 0,       <<scratch integer>>                       30150000
      len         := 0,       <<length of an fread>>                    30152000
      max'recsize := 0,       <<max legal recsize for tape/disc>>       30154000
      recsize     := 0,                                                 30156000
      req'type    := 0,       <<requisition type for mount>>            30158000
      start'inx   := 0,       <<inx of first token after "STORE">>      30160000
      status      := 0,       <<used in send'mail'to'parent>>           30162000
      sub'code    := 0,       <<used in pre'check'direc>>               30164000
      why         := 0,       <<why we returned from cxstore'restore>>  30166000
      z'size      := 0;       <<for expand'stack                    >>  30168000
                                                                        30170000
   logical                                                              30172000
      aoptions    := 0,                                                 30174000
      foptions    := 0,                                                 30176000
      oldcritical := false,                                             30178000
      yes         := false;   <<scratch logical>>                       30180000
                                                                        30182000
   byte array                                                           30184000
      fathers'name (0:procinfo'ret'size),                      <<04870>>30186000
      formal'name'  (*) = formal'name (0),                              30188000
      indirect'name'(*) = indirect'name (0),                            30190000
      scratch'      (0:file'part'size);                                 30192000
                                                                        30194000
   byte pointer                                                         30196000
      pt;                     <<scratch byte pointer>>                  30198000
                                                                        30200000
   label                                                                30202000
      end'cxstore;                                                      30204000
$page                                                                   30206000
   <<----------------------------------------------------->>            30208000
   <<                                                     >>            30210000
   << subroutine directory:                               >>            30212000
   <<                                                     >>            30214000
   <<   the subroutines used in cxstore are divided       >>            30216000
   <<   into 2 groups:  error handling routines;          >>            30218000
   <<   and parsers/workers.  this directory states       >>            30220000
   <<   at what sequence range each subroutine can        >>            30222000
   <<   be found in.                                      >>            30224000
   <<                                                     >>            30226000
   << error handling routines:                            >>            30228000
   <<               fail                                  >>            30230000
   <<               fail2                                 >>            30232000
   <<               file'fail                             >>            30234000
   <<                                                     >>            30236000
   << parsers/workers (alphabetical order)                >>            30238000
   <<               build'restore'good'file               >>            30240000
   <<               check'filesets'syntax                 >>            30242000
   <<               check'indirect'file                   >>            30244000
   <<               check'tape'name                       >>            30246000
   <<               generate'good'file                    >>            30248000
   <<               initialize'cxstore                    >>            30250000
   <<               open'files                            >>            30252000
   <<               open'indirect'file                    >>            30254000
   <<               open'syslist'file                     >>            30256000
   <<               open'tape'file                        >>            30258000
   <<               parse'options                         >>            30260000
   <<               pre'parse'input                       >>            30262000
   <<               print'summary                         >>            30264000
   <<               read'indirect'and'generate'good       >>            30266000
   <<               restore'the'files                     >>            30268000
   <<               send'mail'to'parent                   >>            30270000
   <<               set'jcw                               >>            30272000
   <<               sm'reset                              >>            30274000
   <<               sm'set                                >>            30276000
   <<               store'the'files                       >>            30278000
   <<                                                     >>            30280000
   <<----------------------------------------------------->>            30282000
$page ";CXSTORE=  CXSTORE'RESTORE --- ERROR SUBROUTINES"                30284000
   <<------------------------->>                                        30286000
   <<  fail                   >>                                        30288000
   <<------------------------->>                                        30290000
                                                                        30292000
   subroutine fail (errnum);                                            30294000
            value    errnum;                                            30296000
            integer  errnum;                                            30298000
      begin                                                             30300000
                                                                        30302000
      unlock'files (all'files, 0);                                      30304000
                                                                        30306000
      if errnum <> 0 then                                               30308000
         sendmessage (errnum);                                          30310000
                                                                        30312000
      close'files (no'file);                                            30314000
                                                                        30316000
      reply'message (mail'overall):=failed;                             30318000
                                                                        30320000
      go end'cxstore;                                                   30322000
                                                                        30324000
      end <<fail sub>>;                                                 30326000
   <<------------------------->>                                        30328000
   <<  fail'not'critical      >>                                        30330000
   <<------------------------->>                                        30332000
                                                                        30334000
   subroutine fail'not'critical (errnum);                               30336000
            value    errnum;                                            30338000
            integer  errnum;                                            30340000
      begin                                                             30342000
                                                                        30344000
                                                                        30346000
      if errnum <> 0 then                                               30348000
         sendmessage (errnum);                                          30350000
                                                                        30352000
                                                                        30354000
      reply'message (mail'overall):=failed;                             30356000
                                                                        30358000
      go end'cxstore'not'critical;                                      30360000
                                                                        30362000
      end <<fail sub>>;                                                 30364000
                                                                        30366000
   <<------------------------->>                                        30368000
   <<  fail2                  >>                                        30370000
   <<------------------------->>                                        30372000
                                                                        30374000
   subroutine fail2 (errnum, erradr);                                   30376000
            value    errnum, erradr;                                    30378000
            integer  errnum, erradr;                                    30380000
      begin                                                             30382000
                                                                        30384000
      if errnum <> 0 then                                               30386000
         print'carrot (erradr);                                         30388000
                                                                        30390000
      fail (errnum);                                                    30392000
                                                                        30394000
      end <<fail2 sub>>;                                                30396000
                                                                        30398000
   <<------------------------->>                                        30400000
   <<  file'fail              >>                                        30402000
   <<------------------------->>                                        30404000
                                                                        30406000
   subroutine file'fail (fid, errnum);                                  30408000
            value        fid, errnum;                                   30410000
            integer      fid, errnum;                                   30412000
      begin                                                             30414000
                                                                        30416000
      print'file'error (fid);                                           30418000
                                                                        30420000
      fail (errnum);                                                    30422000
                                                                        30424000
      end <<file'fail sub>>;                                            30426000
$page ";CXSTORE=  CXSTORE'RESTORE --- UTILITY SUBROUTINES"              30428000
   <<--------------------------->>                                      30430000
   <<  build'restore'good'file  >>                                      30432000
   <<--------------------------->>                                      30434000
                                                                        30436000
   subroutine build'restore'good'file;                                  30438000
                                                                        30440000
      begin                                                             30442000
                                                                        30444000
            <<this routine calls irestore to process the candidate      30446000
              file (candidat) with the tape directory, to               30448000
              determine what files to restore...>>                      30450000
                                                                        30452000
      why:=why'scanning;      <<remember "state">>                      30454000
                                                                        30456000
      if irestore (tdbuf) = failed then                                 30458000
         fail (0);                    <<message already printed>>       30460000
                                                                        30462000
      end <<build'restore'good'file sub>>;                              30464000
   <<------------------------->>                                        30466000
   <<   check'filesets'syntax >>                                        30468000
   <<------------------------->>                                        30470000
                                                                        30472000
   subroutine check'filesets'syntax (star'ok);                          30474000
            value   star'ok;                                            30476000
            logical star'ok;                                            30478000
                                                                        30480000
      begin                                                             30482000
                                                                        30484000
            <<this routine scans the fileset list, checking it          30486000
              for valid syntax.  this is done now, rather than          30488000
              later, so that any syntax errors will be detected         30490000
              before the first call on directorysearch!!! >>            30492000
                                                                        30494000
$if x1=on then                <<debugging code>>                        30496000
      if debugging then                                                 30498000
         begin                                                          30500000
         say "   check'filesets'syntax (" endsay;                       30502000
         if star'ok then                                                30504000
            say "true)" endsay                                          30506000
         else                                                           30508000
            say "false)" endsay;                                        30510000
         send;                                                          30512000
         end;                                                           30514000
$if                           <<debugging code>>                        30516000
                                                                        30518000
      itemp'offset:=fileset'inx;                                        30520000
      unstepit;                                                         30522000
      stepit;                                                           30524000
                                                                        30526000
<<    if star'ok and itemp = "*" then >>   <<!indirect>>                30528000
<<       begin       >>                                                 30530000
<<       stepit;     >>         <<step over indirect name>>             30532000
<<       end         >>                                                 30534000
                                                                        30536000
      if star'ok and itemp="!" then                                     30538000
         begin                                                          30540000
            stepit;                   <<the indirect file name>>        30542000
            stepit;                   <<next token>>                    30544000
         end                                                            30546000
                                                                        30548000
      else                                                              30550000
         begin                <<parse filesets...>>                     30552000
         unstepit;                                                      30554000
                                                                        30556000
               <<at end of loop, look for a comma/return/semicolon>>    30558000
                                                                        30560000
         do                                                             30562000
            begin                                                       30564000
            stepit;                                                     30566000
                                                                        30568000
$if x1=on then                <<debugging code>>                        30570000
            if debugging then                                           30572000
               begin                                                    30574000
               say "(1)CHECK'FILESETS'SYNTAX: " endsay;                 30576000
               send;                                                    30578000
               debug'scanner;                                           30580000
               end;                                                     30582000
$if                           <<debugging code>>                        30584000
                                                                        30586000
            if itemp <> ";" and iclass isnt endlinev then               30588000
               if parse'fileset = failed then                           30590000
                  fail (0);   <<message already printed>>               30592000
                                                                        30594000
$if x1=on then                <<debugging code>>                        30596000
            if debugging then                                           30598000
               begin                                                    30600000
               say "(2)check'filesets'syntax: " endsay;                 30602000
               send;                                                    30604000
               debug'scanner;                                           30606000
               end;                                                     30608000
$if                           <<debugging code>>                        30610000
            end                                                         30612000
         until                                                          30614000
            itemp <> ",";                                               30616000
         end;                                                           30618000
                                                                        30620000
      if itemp <> ";" and iclass isnt endlinev then                     30622000
         fail2 (sr'semi'expected, itemp'offset);                        30624000
                                                                        30626000
$if x1=on then                <<debugging code>>                        30628000
      if debugging then                                                 30630000
         begin                                                          30632000
         say "END CHECK'FILESETS'SYNTAX" endsay;                        30634000
         send;                                                          30636000
         end;                                                           30638000
$if                           <<debugging code>>                        30640000
                                                                        30642000
      end <<check'filesets'syntax sub>>;                                30644000
$page                                                                   30646000
                                                                        30648000
   <<------------------------->>                                        30650000
   <<  check'indirect'file    >>                                        30652000
   <<------------------------->>                                        30654000
                                                                        30656000
   subroutine check'indirect'file;                                      30658000
                                                                        30660000
            <<this routine checks the indirect file, to see if          30662000
              it looks like a valid format file for s/r to be           30664000
              reading.  if it is not, an error is generated.            30666000
                                                                        30668000
              a "valid" format is:                                      30670000
                 open for input;                                        30672000
                 record size of at least 8 characters,                  30674000
                 and not more than 255 characters.                      30676000
              ascii and binary are equally acceptable.   >>             30678000
                                                                        30680000
      begin                                                             30682000
                                                                        30684000
      fgetinfo (i'num, , foptions, aoptions, i'num'recsize);            30686000
                                                                        30688000
      if <> then                                                        30690000
         file'fail (i'num, sr'ind'fgetinfo);                            30692000
                                                                        30694000
            <<dont rewind file...assume user has positioned it at       30696000
              the desired location.                                     30698000
              do check to see if any records exist in it...>>           30700000
                                                                        30702000
$if x1=on then                <<debugging code>>                        30704000
      if debugging then                                                 30706000
         begin                                                          30708000
         say "I'NUM RECSIZE=" endsay;                                   30710000
         saynum(i'num'recsize);                                         30712000
         send;                                                          30714000
         end;                                                           30716000
$if                           <<debugging code>>                        30718000
                                                                        30720000
      if (aoptions.(12:4) <> 0) and                                     30722000
            (aoptions.(12:4) <> %4) then    <<cant read!>>              30724000
         fail (sr'ind'not'input);                                       30726000
                                                                        30728000
      if i'num'recsize < 0 then                                         30730000
         i'num'chars := \i'num'recsize\                                 30732000
      else                                                              30734000
         i'num'chars := 2*i'num'recsize;                                30736000
                                                                        30738000
      if not (file'part'size <= i'num'chars <= 255) then                30740000
         fail (sr'ind'recsize'bad);                                     30742000
                                                                        30744000
      end <<check'indirect'file sub>>;                                  30746000
$page                                                                   30748000
   <<------------------------->>                                        30750000
   <<  check'tape'name        >>                                        30752000
   <<------------------------->>                                        30754000
                                                                        30756000
   subroutine check'tape'name;                                          30758000
      begin                                                             30760000
            <<parses tape name.  if an error is found, it is            30762000
              reported and cxstore is terminated.  itemp points         30764000
              at the supposed name (or else iclass is endlinev). >>     30766000
                                                                        30768000
            <<at the end of finding a good tapename, this               30770000
              will look for a semi-colon or an end-of-line;             30772000
              if neither are found, an error results!>>                 30774000
                                                                        30776000
$if x1=on then                <<debugging code>>                        30778000
      if debugging then                                                 30780000
         begin                                                          30782000
         send;                                                          30784000
         say "CHECK'TAPE'NAME: " endsay;                                30786000
         send;                                                          30788000
         debug'scanner;                                                 30790000
         end;                                                           30792000
$if                           <<debugging code>>                        30794000
                                                                        30796000
      fill' (tape'name', file'part'size+1, " ");                        30798000
                                                                        30800000
$if x2=off then                                                         30802000
      if iclass is endlinev then                                        30804000
         fail2 (sr'tapename'expected, itemp'offset);                    30806000
$if                                                                     30808000
                                                                        30810000
      tape'inx:=itemp'offset;                                           30812000
                                                                        30814000
      if itemp = "$" then                                               30816000
         begin                                                          30818000
         stepit;                                                        30820000
         move itemp:=itemp while as;     <<upcase>>                     30822000
         if itemp = "NULL" and ilen = 4 then                            30824000
            begin                                                       30826000
            move tape'name':="$NULL ";                                  30828000
            tape'null'tog:=true;                                        30830000
            end                                                         30832000
         else if itemp = "CTUL" and ilen = 4 or                         30834000
                 itemp = "CTUR" and ilen = 4 then                       30836000
            begin                                                       30838000
            move tape'name':="$", 2;   <<leave dest addr>>              30840000
            move *:=itemp,(ilen);      <<append ctur/ctul>>             30842000
            tape'cartridge'tog:=true;                                   30844000
            if itemp = "CTUL" then                                      30846000
               cartridge:=ctulv                                         30848000
            else                                                        30850000
               cartridge:=cturv;                                        30852000
            end                                                         30854000
         else                                                           30856000
            fail2 (sr'tape'back'reference'expected,                     30858000
                   itemp'offset-1);                                     30860000
                                                                        30862000
         if stepit isnt endlinev then                                   30864000
            if itemp <> ";" then                                        30866000
               fail2 (sr'semi'expected, itemp'offset);                  30868000
         return;                                                        30870000
         end;                                                           30872000
                                                                        30874000
            <<see if the tapename is not prefaced with an               30876000
              asterisk (*) and that it doesnt consist solely            30878000
              of an asterisk...>>                                       30880000
                                                                        30882000
$if x2=on then                                                          30884000
      if (iclass is endlinev) or (itemp=";") then                       30886000
         begin                                                          30888000
            move tape'name' := logon'user', (8);                        30890000
            blank'tape'name := true;                                    30892000
         end                                                            30894000
      else                                                              30896000
         begin                                                          30898000
$if                                                                     30900000
      if itemp <> "*" then                                              30902000
         fail2 (sr'tape'back'reference'expected, itemp'offset);         30904000
                                                                        30906000
      @pt:=@itemp;                                                      30908000
                                                                        30910000
      case parse'name (itemp, ilen) of                                  30912000
         begin                                                          30914000
                                                                        30916000
         <<pn'ok: (0) >>                                                30918000
            ;      <<good result...handled after end of case>>          30920000
                                                                        30922000
         <<pn'name'too'long:  (1) >>                                    30924000
            fail2 (sr'tape'name'too'long, itemp'offset);                30926000
                                                                        30928000
         <<pn'empty'name:     (2) >>                                    30930000
            fail2 (sr'tapename'expected, itemp'offset);                 30932000
                                                                        30934000
         <<pn'back'illegal:   (3) >>   <<shouldnt happen>>              30936000
            fail2 (sr'tape'special'char, itemp'offset);                 30938000
                                                                        30940000
         <<pn'must'start'with'alpha: (4) >>                             30942000
            fail2 (sr'tape'must'start'with'alpha,                       30944000
                   integer((itemp'offset)+1));                          30946000
                                                                        30948000
         <<pn'illegal'character: (5) >>                                 30950000
            fail2 (sr'tape'special'char, itemp'offset);                 30952000
                                                                        30954000
         <<pn'wildcards'illegal: (6) >>                                 30956000
            fail2 (sr'tape'wildcards, itemp'offset)                     30958000
                                                                        30960000
         end;                                                           30962000
                                                                        30964000
            <<if we get here, parse'name liked our tape name            30966000
              so we want to save it away...>>                           30968000
                                                                        30970000
      move tape'name':=pt(1), (ilen-1);     <<don't store the "*">>     30972000
                                                                        30974000
            <<make sure the rest of the tape name area is               30976000
              clean...>>                                                30978000
                                                                        30980000
      if stepit isnt endlinev then                                      30982000
         if itemp <> ";" then                                           30984000
            fail2 (sr'semi'expected, itemp'offset);                     30986000
                                                                        30988000
$if x2=on then                                                          30990000
      end;                                                              30992000
$if                                                                     30994000
      end <<check'tape'name sub>>;                                      30996000
$page                                                                   30998000
   <<------------------------->>                                        31000000
   <<  generate'good'file     >>                                        31002000
   <<------------------------->>                                        31004000
                                                                        31006000
   subroutine generate'good'file;                                       31008000
                                                                        31010000
            <<for store: this routine calls directorysearch for         31012000
              each fileset, which builds up the good file.              31014000
              for restore: this routine writes each fileset to          31016000
              the candidat file for later processing by irestore.>>     31018000
                                                                        31020000
      begin                                                             31022000
                                                                        31024000
      check'filesets'syntax (false <<"*" not ok>>);                     31026000
                                                                        31028000
            <<do parse and directorysearch now...>>                     31030000
                                                                        31032000
      itemp'offset:=fileset'inx;                                        31034000
      unstepit;                                                         31036000
                                                                        31038000
            <<loop until itemp <> "," ...>>                             31040000
                                                                        31042000
      do                                                                31044000
         begin                                                          31046000
                                                                        31048000
         check'break;         <<wont return if break sensed>>           31050000
                                                                        31052000
         stepit;                                                        31054000
                                                                        31056000
         if parse'fileset = failed then                                 31058000
            fail (0);     <<message already printed>>                   31060000
                                                                        31062000
$if x1=on then                <<debugging code>>                        31064000
         if debugging then                                              31066000
            begin                                                       31068000
            say "TITLE = '" endsay;                                     31070000
            say'standard (look'title');                                 31072000
            say "'" endsay;                                             31074000
            send;                                                       31076000
            end;                                                        31078000
$if                           <<debugging code>>                        31080000
                                                                        31082000
         fileset'number:=fileset'number+1;                              31084000
                                                                        31086000
                                                                        31088000
         if storing then                                                31090000
            begin                                                       31092000
            if directorysearch (recip'store) = failed then              31094000
               fail (0);                                                31096000
$if x5=on then                                                          31098000
            say "OLD'TOTAL'EXTENTS = " endsay;                          31100000
            saydnum (old'total'extents);                                31102000
            send;                                                       31104000
            say "OLD'DISC'READS = " endsay;                             31106000
            saydnum (old'disc'reads);                                   31108000
            send;                                                       31110000
            say "OLD'TAPE'WRITES = " endsay;                            31112000
            saydnum (old'tape'writes);                                  31114000
            send;                                                       31116000
            say "NEW'TOTAL'EXTENTS = " endsay;                          31118000
            saydnum (new'total'extents);                                31120000
            send;                                                       31122000
            say "NEW'DISC'READS = " endsay;                             31124000
            saydnum (new'disc'reads);                                   31126000
            send;                                                       31128000
            say "NEW'TAPE'WRITES = " endsay;                            31130000
            saydnum (new'tape'writes);                                  31132000
            send;                                                       31134000
            fail (0);                                                   31136000
$if                                                                     31138000
            end                                                         31140000
         else                                                           31142000
            begin                      <<restoreing...>>                31144000
            if pattern'build'standard (look'title',                     31146000
                     look'file'pat, look'group'pat, look'acct'pat,      31148000
                     error'code) = failed then                          31150000
               fail2 (sr'restore'pattern'err, itemp'offset);            31152000
                                                                        31154000
            candidat'used := false;                            <<lb.rs>>31155000
            move candidat'buf(1) :=                            <<lb.rs>>31156000
                      look'lock, (file'part'words), 2;         <<lb.rs>>31157000
            move *:=look'patterns,(look'patterns'length);               31158000
                                                                        31160000
            fwrite (candidat, candidat'buf, candidat'recsize, 0);       31162000
                                                                        31164000
            if > then                                                   31166000
               file'fail (candidat, sr'candidat'full)                   31168000
            else if < then                                              31170000
               file'fail (candidat, rs'write'candidat'fail);            31172000
            c'rec'count:=c'rec'count + 1d;                              31174000
            end;                                                        31176000
                                                                        31178000
         end                                                            31180000
      until                                                             31182000
         itemp <> ",";                                                  31184000
                                                                        31186000
      if itemp <> ";" and iclass isnt endlinev then                     31188000
         fail2 (sr'semi'expected, itemp'offset);                        31190000
                                                                        31192000
$if x1=on then                <<debugging code>>                        31194000
      if debugging then                                                 31196000
         begin                                                          31198000
         say "END OF GENERATE'GOOD'FILE" endsay;                        31200000
         send;                                                          31202000
         end;                                                           31204000
$if                           <<debugging code>>                        31206000
                                                                        31208000
      check'break;            <<wont return if break sensed>>           31210000
                                                                        31212000
      end <<generate'good'file sub>>;                                   31214000
$page                                                                   31216000
   <<------------------------->>                                        31218000
   << initialize'cxstore      >>                                        31220000
   <<------------------------->>                                        31222000
                                                                        31224000
   subroutine initialize'cxstore;                                       31226000
                                                                        31228000
            <<this routine initializes the local/global stuff           31230000
              for store/restore.>>                                      31232000
                                                                        31234000
      begin                                                             31236000
                                                                        31238000
      fill (reply'message, mail'length, 0);                             31240000
      reply'message (mail'overall):=good;                               31242000
      why:=why'syntax;        <<remember "state">>                      31244000
                                                                        31246000
                                                                        31248000
      fill (zero'buf, @last'zeroed - @first'zeroed, 0);                 31250000
$if x5=on then                                                          31252000
      old'tape'writes    := 0d;                                         31254000
      old'disc'reads     := 0d;                                         31256000
      old'total'extents  := 0d;                                         31258000
      new'tape'writes    := 0d;                                         31260000
      new'disc'reads     := 0d;                                         31262000
      new'total'extents  := 0d;                                         31264000
$if                                                                     31266000
$if x1=on then                <<debugging code>>                        31268000
      if debugging then                                                 31270000
         begin                                                          31272000
         send;                                                          31274000
         end;                                                           31276000
$if                           <<debugging code>>                        31278000
                                                                        31280000
                                                                        31282000
                                                                        31284000
            <<  check out the text parameter ... >>                     31286000
                                                                        31288000
                                                                        31290000
      fill' (command'text', command'text''len, %15);                    31292000
                                                                        31294000
            <<scan p...>>                                               31296000
                                                                        31298000
      scan p until %15, 1;             <<leave pointer>>                31300000
      len:= logical(tos) - logical(@p);                                 31302000
                                                                        31304000
            <<strip trailing blanks...>>                                31306000
                                                                        31308000
      while len > 1 and p(len-1) = " " do                               31310000
         len:=len-1;                                                    31312000
                                                                        31314000
      inputlen:=len;                                                    31316000
      p(len) := %15;                   <<append a return>>              31318000
                                                                        31320000
      if len > command'text''len then                                   31322000
         fail (sr'command'text'too'long);                               31324000
                                                                        31326000
            <<initialize scanner text & variables...>>                  31328000
                                                                        31330000
      move command'text':=p, (len+1);  <<transfer the text and %15>>    31332000
      itemp'offset:=0;                                                  31334000
      unstepit;                                                         31336000
                                                                        31338000
            <<see if store or restore was requested...>>                31340000
                                                                        31342000
      if stepit is endlinev or iclass isnt tokenv then                  31344000
         fail2 (sr'what'kind, 0);                                       31346000
                                                                        31348000
      if itemp = "STORE" and ilen = 5 then                              31350000
         s'r'status:=storingv                                           31352000
      else if itemp = "RESTORE" and ilen = 7 then                       31354000
         s'r'status:=restoringv                                         31356000
      else if itemp = "SYSDUMP" and ilen = 7 then              <<04870>>31358000
         begin                                                 <<04870>>31360000
         if using'driver then                                  <<04870>>31362000
            fail2 (sr'what'kind, itemp'offset);                <<04870>>31364000
         fathers'pin := father;                                <<04870>>31366000
         if <> then fail2 (sr'what'kind, itemp'offset);        <<04870>>31368000
         s'r'status:=sysdumpingv                                        31370000
         end                                                   <<04870>>31372000
      else if itemp = "DBSTORE" and ilen = 7 then              <<04870>>31374000
         begin                                                          31376000
         if using'driver then fail(sr'dbstore'called'by'alien);<<04870>>31378000
         fathers'pin := father;                                <<04870>>31380000
         if <> then fail (sr'dbstore'called'by'alien);         <<04870>>31382000
         procinfo (parms'tempi'1, parms'tempi'2, fathers'pin,  <<04870>>31384000
                   10, fathers'name);                          <<04870>>31386000
         if <> then fail (sr'checking'fathers'name);           <<04870>>31388000
         if fathers'name <> "DBSTORE.PUB.SYS " then            <<04870>>31390000
            fail (sr'dbstore'called'by'alien);                 <<04870>>31392000
         dbstore'tog:=true;                                             31394000
         ignore'priv'check'flag:=true;                                  31396000
         s'r'status:=storingv;                                          31398000
         end                                                            31400000
      else                                                              31402000
         fail2 (sr'what'kind, itemp'offset);                            31404000
                                                                        31406000
            <<note: the code assumes that s'r'status is setup           31408000
              such that the following is always true:                   31410000
                    storing xor restoring                               31412000
              since these are defines, this resolves to: either         31414000
              we are doing a restore (so restoring is true because      31416000
              s'r'status=restoringv), or we are doing a store           31418000
              or a sysdump (so storing is true because s'r'status       31420000
              is storingv or sysdumpingv).  the differences between     31422000
              a store and a sysdump are very small, mostly              31424000
              occuring before this program was started up.              31426000
              (one difference is: we do not recover errors on           31428000
              the first reel of a sysdump tape.)                 >>     31430000
                                                                        31432000
                                                                        31434000
            <<find start of first token after store/restore..>>         31436000
                                                                        31438000
      stepit;                                                           31440000
      start'inx:=itemp'offset;                                          31442000
                                                                        31444000
                                                                        31446000
            <<setup other parms...>>                                    31448000
                                                                        31450000
      syslist'num     := stdlistnum;                                    31452000
                                                                        31454000
      adate'high      := %177777;                                       31456000
      adate'low       :=       0;                                       31458000
      cdate'high      := %177777;                                       31460000
      cdate'low       :=       0;                                       31462000
      cold'load'id    := absolute(coldloadidn);                         31464000
      dbstore'high    := 99;                                   <<04870>>31466000
      dbstore'low     := 0;                                    <<04870>>31468000
      file'number     :=      0d;                                       31470000
      filecode'high   :=   32767;                                       31472000
      filecode'low    :=  -32767;                                       31474000
      files'to'handle :=      0d;                                       31476000
      jcw'flag        := want'jcw;                                      31478000
      mail'tog        := want'mail;                                     31480000
      mdate'high      := %177777;                                       31482000
      offline'recsize :=     -72;      <<initial assumption>>           31484000
      on'err          := if storing then onerr'redo            <<lb.rs>>31486000
                         else onerr'skipfile;                  <<lb.rs>>31486100
      start'clock'time:= timer;                                         31486300
      start'cpu'time  := proctime;                                      31486400
      syslist'recsize :=     -72;      <<initial assumption>>           31488000
      todays'date     := calendar;                                      31490000
      using'attio     :=   false;                                       31492000
      using'filesys   :=    true;                                       31494000
                                                               <<04870>>31496000
      if dbstore'tog then                                      <<04870>>31498000
         begin                                                 <<04870>>31500000
         filecode'high := -400;                                <<04870>>31502000
         filecode'low  := -404;                                <<04870>>31504000
         end;                                                  <<04870>>31506000
                                                                        31508000
      who (mode,                                                        31510000
           capability,                                                  31512000
           ,                                                            31514000
           logon'user',                                                 31516000
           logon'group',                                                31518000
           logon'acct',                                                 31520000
           home'group');                                                31522000
                                                                        31524000
      fill' (indirect'name', file'part'size+1, " ");                    31526000
      fill' (res'acct',      file'part'size,   " ");                    31528000
      fill' (res'group',     file'part'size,   " ");                    31530000
      fill' (res'creator',   file'part'size,   " ");                    31532000
      fill' (res'file',      file'part'size,   " ");           <<lb.rs>>31532050
      fill' (last'acct'  ,   file'part'size,   " ");           <<lb.rs>>31532100
      fill' (last'group' ,   file'part'size,   " ");           <<lb.rs>>31532200
      fill' (last'user'  ,   file'part'size,   " ");           <<lb.rs>>31532300
                                                                        31534000
$if x1=on then                <<debugging code>>                        31536000
      if interactive then                                               31538000
         begin                                                          31540000
         say "Turn on debugging? " endsay;                              31542000
         sendstop;                                                      31544000
         affirm (debugging, false);                                     31546000
         end;                                                           31548000
$if                           <<debugging code>>                        31550000
                                                                        31552000
      if restoring then                                                 31554000
         begin                                                          31556000
         move scratch':="DISC.";                                        31558000
         if getdevinfo (scratch', deviceinfo) = 0 then                  31560000
            disc'exists:=true                                           31562000
         else                                                           31564000
            disc'exists:=false;                                         31566000
                                                                        31568000
$if x9=off then                                                         31570000
            fail (rs'disabled);                                         31572000
$if                                                                     31574000
         end;                                                           31576000
                                                                        31578000
      end <<initialize'cxstore sub>>;                                   31580000
$page                                                                   31582000
   <<------------------------->>                                        31584000
   << open'files              >>                                        31586000
   <<------------------------->>                                        31588000
                                                                        31590000
   subroutine open'files (num'records);                        <<lb.rs>>31592000
      value num'records;                                       <<lb.rs>>31592100
      double num'records;                                      <<lb.rs>>31592200
                                                                        31594000
      begin                                                             31596000
            <<open'files opens all internal files other than the        31598000
              tape file, syslist, and the indirect file.>>              31600000
                                                                        31602000
      why:=why'opening'files; <<remember "state">>                      31604000
                                                               <<lb.rs>>31604100
   if num'records = 0d then                                    <<lb.rs>>31604200
      num'records := g'num'fsize;                              <<lb.rs>>31604300
                                                                        31606000
      check'break;            <<wont return if break sensed>>           31608000
                                                                        31610000
                                                                        31612000
            << open good file... >>                                     31614000
                                                                        31616000
      if g'num'fsize = 0d then                                          31618000
         begin                                                          31620000
         g'num'fsize:=default'g'num'fsize;                              31622000
         g'num'extents:=1;                                              31624000
         end                                                            31626000
      else if g'num'fsize <= default'g'num'fsize then                   31628000
         g'num'extents:=1                                               31630000
      else                                                              31632000
         g'num'extents:=32;   <<ask for all extents!>>                  31634000
                                                                        31636000
      move formal'name':="GOOD ";                                       31638000
      if open'file (g'num,                                              31640000
                    formal'name,                                        31642000
                    %2000, <<no feq, nocctl, fixed, binary, new>>       31644000
                    %105,  <<wait, nomulti, buf, excl, nomr, upd>>      31646000
                    g'recsize,                                          31648000
                    ,                  <<device>>                       31650000
                    16,                <<blockfactor>>                  31652000
                    ,                  <<buffer>>              <<lb.rs>>31654000
                    num'records,       <<# records>>           <<lb.rs>>31656000
                    32,                <<extents>>                      31658000
                    g'num'extents)     <<initial extents allocated>>    31660000
            = failed then        <<open failed on "GOOD" file>>         31662000
         fail (sr'g'num'error);                                         31664000
                                                                        31666000
      <<now open candidate file, maybe.  this file holds info on>>      31668000
      <<all the files in the intersection of the user's request and>>   31670000
      <<the tape directory.  it is created in irestore and used>>       31672000
      <<in frestore.  c'rec'count (a.k.a. retval) is the number of>>    31674000
      <<records in the candidate file.>>                                31676000
                                                                        31678000
      if restoring then                                                 31680000
         begin                                                          31682000
         move formal'name':="CANDIDAT ";                                31684000
                                                                        31686000
         if open'file (candidat,                                        31688000
                       formal'name,                                     31690000
                       %2000,                                           31692000
                       %105,     <<excl, update>>                       31694000
                       candidat'recsize,                                31696000
                       ,         <<device>>                             31698000
                       candidat'blockfactor,                            31700000
                       ,                  <<buf>>              <<lb.rs>>31702000
                       num'records,       <<file size>>        <<lb.rs>>31704000
                       max'num'extents,   <<extents>>          <<lb.rs>>31706000
                       1)                                      <<lb.rs>>31708000
               = failed then     <<open of candidate file failed>>      31710000
            fail (sr'candidat'error);                                   31712000
                                                                        31714000
         move formal'name':="DIREC ";                                   31716000
                                                                        31718000
         if open'file (d'num,                                           31720000
                       formal'name,                                     31722000
                       %2000, <<no feq, nocctl, fixed,binary, new>>     31724000
                       %105,  <<wait, nomulti, buf, excl, nomr, upd>>   31726000
                       d'blocksize,                            <<lb.rs>>31728000
                       ,                  <<device>>                    31730000
                       1,                 <<we do the blking>> <<lb.rs>>31732000
                       ,                  <<buffer>>           <<lb.rs>>31734000
                       num'records/double (d'blockfactor + 1), <<lb.rs>>31736000
                       max'num'extents,   <<extents>>          <<lb.rs>>31738000
                       max'num'extents)   <<initial extents >> <<lb.rs>>31740000
               = failed then                                            31742000
            fail (rs'd'num'error);                                      31744000
                                                                        31746000
         end;                                                           31748000
                                                                        31750000
            <<open offline now, maybe...>>                              31752000
                                                                        31754000
      if show'offline'flag = 1 then                                     31756000
         begin                                                          31758000
         move formal'name':="OFFLINE ";                                 31760000
         move scratch':="LP ";                                          31762000
                                                                        31764000
         if open'file (offline'num,                                     31766000
                       formal'name,                                     31768000
                       %504,  <<feq, cctl, var, filename, asci, new>>   31770000
                       2,     <<wait, nomult, buf, nomr, write(save)>>  31772000
                       -132 <<recsize>>,                                31774000
                       scratch'  <<device>> )                           31776000
               = failed then                                            31778000
                              <<open failed on list file>>              31780000
            fail (sr'bad'offline);                                      31782000
                                                                        31784000
         fgetinfo (offline'num, , , , recsize);                         31786000
                                                                        31788000
         if = then                                                      31790000
            if recsize > 0 then                                         31792000
               offline'recsize:=recsize * -2                            31794000
            else                                                        31796000
               offline'recsize:=recsize;                                31798000
$if x1=on then                <<debugging code>>                        31800000
         if debugging then                                              31802000
            begin                                                       31804000
            say "OFFLINE'RECSIZE = " endsay;                            31806000
            saynum (offline'recsize);                                   31808000
            send;                                                       31810000
            if not (-133 <= offline'recsize <= 66) then                 31812000
               printfileinfo (offline'num);                             31814000
            end;                                                        31816000
$if                           <<debugging code>>                        31818000
         end;                                                           31820000
                                                                        31822000
            <<open pv file...>>                                         31824000
                                                                        31826000
      move formal'name':=" ";          <<nameless file>>                31828000
      move scratch':="DISC ";                                           31830000
                                                                        31832000
      if open'file (pv'num,                                             31834000
                    formal'name,                                        31836000
                    pv'foptions,                                        31838000
                    pv'aoptions,                                        31840000
                    pv'recsize,                                         31842000
                    scratch', <<device>>                                31844000
                    pv'blockfactor,                                     31846000
                    pv'buffers,                                         31848000
                    pv'filesize,                                        31850000
                    pv'extents'max,                                     31852000
                    pv'extents'initial)                                 31854000
            = failed then                                               31856000
         fail (sr'pv'open'error);                                       31858000
                                                                        31860000
                                                                        31862000
      end <<open'files sub>>;                                           31864000
$page                                                                   31866000
   <<------------------------->>                                        31868000
   << open'indirect'file      >>                                        31870000
   <<------------------------->>                                        31872000
                                                                        31874000
   subroutine open'indirect'file;                                       31876000
      begin                                                             31878000
            <<attempts to open the user-specified indirect file.        31880000
              if the file fails to open, or any other error occurs,     31882000
              an error message will be generated and cxstore will       31884000
              terminate.>>                                              31886000
                                                                        31888000
      why:=why'indirect;      <<remember "state">>                      31890000
                                                                        31892000
      itemp'offset:=fileset'inx;                                        31894000
      unstepit;                                                         31896000
                                                                        31898000
      stepit;                                                           31900000
                                                                        31902000
<<    if itemp <> "*" then >>                                           31904000
<<       return;           >>     <<no indirect file to open>>          31906000
<<                         >>     <<!indirect>>                         31908000
<<    @pt:=@itemp'1;       >>                                           31910000
                                                                        31912000
      if itemp <> "!" then                                              31914000
         return;                                                        31916000
                                                                        31918000
      if itemp'1 <> alpha then                                          31920000
         fail2 (sr'ind'must'start'with'alpha,                           31922000
                integer ((itemp'offset)+1));                            31924000
                                                                        31926000
      stepit;                                                           31928000
      @pt:=@itemp;                                                      31930000
$if                                                                     31932000
                                                                        31934000
      case parse'name (itemp, ilen) of                                  31936000
         begin                                                          31938000
                                                                        31940000
         <<ok: (0) >>                                                   31942000
            ;                                                           31944000
                                                                        31946000
         <<pn'name'too'long:  (1) >>                                    31948000
            fail2 (sr'ind'name'too'long, itemp'offset);                 31950000
                                                                        31952000
         <<pn'empty'name:     (2) >>                                    31954000
            fail2 (sr'ind'name'expected, itemp'offset);                 31956000
                                                                        31958000
         <<pn'back'illegal:   (3) >>   <<shouldnt happen>>              31960000
            fail2 (sr'ind'special'char, itemp'offset);                  31962000
                                                                        31964000
         <<pn'must'start'with'alpha: (4) >>                             31966000
            fail2 (sr'ind'must'start'with'alpha,                        31968000
                   integer((itemp'offset)+1));                          31970000
                                                                        31972000
         <<pn'illegal'character: (5) >>                                 31974000
            fail2 (sr'ind'special'char, itemp'offset);                  31976000
                                                                        31978000
         <<pn'wildcards'illegal: (6) >>                                 31980000
            fail2 (sr'ind'wildcards, itemp'offset)                      31982000
                                                                        31984000
         end;                                                           31986000
                                                                        31988000
            <<pt points to the file name (which starts with             31990000
              an asterisk).  we now want to check to see if             31992000
              any other filesets appear after this name (if             31994000
              so, this is an error)... >>                               31996000
                                                                        31998000
<<    move indirect'name' := pt,(ilen); >> <<!indirect>>                32000000
                                                                        32002000
      move indirect'name' := pt, (ilen);                                32004000
                                                                        32006000
      if stepit is endlinev or itemp = ";" then                         32008000
      else                                                              32010000
         fail2 (sr'ind'name'not'alone, itemp'offset);                   32012000
                                                                        32014000
      if open'file (i'num,                                              32016000
                    indirect'name,                                      32018000
                    %7, <<feq, unlab, nocctl, fix, ascii, oldu>>        32020000
                    %1300,   <<multi, share, ro>>                       32022000
                    -255)                                               32024000
            = failed then                                               32026000
         fail (sr'ind'open'failed);                                     32028000
                                                                        32030000
      check'indirect'file;                                              32032000
                                                                        32034000
      end <<open'indirect'file sub>>;                                   32036000
$page                                                                   32038000
   <<------------------------->>                                        32040000
   <<  open'syslist'file      >>                                        32042000
   <<------------------------->>                                        32044000
                                                                        32046000
   subroutine open'syslist'file;                                        32048000
                                                                        32050000
      begin                                                             32052000
                                                                        32054000
            << open syslist file, verify its attributes...>>            32056000
                                                                        32058000
$if x1=on then                <<debugging code>>                        32060000
      if debugging then                                                 32062000
         begin                                                          32064000
         say "OPEN SYSLIST.  (SYSLIST'NUM = " endsay;                   32066000
         saynum (syslist'num);                                          32068000
         say1 (")");                                                    32070000
         send;                                                          32072000
         end;                                                           32074000
$if                           <<debugging code>>                        32076000
                                                                        32078000
                                                                        32080000
      if syslist'num <> 0 then                                          32082000
         begin                <<check passed-in syslist...>>            32084000
         fgetinfo (syslist'num, , i <<fopt>>, , recsize);               32086000
         if <> then                                                     32088000
            begin                                                       32090000
            print'file'error (syslist'num);                             32092000
            sendmessage (sr'bad'pnum);                                  32094000
            syslist'num:=0;                                             32096000
            end                                                         32098000
         else if i.(10:3) = %6               <<it is $null !!!>>        32100000
                  or recsize <= -72                                     32102000
                  or recsize >= 36 then      <<good recsize>>           32104000
            syslist'supplied:=true                                      32106000
         else                  <<bad recsize and not $null>>            32108000
            begin                                                       32110000
            sendmessage (sr'bad'pnum);                                  32112000
            syslist'num:=0;                                             32114000
            end;                                                        32116000
$if x1=on then                <<debugging code>>                        32118000
         if debugging then                                              32120000
            begin                                                       32122000
            say "SYSLIST RECSIZE = " endsay;                            32124000
            saynum (recsize);                                           32126000
            send;                                                       32128000
            end;                                                        32130000
$if                           <<debugging code>>                        32132000
         end;                                                           32134000
                                                                        32136000
      if syslist'num = 0 then                                           32138000
         begin                                                          32140000
         if sysdumping then                                    <<04103>>32142000
            move formal'name':="SYSDLIST "                     <<04103>>32142100
         else                                                  <<04103>>32142200
            move formal'name':="SYSLIST ";                     <<04103>>32142300
                                                                        32144000
         if open'file (syslist'num,                                     32146000
                       formal'name,                                     32148000
                       %514,  <<feq, cctl, var, $stdlist, asci, new>>   32150000
                       %1302, <<wait,mult,shr,buf,write(save)>><<04103>>32152000
                       (if interactive then                             32154000
                           -72                                          32156000
                        else                                            32158000
                           -132)  )                                     32160000
               = failed then                                            32162000
            begin             <<open failed on list file>>              32164000
                  <<try plain $stdlist...>>                             32166000
            if open'file (syslist'num,                                  32168000
                          formal'name,                                  32170000
                          %2514,   <<as above, but no feq>>             32172000
                          %2,      <<as above>>                <<04103>>32174000
                          -72)                                          32176000
                  = failed then                                         32178000
               fail (sr'badsyslist)                                     32180000
            else                                                        32182000
               sendmessage (sr'badsyslist);                             32184000
            end;                                                        32186000
         end;                                                           32188000
                                                                        32190000
      fgetinfo (syslist'num, , i <<fopt>>, , recsize);                  32192000
                                                                        32194000
      if = then                                                         32196000
         if recsize > 0 then                                            32198000
            syslist'recsize:=recsize * -2                               32200000
         else                                                           32202000
            syslist'recsize:=recsize;                                   32204000
                                                                        32206000
$if x1=on then                <<debugging code>>                        32208000
      if debugging then                                                 32210000
         begin                                                          32212000
         say "SYSLIST'RECSIZE = " endsay;                               32214000
         saynum (syslist'recsize);                                      32216000
         send;                                                          32218000
         end;                                                           32220000
$if                           <<debugging code>>                        32222000
                                                                        32224000
      end <<open'syslist'file sub>>;                                    32226000
$page                                                                   32228000
   <<------------------------->>                                        32230000
   <<  open'tape'file         >>                                        32232000
   <<------------------------->>                                        32234000
                                                                        32236000
   subroutine open'tape'file;                                           32238000
                                                                        32240000
      begin                                                             32242000
            << open tape, check its characteristics... >>               32244000
            << if the tape is $ctul or $ctur, then     >>               32246000
            << the file "CARTFILE " is opened.         >>               32248000
                                                                        32250000
               <<open the tape file...>>                                32252000
                                                                        32254000
      why:=why'opening'tape;  <<remember "state">>                      32256000
                                                                        32258000
      if tape'null'tog then                                             32260000
         begin                                                          32262000
               <<fopt = $null, binary, new>>                            32264000
         foptions:=%60;                                                 32266000
               <<aopt = wait, write>>                                   32268000
         aoptions:=%1;                                                  32270000
         end                                                            32272000
      else if storing then                                              32274000
         begin                                                          32276000
               <<fopt = feq, nocctl, undef, binary, new>>               32278000
         foptions:=%200;                                                32280000
               <<aopt = wait, nomulti, buf, excl, nomr, write>>         32282000
         aoptions:=%105;                                                32284000
         if sysdumping then                                             32286000
            aoptions.(08:02):=3;       <<share>>                        32288000
         end                                                            32290000
      else                                                              32292000
         begin                                                          32294000
               <<fopt = feq, nocctl, undef, binary, old>>               32296000
         foptions:=%201;                                                32298000
               <<aopt = excl, buf, nomr, read>>                         32300000
         aoptions:=%100;                                                32302000
         end;                                                           32304000
                                                                        32306000
            <<setup default recsize...>>                                32308000
                                                                        32310000
      if tape'cartridge'tog then                                        32312000
         tape'recsize:=128                                              32314000
      else                                                              32316000
         tape'recsize:=default'tape'recsize;                            32318000
                                                                        32320000
      if tape'ldev <> 0 then                                            32322000
         begin                <<convert desired ldev to text>>          32324000
         move scratch':="         ";                                    32326000
         ascii (tape'ldev, 10, scratch');                               32328000
         foptions.(05:01):=1;          <<disallow :file>>               32330000
                                                                        32332000
$if x1=on then                <<debugging code>>                        32334000
         if debugging then                                              32336000
            begin                                                       32338000
            say "asking for dev = " endsay;                             32340000
            say scratch', (8) endsay;                                   32342000
            send;                                                       32344000
            end;                                                        32346000
$if                           <<debugging code>>                        32348000
         end                                                            32350000
$if x2=on then                                                          32352000
           << if using default tape name >>                             32354000
      else if blank'tape'name then                                      32356000
         begin                                                          32358000
            foptions. (05:01) := 1;  << :file disallowed >>             32360000
            move scratch' := "TAPE    " ;                               32362000
         end                                                            32364000
$if                                                                     32366000
      else if dbstore'tog then                                          32368000
         move scratch':="TAPE "                                         32370000
      else                                                              32372000
         move scratch':="DISC ";                                        32374000
                                                                        32374100
      if seen'time then          <<time>>                               32374200
         begin                                                          32374300
         sendmessage (m'time'info,true);                                32374310
         sendmessage (sr'tim'before'fopen);                             32374400
         end;                                                           32374600
                                                                        32376000
      if open'file (t'num,                                              32378000
                    tape'name,                                          32380000
                    foptions,                                           32382000
                    aoptions,                                           32384000
                    tape'recsize,                                       32386000
                    scratch' <<device>> )                               32388000
            = failed then           <<tape open failed>>                32390000
         begin                                                          32392000
$if x1=on then                <<debugging code>>                        32394000
         if debugging then                                              32396000
            begin                                                       32398000
            say "FAILED TO OPEN TAPE FILE" endsay;                      32400000
            say ", ERR#" endsay;                                        32402000
            saynum (error'code);                                        32404000
            send;                                                       32406000
            end;                                                        32408000
$if                           <<debugging code>>                        32410000
         fail (sr'cant'open'tape);                                      32412000
         end;                                                           32414000
                                                                        32416000
      if seen'time then          <<time>>                               32416100
         begin                                                          32416200
         sendmessage (m'time'info,true);                                32416210
         sendmessage (sr'tim'after'fopen);                              32416300
         end;                                                           32416500
                                                                        32416600
      fgetinfo (t'num, , tape'foptions, tape'aoptions,                  32418000
                tape'recsize, tape'devinfo);                            32420000
      if <> then                                                        32422000
         fail (sr'tape'fgetinfo'fail);                                  32424000
   ffileinfo (t'num, item'ldev, tape'ldev,                              32424100
                     item'virt, parms'tempi'1);                         32424110
   if <> then                                                           32424200
      fail (rs't'fgetinfo'fail);                                        32424300
   virtdev := (parms'tempi'1 <> 0);                                     32424400
                                                                        32426000
      ffileinfo (t'num, den'option, tape'density);                      32428000
      if <> or tape'density <= 0 then                                   32430000
         tape'density:=1600;                                            32432000
                                                                        32434000
      if tape'foptions.(10:3) = %6 and storing then                     32436000
         tape'null'tog:=true;       <<$null>>                           32438000
                                                                        32440000
            <<now that we have the tape opened, check its >>            32442000
            <<attributes (or, for null, set attributes)...>>            32444000
                                                                        32446000
      if tape'null'tog then                                             32448000
         begin                                                          32450000
         tape'null'tog:=true;          <<$null>>                        32452000
         tape'recsize:=1024;           <<force good recsize>>           32454000
         end                                                            32456000
                                                                        32458000
      else                                                              32460000
         begin                         <<examine tape attributes..>>    32462000
                  <<check foptions...>>                                 32464000
                                                                        32466000
         if (tape'foptions land (if storing then %2777                  32468000
                                 else %176777)) <> foptions then        32470000
            fail (sr'tfilfoption);                                      32472000
                                                                        32474000
                  <<check aoptions..>>                                  32476000
                                                                        32478000
         if (tape'aoptions land %177377) <> aoptions then               32480000
            fail (sr'tfilaoption);                                      32482000
                                                                        32484000
               <<see if the tape is a 7976 and if 6250bpi               32486000
                 is being used...>>                                     32488000
                                                                        32490000
         if tape'devinfo.devtypef = magtape                             32492000
               and tape'devinfo.subtypef = subtype'7976 then            32494000
            begin                                                       32496000
            a'7976:=true;                                               32498000
            if tape'density = 6250 then                                 32500000
               use'6250bpi:=true;                                       32502000
            end;                                                        32504000
                                                                        32506000
         if tape'devinfo.devtypef = magtape then                        32508000
            begin                                                       32510000
                  <<disallow labeled tapes over ds/3000...>>            32512000
            if labeled and virtdev then                                 32514000
               fail (sr'no'labeled'ds);                                 32516000
            end                                                         32518000
         else if tape'devinfo.devtypef = sdisc then                     32520000
            tape'sdisc'tog:=true                                        32522000
         else                 <<not a tape or a serial disc...>>        32524000
            fail (sr'xpcttapedev);                                      32526000
                                                                        32528000
         if ( (tape'recsize mod 256) <> 0) then                         32530000
            fail (sr'recsizebad);                                       32532000
                                                                        32534000
         if tape'cartridge'tog then                                     32536000
            if tape'recsize <> 128 and tape'recsize <> -256 then        32538000
               fail (sr'cart'recsize'bad);                              32540000
                                                                        32542000
               <<check recsize...>>                                     32544000
                                                                        32546000
         if tape'devinfo.devtypef = sdisc then                          32548000
            max'recsize:=max'sdisc'recsize                              32550000
         else if tape'density = 6250 and (not virtdev)                  32552000
               and (not labeled) then                                   32554000
            max'recsize:=max'7976'recsize                               32556000
         else                                                           32558000
            max'recsize:=max'7970'recsize;                              32560000
                                                                        32562000
         if not (256 <= tape'recsize <= max'recsize) then               32564000
            fail (sr'recsizebad);                                       32566000
                                                                        32568000
               <<if user specified attio, make sure that the            32570000
                 output device is a tape...>>                           32572000
                                                                        32574000
         if seen'attio then                                             32576000
            if tape'devinfo.devtypef <> magtape then                    32578000
               seen'attio:=false;                                       32580000
                                                                        32582000
               <<decide whether or not to use attachio                  32584000
                 output method (instead of the file system)...>>        32586000
                                                                        32588000
         if (not labeled) and (not virtdev) and                         32590000
               (a'7976 or seen'attio) then                              32592000
            begin                                                       32594000
            using'attio:=true;                                          32596000
            using'filesys:=false;                                       32598000
            end                                                         32600000
         else                                                           32602000
            begin                                                       32604000
            using'attio:=false;                                         32606000
            using'filesys:=true;                                        32608000
            end;                                                        32610000
                                                                        32612000
               <<see if we should use the larger hp7976 (8192           32614000
                 words) recsize even if the tape was opened             32616000
                 with a default recsize (4096 words)...>>               32618000
                                                                        32620000
         if using'attio and tape'recsize = default'tape'recsize and     32622000
               tape'devinfo.tape'typef = type'7976 and                  32624000
               tape'density = 6250 then                                 32626000
            if not tape'recsize'was'specified then                      32628000
               begin                                                    32630000
               tape'recsize:=max'7976'recsize;                          32632000
               end;                                                     32634000
                                                                        32636000
         end;                                                           32638000
                                                                        32640000
$if x1=on then                <<debugging code>>                        32642000
      if debugging then                                                 32644000
         begin                                                          32646000
         say "   TAPE OPENED OK, RECSIZE = " endsay;                    32648000
         saynum (tape'recsize);                                         32650000
         say ", MAX'RECSIZE = " endsay;                                 32652000
         saynum (max'recsize);                                          32654000
         send;                                                          32656000
         say "   DENSITY = " endsay;                                    32658000
         saynum (tape'density);                                         32660000
         say ", DEVINFO=%" endsay;                                      32662000
         sayoctal (tape'devinfo);                                       32664000
         send;                                                          32666000
         say "   LDEV = " endsay;                                       32668000
         saynum (tape'ldev);                                            32670000
         send;                                                          32672000
         end;                                                           32674000
$if                           <<debugging code>>                        32676000
                                                                        32678000
      if labeled then                                                   32680000
         begin                                                          32682000
         if seen'onerr and on'err <> onerr'quit then                    32684000
            sendmessage (sr'cant'recover'labeled'tapes);                32686000
         on'err:=onerr'quit;                                            32688000
         end;                                                           32690000
                                                                        32692000
      if tape'null'tog then                                             32694000
         begin                                                          32696000
         if seen'onerr and on'err <> onerr'quit then                    32698000
            sendmessage (sr'null'cant'recover);                         32700000
         on'err:=onerr'quit;                                            32702000
         end;                                                           32704000
                                                                        32706000
      end <<open'tape'file sub>>;                                       32708000
$page                                                                   32710000
   <<------------------------->>                                        32712000
   << parse'options           >>                                        32714000
   <<------------------------->>                                        32716000
                                                                        32718000
   subroutine parse'options;                                            32720000
      begin                                                             32722000
            <<parse the various store options appearing after the       32724000
              tape name.>>                                              32726000
                                                                        32728000
      if options'inx > 0 then                                           32730000
         if parse'other'parms                                           32732000
                  = failed then                                         32734000
            begin                                                       32736000
$if x1=on then                <<debugging code>>                        32738000
            if debugging then                                           32740000
               begin                                                    32742000
               say "PARSE'OTHER' FAILED" endsay;                        32744000
               send;                                                    32746000
               end;                                                     32748000
$if                           <<debugging code>>                        32750000
            fail (0);     <<error messages already printed>>            32752000
            end;                                                        32754000
                                                                        32756000
      end <<parse'options sub>>;                                        32758000
$page                                                          <<05012>>32760000
subroutine pre'assert'save'access;                                      32762000
begin                                                                   32764000
                                                                        32766000
   g'security'1 := group'entry (g'sec);                                 32768000
   g'security'2 := group'entry (g'sec + 1);                             32770000
                                                                        32772000
   if not (sm'tog) then                                                 32774000
      if res'acct' = logon'acct',(8) then                               32776000
         begin                                                          32778000
            if cap'am or save'any or save'account then                  32780000
            else if cap'al and save'acct'lib then                       32782000
            else if res'group' = home'group',(8) land                   32784000
                    (save'group lor (cap'gl land save'group'lib)) then  32786000
            else if (res'group' = logon'group',(8)) and save'group then 32788000
            else fail(m'pre'no'save'access);                            32790000
         end << res'acct = logon'acct >>                                32792000
      else fail(m'pre'accross'accounts);                                32794000
                                                                        32796000
                                                                        32798000
end; << assert'save'access >>                                           32800000
subroutine pre'check'direc;                                             32802000
begin                                                                   32804000
                                                                        32806000
   if not sm'tog then                                                   32808000
      move res'acct' := logon'acct', (8);                               32810000
                                                                        32812000
   if seen'local or seen'acct or not sm'tog then                        32814000
      begin                                                             32816000
         dont'chk'acct := true;                                         32830000
         change'jit'acct (get'jitdst, res'acct);                        32832000
                                                                        32834000
                                                                        32836000
         sub'code := lock'directory;                           <<lb.rs>>32838000
         if sub'code = m'no'acct then                          <<lb.rs>>32840000
            sub'code := m'res'acct'doesnt'exist                <<lb.rs>>32842000
         else if sub'code = m'no'group then                    <<lb.rs>>32844000
            sub'code := m'res'group'doesnt'exist;              <<lb.rs>>32846000
         if sub'code <> 0 then fail (sub'code);                <<lb.rs>>32848000
                                                                        32860000
         if seen'creator and not blank'creator then                     32862000
            if check'user (res'acct', res'creator', sub'code)  <<lb.rs>>32864000
                                                  = good then  <<lb.rs>>32866000
               dont'chk'user := true                                    32868000
            else if sub'code = userlevel then                           32870000
               fail (m'res'user'doesnt'exist)                           32872000
            else if sub'code = nocreate then fail (m'no'create)         32874000
            else fail (m'res'user'verify);                              32876000
      end;                                                              32878000
                                                                        32880000
end;                                                                    32896000
$page                                                                   32898000
   <<------------------------->>                                        32900000
   <<   pre'parse'input       >>                                        32902000
   <<------------------------->>                                        32904000
                                                                        32906000
   subroutine pre'parse'input (global'parse);                           32908000
         value global'parse;                                            32910000
         logical global'parse;                                          32912000
                                                                        32914000
            <<this routine scans the input, looking for the             32916000
              start of the following "areas": tape name,                32918000
              fileset list, options.  note that for store these         32920000
              areas occur in the order:                                 32922000
                    fileset list, tape name, [ options ]                32924000
              and for restore they occur in the order:                  32926000
                    tape name, fileset list, [ options ]                32928000
              (the options "area" is optional for both commands).       32930000
                                                                        32932000
              as each area is found, the appropriate index is           32934000
              setup (fileset'inx, tape'inx, options'inx) so             32936000
              that later routines can point the scanner to the          32938000
              start of the stuff they are interested in.>>              32940000
                                                                        32942000
      begin                                                             32944000
                                                                        32946000
            <<reset scanner to start...>>                               32948000
                                                                        32950000
      itemp'offset:=0;                                                  32952000
      unstepit;                                                         32954000
                                                                        32956000
$if x1=on then                <<debugging code>>                        32958000
      if debugging then                                                 32960000
         begin                                                          32962000
         say "PRE'PARSE OF: '" endsay;                                  32964000
         say itemp,(ileft) endsay;                                      32966000
         say1("'");                                                     32968000
         send;                                                          32970000
         end;                                                           32972000
$if                           <<debugging code>>                        32974000
                                                                        32976000
            <<skip to first token...>>                                  32978000
                                                                        32980000
      itemp'offset:=start'inx;                                          32982000
      unstepit;                                                         32984000
      stepit;       <<first token after 'store' or 'restore'!!!>>       32986000
                                                                        32988000
                                                                        32990000
            <<this section scans the input text for the first           32992000
              two semicolons, if any.  itemp points to the first        32994000
              non-blank character (if any). >>                          32996000
                                                                        32998000
      options'inx:=-1;        <<default value!>>                        33000000
      tape'inx:=-1;                                                     33002000
      fileset'inx:=-1;                                                  33004000
                                                                        33006000
                                                                        33008000
      if global'parse then                                              33010000
                                                                        33012000
         begin                                                          33014000
                                                                        33016000
         if restoring then                                              33018000
            begin                                                       33020000
                                                                        33022000
                  <<look for:  *tape;fileset[[,fileset]][;options]>>    33024000
                                                                        33026000
            check'tape'name;     <<won't return on error>>              33028000
                                                                        33030000
                  <<note: itemp now = ";" or end-of-line>>              33032000
                                                                        33034000
            fileset'inx:=itemp'offset + 1;                              33036000
                                                                        33038000
                  <<get next token after the semicolon (if              33040000
                    there was one) that followed the tape               33042000
                    name...>>                                           33044000
                                                                        33046000
            stepit;                                                     33048000
                                                                        33050000
            if iclass is endlinev or itemp = ";" then                   33052000
               begin                                                    33054000
                     <<found one of the following:                      33056000
                              restore *t                                33058000
                              restore *t;                               33060000
                              restore *t;;...                           33062000
                       which may, or may not, be legal...>>             33064000
                                                                        33066000
               if allow'empty'fileset then                              33068000
                  unstepit    <<back off the ";", if any>>              33070000
               else                                                     33072000
                  fail2 (rs'fileset'expected, fileset'inx);             33074000
               end;                                                     33076000
                                                                        33078000
                  <<now find options'inx for restore...>>               33080000
                                                                        33082000
                  <<if a one or more filesets were specified,           33084000
                    itemp is now pointing to the first character        33086000
                    of the first fileset.  if no filesets were          33088000
                    found, itemp is either a ";" or end-of-line.        33090000
                    we now want to find the semicolon separating        33092000
                    the fileset list and the options...        >>       33094000
                                                                        33096000
                                                                        33098000
            if itemp <> ";" then                                        33100000
               while stepit isnt endlinev and itemp <> ";" do           33102000
                  ;           <<loop till ";" or end-of-line>>          33104000
                                                                        33106000
            if itemp = ";" then                                         33108000
               options'inx:=itemp'offset + 1;                           33110000
                                                                        33112000
            end                                                         33114000
                                                                        33116000
         else                                                           33118000
            begin             <<storing...>>                            33120000
                                                                        33122000
            fileset'inx:=itemp'offset;                                  33124000
                                                                        33126000
                  <<look for: fileset[[,fileset]];*tape[;opt]...>>      33128000
                                                                        33130000
            if itemp = ";" then                                         33132000
               if allow'empty'fileset then                              33134000
                  <<don't do anything...user said: store ;*t>>          33136000
               else                                                     33138000
                  fail2 (rs'fileset'expected, itemp'offset)             33140000
                                                                        33142000
            else              <<found something other than ";">>        33144000
               begin                                                    33146000
               while stepit isnt endlinev and itemp <> ";" do           33148000
                  ;                                                     33150000
               end;           <<end scanning thru filesets>>            33152000
                                                                        33154000
                  <<at this point, for legal syntax, itemp              33156000
                    must be either ";" or end-of-line...>>              33158000
                                                                        33160000
$if x2=off then                                                         33162000
            if itemp <> ";" then                                        33164000
               fail2 (sr'tapename'expected, inputlen);                  33166000
$if                                                                     33168000
                                                                        33170000
                  <<check the tape name..>>                             33172000
                                                                        33174000
            stepit;                                                     33176000
            check'tape'name;                                            33178000
                                                                        33180000
                  <<now pointing at either ";" or endline>>             33182000
                                                                        33184000
            if itemp = ";" then                                         33186000
               options'inx:=itemp'offset + 1;                           33188000
                                                                        33190000
            end                                                         33192000
         end                  <<end global parse stuff>>                33194000
                                                                        33196000
      else                                                              33198000
         begin                <<not global parse...>>                   33200000
                                                                        33202000
         if itemp = ";" then                                            33204000
            options'inx:=itemp'offset+1    <<fileset'inx:=-1>>          33206000
         else                                                           33208000
            begin                                                       33210000
            fileset'inx:=itemp'offset;                                  33212000
            while stepit isnt endlinev and itemp <> ";" do              33214000
               ;                                                        33216000
            if itemp = ";" then                                         33218000
               options'inx:=itemp'offset+1;                             33220000
            end;                                                        33222000
         end;                                                           33224000
                                                                        33226000
      if fileset'inx >= 0 then                                 <<06157>>33227000
         check'filesets'syntax (true <<"*" ok>>);              <<06157>>33228000
                                                                        33230000
$if x1=on then                <<debugging code>>                        33232000
      if debugging then                                                 33234000
         begin                                                          33236000
         say "END OF PRE'PARSE'INPUT" endsay;                           33238000
         send;                                                          33240000
         say "FSET=" endsay; saynum (fileset'inx);                      33242000
         say ", TAPE=" endsay; saynum (tape'inx);                       33244000
         say ", OPT=" endsay; saynum (options'inx);                     33246000
         send;                                                          33248000
         end;                                                           33250000
$if                           <<debugging code>>                        33252000
                                                                        33254000
      end <<pre'parse'input sub>>;                                      33256000
$page                                                                   33258000
   <<------------------------->>                                        33260000
   << print'summary           >>                                        33262000
   <<------------------------->>                                        33264000
                                                                        33266000
   subroutine print'summary;                                            33268000
                                                                        33270000
            <<this routine prints a blank line and then the             33272000
              summary of the number of files stored or restored>>       33274000
                                                                        33276000
      begin                                                             33278000
                                                                        33280000
      sendmessage (m'blank'line);                                       33282000
                                                                        33284000
      sendmessage (m'store'summary);                                    33286000
                                                                        33288000
      end <<print'summary sub>>;                                        33290000
$page                                                                   33292000
   <<--------------------------------->>                                33294000
   << read'indirect'and'generate'good >>                                33296000
   <<--------------------------------->>                                33298000
                                                                        33300000
   subroutine read'indirect'and'generate'good;                          33302000
                                                                        33304000
            <<this routine reads the indirect file (i'num) and          33306000
              handles any options or filesets found.  it first          33308000
              strips the sequence number (if any) from the end          33310000
              and then calls pre'parse'input.  if the first two         33312000
              characters of the input are "//", then the                33314000
              routine terminates.  (just like editor/3000's             33316000
              add command!)   >>                                        33318000
                                                                        33320000
      begin                                                             33322000
                                                                        33324000
      i'num'recs:=0d;                                                   33326000
      start'inx:=0;           <<no more 'store'/'restore' at front!>>   33328000
                                                                        33330000
         <<loop, reading i'num, until an eof or "//" is found...>>      33332000
                                                                        33334000
      while true do                                                     33336000
         begin                                                          33338000
         fill' (command'text', command'text''len, %15);                 33340000
         @pt:=@command'text';                                           33342000
                                                                        33344000
         len:=fread (i'num, command'text, i'num'recsize);               33346000
                                                                        33348000
         if < then                                                      33350000
            fail (sr'ind'io'error);                                     33352000
                                                                        33354000
         if > or pt = "//" then   <<eof on indirect file>>              33356000
            begin                                                       33358000
            if i'num'recs = 0d then                                     33360000
               fail (sr'ind'empty);                                     33362000
$if x1=on then                <<debugging code>>                        33364000
            if debugging then                                           33366000
               begin                                                    33368000
               say "I'NUM EOF" endsay;                                  33370000
               send;                                                    33372000
               end;                                                     33374000
$if                           <<debugging code>>                        33376000
            fclose (i'num, 0, 0);                                       33378000
            return;                                                     33380000
            end;                                                        33382000
                                                                        33384000
         i'num'recs:=i'num'recs + 1d;                                   33386000
                                                                        33388000
               <<determine number of characters read...>>               33390000
               <<do this each fread...file may be variable!>>           33392000
                                                                        33394000
         if i'num'recsize < 0 then                                      33396000
            i'num'chars:=len                                            33398000
         else                                                           33400000
            i'num'chars:=len*2;                                         33402000
                                                                        33404000
               <<"drop" the sequence number, if any...>>                33406000
                                                                        33408000
         strip'sequence'number (pt, i'num'chars);                       33410000
                                                                        33412000
         while (i'num'chars > 1) and (pt(i'num'chars-1)=" ") do         33414000
            i'num'chars:=i'num'chars-1;  <<strip trailing blanks>>      33416000
                                                                        33418000
               <<append stopper for scanner...>>                        33420000
                                                                        33422000
         pt(i'num'chars):=%15;                                          33424000
         ileft:=inputlen:=i'num'chars;                                  33426000
                                                                        33428000
$if x1=on then                <<debugging code>>                        33430000
         if debugging then                                              33432000
            begin                                                       33434000
            say "READ I'NUM, LEN=" endsay;                              33436000
            saynum(len);                                                33438000
            say ", CHARS=" endsay;                                      33440000
            saynum(i'num'chars);                                        33442000
            send;                                                       33444000
            say "TEXT: '" endsay;                                       33446000
            say command'text',(i'num'chars) endsay;                     33448000
            say1("'");                                                  33450000
            send;                                                       33452000
            end;                                                        33454000
$if                           <<debugging code>>                        33456000
                                                                        33458000
            <<do some parsing...an error in either of these             33460000
              will kick us out of this subroutine & procedure>>         33462000
                                                                        33464000
         pre'parse'input (false);   <<preparse indirect>>               33466000
                                                                        33468000
         if options'inx > 0 then                                        33470000
            parse'options;                                              33472000
                                                                        33474000
         if fileset'inx >= 0 then                                       33476000
            begin                                                       33478000
            itemp'offset:=fileset'inx;                                  33480000
            if itemp <> ";" then                                        33482000
               generate'good'file;                                      33484000
            end;                                                        33486000
                                                                        33488000
         end;                                                           33490000
                                                                        33492000
      end <<read'indirect'and'generate'good sub>>;                      33494000
$page                                                                   33496000
   <<------------------------->>                                        33498000
   <<  restore'the'files      >>                                        33500000
   <<------------------------->>                                        33502000
                                                                        33504000
   subroutine restore'the'files;                                        33506000
                                                                        33508000
            <<this routine calls frestore to restore the files          33510000
              selected by irestore.>>                                   33512000
                                                                        33514000
      begin                                                             33516000
                                                                        33518000
$if x1=on then                <<debugging code>>                        33520000
      if debugging then                                                 33522000
         begin                                                          33524000
         say "RESTORE'THE'FILES" endsay;                                33526000
         send;                                                          33528000
         end;                                                           33530000
$if                           <<debugging code>>                        33532000
                                                                        33534000
      why:=why'doing;         <<remember "state">>                      33536000
                                                                        33538000
      if frestore (tdbuf) = failed then                                 33540000
         begin                                                          33542000
$if x1=on then                <<debugging code>>                        33544000
         if debugging then                                              33546000
            begin                                                       33548000
            say "FRESTORE FAILED!" endsay;                              33550000
            send;                                                       33552000
            end;                                                        33554000
$if                           <<debugging code>>                        33556000
         print'summary;                                                 33558000
         fail (0);           <<message already printed>>                33560000
         end;                                                           33562000
                                                                        33564000
$if x1=on then                <<debugging code>>                        33566000
      if debugging then                                                 33568000
         begin                                                          33570000
         say "FRESTORE GOOD!" endsay;                                   33572000
         send;                                                          33574000
         end;                                                           33576000
$if                           <<debugging code>>                        33578000
                                                                        33580000
      end <<restore'the'files sub>>;                                    33582000
$page                                                                   33584000
   <<----------------------->>                                          33586000
   <<  send'mail'to'parent  >>                                          33588000
   <<----------------------->>                                          33590000
                                                                        33592000
   subroutine send'mail'to'parent;                                      33594000
                                                                        33596000
         <<this routine sends a reply, via sendmail, to                 33598000
           the caller.  the information sent is: overall                33600000
           result (good/failed), good'file'count,                       33602000
           and failed'file'count.                                       33604000
                                                                        33606000
           note: this must be the last thing done by this               33608000
           procedure, as the caller is not guaranteed to                33610000
           wait around after receiving mail from us to                  33612000
           allow us to clean up nicely!!!!                              33614000
                                                       >>               33616000
                                                                        33618000
      begin                                                             33620000
                                                                        33622000
      reply'message (mail'good):=integer(good'file'count);              33624000
      reply'message (mail'bad) :=integer(failed'file'count);            33626000
      reply'message (mail'why) :=why;                                   33628000
                                                                        33630000
            <<note: reply'message (mail'overall) is already             33632000
              set up by initialize and (maybe) by fail!>>               33634000
                                                                        33636000
      status:=sendmail (0, mail'length, reply'message, false);          33638000
                                                                        33640000
      if = then               <<mail sent>>                             33642000
         begin                <<wait for ack...>>                       33644000
$if x1=on then                <<debugging code>>                        33646000
         if debugging then                                              33648000
            begin                                                       33650000
            say "sendmail status = " endsay;                            33652000
            saynum (status);                                            33654000
            send;                                                       33656000
            end;                                                        33658000
$if                           <<debugging code>>                        33660000
                                                                        33662000
               <<wait awhile (but not too long) for father              33664000
                 to read mail and reply...>>                            33666000
                                                                        33668000
         i:=max'pause'loops;                                            33670000
                                                                        33672000
         while (i:=i-1) >= 0 do                                         33674000
            begin                                                       33676000
            status:=mail (0, len);                                      33678000
$if x1=on then                <<debugging code>>                        33680000
            if debugging then                                           33682000
               begin                                                    33684000
               say "'mail' status = " endsay;                           33686000
               saynum (status);                                         33688000
               send;                                                    33690000
               end;                                                     33692000
$if                           <<debugging code>>                        33694000
            if status = 1 or status = 4 then                            33696000
               pause (secs);                                            33698000
            end;                                                        33700000
                                                                        33702000
         status:=receivemail (0, reply'message, true);                  33704000
                                                                        33706000
$if x1=on then                <<debugging code>>                        33708000
         if debugging then                                              33710000
            begin                                                       33712000
            say "received mail reply, status = " endsay;                33714000
            saynum (status);                                            33716000
            send;                                                       33718000
            end;                                                        33720000
$if                           <<debugging code>>                        33722000
         end                                                            33724000
      else                                                              33726000
         sendmessage (sr'sendmail'fail);                                33728000
                                                                        33730000
      end <<send'mail'to'parent sub>>;                                  33732000
$page                                                                   33734000
   <<----------->>                                                      33736000
   <<  set'jcw  >>                                                      33738000
   <<----------->>                                                      33740000
                                                                        33742000
   subroutine set'jcw;                                                  33744000
                                                                        33746000
         <<this routine sets the storejcw jcw to the current>>          33748000
         <<value of why.  (why reflects the state of store, >>          33750000
         <<a value <> why'good means store failed.)         >>          33752000
                                                                        33754000
      begin                                                             33756000
                                                                        33758000
            <<set the storejcw jcw to flag an error...>>                33760000
                                                                        33762000
      move scratch':="STOREJCW ";                                       33764000
                                                                        33766000
      i:=why;                                                           33768000
                                                                        33770000
      putjcw (scratch', i, dummy'i);                                    33772000
                                                                        33774000
      end <<set'jcw sub>>;                                              33776000
$page                                                                   33778000
   <<------------>>                                                     33780000
   <<  sm'reset  >>                                                     33782000
   <<------------>>                                                     33784000
                                                                        33786000
   subroutine sm'reset;                                                 33788000
                                                                        33790000
      begin                                                             33792000
                                                                        33794000
            <<if op but not sm, then we earlier set the sm              33796000
              bit for this user...reset it now...>>                     33798000
                                                                        33800000
      if need'to'reset'sm then                                          33802000
         begin                                                          33804000
         push(dl);                                                      33806000
         i:=tos-ps0(-1);                 <<displacement of pcbx>>       33808000
         db2(i).(00:01):=0;            <<reset sm bit>>                 33810000
         end;                                                           33812000
                                                                        33814000
      end <<sm'reset sub>>;                                             33816000
$page                                                                   33818000
   <<---------->>                                                       33820000
   <<  sm'set  >>                                                       33822000
   <<---------->>                                                       33824000
                                                                        33826000
   subroutine sm'set;                                                   33828000
                                                                        33830000
         <<will set the sm bit in the user's session capabilities,      33832000
           but only if the user already has the op bit set.>>           33834000
                                                                        33836000
      begin                                                             33838000
                                                                        33840000
      need'to'reset'sm:=false;                                          33842000
                                                                        33844000
      if cap'sm then          <<sm>>                                    33846000
         sm'tog:=true                                                   33848000
                                                                        33850000
      else if cap'op then     <<op>>                                    33852000
         begin                                                          33854000
         push(dl);                                                      33856000
         i:=tos-ps0(-1);                                                33858000
         db2(i).(00:01):=1;            <<set sm capability>>            33860000
         cap'sm:=1;                                                     33862000
         need'to'reset'sm:=true;                                        33864000
         sm'tog:=true;                                                  33866000
         end                                                            33868000
                                                                        33870000
      else                    <<neither>>                               33872000
         sm'tog:=false;                                                 33874000
                                                                        33876000
      end <<sm'set sub>>;                                               33878000
$page                                                                   33880000
   <<------------------------->>                                        33882000
   <<  store'the'files        >>                                        33884000
   <<------------------------->>                                        33886000
                                                                        33888000
   subroutine store'the'files;                                          33890000
                                                                        33892000
            <<this routine calls fstore to do the actual storing        33894000
              of the selected files.  it then checks to see if          33896000
              we have stored all the files we thought we should!>>      33898000
                                                                        33900000
      begin                                                             33902000
                                                                        33904000
      why:=why'doing;         <<remember "state">>                      33906000
                                                                        33908000
      if fstore (tdbuf) = failed then                                   33910000
         begin                                                          33912000
$if x1=on then                <<debugging code>>                        33914000
         if debugging then                                              33916000
            begin                                                       33918000
            say "FSTORE FAILED, ERROR'CODE=" endsay;                    33920000
            saynum (error'code);                                        33922000
            send;                                                       33924000
            end;                                                        33926000
$if                           <<debugging code>>                        33928000
         fail (0);                     <<already printed msg>>          33930000
         end;                                                           33932000
                                                                        33934000
            <<see if we exhausted the good file...if we did,            33936000
              the number of files we stored plus the number we          33938000
              failed to store will match files'to'handle...   >>        33940000
                                                                        33942000
      if files'to'handle <> failed'file'count + good'file'count then    33944000
         fail (sr'bad'good'count);                                      33946000
                                                                        33948000
      if not labeled then                                               33950000
         begin                <<unlabeled tape only>>                   33952000
$if x1=on then                <<debugging code>>                        33954000
         if debugging then                                              33956000
            begin                                                       33958000
            say "FILES STORED OK...CLOSE TAPE NOW" endsay;              33960000
            send;                                                       33962000
            end;                                                        33964000
$if                           <<debugging code>>                        33966000
                                                                        33968000
               <<close tape without rewinding it, if    >>              33970000
               <<possible...note that the temp'norewind >>              33972000
               <<will leave tape where it is iff someone>>              33974000
               <<else in our process tree has the same  >>              33976000
               <<device open, otherwise it will cause   >>              33978000
               <<the tape to rewind after an eof is     >>              33980000
               <<written to the tape!!!!                >>              33982000
                                                                        33984000
         if t'num > 0 and not tape'null'tog then                        33986000
            fclose (t'num, tape'close'disp, 0);                <<04726>>33988000
         end;                                                           33990000
                                                                        33992000
      t'num:=0;                <<stop any future close on tape>>        33994000
                                                                        33996000
$if x1=on then                <<debugging code>>                        33998000
      if debugging then                                                 34000000
         begin                                                          34002000
         say "STORE'THE'FILES ENDED OK" endsay;                         34004000
         send;                                                          34006000
         end;                                                           34008000
$if                           <<debugging code>>                        34010000
                                                                        34012000
      end <<store'the'files sub>>;                                      34014000
$page "WRITE'TAPEMARKS'ONLY of CXSTORE"                        <<05012>>34014100
<<---------------------->>                                     <<05012>>34014110
<< write'tapemarks'only >>                                     <<05012>>34014120
<<---------------------->>                                     <<05012>>34014130
                                                               <<05012>>34014140
subroutine write'tapemarks'only;                               <<05012>>34014200
begin                                                          <<05012>>34014300
   open'tape'file;                                             <<05012>>34014400
   write'tape'mark (parms'tempi'1);                            <<05012>>34014500
   write'tape'mark (parms'tempi'1);                            <<05012>>34014600
   fail (m'no'files'to'store);                                 <<05012>>34014650
end;                                                           <<05012>>34014700
$page ";CXSTORE=  CXSTORE'RESTORE --- OUTER BLOCK"                      34016000
   <<=====================================================>>            34018000
   <<     o u t e r   b l o c k   o f   c x s t o r e     >>            34020000
   <<=====================================================>>            34022000
   <<first step is to parse the parameters to the command.>>            34024000
   <<to begin with, we do crude check of command.         >>            34026000
   <<=====================================================>>            34028000
                                                                        34030000
   enable'arithmetic'traps;                                             34032000
                                                                        34034000
$if x1=on then                <<debugging code>>                        34036000
   ahem;                                                                34038000
$if                           <<debugging code>>                        34040000
                                                                        34042000
   initialize'cxstore;                                                  34044000
                                                                        34046000
        << make sure we have a big enough stack >>                      34048000
   zsize (max'tape'buf'size + min'stack'size);                          34050000
   if <> then fail'not'critical (sr'insufstack);                        34052000
                                                                        34054000
         <<we dont want to be aborted except under our own              34056000
           control, so set critical mode...>>                           34058000
                                                                        34060000
   oldcritical:=setcritical;                                            34062000
                                                                        34064000
   sm'set;                    <<sets sm iff op set>>                    34066000
                                                                        34068000
   open'syslist'file;                                                   34070000
                                                                        34072000
   if seen'time then          <<time>>                                  34072100
      begin                                                             34072200
      sendmessage (m'time'info,true);                                   34072210
      sendmessage (sr'tim'start);                                       34072300
      end;                                                              34072500
                                                                        34072600
         <<preparse the input, which may result in indirect being       34074000
           opened...>>                                                  34076000
                                                                        34078000
   pre'parse'input (true);                                              34080000
                                                                        34082000
   parse'options;                                                       34084000
                                                                        34086000
                                                               <<04870>>34088000
   if dbstore'tog then                                         <<04870>>34090000
      if (not seen'high) or (not seen'low) then                <<04870>>34092000
         fail (sr'dbstore'wo'high'and'low);                    <<04870>>34094000
         <<---------------------------------------------------->>       34096000
         << this concludes the parse.  if we made it this far, >>       34098000
         << the rough outline of the command is good.  the next>>       34100000
         << step is to set up the environment of the store by  >>       34102000
         << opening the files...                               >>       34104000
         <<---------------------------------------------------->>       34106000
                                                                        34108000
                                                                        34110000
                                                                        34112000
   if syntax'tog then                                                   34114000
      begin                                                             34116000
      why:=why'good;          <<remember "state">>                      34118000
      go end'cxstore;                                                   34120000
      end;                                                              34122000
                                                                        34124000
   open'indirect'file;        <<only if it was specified by user>>      34126000
                                                                        34128000
   open'files (0d);           <<open all files but tape file>> <<lb.rs>>34130000
                                                               <<05012>>34130100
   if sysdumping and itemp="NOFILES-NOFILES" then              <<05012>>34130200
      write'tapemarks'only;                                    <<05012>>34130400
                                                                        34132000
   sendmessage (sr'store'version);                                      34134000
   sendmessage (m'dateline);                                            34136000
                                                                        34138000
   if release'flag then                                                 34140000
      sendmessage (sr'public'tape);                                     34142000
                                                                        34144000
   sendmessage (m'blank'line);                                          34146000
                                                                        34148000
         <<we are now ready to do the store or restore...>>             34150000
                                                                        34152000
$page ";CXSTORE=  CXSTORE'RESTORE --- RESTORE OUTER BLOCK"              34154000
                                                                        34156000
   if restoring then                                                    34158000
      begin                                                             34160000
                                                                        34162000
            <<generate the candidat file ... (not the good              34164000
              file, but the candidat file!!)...>>                       34166000
                                                                        34168000
      if i'num <> 0 then           <<read recs from indirect...>>       34170000
         read'indirect'and'generate'good                                34172000
      else                                                              34174000
         generate'good'file;                                            34176000
                                                                        34178000
      if c'rec'count = 0d then                                          34180000
         begin                                                          34182000
         sendmessage (m'no'files'to'restore);                           34184000
         print'summary;                                                 34186000
         close'files (no'file);                                         34188000
         go end'cxstore;                                                34190000
         end;                                                           34192000
                                                                        34194000
      pre'check'direc;                                                  34196000
      open'tape'file;                                                   34198000
                                                                        34200000
      build'tape'buffer;                                                34202000
                                                                        34204000
      if check'store'restore'label = failed then                        34206000
         fail (0);                                                      34208000
                                                                        34210000
      build'restore'good'file;                                          34212000
                                                                        34214000
      restore'the'files;                                                34216000
                                                                        34218000
      end                                                               34220000
                                                                        34222000
$page ";CXSTORE=  CXSTORE'RESTORE --- STORE OUTER BLOCK"                34224000
                                                                        34226000
   else                                                                 34228000
      begin                                                             34230000
      why:=why'scanning;      <<remember "state">>                      34232000
      if i'num <> 0 then           <<read recs from indirect...>>       34234000
         read'indirect'and'generate'good                                34236000
      else                                                              34238000
         generate'good'file;                                            34240000
                                                                        34242000
      if files'to'handle = 0d then                                      34244000
         if sysdumping then                                    <<05012>>34245000
            write'tapemarks'only                               <<05012>>34245200
         else                                                  <<05012>>34245500
            sendmessage (m'no'files'to'store)                  <<05012>>34246000
      else if dbstore'tog and files'rejected <> 0d then        <<04870>>34248000
         fail (0)                                              <<04870>>34250000
      else if dbstore'tog and                                  <<04870>>34252000
           (files'to'handle <>                                 <<04870>>34254000
               double (dbstore'high - dbstore'low + 2) ) then  <<04870>>34256000
         fail (sr'incorrect'number'of'files)                   <<04870>>34258000
                                                               <<04870>>34260000
      else                                                              34262000
         begin                                                          34264000
         open'tape'file;                                                34266000
                                                                        34268000
            <<------------------------------------------------>>        34270000
            << files parsed, put in file good, tape open,     >>        34272000
            << first eofs written.  now put files on tape.    >>        34274000
            <<------------------------------------------------>>        34276000
                                                                        34278000
         build'tape'buffer;                                             34280000
                                                                        34282000
         store'the'files;                                               34284000
                                                                        34284100
         if seen'purge then                                             34284200
            purge'files;                                                34284300
         end;                                                           34286000
                                                                        34288000
      end;                                                              34290000
                                                                        34292000
$page ";CXSTORE=  CXSTORE'RESTORE --- WRAPUP"                           34294000
                                                                        34296000
   print'summary;                                                       34298000
                                                                        34300000
   if seen'time then          <<time>>                                  34300100
      begin                                                             34300200
      sendmessage (m'time'info,true);                                   34300210
      sendmessage (sr'tim'done);                                        34300300
      end;                                                              34300500
                                                                        34300600
   close'files (no'file);             <<all of them>>                   34302000
                                                                        34304000
   why:=why'good;             <<remember "state">>                      34306000
                                                                        34308000
$page                                                                   34310000
end'cxstore:                                                            34312000
                                                               <<lb.rs>>34312100
         <<unlock the directory if not already done>>          <<lb.rs>>34312200
                                                               <<lb.rs>>34312300
   res'acct' := " ";                                           <<lb.rs>>34312400
   if group'index'ptr <> 0 then                                <<lb.rs>>34312500
      lock'directory;                                          <<lb.rs>>34312600
                                                               <<lb.rs>>34312700
         <<set jit acct back>>                                 <<lb.rs>>34312800
   if sm'tog and restoring then                                <<lb.rs>>34312900
      change'jit'acct (get'jitdst, logon'acct);                <<lb.rs>>34313000
                                                                        34314000
         <<dismount any and all private volumes we may                  34316000
           have mounted prior to this point...>>                        34318000
                                                                        34320000
   if pv'num > 0 then                                                   34322000
      dismount'private'volumes;                                         34324000
                                                                        34326000
         <<if we made ourselves sm because we had op but                34328000
           not sm, reset sm...                          >>              34330000
                                                                        34332000
   sm'reset;                                                            34334000
                                                                        34336000
         <<now, we can reset critical mode...before this we             34338000
           could not afford to be aborted.                 >>           34340000
                                                                        34342000
   resetcritical (oldcritical);                                         34344000
                                                                        34346000
end'cxstore'not'critical:                                               34348000
         <<if the caller wanted information communicated                34350000
           through the jcw called storejcw, place it                    34352000
           there now...                                    >>           34354000
                                                                        34356000
   if jcw'flag then                                                     34358000
      set'jcw;                                                          34360000
                                                                        34362000
         <<note: the send'mail'to'parent must be the last               34364000
           executable code in this procedure...all files                34366000
           should be closed, all resources released, before             34368000
           calling it...our parent is not guaranteed to                 34370000
           wait for us to terminate after we send him                   34372000
           mail...if the caller terminates quickly after                34374000
           getting the mail, we terminate too!             >>           34376000
                                                                        34378000
   if mail'tog then                                                     34380000
      send'mail'to'parent;                                              34382000
                                                                        34384000
   end <<cxstore'restore proc>>;                                        34386000
$page ";THUNK'STORE=  RECIP'STORE --- CLEAN DIRECSCAN INTERFACE"        34388000
$control segment=thunk'store                                            34390000
<<*****************************************************************>>   34392000
integer procedure recip'store (x'element, level, parms'offset, sir);    34394000
         value level, parms'offset, sir;                                34396000
         integer level, parms'offset;                                   34398000
         integer array x'element;                                       34400000
         double sir;                                                    34402000
         option privileged, uncallable;                                 34404000
<<----------------------------------------------------------------->>   34406000
<<  recip'store runs with its db set to the base of the disk       >>   34408000
<<  directory stack at first.                                      >>   34410000
<<----------------------------------------------------------------->>   34412000
<<                                                                 >>   34414000
<< parameters to recip'store                                       >>   34416000
<<                                                                 >>   34418000
<<   x'element  -  a directory data segment pointer to file/group/ >>   34420000
<<                 acct entry.                                     >>   34422000
<<                                                                 >>   34424000
<<     level    -  0=file,  1=group,  2=acct,  3=user (should not  >>   34426000
<<                                                     happen!)    >>   34428000
<< parms'offset -  caller's q-relative negative displacement of    >>   34430000
<<                 stack parameters passed to direcscan;           >>   34432000
<<                 delta-q must be subtracted to reference as:     >>   34434000
<<                 arq (parms'offset).                             >>   34436000
<<                                                                 >>   34438000
<<     sir      -  dsir and dsir'info                              >>   34440000
<<                                                                 >>   34442000
<<  recip'store returns (to direcscan) :                           >>   34444000
<<                                                                 >>   34446000
<<     0 + l   -   continue scan                                   >>   34448000
<<     2 + l   -   skip this tree (scan brother)                   >>   34450000
<<     4 + l   -   stop scan                                       >>   34452000
<<                                                                 >>   34454000
<<           where  l = 0 if directory not locked down             >>   34456000
<<                            (recip'store unlocked it).           >>   34458000
<<                  l = 1 if directory is still locked down.       >>   34460000
<<                                                                 >>   34462000
<<----------------------------------------------------------------->>   34464000
<<                                                                 >>   34466000
<< recip'store is called with db set to dds (the stack of the file >>   34468000
<< directory.                                                      >>   34470000
<<  the directory is always locked down when recip'store is called,>>   34472000
<<  and will stay locked down unless recip'store unlocks it.       >>   34474000
<<                                                                 >>   34476000
<<----------------------------------------------------------------->>   34478000
   begin                                                                34480000
                                                                        34482000
   integer array                                                        34484000
      arq         (*) = q + 0,         <<address q-relative>>           34486000
      element     (0:64) = q;          <<direct q array...important!>>  34488000
                                                                        34490000
   integer pointer                                                      34492000
      parms;                                                            34494000
                                                                        34496000
   integer                                                              34498000
      len         := 0,                                                 34500000
      sir'1       = sir + 0,                                            34502000
      sir'2       = sir + 1;                                            34504000
                                                                        34506000
   equate                                                               34508000
      dirdst      = 20;                                                 34510000
                                                                        34512000
         <<--------------------- split db ----------------------->>     34514000
                                                                        34516000
         <<subtract delta q to get total distance>>                     34518000
                                                                        34520000
   parms'offset:=parms'offset - arq;                                    34522000
                                                                        34524000
         <<copy x'element into the q-relative direct array element..>>  34526000
                                                                        34528000
   len:=64;                                                             34530000
   while (len:=len-1) >= 0 do                                           34532000
      element(len):=x'element(len);                                     34534000
                                                                        34536000
         <<now go back to the user's db...>>                            34538000
                                                                        34540000
   exchangedb (0);                                                      34542000
                                                                        34544000
         <<pick up parms...>>                                           34546000
                                                                        34548000
<< @parms:=@arq (parms'offset); >>                                      34550000
                                                                        34552000
         <<call the non-splitstack procedure to examine this            34554000
           directory entry...>>                                         34556000
                                                                        34558000
   recip'store:=thunk'store (element, level,                            34560000
                             sir'1, sir'2);                             34562000
                                                                        34564000
         <<switch back to the directory stack and exit...>>             34566000
                                                                        34568000
   exchangedb (dirdst);                                                 34570000
                                                                        34572000
   end <<recip'store proc>>;                                            34574000
$if x5=on then                                                          40000000
$page "STATISTICS ROUTINE"                                              40002000
$control segment=thunk'store                                            40004000
procedure iocount;                                                      40006000
begin                                                                   40008000
   double array                                                         40010000
      disj'ext'addr(0:31),                                              40012000
      disj'ext'len(0:31),                                               40014000
      fl'extmap'd (*) = flextmap'd;                                     40016000
   integer                                                              40018000
      ext,                                                              40020000
      num'disj'exts;                                                    40022000
   double                                                               40024000
      sectors'to'write,                                                 40026000
      sectors'this'write;                                               40028000
                                                                        40030000
   sectors'to'write := file'sectors;                                    40032000
   ext := -1;                                                           40034000
                                                                        40036000
   while ((ext:=ext+1) <= flnumexts) and (sectors'to'write<>0d) do      40038000
      begin                                                             40040000
         if flextsize'd <= sectors'to'write then                        40042000
            sectors'this'write := flextsize'd                           40044000
         else sectors'this'write := sectors'to'write;                   40046000
         sectors'to'write := sectors'to'write - sectors'this'write;     40048000
         old'tape'writes := old'tape'writes +                           40050000
            (sectors'this'write-1d)/tape'write'sectors+1d;              40052000
         old'disc'reads := old'disc'reads  +                            40054000
            (sectors'this'write-1d)/disc'read'sectors+1d;               40056000
      end;                                                              40058000
                                                                        40060000
   old'total'extents := old'total'extents + double(ext);                40062000
                                                                        40064000
   join'contiguous'extents (num'disj'exts, disj'ext'addr,               40066000
                            disj'ext'len,  fl'extmap'd   );             40068000
                                                                        40070000
   sectors'to'write := file'sectors;                                    40072000
   ext := -1;                                                           40074000
                                                                        40076000
   while ((ext:=ext+1) <= num'disj'exts) and (sectors'to'write<>0d) do  40078000
      begin                                                             40080000
         if disj'ext'len(ext) <= sectors'to'write then                  40082000
            sectors'this'write := disj'ext'len(ext)                     40084000
         else sectors'this'write := sectors'to'write;                   40086000
         sectors'to'write := sectors'to'write - sectors'this'write;     40088000
         new'tape'writes := new'tape'writes +                           40090000
            (sectors'this'write-1d)/tape'write'sectors+1d;              40092000
         new'disc'reads  := new'disc'reads  +                           40094000
            (sectors'this'write-1d)/disc'read'sectors+1d;               40096000
      end;                                                              40098000
                                                                        40100000
   new'total'extents := new'total'extents + double(ext);                40102000
                                                                        40104000
end;                                                                    40106000
$if                                                                     40108000
$page ";THUNK'STORE=  THUNK'STORE --- EXAMINES DIRECTORY ENTRIES"       40110000
$control segment=thunk'store                                            40112000
<<*****************************************************************>>   40114000
integer procedure thunk'store (element, level, dsirnumber,              40116000
                               dsirinfo);                               40118000
         value   level, dsirnumber, dsirinfo;                           40120000
         integer level, dsirnumber, dsirinfo;                           40122000
         integer array element;                                         40124000
         option privileged, uncallable;                                 40126000
<<----------------------------------------------------------------->>   40128000
<<  thunk'store runs with the original db, not the dds db!         >>   40130000
<<----------------------------------------------------------------->>   40132000
<<                                                                 >>   40134000
<< parameters to thunk'store                                       >>   40136000
<<                                                                 >>   40138000
<<     element  -  a directory data segment pointer to file/group/ >>   40140000
<<                 acct entry.                                     >>   40142000
<<                                                                 >>   40144000
<<     level    -  0=file,  1=group,  2=acct,  3=user (should not  >>   40146000
<<                                                     happen!)    >>   40148000
<<     parms    -  integer array passed to recip'store by istore...>>   40150000
<<                 has a lot of information needed by this routine.>>   40152000
<<                                                                 >>   40154000
<<     dsirnumber - number of (presumably) directory sir.         >>    40156000
<<     dsirinfo -  info returned by getsir that got above sir.    >>    40158000
<<                                                                 >>   40160000
<<  thunk'store returns to recip'store:                            >>   40162000
<<                                                                 >>   40164000
<<     0 + l   -   continue scan                                   >>   40166000
<<     2 + l   -   skip this tree (scan brother)                   >>   40168000
<<     4 + l   -   stop scan                                       >>   40170000
<<                                                                 >>   40172000
<<           where  l = 0 if directory not locked down             >>   40174000
<<                     (thunk'store unlocked it).               >  >>   40176000
<<                  l = 1 if directory is still locked down.       >>   40178000
<<                                                                 >>   40180000
<<----------------------------------------------------------------->>   40182000
<<  the directory is always locked down when thunk'store is called,>>   40184000
<<  and will stay locked down unless thunk'store unlocks it.       >>   40186000
<<                                                                 >>   40188000
<<----------------------------------------------------------------->>   40190000
<<                                                                 >>   40192000
<< only two errors encountered herein are handled out at the       >>   40194000
<< cxstore level:  user hit 'break', and the 'good' file got an    >>   40196000
<< i/o error.  these two terminate thunk'store, recip'store,       >>   40198000
<< direcscan, directory'search and istore with no messages, then   >>   40200000
<< cxstore will call cierr with the appropriate message number.    >>   40202000
<<                                                                 >>   40204000
<< all other errors are reported from within here via the          >>   40206000
<< sendmessage routine.  a few errors will abort scanning the      >>   40208000
<< directory for this file only! (e.g: a direcscan logic error)    >>   40210000
<< other errors (e.g: failing to read a file label) result in      >>   40212000
<< warning messages and the non-storing of the particular file.    >>   40214000
<<                                                                      40216000
<< note: before any output call, thunk'store unlocks all sirs!!    >>   40218000
<<                                                                 >>   40220000
<<----------------------------------------------------------------->>   40222000
<<----------------------------------------------------------------->>   40224000
<<           !f.g.a returned  !   # of calls    !level value passed>>   40226000
<<fileset in !by produceparms ! of thunk'store  !  to thunk'store  >>   40228000
<<look'title'! (- = blank)    !  by direcscan   !  per call        >>   40230000
<<-----------+----------------+-----------------+------------------>>   40232000
<<           !                !                 !                  >>   40234000
<< f.g.a     !     f.g.a      !        1        !       0          >>   40236000
<<           !                !                 !                  >>   40238000
<< f.g       !     f.g.-      !        1        !       0          >>   40240000
<<           !                !                 !                  >>   40242000
<< f         !     f.-.-      !        1        !       0          >>   40244000
<<           !                !                 !                  >>   40246000
<< @         !     -.-.-      !  #files         !    0,0,0,...,0   >>   40248000
<<           !                !                 !                  >>   40250000
<< @.g       !     -.g.-      !  #files         !    0,0,0,...,0   >>   40252000
<<           !                !                 !                  >>   40254000
<< @.g.a     !     -.g.a      !  #files         !    0,0,0,...,0   >>   40256000
<<           !                !                 !                  >>   40258000
<< @.@       !     -.-.-      !  (#files+1)     !  1,0,0,0,...,0   >>   40260000
<<           !                !  * #groups      !  1,0,0,0,...,0   >>   40262000
<<           !                !                 !      etc.        >>   40264000
<<           !                !                 !                  >>   40266000
<< @.@.a     !     -.-.a      !  (#files+1)     !  1,0,0,0,...,0   >>   40268000
<<           !                !  * #groups      !  1,0,0,0,   ,0   >>   40270000
<<           !                !                 !      etc.        >>   40272000
<<           !                !                 !                  >>   40274000
<< @.@.@     !     -.-.-      !  ((#files+1)    !2,1,0,0,0,...,0   >>   40276000
<<           !                !  * (#groups+1)  !  1,0,0,0,...,0   >>   40278000
<<           !                !  * #accounts    !  1,0,0,0,...,0   >>   40280000
<<           !                !                 !      etc.        >>   40282000
<<           !                !                 !2,1,0,0,0,...,0   >>   40284000
<<           !                !                 !  1,0,0,0,...,0   >>   40286000
<<           !                !                 !  1,0,0,0,...,0   >>   40288000
<<           !                !                 !      etc.        >>   40290000
<<----------------------------------------------------------------->>   40292000
                                                                        40294000
   begin                                                                40296000
                                                                        40298000
   double array                                                         40300000
      element'd   (*) = element (0),                                    40302000
      extent'addr'd (0:32),                                             40304000
      gbuf'd      (0:g'recsize/2);                                      40306000
                                                                        40308000
   double                                                               40310000
      iob,                                                              40312000
      label'address := 0d;                                              40314000
                                                                        40316000
                                                                        40318000
   integer array                                                        40320000
      gbuf        (*) = gbuf'd (0),                                     40322000
      pvbuf       (0:pv'recsize-1);                                     40324000
                                                                        40326000
   integer                                                              40328000
      hvsind      := [8/"*", 8/" "],                                    40330000
      i           := 0,       <<scratch integer>>                       40332000
      label'address'1 = label'address + 0,                              40334000
      label'address'2 = label'address + 1,                              40336000
      label'ldev,                                                       40338000
      len,                                                              40340000
      reqtype,                                                          40342000
      x           := 0;       <<used by checksum>>                      40344000
                                                                        40346000
   logical array                                                        40348000
      mess        (0:max'title'len*2);                                  40350000
                                                                        40352000
   logical                                                              40354000
      locked'the'file:=false,                                           40356000
      matched'pattern:=false,                                           40358000
      need'rel'dsir := false, <<if true, relsir(dsir) at end>>          40360000
      yes;                                                              40362000
                                                                        40364000
   byte array                                                           40366000
      element'    (*) = element (0),                                    40368000
      gbuf'       (*) = gbuf (0),                                       40370000
      mess'       (*) = mess (0),                                       40372000
      temp'       (0:9);                                                40374000
                                                                        40376000
   equate                                                               40378000
      dtimu       =  5;  <<frequency of unlocking dds by thunk'store>>  40380000
                                                                        40382000
   label                                                                40384000
      thunk'store'exit;                                                 40386000
                                                                        40388000
   <<---------------->>                                                 40390000
   <<  fail          >>                                                 40392000
   <<---------------->>                                                 40394000
                                                                        40396000
   subroutine fail (thunk'storeval, mnum);                              40398000
         value   mnum, thunk'storeval;                                  40400000
         integer mnum, thunk'storeval;                                  40402000
      begin                                                             40404000
                                                                        40406000
      if mnum <> 0 then                                                 40408000
         begin                                                          40410000
         release'sirs (got'fisir, got'dsir);                            40412000
         sendmessage (mnum);                                            40414000
         end;                                                           40416000
                                                                        40418000
      if matched'pattern then                                           40420000
         files'rejected:=files'rejected + 1d;                           40422000
                                                                        40424000
      if thunk'storeval = rc'stop then                                  40426000
         thunk'store'err:=true;                                         40428000
                                                                        40430000
      thunk'store:=thunk'storeval;                                      40432000
                                                                        40434000
      go thunk'store'exit;                                              40436000
                                                                        40438000
      end <<fail sub>>;                                                 40440000
                                                                        40442000
   <<----------------->>                                                40444000
   <<  lock'the'file  >>                                                40446000
   <<----------------->>                                                40448000
                                                                        40450000
   subroutine lock'the'file;                                            40452000
      begin                                                             40454000
                                                                        40456000
      if flclid <> cold'load'id then                                    40458000
         begin                <<cold load id not valid>>                40460000
         count'rewrites'cold'load'id:=count'rewrites'cold'load'id+1;    40462000
         flstorerestore := 0;                                           40464000
         flwrite:=0;                                                    40466000
         flrw := 0;                                                     40468000
         flloaded := 0;                                                 40470000
         flfcbvect := 0d;                                      <<lb.36>>40472000
         flpvinfo  := 0;                                       <<lb.36>>40473000
         flclid := cold'load'id;                                        40474000
         flab'checksum;                                                 40476000
         end;                                                           40478000
                                                                        40480000
      if flstore <> 0 then                                              40482000
         fail (0, m'open'for'store);                                    40484000
                                                                        40486000
      if flrestore <> 0 then                                            40488000
         fail (0, m'open'for'restore);                                  40490000
                                                                        40492000
      if flwrite <> 0 then                                              40494000
         fail (0, m'open'for'write);                                    40496000
                                                                        40498000
            <<we get here also if we need to rewrite coldloadid!>>      40500000
                                                                        40502000
      flstore:=1;          <<lock it down>>                             40504000
                                                                        40506000
      if write'label (label'ldev, label'address, got'sir)               40508000
            = failed then                                               40510000
         fail (0, m'nolock'write'fail);                                 40512000
                                                                        40514000
      locked'the'file:=true;                                            40516000
                                                                        40518000
$if x1=on then                <<debugging code>>                        40520000
      if debugging then                                                 40522000
         begin                                                          40524000
         say "LOCK'THE'FILE GOOD" endsay;                               40526000
         send;                                                          40528000
         end;                                                           40530000
$if                           <<debugging code>>                        40532000
                                                                        40534000
      end <<lock'the'file sub>>;                                        40536000
                                                                        40538000
   <<--------------------->>                                            40540000
   <<  report'dates       >>                                            40542000
   <<--------------------->>                                            40544000
                                                                        40546000
   subroutine report'dates (typ, lo, mid, hi);                          40548000
         value typ, lo, mid, hi;                                        40550000
         logical typ, lo, mid, hi;                                      40552000
                                                                        40554000
      begin                                                             40556000
                                                                        40558000
$if x1=on then                <<debugging code>>                        40560000
      say "   " endsay;                                                 40562000
      say1 (typ);                                                       40564000
      say "DATE NOT IN RANGE: " endsay;                                 40566000
      saydnum(double(lo));                                              40568000
      say " <= " endsay;                                                40570000
      saydnum(double(mid));                                             40572000
      say " <= " endsay;                                                40574000
      saydnum(double(hi));                                              40576000
      send;                                                             40578000
$if                           <<debugging code>>                        40580000
                                                                        40582000
      end <<report'dates sub>>;                                         40584000
                                                                        40586000
   <<------------------>>                                               40588000
   <<  always'matches  >>                                               40590000
   <<------------------>>                                               40592000
                                                                        40594000
   logical subroutine always'matches (pattern);                         40596000
        integer array pattern;                                          40598000
                                                                        40600000
     begin                                                              40602000
                                                                        40604000
     always'matches:= false;                                            40606000
     if pattern(0) = 1 then                                             40608000
        if pattern(1).pattypef = anycharactersp then                    40610000
           always'matches:= true;                                       40612000
                                                                        40614000
     end <<always'matches sub>>;                                        40616000
   <<------------------------------------------------------------>>     40618000
$page ";THUNK'STORE=  THUNK'STORE --- OUTER BLOCK"                      40620000
                                                                        40622000
   error'code:=0;               <<indicates no serious error>>          40624000
                                                                        40626000
   dsir'info:=dsirinfo;                                                 40628000
                                                                        40630000
$if x1=on then                <<debugging code>>                        40632000
   if debugging then                                                    40634000
      begin                                                             40636000
      say "DSIR'INFO:= " endsay;                                        40638000
      saynum (dsir'info);                                               40640000
      send;                                                             40642000
      end;                                                              40644000
$if                           <<debugging code>>                        40646000
                                                                        40648000
   got'dsir:=true;                                                      40650000
                                                                        40652000
$if x1=on then                <<debugging code>>                        40654000
   if debugging then                                                    40656000
      begin                                                             40658000
      say "THUNK'STORE: LEVEL=" endsay;                                 40660000
      saynum (level);                                                   40662000
      say ", ELEMENT = " endsay;                                        40664000
      say element',(file'part'size) endsay;                             40666000
      say ", LOOK'TITLE = " endsay;                                     40668000
      say'standard (look'title');                                       40670000
      send;                                                             40672000
      end;                                                              40674000
$if                           <<debugging code>>                        40676000
                                                               <<04965>>40676100
   if thunk'store'err then                                     <<04965>>40676200
      fail (rc'stop, 0);                                       <<04965>>40676300
                                                                        40678000
   if not (0<=level<=2) then                                            40680000
      fail (rc'stop, m'direcscan'error);                                40682000
                                                                        40684000
         <<see if the user hit break...                                 40686000
           if so, terminate the search, but dont unlock the             40688000
           files...this will be done by the caller (or the              40690000
           caller's caller?)...>>                                       40692000
                                                                        40694000
   if requestservice then              <<saw a break/abort>>            40696000
      fail (rc'stop, sr'break'sensed);                                  40698000
                             <<be printed by cxstore'restore>>          40700000
                                                                        40702000
         <<extract the file (or group or acct) part from element...     40704000
           and place it (plus its length count) into temp'...>>         40706000
                                                                        40708000
   move temp'(1):=element',(file'part'size);                            40710000
   temp'(9):=" ";             <<place a stopper at the end>>            40712000
   scan temp'(1) until " ",1; <<leave pointer on stack>>                40714000
   len:=tos-logical(@temp'(1));                                         40716000
   temp'(0):=byte(len);                                                 40718000
                                                                        40720000
         <<see if this title part is valid alphanumeric...>>            40722000
                                                                        40724000
   move temp'(1):=temp'(1) while an, 1;      <<leave dest addr>>        40726000
   len:=tos-logical(@temp'(1));        <<length of alpha>>              40728000
                                                                        40730000
   if len <> integer(temp'(0)) or temp'(1) <> alpha then                40732000
      begin                                                             40734000
      if level = acctlevel then                                         40736000
         fail (skiptree, sr'bad'acct'in'direcscan);                     40738000
      if level = grouplevel then                                        40740000
         fail (skiptree, sr'bad'group'in'direcscan);                    40742000
      fail (skipnode, sr'bad'file'in'direcscan);                        40744000
      end;                                                              40746000
                                                                        40748000
$if x1=on then                <<debugging code>>                        40750000
   if debugging then                                                    40752000
      begin                                                             40754000
      say "   TEMP' = '" endsay;                                        40756000
      say temp'(1),(len) endsay;                                        40758000
      say "'  LEN = " endsay;                                           40760000
      saynum (len);                                                     40762000
      send;                                                             40764000
      end;                                                              40766000
$if                           <<debugging code>>                        40768000
$page ";THUNK'STORE=  THUNK'STORE --- ACCOUNT LEVEL HANDLING"           40770000
   if level = acctlevel then                                            40772000
      begin                                                             40774000
                                                                        40776000
            <<see if the account matches...>>                           40778000
                                                                        40780000
      if look'acct'pat <> 0 then                                        40782000
         if pattern'match (temp', look'acct'pat) = failed then          40784000
            begin                                                       40786000
$if x1=on then                <<debugging code>>                        40788000
            if debugging then                                           40790000
               begin                                                    40792000
               say "   ACCT MIS" endsay;                                40794000
               report'mismatch (element', look'acct'pat);               40796000
               end;                                                     40798000
$if                           <<debugging code>>                        40800000
            fail (skiptree, 0);                                         40802000
            end;                                                        40804000
                                                                        40806000
            <<if the 'exception account' matches this account,          40808000
              and the group & file exception patterns are "@"           40810000
              then leave...>>                                           40812000
                                                                        40814000
      if not'acct'pat <> 0 then                                         40816000
         if always'matches (not'file'pat)  and                          40818000
               always'matches (not'group'pat) and                       40820000
               (pattern'match (temp', not'acct'pat) = good) then        40822000
            begin                                                       40824000
$if x1=on then                <<debugging code>>                        40826000
            if debugging then                                           40828000
               begin                                                    40830000
               say "   NOT ACCT " endsay;                               40832000
               report'mismatch (element', not'acct'pat);                40834000
               end;                                                     40836000
$if                           <<debugging code>>                        40838000
            fail (skiptree, 0);                                         40840000
            end;                                                        40842000
                                                                        40844000
      fill' (curr'title', max'std'len, 0);                              40846000
                                                                        40848000
      move curr'acct:=element(0),(4);  <<account name>>                 40850000
      fill (curr'file, 4, "??");       <<blank out file entry>>         40852000
      fill (curr'group, 4, "??");      <<blank out the group entry>>    40854000
      if display'3'to'standard (curr'file', curr'group',                40856000
                             curr'acct', curr'title', error'code)       40858000
            = failed then                                               40860000
         fail (0, sr'd'2's'failed);                                     40862000
                                                                        40864000
      a'security:=element(26);         <<account security>>             40866000
                                                                        40868000
$if x1=on then                <<debugging code>>                        40870000
      if debugging then                                                 40872000
         begin                                                          40874000
         say "  Good account! " endsay;                                 40876000
         send;                                                          40878000
         end;                                                           40880000
$if                           <<debugging code>>                        40882000
                                                                        40884000
      go thunk'store'exit;                                              40886000
                                                                        40888000
      end;                                                              40890000
$page ";THUNK'STORE=  THUNK'STORE --- GROUP LEVEL HANDLING"             40892000
   if level = grouplevel then                                           40894000
      begin                                                             40896000
                                                                        40898000
      if look'group'pat <> 0 then                                       40900000
         if pattern'match (temp', look'group'pat) = failed then         40902000
            begin                                                       40904000
$if x1=on then                <<debugging code>>                        40906000
            if debugging then                                           40908000
               begin                                                    40910000
               say "   LOOK'GROUP MIS" endsay;                          40912000
               report'mismatch (element', look'group'pat);              40914000
               end;                                                     40916000
$if                           <<debugging code>>                        40918000
            fail (skiptree, 0);                                         40920000
            end;                                                        40922000
                                                                        40924000
      if not'group'pat <> 0 then                                        40926000
         if always'matches (not'file'pat) and                           40928000
               always'matches (not'acct'pat) and                        40930000
               (pattern'match (temp', not'group'pat) = good) then       40932000
            begin                                                       40934000
$if x1=on then                <<debugging code>>                        40936000
            if debugging then                                           40938000
               begin                                                    40940000
               say "   NOT'GROUP " endsay;                              40942000
               report'mismatch (element', not'group'pat);               40944000
               end;                                                     40946000
$if                           <<debugging code>>                        40948000
            fail (skiptree, 0);                                         40950000
            end;                                                        40952000
                                                                        40954000
$if x1=on then                <<debugging code>>                        40956000
      if debugging then                                                 40958000
         begin                                                          40960000
         say "   Good group!" endsay;                                   40962000
         send;                                                          40964000
         end;                                                           40966000
$if                           <<debugging code>>                        40968000
                                                                        40970000
      g'security'1:=element(21);                                        40972000
      g'security'2:=element(22);                                        40974000
      move curr'group:=element,(4);                                     40976000
      if display'3'to'standard (curr'file', curr'group',                40978000
                             curr'acct', curr'title', error'code)       40980000
            = failed then                                               40982000
         fail (0, sr'd'2's'failed);                                     40984000
                                                                        40986000
      if element (glinkage).(pvf) = pv then                             40988000
         begin                <<group assigned to pv>>                  40990000
         release'sirs (false, got'dsir);                                40992000
                                                                        40994000
$if x1=on then                <<debugging code>>                        40996000
         if debugging then                                              40998000
            begin                                                       41000000
            say "   Group on PV!" endsay;                               41002000
            send;                                                       41004000
            end;                                                        41006000
$if                           <<debugging code>>                        41008000
         reqtype:=condmount'bind;                                       41010000
                                                                        41012000
         mount (hvsind, curr'group, curr'acct,                          41014000
                reqtype, -1, mounted'volume'info);                      41016000
                                                                        41018000
         if < then                                                      41020000
            begin                      <<mount problem>>                41022000
            move flab:="@       ",2;                                    41024000
            move *:=curr'group,(4),2;                                   41026000
            move *:=curr'acct,(4);                                      41028000
            mounted'volume'info := 0;                                   41030000
            sendmessage (m'pv'mount'problem);                           41032000
            fail (skiptree, 0);        <<stops scan of this tree>>      41034000
            end;                                                        41036000
                                                                        41038000
         move pvbuf(pvinx'group):=curr'group,(4);                       41040000
         move pvbuf(pvinx'acct) :=curr'acct, (4);                       41042000
         pvbuf(pvinx'pvinfo):=mounted'volume'info;                      41044000
                                                                        41046000
         fwrite (pv'num, pvbuf, pv'recsize, 0);                         41048000
         if <> then                                                     41050000
            fail (0, sr'pv'write'fail);                                 41052000
                                                                        41054000
         mounted'volume'info.(0:2) := 3; <<ind mount required>>         41056000
         thunk'store.(0:1) := 1;           <<need to redo entry>>       41058000
         end                                                            41060000
      else                                                              41062000
         mounted'volume'info:=sp'pv;                                    41064000
                                                                        41066000
      go thunk'store'exit;                                              41068000
                                                                        41070000
      end;                                                              41072000
$page ";THUNK'STORE=  THUNK'STORE --- FILE LEVEL HANDLING"              41074000
         <<if we get here, level = filelevel>>                          41076000
                                                                        41078000
   if look'file'pat <> 0 then                                           41080000
      if pattern'match (temp', look'file'pat) = failed then             41082000
         begin                                                          41084000
$if x1=on then                <<debugging code>>                        41086000
         if debugging then                                              41088000
            begin                                                       41090000
            say "   LOOK'FILE MIS" endsay;                              41092000
            report'mismatch (element', look'file'pat);                  41094000
            end;                                                        41096000
$if                           <<debugging code>>                        41098000
         fail (skipnode, 0);                                            41100000
         end;                                                           41102000
                                                                        41104000
   rc'calls := rc'calls + 1;                                            41106000
                                                                        41108000
$if x1=on then                <<debugging code>>                        41110000
   if debugging then                                                    41112000
      begin                                                             41114000
      send;                                                             41116000
      say "THUNK'STORE # " endsay;                                      41118000
      saynum (rc'calls);                                                41120000
      send;                                                             41122000
      end;                                                              41124000
$if                           <<debugging code>>                        41126000
                                                                        41128000
   move curr'file:=element(0),(4);                                      41130000
                                                                        41132000
         <<convert current file title to standard form...>>             41134000
                                                                        41136000
   if display'3'to'standard (curr'file', curr'group', curr'acct',       41138000
                             curr'title', error'code)                   41140000
         = failed then                                                  41142000
      fail (0, sr'd'2's'failed);                                        41144000
                                                                        41146000
         <<see if the user did not want this file stored...>>           41148000
                                                                        41150000
   if not'file'pat <> 0 then                                            41152000
      if pattern'match'standard (curr'title', not'file'pat,             41154000
                                not'group'pat, not'acct'pat, i)         41156000
               = good then                                              41158000
         begin                                                          41160000
$if x1=on then                <<debugging code>>                        41162000
         if debugging then                                              41164000
            begin                                                       41166000
            say "   NOT'FILE " endsay;                                  41168000
            saynum (i);                                                 41170000
            say " for " endsay;                                         41172000
            say'standard (curr'title');                                 41174000
            send;                                                       41176000
            report'mismatch (element', not'file'pat);                   41178000
            end;                                                        41180000
$if                           <<debugging code>>                        41182000
         fail (skipnode, 0);                                            41184000
         end;                                                           41186000
                                                                        41188000
$if x1=on then                <<debugging code>>                        41190000
   if debugging then                                                    41192000
      begin                                                             41194000
      say "   file " endsay;                                            41196000
      say'standard (curr'title');                                       41198000
      say " worked for: " endsay;                                       41200000
      send;                                                             41202000
      say "      " endsay;                                              41204000
      say'pattern (look'file'pat);                                      41206000
      say " and not for: " endsay;                                      41208000
      say'pattern (not'file'pat);                                       41210000
      send;                                                             41212000
      end;                                                              41214000
$if                           <<debugging code>>                        41216000
                                                                        41218000
         <<if we get here, the file found matched the  >>               41220000
         <<pattern specifed, so the user expects it to >>               41222000
         <<be stored, unless something goes wrong.     >>               41224000
                                                                        41226000
   matched'pattern:=true;                                               41228000
                                                                        41230000
         <<pick up label address...>>                                   41232000
                                                                        41234000
   label'address:=element'd(2);   <<  element(4 & 5) >>                 41236000
   label'address'1.(00:08):=0;    <<zap the lun portion of address>>    41238000
                                                                        41240000
         <<map the logical unit number into a logical                   41242000
           device number...>>                                           41244000
                                                                        41246000
   label'ldev:= lun (element(4).(0:8), mounted'volume'info.(4:4));      41248000
                                                                        41250000
   if not got'fisir or not got'dsir then                                41252000
      begin                                                             41254000
$if x1=on then                <<debugging code>>                        41256000
      if debugging then                                                 41258000
         begin                                                          41260000
         say "...IN THUNK'STORE: GOT'FISIR=" endsay;                    41262000
         saynum (got'fisir);                                            41264000
         say ", GOT'DSIR=" endsay;                                      41266000
         saynum (got'dsir);                                             41268000
         send;                                                          41270000
         end;                                                           41272000
$if                           <<debugging code>>                        41274000
      get'sirs (true, true);          <<get fisir and dsir>>            41276000
      need'rel'dsir:=true;                   <<release at end>>         41278000
      end;                                                              41280000
                                                                        41282000
   if read'label (label'ldev, label'address, got'sir)                   41284000
         = failed then                                                  41286000
      begin                                                             41288000
      parms'tempi'1:=label'ldev;                                        41290000
      parms'tempd'1:=label'address;                                     41292000
      fail (0, m'read'file'label'failed);                               41294000
      end;                                                              41296000
                                                                        41298000
         <<see if the file label info matches the directory info...>>   41300000
                                                                        41302000
   if element'd(2) <> flextmap'd then        <<address match? >>        41304000
      fail (0, m'flab'address'mismatch);                                41306000
                                                                        41308000
   if fllocname' = curr'file',(file'part'size) and                      41310000
      flgrpname' = curr'group',(file'part'size) and                     41312000
      flacctname'= curr'acct',(file'part'size) then                     41314000
   else                                                                 41316000
      fail (0, m'flab'title'mismatch);                                  41318000
                                                                        41320000
         <<check the file label checksum...>>                           41322000
                                                                        41324000
   i:=flchecksum;                                                       41326000
   flab'checksum;                                                       41328000
   if i <> 0 and i <> flchecksum then                                   41330000
      begin                                                             41332000
      parms'tempi'1:=flchecksum;                                        41334000
      parms'tempi'2:=i;                                                 41336000
      fail (0, m'flab'checksum);                                        41338000
      end;                                                              41340000
                                                                        41342000
         <<see if we can calculate the filesize...>>                    41344000
                                                                        41346000
   file'sectors:=find'file'size (file'size'minv,                        41348000
                                 extent'addr'd);                        41350000
                                                                        41352000
$if x5=on then                                                          41354000
   iocount;         <<count disc reads,tape writes>>                    41356000
$if                                                                     41358000
         <<do date check...>>                                           41360000
                                                                        41362000
$if x1=on then                <<debugging code>>                        41364000
   if debugging then                                                    41366000
      begin                                                             41368000
      say "***FILE = " endsay;                                          41370000
      say fllocname', (file'part'size) endsay;  say1(".");              41372000
      say flgrpname', (file'part'size) endsay;  say1(".");              41374000
      say flacctname',(file'part'size) endsay;                          41376000
      send;                                                             41378000
      end;                                                              41380000
$if                           <<debugging code>>                        41382000
                                                                        41384000
   if adate'low > fllastacc                                             41386000
         or adate'high < fllastacc then                                 41388000
      begin                                                             41390000
$if x1=on then                <<debugging code>>                        41392000
      if debugging then                                                 41394000
         begin                                                          41396000
         report'dates ("A", adate'low, fllastacc, adate'high);          41398000
         end;                                                           41400000
$if                           <<debugging code>>                        41402000
      matched'pattern:=simple'tog;                                      41404000
      if simple'tog then                                                41406000
         fail (0, m'adate'not'in'range)                                 41408000
      else                                                              41410000
         fail (0, 0);         <<access date not in range>>              41412000
      end;                                                              41414000
                                                                        41416000
   if cdate'low > flcreate                                              41418000
         or cdate'high < flcreate then                                  41420000
      begin                                                             41422000
$if x1=on then                <<debugging code>>                        41424000
      if debugging then                                                 41426000
         begin                                                          41428000
         report'dates ("C", cdate'low, flcreate, cdate'high);           41430000
         end;                                                           41432000
$if                           <<debugging code>>                        41434000
      matched'pattern:=simple'tog;                                      41436000
      if simple'tog then                                                41438000
         fail (0, m'cdate'not'in'range)                                 41440000
      else                                                              41442000
         fail (0, 0);         <<create date not in range>>              41444000
      end;                                                              41446000
                                                                        41448000
   if mdate'low > fllastmod                                             41450000
         or mdate'high < fllastmod then                                 41452000
      begin                                                             41454000
$if x1=on then                <<debugging code>>                        41456000
      if debugging then                                                 41458000
         begin                                                          41460000
         report'dates ("M", mdate'low, fllastmod, mdate'high);          41462000
         end;                                                           41464000
$if                           <<debugging code>>                        41466000
      matched'pattern:=simple'tog;                                      41468000
      if simple'tog then                                                41470000
         fail (0, m'mdate'not'in'range)                                 41472000
      else                                                              41474000
         fail (0, 0);         <<modify date not in range>>              41476000
      end;                                                              41478000
                                                                        41480000
         <<do filecode range check...>>                                 41482000
                                                                        41484000
$if x1=on then                <<debugging code>>                        41486000
   if debugging then                                                    41488000
      begin                                                             41490000
      say "   DATE OK, DO FILECODE CHECK..." endsay;                    41492000
      send;                                                             41494000
      end;                                                              41496000
$if                           <<debugging code>>                        41498000
                                                                        41500000
   if not (filecode'low <= flfilecode <= filecode'high) then            41502000
      begin                                                             41504000
      matched'pattern:=simple'tog;                                      41506000
      if simple'tog then                                                41508000
         fail (0, m'filecode'not'in'range)                              41510000
      else                                                              41512000
         fail (0, 0);                                                   41514000
      end;                                                              41516000
                                                                        41518000
         <<check security now...>>                                      41520000
                                                                        41522000
$if x1=on then                <<debugging code>>                        41524000
   if debugging then                                                    41526000
      begin                                                             41528000
      say "   CHECK FILE SECURITY NOW" endsay;                          41530000
      send;                                                             41532000
      end;                                                              41534000
$if                           <<debugging code>>                        41536000
                                                                        41538000
   if flsecure and not (cap'op lor cap'sm) then                         41540000
      begin                                                             41542000
      tos:=acccheck (0, flacctname, a'security,                         41544000
                     flgrpname, g'security, fluserid, flsecmx);         41546000
$if x1=on then                <<debugging code>>                        41548000
      if debugging then                                                 41550000
         begin                                                          41552000
         assemble(dup);                                                 41554000
         say "   ACCCHECK, TOS = " endsay;                              41556000
         sayoctal (tos);                                                41558000
         say ", QP'TYPE = " endsay;                                     41560000
         sayoctal (qp'type);                                            41562000
         send;                                                          41564000
         end;                                                           41566000
$if                           <<debugging code>>                        41568000
      if not tos.(10:1) then           <<read access failure>>          41570000
         begin                                                          41572000
         if not qp'type.(9:1) then                                      41574000
            begin                                                       41576000
$if x1=on then                <<debugging code>>                        41578000
            if debugging then                                           41580000
               begin                                                    41582000
               say "   QP'TYPE.9:1 = 0 " endsay;                        41584000
               send;                                                    41586000
               end;                                                     41588000
$if                           <<debugging code>>                        41590000
            fail (0, m'read'access'failure);                            41592000
            end;                                                        41594000
         fail (0, m'access'10'failure);                                 41596000
         end;                                                           41598000
      end;                                                              41600000
                                                                        41602000
         <<see if user is sm or op...>>                                 41604000
                                                                        41606000
$if x1=on then                <<debugging code>>                        41608000
   if debugging then                                                    41610000
      begin                                                             41612000
      say "   CHECK < FILECODE" endsay;                                 41614000
      send;                                                             41616000
      end;                                                              41618000
$if                           <<debugging code>>                        41620000
                                                                        41622000
   if not sm'tog then                                                   41624000
      begin                   <<not sm or op>>                          41626000
                                                                        41628000
            <<check filecode, lockword, access...>>                     41630000
                                                                        41632000
      if flfilecode < 0 then           <<negative filecode>>            41634000
         if not ignore'priv'check'flag then     <<ignore>>              41636000
            if not cap'pm then                                          41638000
               begin                   <<doesn't have priv mode>>       41640000
               fail (0, m'negative'filecode);                           41642000
               end;                                                     41644000
                                                                        41646000
$if x1=on then                <<debugging code>>                        41648000
      if debugging then                                                 41650000
         begin                                                          41652000
         say "   CHECK ACCT NAME AND 5.(1:1)=1" endsay;                 41654000
         send;                                                          41656000
         end;                                                           41658000
$if                           <<debugging code>>                        41660000
                                                                        41662000
      if cap'am and logon'acct' = flacctname',(file'part'size) then     41664000
$if x1=on then                <<debugging code>>                        41666000
         if debugging then                                              41668000
            begin                                                       41670000
            say "AM...ACCT MATCH"endsay;                                41672000
            send;                                                       41674000
            end                                                         41676000
         else                                                           41678000
$if                           <<debugging code>>                        41680000
                                                                        41682000
      else if look'lock' = fllockword',(file'part'size) then            41684000
$if x1=on then                <<debugging code>>                        41686000
         if debugging then                                              41688000
            begin                                                       41690000
            say "LOCKWORD MATCH" endsay;                                41692000
            send;                                                       41694000
            end                                                         41696000
         else                                                           41698000
$if                           <<debugging code>>                        41700000
                                                                        41702000
      else if look'lock' = " " then        <<not supplied>>             41704000
         begin                         <<prompt user for lockword>>     41706000
                                                                        41708000
            <<we get here only if the file has a lockword               41710000
              and the user supplied none.  (if the file had             41712000
              no lockword, fllockword' would be "        ",             41714000
              which is what look'lock is at this point.)   >>           41716000
                                                                        41718000
            <<lock the file so nothing strange will happen              41720000
              to it while we are trying to get its lockword             41722000
              from the user...                             >>           41724000
                                                                        41726000
         lock'the'file;                <<may not return to here!>>      41728000
                                                                        41730000
         release'sirs (got'fisir, got'dsir);                            41732000
                                                                        41734000
         move mess':="LOCKWORD: ";                                      41736000
         standard'to'display (curr'title', mess'(10), error'code,       41738000
                              len);                                     41740000
         len:=len+10;                                                   41742000
         mess'(len):="?";                                               41744000
         len:=len+1;                                                    41746000
                                                                        41748000
               <<get lockword from user with freply...                  41750000
                 then set yes to true if we want to fail due            41752000
                 to lockword mismatch...                     >>         41754000
                                                                        41756000
         if freply (mess', len) = false then                            41758000
            yes:=true                                                   41760000
         else if mess' = fllockword', (file'part'size) then             41762000
            yes:=false                                                  41764000
         else                                                           41766000
            yes:=true;                                                  41768000
                                                                        41770000
         get'sirs (true, true);    <<get fisir and dsir>>               41772000
         need'rel'dsir:=true;             <<release dsir at end>>       41774000
                                                                        41776000
         if yes then                                                    41778000
            begin             <<bad reply, or mismatched lockword>>     41780000
            flstorerestore:=0;       <<unlock file>>                    41782000
            if write'label (label'ldev, label'address,                  41784000
                            got'sir)                                    41786000
                  = failed then                                         41788000
               fail (rc'stop, m'nounlock'write'failed);                 41790000
            fail (0, m'file'lockword'wrong);                            41792000
            end;                                                        41794000
                                                                        41796000
$if x1=on then                <<debugging code>>                        41798000
         if debugging then                                              41800000
            begin                                                       41802000
            say "LOCK MATCHES" endsay;                                  41804000
            send;                                                       41806000
            end;                                                        41808000
$if                           <<debugging code>>                        41810000
         end                                                            41812000
                                                                        41814000
      else                    <<supplied lockword was wrong>>           41816000
         fail (0, m'file'lockword'wrong);                               41818000
                                                                        41820000
      end;                    <<not sm or op>>                          41822000
                                                                        41824000
   if not locked'the'file then                                          41826000
      begin                                                             41828000
$if x1=on then                <<debugging code>>                        41830000
      if debugging then                                                 41832000
         begin                                                          41834000
         say "   TRY TO LOCK FILE" endsay;                              41836000
         send;                                                          41838000
         end;                                                           41840000
$if                           <<debugging code>>                        41842000
      lock'the'file;                                                    41844000
            <<can be stored if we come back to here!...>>               41846000
      end;                                                              41848000
                                                                        41850000
$if x1=on then                <<debugging code>>                        41852000
   if debugging then                                                    41854000
      begin                                                             41856000
      say "   LOCKED FILE" endsay;                                      41858000
      send;                                                             41860000
      end;                                                              41862000
$if                           <<debugging code>>                        41864000
                                                                        41866000
         <<prepare to store in good file...>>                           41868000
                                                                        41870000
   file'number:=file'number + 1d;                                       41872000
                                                                        41874000
   fill (gbuf, g'recsize, 0);                                           41876000
                                                                        41878000
   gbuf'd (g'filenum'inx'd):=file'number;                               41880000
   gbuf'd (g'address'inx'd) := label'address;                           41882000
   gbuf'd (g'extsize'inx'd) := flextsize'd;                             41884000
   gbuf'd (g'file'sectors'inx'd) := file'sectors;                       41886000
   gbuf (g'ldev'inx):=label'ldev;                                       41888000
   gbuf (g'pvinfo'inx) := mounted'volume'info;   <<flags & pvinfo>>     41890000
   g'locked'bit:=1;           <<mark it as locked>>                     41892000
                                                                        41894000
   move gbuf'(g'title'inx') := flab',(3*file'part'size);                41896000
                                                                        41898000
$if x1=on then                <<debugging code>>                        41900000
   if debugging then                                                    41902000
      begin                                                             41904000
      say "   WRITE TO G'NUM" endsay;                                   41906000
      send;                                                             41908000
      end;                                                              41910000
$if                           <<debugging code>>                        41912000
                                                                        41914000
   files'to'handle:=files'to'handle +1d;                                41916000
                                                                        41918000
   fwrite (g'num, gbuf, g'recsize, 0);                                  41920000
                                                                        41922000
   if <> then                                                           41924000
      begin                                                             41926000
                                                                        41928000
      if > then                                                         41930000
         begin                                                          41932000
$if x1=on then                <<debugging code>>                        41934000
         if debugging then                                              41936000
            begin                                                       41938000
            say "EOF ON GOOD FILE" endsay;                              41940000
            send;                                                       41942000
            end;                                                        41944000
$if                           <<debugging code>>                        41946000
         i:=sr'g'num'full;                                              41948000
         end                                                            41950000
      else                                                              41952000
         begin                                                          41954000
         fcheck (g'num, i);                                             41956000
$if x1=on then                <<debugging code>>                        41958000
         if debugging then                                              41960000
            begin                                                       41962000
            say "I/O ERROR ON GOOD FILE, ERR# " endsay;                 41964000
            saynum (i);                                                 41966000
            send;                                                       41968000
            end;                                                        41970000
$if                           <<debugging code>>                        41972000
         i:=sr'g'num'error;                                             41974000
         end;                                                           41976000
                                                                        41978000
            <<manually unlock current file...>>                         41980000
                                                                        41982000
      lock'unlock'file (unlock'file,                                    41984000
                        label'ldev, label'address,                      41986000
                        got'sir);                                       41988000
                                                                        41990000
            <<fail ... this will cause all the other files to           41992000
              be unlocked...>>                                          41994000
                                                                        41996000
      fail (rc'stop, i);                                                41998000
      end;                                                              42000000
                                                                        42002000
   mounted'volume'info.(1:1) := 0;        <<one mount per group>>       42004000
                                                                        42006000
$page                                                                   42008000
thunk'store'exit:                                                       42010000
                                                                        42012000
$if x1=on then                <<debugging code>>                        42014000
   if debugging then                                                    42016000
      begin                                                             42018000
      say "   EXIT OF THUNK'STORE" endsay;                              42020000
      send;                                                             42022000
      end;                                                              42024000
$if                           <<debugging code>>                        42026000
                                                                        42028000
         <<unlock the file integrity sir and the directory              42030000
           sir every 'n' times...>>                                     42032000
                                                                        42034000
   if (rc'calls mod dtimu = 0) and dsir'info = 1 then                   42036000
      yes:=true               <<every "n" times, but only when>>        42038000
   else                       <<processing file/group, not acct>>       42040000
      yes:=false;                                                       42042000
                                                                        42044000
   need'rel'dsir := need'rel'dsir lor yes lor (not got'fisir);          42046000
                                                                        42048000
   release'sirs (yes, need'rel'dsir);                                   42050000
                                                                        42052000
   if not got'fisir then    <<if true, we also dont have dsir !!>>      42054000
      get'sirs (true, false);   <<get fisir only>>                      42056000
                                                                        42058000
         <<tell direcscan whether or not we still have                  42060000
           dsir locked...>>                                             42062000
                                                                        42064000
   if got'dsir then                                                     42066000
      thunk'store.(15:1) := 1          <<dsir still locked>>            42068000
   else                                                                 42070000
      thunk'store.(15:1) := 0;         <<dsir not locked>>              42072000
                                                                        42074000
$if x1=on then                <<debugging code>>                        42076000
   if debugging then                                                    42078000
      begin                                                             42080000
      say "   END OF THUNK'STORE" endsay;                               42082000
      send;                                                             42084000
      end;                                                              42086000
$if                           <<debugging code>>                        42088000
                                                                        42090000
   end <<thunk'store proc>>;                                            42092000
$page ";STORE=  CHECK'FOR'DISMOUNT -- DISMOUNT PRIV VOLUME, IF NEED"    50000000
$control segment=store                                                  50002000
<<*****************************************************************>>   50004000
logical procedure check'for'dismount (old'pvinfo, curr'pvinfo,          50006000
                                  old'gbuf, err'code);                  50008000
         value   old'pvinfo, curr'pvinfo;                               50010000
         logical old'pvinfo, curr'pvinfo;                               50012000
         integer err'code;                                              50014000
         array   old'gbuf;                                              50016000
         option privileged, uncallable;                                 50018000
                                                                        50020000
      <<returns good if no error occurs, otherwise failed.              50022000
        in the event of an error, err'code has the error info.>>        50024000
   begin                                                                50026000
                                                                        50028000
   integer                                                              50030000
      hvsind      := [8/"*", 8/" "],                                    50032000
      reqtype     := conddismount'bind;                                 50034000
                                                                        50036000
   check'for'dismount:=good;  <<ok until failure>>                      50038000
   err'code:=0;                                                         50040000
                                                                        50042000
   return;                                                              50044000
                                                                        50046000
   if old'pvinfo.(0:1) = 1 then        <<last one was mounted>>         50048000
      if curr'pvinfo.(0:1) = 0  or     <<mounted => not mounted>>       50050000
            curr'pvinfo.(1:1) = 1 then <<different mount>>              50052000
         begin                                                          50054000
         dismount (hvsind, old'gbuf(g'group'inx),                       50056000
                   old'gbuf(g'acct'inx),                                50058000
                   reqtype, old'pvinfo);                                50060000
         if <> then                                                     50062000
            begin                                                       50064000
            check'for'dismount:=failed;                                 50066000
            err'code:=reqtype;                                          50068000
            end;                                                        50070000
         end;                                                           50072000
                                                                        50074000
   end <<check'for'dismount proc>>;                                     50076000
$page ";STORE=  DIREC'TO'TAPE --- WRITES DIRECTORY OF FILES TO TAPE"    50078000
$control segment=store                                                  50080000
<<*****************************************************************>>   50082000
logical procedure direc'to'tape (tdbuf);                                50084000
                                                                        50086000
      integer array tdbuf;                                              50088000
      option privileged, uncallable;                                    50090000
                                                                        50092000
   <<writes the directory to the tape.>>                                50094000
                                                                        50096000
   begin                                                                50098000
                                                                        50100000
                                                                        50102000
   double array                                                         50104000
      gbuf'd      (0:g'recsize/2);                                      50106000
                                                                        50108000
   double                                                               50110000
      file'ktr    := 0d;                                                50112000
                                                                        50114000
   integer array                                                        50116000
      gbuf        (*) = gbuf'd (0);                                     50118000
                                                                        50120000
   integer pointer                                                      50122000
      bp;                                                               50124000
                                                                        50126000
   integer                                                              50128000
      blktd,                                                            50130000
      len,                                                              50132000
      nlrtd,                                                            50134000
      recsize     := 0;       <<tape recsize (or smaller)>>             50136000
                                                                        50138000
   byte array                                                           50140000
      gbuf'       (*) = gbuf (0);                                       50142000
                                                                        50144000
   define                                                               50146000
      pvinfo      = gbuf (g'pvinfo'inx) #;                              50148000
                                                                        50150000
   label                                                                50152000
      end'direc'to'tape;                                                50154000
                                                                        50156000
   <<-------->>                                                         50158000
   <<  fail  >>                                                         50160000
   <<-------->>                                                         50162000
                                                                        50164000
   subroutine fail (n);                                                 50166000
            value   n;                                                  50168000
            integer n;                                                  50170000
      begin                                                             50172000
                                                                        50174000
      if n <> 0 then                                                    50176000
         sendmessage (n);                                               50178000
                                                                        50180000
      direc'to'tape:=failed;                                            50182000
                                                                        50184000
      go end'direc'to'tape;                                             50186000
                                                                        50188000
      end <<fail sub>>;                                                 50190000
                                                                        50192000
   <<------------->>                                                    50194000
   <<  file'fail  >>                                                    50196000
   <<------------->>                                                    50198000
                                                                        50200000
   subroutine file'fail (fid, n);                                       50202000
            value   fid, n;                                             50204000
            integer fid, n;                                             50206000
                                                                        50208000
      begin                                                             50210000
                                                                        50212000
      if fid <> no'file then                                            50214000
         print'file'error (fid);                                        50216000
                                                                        50218000
      fail (n);                                                         50220000
                                                                        50222000
      end <<file'fail sub>>;                                            50224000
   <<----------------------------->>                                    50226000
                                                                        50228000
   direc'to'tape:=good;       <<default result>>                        50230000
                                                                        50232000
   need'directory:=false;                                               50234000
                                                                        50236000
   if (recsize:=tape'recsize) > direc'max'recsize then                  50238000
      if tape'devinfo.devtypef = magtape then                           50240000
         recsize:=direc'max'recsize;                                    50242000
                                                                        50244000
   nlrtd:=recsize/tape'dir'recsize;  <<#dir recors/tape record>>        50246000
   blktd:=nlrtd*tape'dir'recsize;  <<make dir block mult of entry size>>50248000
                                                                        50250000
   @bp := @tdbuf;                                                       50252000
                                                                        50254000
$if x1=on then                <<debugging code>>                        50256000
   if debugging then                                                    50258000
      begin                                                             50260000
      send;                                                             50262000
      say "DIREC'TO'TAPE STARTED" endsay;                               50264000
      send;                                                             50266000
      end;                                                              50268000
$if                           <<debugging code>>                        50270000
                                                                        50272000
   rewind'good'file;                                                    50274000
                                                                        50276000
   read'good'file;            <<get first entry>>                       50278000
                                                                        50280000
   while = do                 <<scan through file...>>                  50282000
      begin                                                             50284000
      file'ktr:=file'ktr + 1d;                                          50286000
$if x1=on then                <<debugging code>>                        50288000
      if debugging then                                                 50290000
         begin                                                          50292000
         say "   " endsay;                                              50294000
         say gbuf'(g'title'inx'),(file'part'size*3) endsay;             50296000
         say "   @BP = %" endsay;                                       50298000
         sayoctal (@bp);                                                50300000
         send;                                                          50302000
         end;                                                           50304000
$if                           <<debugging code>>                        50306000
                                                                        50308000
      move bp:=gbuf(g'title'inx), (3*file'part'words), 2;               50310000
                                                                        50312000
            <<alter group/acct if needed...>>                           50314000
                                                                        50316000
      if res'acct' <> " " then                                          50318000
         move bp(2*file'part'words):=res'acct,(file'part'words);        50320000
                                                                        50322000
      if res'group' <> " " then                                         50324000
         move bp(file'part'words):=res'group,(file'part'words);         50326000
                                                                        50328000
      @bp:=tos;                                                         50330000
                                                                        50332000
      check'break;            <<wont return if break sensed>>           50334000
                                                                        50336000
      if file'ktr mod double(nlrtd) = 0d then                           50338000
         begin                <<write dir block to tape...>>            50340000
         fwrite (t'num, tdbuf, blktd, 0);                      <<04101>>50342000
         if <> then                                            <<04101>>50344000
            file'fail  (t'num, sr'tape'write'fail)                      50346000
         else                 <<write succeeded>>                       50348000
            @bp:=@tdbuf;      <<reinitialize buffer>>                   50350000
         end;                                                           50352000
                                                                        50354000
      read'good'file;         <<next file name>>                        50356000
                                                                        50358000
      end;                                                              50360000
                                                                        50362000
         <<read'good'file handled any '<' error!                        50364000
           therefore, we get here only when we hit                      50366000
           an eof on g'num...>>                                         50368000
                                                                        50370000
   if (len:=@bp-@tdbuf) <> 0 then      <<write out last block...>>      50372000
      begin                                                    <<04101>>50373000
      fwrite (t'num, tdbuf, len, 0);                           <<04101>>50374000
      if <> then                                               <<04101>>50375000
         file'fail  (t'num, sr'tape'write'fail);                        50376000
      end;                                                     <<04101>>50377000
                                                                        50378000
   if write'tape'mark (parms'tempi'1) = failed then                     50380000
      file'fail  (t'num, sr'tape'write'fail);                           50382000
                                                                        50384000
$if x1=on then                <<debugging code>>                        50386000
   if debugging then                                                    50388000
      begin                                                             50390000
      say "   (EOF ON G'NUM)" endsay;                                   50392000
      send;                                                             50394000
      end;                                                              50396000
$if                           <<debugging code>>                        50398000
                                                                        50400000
         <<we have now written the directory of files to the tape>>     50402000
                                                                        50404000
   rewind'good'file;                                                    50406000
                                                                        50408000
   fpoint (g'num, file'number);                                         50410000
   if <> then                                                           50412000
      file'fail (g'num, sr'g'num'error);                                50414000
                                                                        50416000
end'direc'to'tape:                                                      50418000
                                                                        50420000
$if x1=on then                <<debugging code>>                        50422000
   if debugging then                                                    50424000
      begin                                                             50426000
      say "END OF DIREC'TO'TAPE" endsay;                                50428000
      send;                                                             50430000
      end;                                                              50432000
$if                           <<debugging code>>                        50434000
                                                                        50436000
   end <<direc'to'tape proc>>;                                          50438000
$page ";STORE=  FINISH'REEL --- WRITE TRAILER STUFF TO TAPE"            50440000
$control segment=store                                                  50442000
<<*****************************************************************>>   50444000
logical procedure finish'reel (tdbuf, endoffile);                       50446000
         value   endoffile;                                             50448000
         logical endoffile;                                             50450000
         integer array tdbuf;                                           50452000
         option privileged, uncallable;                                 50454000
   <<                                                                   50456000
     this routine writes trailer labels and eof marks                   50458000
     to the end of the current reel.  it assumes that                   50460000
     the tape is positioned where you want it.                          50462000
                                                    >>                  50464000
                                                                        50466000
   begin                                                                50468000
                                                                        50470000
                                                                        50472000
   integer                                                              50474000
      dummy'i;                                                          50476000
                                                                        50478000
   label                                                                50480000
      end'finish'reel;                                                  50482000
                                                                        50484000
   <<-------->>                                                         50486000
   <<  fail  >>                                                         50488000
   <<-------->>                                                         50490000
                                                                        50492000
   subroutine fail (errnum);                                            50494000
            value   errnum;                                             50496000
            integer errnum;                                             50498000
      begin                                                             50500000
                                                                        50502000
      if errnum <> 0 then                                               50504000
         sendmessage (errnum);                                          50506000
                                                                        50508000
      error'code:=errnum;                                               50510000
                                                                        50512000
      finish'reel:=failed;                                              50514000
                                                                        50516000
      go end'finish'reel;                                               50518000
                                                                        50520000
      end <<fail sub>>;                                                 50522000
   <<-------------------->>                                             50524000
                                                                        50526000
$if x1=on then                <<debugging code>>                        50528000
   if debugging then                                                    50530000
      begin                                                             50532000
      say "FINISH'REEL called" endsay;                                  50534000
      saynum (error'code);                                              50536000
      send;                                                             50538000
      end;                                                              50540000
$if                           <<debugging code>>                        50542000
                                                                        50544000
   finish'reel:=good;                                                   50546000
                                                                        50548000
   if tape'null'tog or labeled or last'reel'finished then      <<06361>>50550000
      return;                 <<ok>>                                    50552000
                                                                        50554000
   if endoffile then                                                    50556000
      begin                                                             50558000
      tl'xfield := 1;                                                   50560000
      tapemark'written := true;                                <<04996>>50561000
      if last'file then tl'zfield := 1                                  50562000
      else tl'zfield := 0;                                              50564000
      end                                                               50566000
   else                                                                 50568000
      begin                                                             50570000
      tl'xfield := 0;                                                   50572000
      tl'zfield := 0;                                                   50574000
      end;                                                              50576000
                                                                        50578000
   if write'tape(tape'label'size, tape'label, true, tdbuf, true)        50580000
                                                        = failed then   50582000
      fail (sr'wt'tape'label);                                          50584000
                                                                        50586000
$if x1=on then                                                          50588000
   if debugging then                                                    50590000
      begin                                                             50592000
      say "FINISH'REEL: TL'XFIELD = " endsay;                           50594000
      saynum (tl'xfield);                                               50596000
      say ";   TL'ZFIELD = " endsay;                                    50598000
      saynum (tl'zfield);                                               50600000
      send;                                                             50602000
      end;                                                              50604000
$if                                                                     50606000
                                                                        50608000
   if write'tape'mark (dummy'i) = failed then                  <<04102>>50610000
      if dummy'i <> eotcode then                               <<04102>>50610100
         fail (sr'wt'eof);                                     <<04102>>50611000
                                                                        50612000
   write'tape'mark (parms'tempi'1);      <<dont check for errors>>      50614000
                                                                        50616000
   << in order to get the unlocking of files during the tape>> <<04724>>50618000
   << rewind, either a rewind'unload or a fclose must be    >> <<04724>>50620000
   << performed before unlock'files is called.  if the tape >> <<04724>>50622000
   << was previously opened (as in sysdump) the rewind will >> <<04724>>50624000
   << not occur until after store has been completed.       >> <<04724>>50626000
   << (i.e. the rewind and the unlocking will not overlap.) >> <<04724>>50628000
                                                               <<04724>>50630000
   if seen'time then       <<time>>                                     50630100
      begin                                                             50630200
      sendmessage (m'time'info,true);                                   50630300
      sendmessage (sr'tim'before'rewind);                               50630400
      sendmessage (m'blank'line);                                       50630500
      end;                                                              50630600
                                                                        50630700
   if not tl'zfield then                                       <<04724>>50632000
      begin                                                    <<04724>>50634000
      if fkontrol (t'num, rewind'unload) = failed then         <<04102>>50636000
         fail (sr'tape'rewind'fail);                           <<04102>>50638000
      end                                                      <<04724>>50640000
   else if t'num <> 0 then                                     <<04724>>50642000
      begin                                                    <<04724>>50644000
      write'tape'mark (parms'tempi'1);                         <<04974>>50645000
      fclose (t'num, tape'close'disp, 0);                      <<04724>>50646000
      t'num := 0;                                              <<04724>>50648000
      end;                                                     <<04724>>50650000
                                                               <<04724>>50652000
   last'reel'finished := (tl'zfield = 1);                      <<06361>>50652100
                                                               <<06361>>50652200
   if endoffile then                                                    50654000
      unlock'files (file'number, 0)                                     50656000
   else                                                                 50658000
      unlock'files (file'number - 1d, 0);                               50660000
                                                                        50662000
end'finish'reel:                                                        50664000
                                                                        50666000
$if x1=on then                <<debugging code>>                        50668000
   if debugging then                                                    50670000
      begin                                                             50672000
      say "   end FINISH'REEL" endsay;                                  50674000
      send;                                                             50676000
      end;                                                              50678000
$if                           <<debugging code>>                        50680000
                                                                        50682000
   end <<finish'reel proc>>;                                            50684000
$page ";STORE=  START'REEL --- STARTS A NEW TAPE REEL"                  50686000
$control segment=store                                                  50688000
<<*****************************************************************>>   50690000
logical procedure start'reel (tdbuf, reel'num);                         50692000
         value   reel'num;                                              50694000
         integer reel'num;                                              50696000
         integer array tdbuf;                                           50698000
                                                                        50700000
      <<this routine is called to start a normal new reel.>>            50702000
                                                                        50704000
   begin                                                                50706000
                                                                        50708000
   integer array                                                        50710000
      hold'label (0:tape'label'size);                                   50712000
                                                                        50714000
   byte array                                                           50716000
      hold'label' (*) = hold'label;                                     50718000
                                                                        50720000
   define                                                               50722000
      hold'label'date' = hold'label' (tl'date'inx')#;                   50724000
                                                                        50726000
   integer                                                              50728000
      dummy'i,                                                          50730000
      read'len;                                                         50732000
                                                                        50734000
   logical                                                              50736000
      done        := false;                                             50738000
                                                                        50740000
   label                                                                50742000
      end'start'reel;                                                   50744000
                                                                        50746000
   <<--------------------->>                                            50748000
   <<  fail               >>                                            50750000
   <<--------------------->>                                            50752000
                                                                        50754000
   subroutine fail (n, should'try'again);                      <<04101>>50756000
            value n, should'try'again;                         <<04101>>50758000
            logical  should'try'again;                         <<04101>>50759000
            integer n;                                                  50760000
      begin                                                             50762000
                                                                        50764000
      if n <> 0 then                                                    50766000
         sendmessage (n);                                               50768000
                                                               <<04101>>50768010
      if should'try'again and not labeled then                 <<04101>>50768100
         begin                                                 <<04101>>50768200
         mark'reel'bad;                                        <<04101>>50768210
         sendmessage (sr'restart'tape);                        <<04101>>50768250
         sendmessage (sr'mount'different'tape,,true);          <<04101>>50768260
         del;                                                  <<04101>>50768300
         goto try'again;                                       <<04101>>50768400
         end;                                                  <<04101>>50768500
                                                               <<04101>>50768600
      dont'do'recovery := true;                                <<04101>>50768700
                                                                        50770000
      start'reel:=failed;                                               50772000
                                                                        50774000
      go end'start'reel;                                                50776000
                                                                        50778000
      end <<fail sub>>;                                                 50780000
                                                                        50782000
   <<--------------------->>                                            50784000
   <<  file'fail          >>                                            50786000
   <<--------------------->>                                            50788000
                                                                        50790000
   subroutine file'fail (fid, n, should'try'again);            <<04101>>50792000
            value fid, n, should'try'again;                    <<04101>>50793000
            logical should'try'again;                          <<04101>>50794000
            integer fid, n;                                             50796000
      begin                                                             50798000
                                                                        50800000
      if fid <> no'file then                                            50802000
         print'file'error (fid);                                        50804000
                                                                        50806000
      fail (n, should'try'again);                              <<04101>>50808000
                                                                        50810000
      end <<file'fail sub>>;                                            50812000
   <<---------------------->>                                           50814000
$page                                                                   50816000
   <<--------------------->>                                            50818000
   <<  build'header'label >>                                            50820000
   <<--------------------->>                                            50822000
                                                                        50824000
   subroutine build'header'label;                                       50826000
                                                                        50828000
         <<this routine builds the tape header label>>                  50830000
                                                                        50832000
      begin                                                             50834000
                                                                        50836000
            <<setup tape header label stuff...>>                        50838000
                                                                        50840000
      tl'reelnum:=reel'num;   <<physical reel count>>                   50842000
      tape'reel:=reel'num;                                              50844000
                                                                        50846000
$if x1=on then                <<debugging code>>                        50848000
      if debugging then                                                 50850000
         begin                                                          50852000
         say "****** TAPE'REEL := " endsay;                             50854000
         saynum (tape'reel);                                            50856000
         send;                                                          50858000
         end;                                                           50860000
$if                           <<debugging code>>                        50862000
                                                                        50864000
      move tl'iibid := "VIIB";                                          50866000
                                                                        50868000
      if reel'num = 1 then                                              50870000
         begin                                                          50872000
         tl'spantog:=0;                                                 50874000
         tl'xfield:=0;                                                  50876000
         tl'fileinx:=0;                                                 50878000
         end                                                            50880000
      else                                                              50882000
         begin                                                          50884000
         tl'spantog := (not logical (tl'xfield)).(15:1);                50886000
         if file'number < 1d then                                       50888000
            tl'fileinx:=0                                               50890000
         else                                                           50892000
            tl'fileinx := logical(file'number) - 1;                     50894000
         end;                                                           50896000
                                                                        50898000
            <<calculate checksum...>>                                   50900000
                                                                        50902000
      tl'chksum:=0;                                                     50904000
      tl'chksum:=checksum (tape'label, tape'label'size);                50906000
                                                                        50908000
      end <<build'header'label sub>>;                                   50910000
$page                                                                   50912000
   <<----------------->>                                                50914000
   <<  start'labeled  >>                                                50916000
   <<----------------->>                                                50918000
                                                                        50920000
   subroutine start'labeled;                                            50922000
                                                                        50924000
      <<this routine starts the next labeled reel>>                     50926000
                                                                        50928000
      begin                                                             50930000
                                                                        50932000
            <<write the tape label...>>                                 50934000
                                                                        50936000
      fwritelabel (t'num, tape'label, tape'label'size);                 50938000
      if <> then                                                        50940000
         file'fail (t'num, sr'wt'tape'label, false);           <<04101>>50942000
                                                                        50944000
            <<if this is reel 1, write the directory.  if not, >>       50946000
            <<don't write the directory just yet, as it will   >>       50948000
            <<come after the current file is done!             >>       50950000
                                                                        50952000
      if reel'num = 1 then                                              50954000
         if direc'to'tape (tdbuf) = failed then                         50956000
            fail (sr'wt'directory, false)                      <<04101>>50958000
         else                                                           50960000
      else                                                              50962000
         need'directory:=true;                                          50964000
                                                                        50966000
      end <<start'labeled sub>>;                                        50968000
$page                                                                   50970000
   <<------------------->>                                              50972000
   <<  start'unlabeled  >>                                              50974000
   <<------------------->>                                              50976000
                                                                        50978000
   subroutine start'unlabeled;                                          50980000
                                                                        50982000
         <<this routine starts an unlabeled reel:        >>             50984000
         << (1) get the tape, (2) write the header label,>>             50986000
         << (3) write the directory;                     >>             50988000
                                                                        50990000
      begin                                                             50992000
                                                                        50994000
$if x1=on then                <<debugging code>>                        50996000
      if debugging then                                                 50998000
         begin                                                          51000000
         say "   START'UNLABELED" endsay;                               51002000
         send;                                                          51004000
         end;                                                           51006000
$if                           <<debugging code>>                        51008000
                                                                        51010000
      if reel'num = 1 then                                              51012000
         begin                                                          51014000
         if not sysdumping then                                         51016000
            begin                                                       51018000
            if write'tape'mark (parms'tempi'1) = failed then            51020000
               file'fail (t'num, sr'wt'eof, true);             <<04101>>51022000
            if write'tape'mark (parms'tempi'1) = failed then            51024000
               file'fail (t'num, sr'wt'eof, true);             <<04101>>51026000
            end;                                                        51028000
         end                                                            51030000
      else                                                              51032000
         begin                                                          51034000
            <<"MOUNT NEXT REEL ON LDEV!">>                              51036000
                                                                        51038000
         parms'tempi'1 := tape'reel;                                    51040000
         parms'tempi'2 := tape'ldev;                                    51042000
         sendmessage (sr'mount'next'reel,,true);                        51044000
         end;                                                           51046000
                                                                        51048000
                                                                        51050000
         << write the label to the new reel...             >>           51052000
         <<                                                >>           51054000
         << in order to guarantee that the tape is at      >>           51056000
         << load point (for unlabelled tapes!) before      >>           51058000
         << the header is written, a rewind is issued.     >>           51060000
         << this will:                                     >>           51062000
         <<   1)  leave the tape at load point if already  >>           51064000
         <<       there;                                   >>           51066000
         <<   2)  bring it back to load point if it is     >>           51068000
         <<       past load point;                         >>           51070000
         <<   3)  repeatedly wind the tape off the end if  >>           51072000
         <<       put on line before the load point.       >>           51074000
         << note that this (kludge) is dependent on the    >>           51076000
         << rewind'unload (in particular the unload)       >>           51078000
         << preceding the rewind.                          >>           51080000
                                                                        51082000
      done:=false;                                                      51084000
                                                                        51086000
      while not done do                                                 51088000
         begin                                                          51090000
                                                                        51098000
                  <<rewind tape, but don't worry about an >>            51100000
                  <<error, as rewind may have already been>>            51102000
                  <<done for us...                        >>            51104000
                                                                        51106000
         if reel'num > 1 then                                           51108000
            begin                                                       51110000
            if fkontrol (t'num, rewind'unload) = failed then   <<04102>>51112000
               file'fail (t'num, sr'tape'rewind'failed, true); <<04102>>51113000
                                                                        51114000
            read'len := fread (t'num, hold'label, tape'label'size+1);   51116000
            if > then                                                   51118000
               read'len := fread (t'num, hold'label, tape'label'size+1);51120000
            if > then                                                   51122000
               read'len := fread (t'num, hold'label, tape'label'size+1);51124000
                                                                        51126000
            if = and (read'len = tape'label'size) and                   51128000
               (hold'label' = tape'label', (tl'text'len')) and          51130000
               (hold'label'date' = tl'date', (6)) then                  51132000
               begin                                                    51134000
               sendmessage (sr'tape'of'same'set,,true);                 51136000
               sendmessage (sr'mount'different'tape,,true);             51138000
               goto try'again;                                          51140000
               end                                                      51142000
            else                                                        51144000
               begin                                                    51146000
                                                                        51146100
               if seen'time then <<time>>                               51146200
                  begin                                                 51146300
                  sendmessage (m'time'info,true);                       51146400
                  sendmessage (sr'tim'start'of'tape);                   51146500
                  end;                                                  51146600
                                                                        51146700
               if fkontrol (t'num, rewind) = failed then       <<04102>>51148000
                  file'fail (t'num,sr'tape'rewind'failed,true);<<04102>>51149000
               end;                                                     51150000
            end;                                                        51152000
                                                                        51154000
         fwrite (t'num, tape'label, tape'label'size, 0);       <<04101>>51156000
                                                               <<04101>>51158000
         if <> then                                            <<04101>>51160000
            sendmessage (sr'tape'mount'fail)                   <<04101>>51216000
         else                                                  <<04101>>51228000
            done:=true;                                        <<04101>>51230000
         end;                                                  <<04101>>51232000
                                                                        51234000
                                                                        51236000
            <<got the tape, have written the header                     51238000
              label...now finish "starting" the reel...>>               51240000
                                                                        51242000
      if reel'num = 1 then                                              51244000
         begin                                                          51246000
               <<write the eof after the header...>>                    51248000
                                                                        51250000
         if write'tape'mark (dummy'i) = failed then            <<04102>>51252000
            file'fail (t'num, sr'tape'write'fail, true);       <<04102>>51256000
         end;                                                           51258000
                                                                        51260000
            <<write the directory..>>                                   51262000
                                                                        51264000
      if direc'to'tape (tdbuf)                                          51266000
            = failed then                                               51268000
         fail (sr'wt'directory, true);                         <<04101>>51270000
                                                                        51270100
      if seen'time then          <<time>>                               51270200
         begin                                                          51270300
         sendmessage (m'time'info,true);                                51270310
         sendmessage (sr'tim'after'directory);                          51270400
         end;                                                           51270600
                                                                        51272000
      end <<start'unlabeled sub>>;                                      51274000
   <<---------------------->>                                           51276000
$page                                                                   51278000
                                                                        51280000
$if x1=on then                <<debugging code>>                        51282000
   if debugging then                                                    51284000
      begin                                                             51286000
      send;                                                             51288000
      fill' (pout, 70, "-");                                            51290000
      @pout:=@pout(70);                                                 51292000
      send;                                                             51294000
      say "START'REEL (@" endsay;                                       51296000
      say ", @" endsay;                                                 51298000
      sayoctal (@tdbuf);                                                51300000
      say ", " endsay;                                                  51302000
      saynum (reel'num);                                                51304000
      say1 (")");                                                       51306000
      send;                                                             51308000
      end;                                                              51310000
$if                           <<debugging code>>                        51312000
                                                                        51314000
try'again:                                                     <<04101>>51314100
                                                               <<04101>>51315000
   if tape'null'tog or last'reel'finished then                 <<06361>>51316000
      begin                                                             51318000
      start'reel:=good;                                                 51320000
      return;                                                           51322000
      end;                                                              51324000
                                                                        51326000
   if tape'ldev = 0 then                                                51328000
      begin                                                             51330000
      ffileinfo (t'num, item'ldev, tape'ldev);                          51332000
      if <> then                                                        51334000
         fail (sr'tape'fgetinfo'fail, false);                  <<04101>>51336000
      end;                                                              51338000
                                                               <<04101>>51338100
   if requestservice then                                      <<04101>>51338200
      fail (sr'break'sensed, false);                           <<04101>>51338300
                                                               <<04101>>51338400
                                                                        51340000
   build'header'label;                                                  51342000
                                                                        51344000
   if labeled then                                                      51346000
      start'labeled                                                     51348000
   else                                                                 51350000
      start'unlabeled;                                                  51352000
                                                                        51354000
   start'reel:=good;                                                    51356000
                                                                        51358000
end'start'reel:                                                         51360000
                                                                        51362000
   end <<start'reel proc>>;                                             51364000
$page ";STORE=  WRITE'TAPE --- WRITE A RECORD TO TAPE"                  51366000
$control segment=store                                                  51368000
<<*****************************************************************>>   51370000
logical procedure write'tape (wordc, buffer, ignore'eot, tdbuf,         51372000
                              last'write'of'file );                     51374000
         value   wordc, ignore'eot, last'write'of'file;                 51376000
         integer wordc;                                                 51378000
         logical        ignore'eot, last'write'of'file;                 51380000
         integer array buffer, tdbuf;                                   51382000
         option privileged, uncallable;                                 51384000
   <<                                                                   51386000
     write'tape returns:    good   -- ok                                51388000
                           failed -- error -  die                       51390000
         if write'tape fails, the reason is returned in                 51392000
         error'code.  the possible reasons are documented               51394000
         in the global equate section.                                  51396000
                                                                        51398000
     parameters:                                                        51400000
         wordc  -- number of words in array buffer to write to the      51402000
                   tape.                                                51404000
                   wordc is never 0 or less!  if you want to write      51406000
                   a tapemark, use write'tape'mark!                     51408000
                   (no check is made for this case!)                    51410000
         buffer -- integer array with data to be written.               51412000
         ignoreeot --                                                   51414000
         tdbuf  -- the usual tape buffer, passed to avoid allocating    51416000
                   a lot of space within direc'to'tape.         >>      51418000
      <<-------------------------------------------------------->>      51420000
   begin                                                                51422000
                                                                        51424000
                                                                        51426000
   integer                                                              51428000
      dummy'i;                                                          51430000
                                                                        51432000
   label                                                                51434000
      end'write'tape;                                                   51436000
                                                                        51438000
   <<-------->>                                                         51440000
   <<  fail  >>                                                         51442000
   <<-------->>                                                         51444000
                                                                        51446000
   subroutine fail (errnum);                                            51448000
            value   errnum;                                             51450000
            integer errnum;                                             51452000
      begin                                                             51454000
                                                                        51456000
      if errnum <> 0 then                                               51458000
         sendmessage (errnum);                                          51460000
                                                                        51462000
      error'code:=errnum;                                               51464000
                                                                        51466000
      write'tape:=failed;                                               51468000
                                                                        51470000
      go end'write'tape;                                                51472000
                                                                        51474000
      end <<fail sub>>;                                                 51476000
                                                                        51478000
   <<------------->>                                                    51480000
   <<  good'exit  >>                                                    51482000
   <<------------->>                                                    51484000
                                                                        51486000
   subroutine good'exit;                                                51488000
                                                                        51490000
      begin                                                             51492000
                                                                        51494000
      write'tape:=good;                                                 51496000
                                                                        51498000
      error'code:=0;                                                    51500000
                                                                        51502000
      go end'write'tape;                                                51504000
                                                                        51506000
      end <<good'exit sub>>;                                            51508000
   <<-------------------->>                                             51510000
$page                                                                   51512000
   <<----------------->>                                                51514000
   <<  write'labeled  >>                                                51516000
   <<----------------->>                                                51518000
                                                                        51520000
   subroutine write'labeled;                                            51522000
                                                                        51524000
         <<writes to a labelled tape>>                                  51526000
                                                                        51528000
      begin                                                             51530000
                                                                        51532000
      error'code:=0;                                                    51534000
                                                                        51536000
      fwrite (t'num, buffer, wordc, 0);                                 51538000
                                                                        51540000
      if <> then                                                        51542000
         fail (sr'wt'label'tape);                                       51544000
                                                                        51546000
$if x1=on then                <<debugging code>>                        51548000
      if debug'write'tape and false then                                51550000
         begin                                                          51552000
         say "FWRITE worked ok, about to call LRELSW, ldev = " endsay;  51554000
         saynum (tape'ldev);                                            51556000
         send;                                                          51558000
         debug;                                                         51560000
         end;                                                           51562000
$if                           <<debugging code>>                        51564000
                                                                        51566000
      disable'arithmetic'traps;                                         51568000
                                                                        51570000
      if lrelsw (t'num) then           <<check&reset reel switch...>>   51572000
         begin                         <<switched reels>>               51574000
         tape'ldev:=0;                 <<force us to get new ldev>>     51576000
         if start'reel (tdbuf, tape'reel+1)                             51578000
               = failed then                                            51580000
            fail (sr'wt'label'tape);                                    51582000
         end;                                                           51584000
                                                                        51586000
      enable'arithmetic'traps;                                          51588000
                                                                        51590000
$if x1=on then                <<debugging code>>                        51592000
      if debug'write'tape and false then                                51594000
         begin                                                          51596000
         say "   LRELSW RETURNED OK" endsay;                            51598000
         send;                                                          51600000
         end;                                                           51602000
$if                           <<debugging code>>                        51604000
                                                                        51606000
      good'exit;                                                        51608000
                                                                        51610000
      end <<write'labeled sub>>;                                        51612000
$page                                                                   51614000
   <<------------------->>                                              51616000
   <<  write'unlabeled  >>                                              51618000
   <<------------------->>                                              51620000
                                                                        51622000
   subroutine write'unlabeled;                                          51624000
                                                                        51626000
         <<writes to an unlabelled tape>>                               51628000
                                                                        51630000
      begin                                                             51632000
                                                                        51634000
      error'code:=0;                                                    51636000
                                                                        51638000
            <<at this point, we want to do a non-null write             51640000
              to an unlabelled tape!                        >>          51642000
                                                                        51644000
      fwrite (t'num, buffer, wordc, 0);                                 51646000
                                                                        51648000
      if = then                                                         51650000
         good'exit;                                                     51652000
                                                                        51654000
            <<maybe we got an eot...>>                                  51656000
                                                                        51658000
      fcheck (t'num, error'code);         <<get details about error>>   51660000
                                                                        51662000
      if error'code = software'abort then                               51664000
         operator'abort:=true;                                          51666000
                                                                        51668000
$if x1=on then                <<debugging code>>                        51670000
      if debugging then                                                 51672000
         begin                                                          51674000
         say "   Error in WRITE'UNLABELED, FCHECK = " endsay;           51676000
         saynum (error'code);                                           51678000
         send;                                                          51680000
         end;                                                           51682000
$if                           <<debugging code>>                        51684000
                                                               <<04996>>51684100
      if error'code = 0 then                                   <<04996>>51684200
         good'exit;                                            <<04996>>51684300
                                                                        51686000
      if error'code.(08:08) <> eotcode then                             51688000
         fail (sr'wt'write3);           << '<' writing>>                51690000
                                                                        51692000
      if ignore'eot then                                                51694000
         good'exit;                                                     51696000
                                                                        51698000
      if write'tape'mark (parms'tempi'1) then                           51700000
         if parms'tempi'1 <> eotcode then                               51702000
            fail (sr'wt'eof);                                           51704000
                                                                        51706000
      if finish'reel (tdbuf, last'write'of'file) = failed then          51708000
         fail (sr'wt'tape'label);                                       51710000
                                                                        51712000
      if tl'zfield=1 then                                               51714000
         good'exit;                                                     51716000
                                                                        51718000
$if x1=on then                <<debugging code>>                        51720000
      if debugging then                                                 51722000
         begin                                                          51724000
         send;                                                          51726000
         fill' (pout, 70, "-");                                         51728000
         @pout:=@pout(70);                                              51730000
         send;                                                          51732000
         say "Get next reel" endsay;                                    51734000
         send;                                                          51736000
         fill' (pout, 70, "-");                                         51738000
         @pout:=@pout(70);                                              51740000
         send;                                                          51742000
         send;                                                          51744000
         end;                                                           51746000
$if                           <<debugging code>>                        51748000
                                                                        51750000
      if start'reel (tdbuf, tape'reel+1) = failed then                  51752000
         fail (sr'unable'to'start'reel);                                51754000
                                                                        51756000
      good'exit;                                                        51758000
                                                                        51760000
      end <<write'unlabeled sub>>;                                      51762000
   <<------------------------->>                                        51764000
$page                                                                   51766000
                                                                        51768000
$if x1=on then                <<debugging code>>                        51770000
   if debugging then                                                    51772000
      begin                                                             51774000
      say "   WRITE'TAPE (" endsay;                                     51776000
      saynum (wordc);                                                   51778000
      say ", @B/@T = " endsay;                                          51780000
      sayoctal (@buffer);                                               51782000
      say1 ("/");                                                       51784000
      sayoctal (@tdbuf);                                                51786000
      say ", IGNEOT = " endsay;                                         51788000
      saynum (ignore'eot);                                              51790000
      say1 (")");                                                       51792000
      say " (TAPE'REEL=" endsay;                                        51794000
      saynum (tape'reel);                                               51796000
      say1 (")");                                                       51798000
      send;                                                             51800000
      end;                                                              51802000
$if                           <<debugging code>>                        51804000
                                                                        51806000
   write'tape:=good;                                                    51808000
                                                                        51810000
   if tape'null'tog then                                                51812000
      good'exit;                                                        51814000
                                                                        51816000
         <<write to the tape...>>                                       51818000
                                                                        51820000
   if labeled then                                                      51822000
      write'labeled                                                     51824000
                                                                        51826000
   else                                                                 51828000
      write'unlabeled;                                                  51830000
                                                                        51832000
end'write'tape:                                                         51834000
                                                                        51836000
$if x1=on then                <<debugging code>>                        51838000
   if debugging then                                                    51840000
      begin                                                             51842000
      say "   end of WRITE'TAPE" endsay;                                51844000
      send;                                                             51846000
      end;                                                              51848000
$if                           <<debugging code>>                        51850000
                                                                        51852000
   end <<write'tape proc>>;                                             51854000
$page ";STORE=  WRITE'TAPE'MARK -- WRITES AN EOF TO THE TAPE"           51856000
$control segment=store                                                  51858000
<<*****************************************************************>>   51860000
logical procedure write'tape'mark (errnum);                             51862000
   integer errnum;                                                      51864000
      <<this routine writes an eof to the tape, returning               51866000
        good or failed.  if an error does occur, the error code         51868000
        is returned (from fcheck) in the error'code slot of parms.>>    51870000
                                                                        51872000
   begin                                                                51874000
                                                                        51876000
                                                                        51878000
   integer                                                              51880000
      dummy'i;                                                          51882000
                                                                        51884000
$if x1=on then                <<debugging code>>                        51886000
   if debugging then                                                    51888000
      begin                                                             51890000
      say "WRITE'TAPE'MARK" endsay;                                     51892000
      send;                                                             51894000
      end;                                                              51896000
$if                           <<debugging code>>                        51898000
                                                                        51900000
   write'tape'mark:=good;                                               51902000
   error'code:=0;                                                       51904000
                                                                        51906000
   if labeled then                                                      51908000
      begin                                                             51910000
      if nexttapefile (t'num) = 0 then                                  51912000
         return;              <<good>>                                  51914000
      end                                                               51916000
   else                                                                 51918000
      begin                   <<unlabelled tape...>>                    51920000
      if fkontrol (t'num, weof) = good then                    <<04102>>51922000
         return;              <<good>>                         <<04102>>51926000
      end;                                                              51928000
                                                                        51930000
         <<an error occurred...get the error code and                   51932000
           "report" the error...                      >>                51934000
                                                                        51936000
   fcheck (t'num, error'code);                                          51938000
   if error'code = software'abort then                                  51940000
      operator'abort:=true;                                             51942000
                                                                        51944000
$if x1=on then                <<debugging code>>                        51946000
   if debugging then                                                    51948000
      begin                                                             51950000
      say "   WRITE'TAPE'MARK = failed, err # " endsay;                 51952000
      saynum (error'code);                                              51954000
      send;                                                             51956000
      end;                                                              51958000
$if                           <<debugging code>>                        51960000
                                                                        51962000
   write'tape'mark:=failed;                                             51964000
   errnum := error'code;                                                51966000
                                                                        51968000
   end <<write'tape'mark proc>>;                                        51970000
$page ";STORE=  MARK'REEL'BAD -- MAKES A REEL BAD"             <<04101>>51970010
   <<----------------->>                                       <<04101>>51970020
   <<  mark'reel'bad  >>                                       <<04101>>51970030
   <<----------------->>                                       <<04101>>51970040
                                                               <<04101>>51970050
procedure mark'reel'bad;                                       <<04101>>51970060
                                                               <<04101>>51970070
      <<this routine rewinds the current reel and writes       <<04101>>51970080
      <<a record to the start of the tape which "marks"        <<04101>>51970090
      <<the tape as a "bad" tape, so a later restore will      <<04101>>51970100
      <<not try to restore from it.                      >>    <<04101>>51970110
                                                               <<04101>>51970120
   begin                                                       <<04101>>51970130
                                                               <<04101>>51970140
   integer                                                     <<04101>>51970141
      dummy'i     := 0;                                        <<04101>>51970142
                                                               <<04101>>51970143
   logical array                                               <<04101>>51970144
      scratch    (0:20);                                       <<04101>>51970145
                                                               <<04101>>51970146
   byte array                                                  <<04101>>51970147
      scratch'   (*)     = scratch;                            <<04101>>51970148
                                                               <<04101>>51970149
   fkontrol (t'num, rewind);                                   <<04101>>51970150
                                                               <<04101>>51970160
         <<don't check the fcontrol to see if it worked.>>     <<04101>>51970170
         <<also, write two tape marks at start of tape, but>>  <<04101>>51970180
         <<don't check them either...>>                        <<04101>>51970190
                                                               <<04101>>51970200
   write'tape'mark (parms'tempi'1);                            <<04101>>51970210
   write'tape'mark (parms'tempi'1);                            <<04101>>51970220
                                                               <<04101>>51970230
   move scratch':="BAD TAPE";                                  <<04101>>51970240
                                                               <<04101>>51970250
   fwrite (t'num, scratch, 4, 0);                              <<04101>>51970260
                                                               <<04101>>51970270
   fkontrol (t'num, rewind'unload);                            <<04101>>51970280
                                                               <<04101>>51970290
   parms'tempi'1 := tape'ldev;                                 <<04101>>51970300
   sendmessage (sr'bad'tape,,true);                            <<04101>>51970310
   sendmessage (sr'take'it'off,,true);                         <<04101>>51970320
   sendmessage (sr'not'part'of'tape'set,,true);                <<04101>>51970330
                                                               <<04101>>51970340
   end <<mark'reel'bad sub>>;                                  <<04101>>51970350
$page ";STORE=  FSTORE --- WRITE FILES TO TAPE"                         51972000
$control segment=store                                                  51974000
<<*****************************************************************>>   51976000
logical procedure fstore (tdbuf);                                       51978000
      integer array tdbuf;                                              51980000
      option privileged, uncallable;                                    51982000
                                                                        51984000
<<----------------------------------------------------------------->>   51986000
<<                                                                      51988000
                                                                        51990000
   the function of fstore is to store onto tape t'num all of the        51992000
   files named in g'num.  all such files are probably locked down       51994000
   for exclusive use (by rcstore).  as each file is stored, fstore      51996000
   will unlock it (iff it thinks the earlier rcstore locked it).        51998000
   (the "probably" is due to a non-supported debugging feature,         52000000
   invoked by doing a: store ...;lock=none, which will not              52002000
   lock any files!)                                                     52004000
                                                                        52006000
   fstore tries to catch and  correct most errors itself,               52008000
   depending on the setting of on'err.  (if it = onerr'quit,            52010000
   no error recovery is done;  if it = onerr'redo, error                52012000
   recovery will probably be done...see recover'error                   52014000
   subroutine for the criteria.)  if the error cannot be                52016000
   corrected, a failed result is returned, otherwise a good.            52018000
                                                                        52020000
   note that there are only two exits from this routine:                52022000
                                                                        52024000
         1) normal termination (i.e: all files stored)                  52026000
            (some may be only partially stored...if a                   52028000
            disc error ocurred while reading a file)                    52030000
                                                                        52032000
         2) fatal error ... exit through the fail subroutine.           52034000
                                                                        52036000
                                                                  >>    52038000
<<----------------------------------------------------------------->>   52040000
<<                                                                      52042000
   interpretation of fields in library tape trailer labels:             52044000
                                                                        52046000
      tl'zfield = 1,                                                    52048000
            tl'xfield = undefined...                                    52050000
                  the eof which preceded this trailer label             52052000
                  label represents the true eof for this file.          52054000
                  it also denotes that this is the last physical        52056000
                  reel of the library tape set.                         52058000
                                                                        52060000
      tl'zfield = 0,                                                    52062000
            tl'xfield = 0...                                            52064000
                  this means that the data for the current file is      52066000
                  continued on the next reel.                           52068000
            tl'xfield = 1...                                            52070000
                  this means that the eof which precedes this           52072000
                  trailer label represents the true eof for this        52074000
                  file.  the next reel begins with a new file.          52076000
                                                                  >>    52078000
<<---------------------------------------------------------------->>    52080000
<<   note:  the header and trailer label formats written by store >>    52082000
<<          do not conform to any hp standards as such.  these    >>    52084000
<<          headers do not make the tape look "labelled" to mpe!  >>    52086000
<<---------------------------------------------------------------->>    52088000
                                                                        52090000
$page                                                                   52092000
   begin                                                                52094000
                                                                        52096000
         <<note: the next variables must be the first local             52098000
           variables declared in this procedure...>>                    52100000
   integer pointer                                                      52108000
      save'locals;                                                      52110000
                                                                        52112000
   integer                                                              52114000
      locals'len  := 0,       <<length of locals storage>>              52116000
      first'local;            <<dummy integer>>                         52118000
                                                                        52120000
      <<-----------------------------------------------------           52122000
      << to recover from tape errors during a store, we do the          52124000
         following:                                                     52126000
                                                                        52128000
            1) After each reel switch, we save the "state of the        52130000
               universe" by calling SAVE'STATE.  This routine           52132000
               copies all of this procedure's local variables           52134000
               (both simple variables and arrays), and some             52136000
               selected global variables (tape'label, good'file'count,  52138000
               failed'file'count) into a holding area (discussed        52140000
               below).  this state saving is done after the directory   52142000
               is written to the newly mounted reel, but before         52144000
               a single data record from a to-be-stored file            52146000
               is written to it.                                        52148000
                                                                        52150000
            2) if a tape error occurs, we apply the following           52152000
               criteria to see if error recovery should be done:        52154000
                                                                        52156000
               a) is error recovery enabled (onerr=redo)?               52158000
                  if not, terminate with error.                         52160000
                                                                        52162000
               b) is the error a tape write error?                      52164000
                  if not, terminate with error.                         52166000
                                                                        52168000
               c) is the reel the first reel of a sysdump?              52170000
                  if it is, terminate with error. (we cannot            52172000
                  recreate the first reel of a sysdump.)                52174000
                                                                        52176000
            3) if a "correctable" error occurred, we do the             52178000
               following:                                               52180000
                                                                        52182000
               a) if the file currently being stored is on              52184000
                  a private volume, dismount the volume.                52186000
                                                                        52188000
               b) restore the local variables to the state              52190000
                  they were in at the time we started this              52192000
                  reel, as saved by save'state.                         52194000
                                                                        52196000
               c) restore the selected global variables to              52198000
                  the state they were in at the time we                 52200000
                  started this reel.                                    52202000
                                                                        52204000
               d) get (i.e: ask operator for) next reel,                52206000
                  write store label and file directory to               52208000
                  it.                                                   52210000
                                                                        52212000
               ....error is now corrected, and the caller of            52214000
               recover'error continues on, fooled into thinking         52216000
               that it is now where it had been when the bad            52218000
               reel was first started.                                  52220000
                                                                        52222000
         ------------------------------------------------               52224000
                                                                        52226000
         how we "save the state":                                       52228000
                                                                        52230000
            we declare the 3 variables: save'locals,                    52232000
            save'tape'label, and first'local as the first               52234000
            three variables in the procedure.  then, as the             52236000
            first executable code we determine the number               52238000
            of words between first'local and the top of stack.          52240000
            since this computation occurs after the stack               52242000
            building code emitted by spl, it is guaranteed to           52244000
            reflect the storage of all simple variables, direct         52246000
            arrays, and indirect arrays of the procedure.               52248000
                                                                        52250000
            once we know how much storage the locals take (this         52252000
            value is stored in locals'len), we allocate on              52254000
            the stack a buffer of that size, saving its address         52256000
            in @save'locals.  we then allocate another buffer           52258000
            on the stack whose size is tape'label'size, saving          52260000
            its address in @save'tape'label.                            52262000
                                                                        52264000
            these two integer pointers (save'tape'label and             52266000
            save'locals) are used by save'state to save the             52268000
            state with two simple move statements.                      52270000
                                                                        52272000
         ------------------------------------------------>>             52274000
$page                                                                   52276000
                                                                        52278000
                                                                        52280000
   double array                                                         52282000
      disj'ext'len (0:31),                                              52284000
      disj'ext'addr (0:31),                                             52286000
      extmap'd    (0:31),                                               52288000
      first'file'info'd (0:4),                                          52290000
      gbuf'd      (0:g'recsize/2),                                      52292000
      io'queue'd  (0:max'num'xds    *max'io),                           52294000
      io'wtm'd    (0:max'num'xds    -1);                                52296000
                                                                        52298000
   double                                                               52300000
      first'file'on'reel := 1d,                                         52302000
      extent'sectors'left:= 0d,                                         52304000
      failed'count      := 0d, <<used to set failed'file'count later>>  52306000
      file'sectors'left := 0d, <<#sectors left in remaining extents>>   52308000
      good'count        := 0d, <<used to set good'file'count later>>    52310000
      iob               := 0d,                                          52312000
      local'file'address:= 0d,                                 <<04104>>52313000
      local'file'number := 1d,                                          52314000
      sector'address    := 0d,                                          52316000
      sectors'filled    := 0d,                                          52318000
      sectors'per'tape'record := 0d,                                    52320000
      sectors'this'read := 0d;                                          52322000
                                                                        52324000
   integer array                                                        52326000
      buffer'status     (0:max'num'xds    -1),                          52328000
      buffer'xds        (0:max'num'xds    -1),                          52330000
      first'io'inx      (0:max'num'xds    -1),                          52332000
      gbuf              (*) = gbuf'd (0),                               52334000
      io'len            (0:max'num'xds    *max'io),                     52336000
      io'queue          (*) = io'queue'd (0),                           52338000
      io'wtm            (*) = io'wtm'd,                                 52340000
      last'io'inx       (0:max'num'xds    -1),                          52342000
      local'flab        (0:file'label'size -1),                <<04104>>52343000
      local'tape'label  (0:tape'label'size -1),                <<04104>>52343100
      old'gbuf          (0:g'recsize-1),                                52344000
      scratch           (0:15);                                         52346000
                                                                        52348000
   integer pointer                                                      52350000
      first'local'array;                                                52352000
                                                               <<04104>>52352100
   byte array                                                  <<04104>>52352200
      local'title'      (0:max'std'len);                       <<04104>>52352300
                                                                        52354000
   integer                                                              52356000
      attio'status= iob + 0,                                            52358000
      cur'inx     := 0,       <<cur buf# ... 0..num'xds    -1>>         52360000
      cur'xds     := 0,       <<  =  buffer'xds(cur'inx)  >>            52362000
      dummy'i,                                                          52364000
      disj'extent'num  := 0,                                            52366000
      first'reel  := 0,       <<reel # a file started on>>              52368000
      i           := 0,       <<scratch variable>>                      52370000
      io'inx      := 0,       <<index thru io'queue'd>>                 52372000
      iob'1       = iob + 0,                                            52374000
      iob'2       = iob + 1,                                            52376000
      len         := 0,                                                 52378000
      local'file'ldev  := 0,                                   <<04104>>52379000
      num'disjoint'extents := 0,                                        52380000
      num'io      := 0,       <<number of pending ios>>                 52382000
      offset      := 0,       <<offset into an xds>>                    52384000
      pvinfo      := 0,                                                 52386000
      recover'label:=0,                                                 52388000
      s0          = s - 0,    <<used by recover'error>>                 52390000
      save'reel   := 0,       <<used to detect reel switch>>            52392000
      state       := 0,       <<store'a'file internal state>>           52394000
      words'left  := 0,       <<used by start'io>>                      52396000
      x           := 0,       <<used by flab'checksum>>                 52398000
      xds'sectors := 0,       <<# of sectors in an xds>>                52400000
      xds'size    := 0,       <<size xds to ask for>>                   52402000
      z'size      := 0;       <<for expand'stack>>                      52404000
                                                                        52406000
   logical                                                              52408000
      first'record'of'file := false,                                    52410000
      first'time'in:=true,    <<first time in store'a'file>>            52412000
      good'store  := false,                                             52414000
      l           := 0,       <<scratch logical>>                       52416000
      ldev        := 0,                                                 52418000
      ll          := 0,       <<scratch logical>>                       52420000
      local'tapemark'written,                                  <<04101>>52421000
      sector'address1 = sector'address + 0,                             52422000
      sector'address2 = sector'address + 1,                             52424000
      yes         := false;                                             52426000
                                                                        52428000
   byte array                                                           52430000
      disj'ext'addr'ldev (*) = disj'ext'addr,                           52432000
      gbuf'       (*) = gbuf(0),                                        52434000
      scratch'    (*) = scratch (0),                                    52436000
      tdbuf'      (*) = tdbuf (0);                                      52438000
                                                                        52440000
   byte                                                                 52442000
      sector'address'ldev = sector'address + 0;                         52444000
                                                                        52446000
   label                                                                52448000
      end'fstore;                                                       52450000
                                                                        52452000
   equate                                                               52454000
      io'bad      = 0,                                                  52456000
      io'good     = 1,                                                  52458000
      io'good'eot = 2,                                                  52460000
      state'0     = 0,                                                  52462000
      state'1     = 1,                                                  52464000
      state'2     = 2,                                                  52466000
      state'3     = 3,                                                  52468000
      state'4     = 4,                                                  52470000
      state'5     = 5,                                                  52472000
      state'6     = 6,                                                  52474000
      state'7     = 7,                                                  52476000
      wait'current= 0,                                                  52478000
      wait'all    = 1;                                                  52480000
                                                                        52482000
   define                                                               52484000
      pv'mvtabxf = (4:4) #;                                             52486000
$page ";STORE=  FSTORE --- ERROR HANDLING SUBROUTINES"                  52488000
   <<------------------->>                                              52490000
   <<  release'buffers  >>                                              52492000
   <<------------------->>                                              52494000
                                                                        52496000
   subroutine release'buffers;                                          52498000
                                                                        52500000
      <<this routine releases any xds buffers obtained by               52502000
        the allocate'buffers subroutine.  this may entail               52504000
        unfreezing and unlocking prior to releasing.     >>             52506000
                                                                        52508000
      begin                                                             52510000
                                                                        52512000
      cur'inx:=-1;                                                      52514000
                                                                        52516000
      while (cur'inx:=cur'inx+1) < num'xds     do                       52518000
         begin                                                          52520000
                                                                        52522000
               <<note: the order here is important!!!>>                 52524000
                                                                        52526000
         if buffer'status(cur'inx) = bufstat'frozen then                52528000
            begin                                                       52530000
            unfreeze (buffer'xds(cur'inx), 1, 0);                       52532000
            buffer'status(cur'inx):=bufstat'locked;                     52534000
            end;                                                        52536000
                                                                        52538000
         if buffer'status(cur'inx) = bufstat'locked then                52540000
            begin                                                       52542000
            unlockseg (buffer'xds(cur'inx), 1, 0);                      52544000
            buffer'status(cur'inx):=bufstat'allocated;                  52546000
            end;                                                        52548000
                                                                        52550000
         if buffer'status(cur'inx) = bufstat'allocated then             52552000
            begin                                                       52554000
            reldataseg (buffer'xds(cur'inx));                           52556000
            buffer'status(cur'inx):=bufstat'empty;                      52558000
            end;                                                        52560000
                                                                        52562000
         end;                                                           52564000
                                                                        52566000
      end <<release'buffers sub>>;                                      52568000
$page                                                                   52570000
   <<-------->>                                                         52572000
   <<  fail  >>                                                         52574000
   <<-------->>                                                         52576000
                                                                        52578000
   subroutine fail (n);                                                 52580000
            value   n;                                                  52582000
            integer n;                                                  52584000
      begin                                                             52586000
                                                                        52588000
      if n <> 0 then                                                    52590000
         sendmessage (n);                                               52592000
                                                                        52594000
      if using'attio then release'buffers;                              52596000
                                                                        52598000
      fstore:=failed;                                                   52600000
                                                                        52602000
      go end'fstore;          <<unlocking done by cxstore>>             52604000
                                                                        52606000
      end <<fail sub>>;                                                 52608000
                                                                        52610000
   <<------------->>                                                    52612000
   <<  file'fail  >>                                                    52614000
   <<------------->>                                                    52616000
                                                                        52618000
   subroutine file'fail (fid, n);                                       52620000
            value fid, n;                                               52622000
            integer fid, n;                                             52624000
      begin                                                             52626000
                                                                        52628000
      if fid <> no'file then                                            52630000
         print'file'error (fid);                                        52632000
                                                                        52634000
      fail (n);                                                         52636000
                                                                        52638000
      end <<file'fail sub>>;                                            52640000
$page ";STORE=  FSTORE --- UTILITY SUBROUTINES"                         52696000
   <<-------------------->>                                             52698000
   <<  allocate'buffers  >>                                             52700000
   <<-------------------->>                                             52702000
                                                                        52704000
   logical subroutine allocate'buffers;                                 52706000
                                                                        52708000
      <<this routine allocates num'xds     extra data segments.         52710000
        if it fail in this, it returns failed and releases              52712000
        any buffers it got.                                             52714000
                                                                        52716000
        it tries to get num'xds     data segment buffers,               52718000
        each of which is large enough to hold max'io areas              52720000
        of tape'recsize words in length.  if this fails,                52722000
        it starts decrementing num'io (initially set to max'io)         52724000
        until it gets that many or until num'io < 1.  if it             52726000
        fails to allocate the buffers, a failed is returned             52728000
        and all buffers it did get (if any) are released.               52730000
        if it succeeds, all buffers are locked & frozen into            52732000
        memory and a good is returned.                                  52734000
                                                                        52736000
        note: we must investigate whether or not these buffers          52738000
        really need to be locked & frozen...attachio may be             52740000
        sufficiently smart in mpe-iv to temporarily lock them           52742000
        in memory while in use.  if so, we should probably              52744000
        remove the locking/freezing code unless we decide               52746000
        (after performance analysis) that we know better than           52748000
        mpe-iv's memory manager.                                        52750000
                                                             >>         52752000
                                                                        52754000
      begin                                                             52756000
                                                                        52758000
      allocate'buffers:=failed;        <<assumption>>                   52760000
                                                                        52762000
      i:=num'xds    *max'io;                                            52764000
      fill (buffer'status, num'xds    , bufstat'empty);                 52766000
      fill (buffer'xds,    num'xds    , 0);                             52768000
      fill (io'wtm,        num'xds    *2, 0);                           52770000
      fill (io'queue,      i*2,         0);                             52772000
      fill (io'len,        i,           0);                             52774000
                                                                        52776000
            <<setup io'queue'd indices...>>                             52778000
                                                                        52780000
      i:=0;                                                             52782000
      cur'inx:=-1;                                                      52784000
      while (cur'inx:=cur'inx+1) < num'xds     do                       52786000
         begin                                                          52788000
         first'io'inx(cur'inx):=i;                                      52790000
         last'io'inx (cur'inx):=i + max'io - 1;                         52792000
         i:=i + max'io;                                                 52794000
         end;                                                           52796000
                                                                        52798000
            <<see how big xds'size should be...>>                       52800000
            <<warning: since max'xds'size is near 32767,                52802000
              be careful not to change this code and cause              52804000
              an integer overflow!                        >>            52806000
                                                                        52808000
      num'io:=(max'xds'size - xds'overhead)/tape'recsize;               52810000
      if num'io > max'io then                                           52812000
         num'io:=max'io;                                                52814000
      xds'size:=num'io*tape'recsize + xds'overhead;                     52816000
                                                                        52818000
      cur'inx:=-1;                                                      52820000
                                                                        52822000
      while (cur'inx:=cur'inx+1) < num'xds     do                       52824000
         begin                                                          52826000
                                                                        52828000
$if x1=on then                <<debugging code>>                        52830000
         if debugging then                                              52832000
            begin                                                       52834000
            say "Allocate buffer # " endsay;                            52836000
            saynum (cur'inx);                                           52838000
            say " of " endsay;                                          52840000
            saynum (xds'size);                                          52842000
            say " words,  NUM'IO = " endsay;                            52844000
            saynum (num'io);                                            52846000
            send;                                                       52848000
            end;                                                        52850000
$if                           <<debugging code>>                        52852000
                                                                        52854000
            <<allocate a buffer of size xds'size words...>>             52856000
                                                                        52858000
         cur'xds:=getdataseg (xds'size, 0);                             52860000
                                                                        52862000
         if < then                                                      52864000
            begin          <<error grabbing an xds>>                    52866000
                                                                        52868000
$if x1=on then                <<debugging code>>                        52870000
            if debugging then                                           52872000
               begin                                                    52874000
               say "   failed...too large, XDS'SIZE was " endsay;       52876000
               saynum (xds'size);                                       52878000
               send;                                                    52880000
               end;                                                     52882000
$if                           <<debugging code>>                        52884000
                                                                        52886000
                  <<this error means that the system does               52888000
                    not want to give us a data segment as               52890000
                    large as we asked for...so shrink the               52892000
                    asking size down...                  >>             52894000
                                                                        52896000
            num'io:=num'io-1;                                           52898000
            xds'size:=num'io*tape'recsize + xds'overhead;               52900000
                                                                        52902000
                  <<we should have no buffers at this point,            52904000
                    but we release them anyway...>>                     52906000
                                                                        52908000
            release'buffers;                                            52910000
                                                                        52912000
                  <<see if num'io is now too small...>>                 52914000
                                                                        52916000
            if num'io < 1 then                                          52918000
               begin                                                    52920000
               sendmessage (sr'buffer'allocate'fail);                   52922000
               return;     <<exit from routine>>                        52924000
               end;                                                     52926000
                                                                        52928000
                  <<"restart" loop by setting cur'inx to -1...>>        52930000
                                                                        52932000
            cur'inx:=-1;                                                52934000
            end                                                         52936000
         else if cur'xds = 0 then                                       52938000
            begin          <<unable to get xds>>                        52940000
                                                                        52942000
$if x1=on then                <<debugging code>>                        52944000
            if debugging then                                           52946000
               begin                                                    52948000
               say "   unable to get XDS for some reason" endsay;       52950000
               send;                                                    52952000
               end;                                                     52954000
$if                           <<debugging code>>                        52956000
            release'buffers;                                            52958000
            sendmessage (sr'buffer'allocate'fail);                      52960000
            return;        <<exit from routine>>                        52962000
            end                                                         52964000
         else                                                           52966000
            begin          <<got the xds!>>                             52968000
                                                                        52970000
$if x1=on then                <<debugging code>>                        52972000
            if debugging then                                           52974000
               begin                                                    52976000
               say "   got XDS, # = " endsay;                           52978000
               saynum (cur'xds);                                        52980000
               send;                                                    52982000
               end;                                                     52984000
$if                           <<debugging code>>                        52986000
            buffer'status(cur'inx):=bufstat'allocated;                  52988000
            buffer'xds(cur'inx):=cur'xds;                               52990000
            end;                                                        52992000
         end;                                                           52994000
                                                                        52996000
$if x1=on then                <<debugging code>>                        52998000
   if debugging then                                                    53000000
      begin                                                             53002000
      say "XDS Buffers allocated" endsay;                               53004000
      send;                                                             53006000
      end;                                                              53008000
$if                           <<debugging code>>                        53010000
                                                                        53012000
            <<all num'xds     xds are allocated.>>                      53014000
            <<now lock and freeze them...>>                             53016000
                                                                        53018000
      cur'inx:=-1;                                                      53020000
                                                                        53022000
      if freeze'and'lock'xds then                                       53024000
         while (cur'inx:=cur'inx+1) < num'xds     do                    53026000
            begin                                                       53028000
                                                                        53030000
                                                                        53032000
            lockseg (buffer'xds(cur'inx), 1, 0);                        53034000
            if < then                                                   53036000
               begin             <<error locking buffer>>               53038000
               release'buffers;                                         53040000
               sendmessage (sr'buffer'lock'fail);                       53042000
               return;           <<exit from routine>>                  53044000
               end;                                                     53046000
            buffer'status(cur'inx):=bufstat'locked;                     53048000
                                                                        53050000
            freeze (buffer'xds(cur'inx), 1, 0);                         53052000
            if < then                                                   53054000
               begin             <<error freezing buffer>>              53056000
               release'buffers;                                         53058000
               sendmessage (sr'buffer'freeze'fail);                     53060000
               return;           <<exit from routine>>                  53062000
               end;                                                     53064000
            buffer'status(cur'inx):=bufstat'frozen;                     53066000
                                                                        53068000
            end;                                                        53070000
$if x1=on then                <<debugging code>>                        53072000
         if debugging then                                              53074000
            begin                                                       53076000
            say "   locked&freezed buffers" endsay;                     53078000
            send;                                                       53080000
            end;                                                        53082000
$if                           <<debugging code>>                        53084000
                                                                        53086000
      allocate'buffers:=good;                                           53088000
                                                                        53090000
      cur'inx:=0;                                                       53092000
      cur'xds:=buffer'xds(0);                                           53094000
                                                                        53096000
      xds'sectors:=(xds'size-xds'overhead) / 128;                       53098000
                                                                        53100000
$if x1=on then                <<debugging code>>                        53102000
      if debugging then                                                 53104000
         begin                                                          53106000
         say "   # of sectors per XDS = " endsay;                       53108000
         saynum (xds'sectors);                                          53110000
         send;                                                          53112000
         end;                                                           53114000
$if                           <<debugging code>>                        53116000
                                                                        53118000
      end <<allocate'buffers sub>>;                                     53120000
$page                                                                   53122000
   <<----------------------->>                                          53124000
   <<  unlock'current'file  >>                                          53126000
   <<----------------------->>                                          53128000
                                                                        53130000
   subroutine unlock'current'file;                                      53132000
                                                                        53134000
      begin                                                             53136000
                                                                        53138000
      if on'err = onerr'quit then                                       53140000
         unlock'files (file'number, 0);                                 53142000
                                                                        53144000
      end <<unlock'current'file sub>>;                                  53146000
$page                                                                   53148000
   <<------------------->>                                              53150000
   <<  wait'for'one'io  >>                                              53152000
   <<------------------->>                                              53154000
                                                                        53156000
   logical subroutine wait'for'one'io;                                  53158000
                                                                        53160000
      <<this routine is used to wait for all ios from the               53162000
        current buffer (cur'inx) to finish.  the result is              53164000
        the "worst" result found, and will be one of the                53166000
        following three:                                                53168000
           io'good     ... all ios finished ok.                         53170000
           io'good'eot ... all ios finished ok, end of tape             53172000
                           was found.                                   53174000
           io'bad      ... one or more ios failed.                      53176000
                                                           >>           53178000
      begin                                                             53180000
                                                                        53182000
      ll:=io'good;            <<assume best result>>                    53184000
                                                                        53186000
      cur'xds:=buffer'xds(cur'inx);                                     53188000
      io'inx:=first'io'inx(cur'inx)-1;                                  53190000
                                                                        53192000
      while (io'inx:=io'inx+1) <= last'io'inx(cur'inx) do               53194000
         begin                                                          53196000
                                                                        53198000
               <<check status of an io...>>                             53200000
                                                                        53202000
         if io'queue'd(io'inx) <> 0d then                               53204000
            begin                                                       53206000
                                                                        53208000
$if x1=on then                <<debugging code>>                        53210000
            if debug'disk then                                          53212000
               begin                                                    53214000
               say "   waitforio #" endsay;                             53216000
               saynum (io'inx);                                         53218000
               say " of cur'inx = " endsay;                             53220000
               saynum (cur'inx);                                        53222000
               say " from xds " endsay;                                 53224000
               saynum (cur'xds);                                        53226000
               say " ioq1 = %" endsay;                                  53228000
               sayoctal (io'queue(io'inx*2));                           53230000
               say ", %" endsay;                                        53232000
               sayoctal (io'queue(io'inx*2+1));                         53234000
               send;                                                    53236000
               end;                                                     53238000
$if                           <<debugging code>>                        53240000
                                                                        53242000
                  <<wait till complete...>>                             53244000
                                                                        53246000
                  <<pass first word of io'queue'd (io'inx)...>>         53248000
            iob:=waitforio (io'queue(io'inx*2) );                       53250000
                                                                        53252000
            if <>  or                                                   53254000
                  attio'status.attio'statusf <> attio'good then         53256000
               begin          <<oops..error!>>                          53258000
               ll:=io'bad;                                              53260000
                     <<someday, consider calling file system            53262000
                       routines like post'acb'error and                 53264000
                       iostat at this point.>>                          53266000
               end                                                      53268000
                                                                        53270000
            else if attio'status.(8:8) = %31 then                       53272000
               begin                                                    53274000
                                                                        53276000
                  <<the write succeeded, but we have now gone           53278000
                    past the eot marker!>>                              53280000
                                                                        53282000
               if ll = io'good then                                     53284000
                  ll:=io'good'eot;                                      53286000
               end                                                      53288000
                                                                        53290000
            else           <<no error occurred!>>                       53292000
               ;              <<don't change ll>>                       53294000
                                                                        53296000
            io'queue'd(io'inx):=0d;                                     53298000
                                                                        53300000
            end;                                                        53302000
         end;                 <<end while loop>>                        53304000
                                                                        53306000
      if io'wtm'd (cur'inx) <> 0d then                                  53308000
         begin                                                          53310000
            iob := waitforio (io'wtm(cur'inx*2));                       53312000
                                                                        53314000
            if <>  or                                                   53316000
                  attio'status.attio'statusf <> attio'good then         53318000
               begin          <<oops..error!>>                          53320000
               ll:=io'bad;                                              53322000
                     <<someday, consider calling file system            53324000
                       routines like post'acb'error and                 53326000
                       iostat at this point.>>                          53328000
               end                                                      53330000
                                                                        53332000
            else if attio'status.(8:8) = %31 then                       53334000
               begin                                                    53336000
                                                                        53338000
                  <<the write succeeded, but we have now gone           53340000
                    past the eot marker!>>                              53342000
                                                                        53344000
               if ll = io'good then                                     53346000
                  ll:=io'good'eot;                                      53348000
               end                                                      53350000
                                                                        53352000
            else           <<no error occurred!>>                       53354000
               ;              <<don't change ll>>                       53356000
                                                                        53358000
            io'wtm'd(cur'inx):=0d;                                      53360000
         end;                                                           53362000
      wait'for'one'io:=ll;                                              53364000
                                                                        53366000
      end <<wait'for'one'io sub>>;                                      53368000
$page                                                                   53370000
   <<------------------->>                                              53372000
   <<  wait'for'all'io  >>                                              53374000
   <<------------------->>                                              53376000
                                                                        53378000
   logical subroutine wait'for'all'io;                                  53380000
                                                                        53382000
      <<this routine is used to wait for all pending ios to             53384000
        complete.  it then returns one of the following                 53386000
        three results:                                                  53388000
           io'good     ... all ios completed normally.                  53390000
           io'good'eot ... all ios completed normally, the end of       53392000
                           tape marker was found.                       53394000
           io'bad      ... one or more ios failed to complete ok.       53396000
                                                                        53398000
        this routine does not write the end of tape marker (if any),    53400000
        it merely reports the end of tape.                              53402000
                                                     >>                 53404000
      begin                                                             53406000
                                                                        53408000
      ll:=io'good;            <<temporarily assume all is well>>        53410000
                                                                        53412000
      cur'inx:=-1;                                                      53414000
                                                                        53416000
      while (cur'inx:=cur'inx+1) < num'xds     do                       53418000
         begin                                                          53420000
                                                                        53422000
               <<wait for an io...>>                                    53424000
                                                                        53426000
         l:=wait'for'one'io;                                            53428000
                                                                        53430000
               <<if l is "worse" than ll, set ll to l...>>              53432000
                                                                        53434000
         if l = io'bad then                                             53436000
            ll:=io'bad                                                  53438000
                                                                        53440000
         else if l = io'good'eot then                                   53442000
            if ll = io'good then                                        53444000
               ll:=l                                                    53446000
            else                                                        53448000
               <<ll is either io'good'eot or io'bad already>>           53450000
                                                                        53452000
         else                                                           53454000
            ;                 <<ll shouldnt be changed>>                53456000
         end;                                                           53458000
                                                                        53460000
      cur'inx:=0;                                                       53462000
      cur'xds:=buffer'xds(cur'inx);                                     53464000
                                                                        53466000
      wait'for'all'io:=ll;                                              53468000
                                                                        53470000
      end <<wait'for'all'io sub>>;                                      53472000
$page                                                                   53474000
   <<------------------->>                                              53476000
   <<  check'io'status  >>                                              53478000
   <<------------------->>                                              53480000
                                                                        53482000
   logical subroutine check'io'status (what);                           53484000
            value   what;                                               53486000
            logical what;                                               53488000
                                                                        53490000
      <<this routine is used to check the status of a batch of          53492000
        nowait attachios write requests issued by fstore.               53494000
                                                                        53496000
        tape will be written past the eot reflector, but only           53498000
        by the number of records still awaiting processing              53500000
        in the buffers defined by buffer'xds, and currently             53502000
        pointed to by cur'xds.                                          53504000
                                                                        53506000
        a failed is returned if any tape errors occurred                53508000
        during the status check.                                        53510000
                                                                        53512000
        if what = wait'current, then the routine will wait              53514000
        for the ios from cur'inx buffer to finish, and then             53516000
        check them.  if what = wait'all, then it waits for              53518000
        all ios from all buffers to finish.                             53520000
                                                 >>                     53522000
      begin                                                             53524000
                                                                        53526000
      check'io'status:=failed;                                          53528000
                                                                        53530000
      if what = wait'current then                                       53532000
         ll:=wait'for'one'io                                            53534000
      else                                                              53536000
         ll:=wait'for'all'io;                                           53538000
                                                                        53540000
$if x1=on then                <<debugging code>>                        53542000
      if debugging then                                                 53544000
         begin                                                          53546000
         say "IN CHECK'IO'RESULT (" endsay;                             53548000
         if what = wait'current then                                    53550000
            say "CURRENT" endsay                                        53552000
         else                                                           53554000
            say "ALL" endsay;                                           53556000
         say "), result = " endsay;                                     53558000
         if ll = io'good then                                           53560000
            say "GOOD" endsay                                           53562000
         else if ll = io'good'eot then                                  53564000
            say "GOOD'EOT" endsay                                       53566000
         else                                                           53568000
            say "BAD" endsay;                                           53570000
         send;                                                          53572000
         end;                                                           53574000
$if                           <<debugging code>>                        53576000
                                                                        53578000
      if ll = io'bad then                                               53580000
         return;              <<return an error condition>>             53582000
                                                                        53584000
            <<if the last status we processed is one that indicates     53586000
              that we went past eot, then we want to wait for           53588000
              all other buffers to finish off their writing,            53590000
              so we can then finish off this reel...>>                  53592000
                                                                        53594000
      if ll = io'good'eot then                                          53596000
         begin                                                          53598000
                                                                        53600000
               <<the write succeeded, but we have now gone              53602000
                 past the eot marker!>>                                 53604000
                                                                        53606000
               <<wait for all pending ios to finish...>>                53608000
                                                                        53610000
         if what = wait'current then                                    53612000
            if wait'for'all'io = io'bad then                            53614000
               return;        <<oops...i/o error after eot>>            53616000
                                                                        53618000
               <<start a new reel...>>                                  53620000
                                                                        53622000
         if not last'startio'wrote'eof then                             53624000
            if write'tape'mark (parms'tempi'1) then                     53626000
               if parms'tempi'1 <> eotcode then                         53628000
                  return;                                               53630000
                                                                        53632000
         if finish'reel (tdbuf, last'startio'wrote'eof)        <<06361>>53634000
               = failed then                                            53638000
            return;                                                     53640000
                                                                        53642000
         if start'reel (tdbuf, tape'reel+1) = failed then               53644000
            return;                                                     53646000
                                                                        53648000
         end;                                                           53650000
                                                                        53652000
      check'io'status:=good;                                            53654000
                                                                        53656000
$if x1=on then                <<debugging code>>                        53658000
      if debugging then                                                 53660000
         begin                                                          53662000
         say "   end check'io" endsay;                                  53664000
         send;                                                          53666000
         end;                                                           53668000
$if                           <<debugging code>>                        53670000
                                                                        53672000
      end <<check'io'status sub>>;                                      53674000
$page                                                                   53676000
   <<---------------------->>                                           53678000
   <<  handle'end'of'reel  >>                                           53680000
   <<---------------------->>                                           53682000
                                                                        53684000
   subroutine handle'end'of'reel (final'reel);                          53686000
            value   final'reel;                                         53688000
            logical final'reel;                                         53690000
                                                                        53692000
         <<this routine unlocks all completed files that                53694000
           are still locked.>>                                          53696000
                                                                        53698000
      begin                                                             53700000
                                                                        53702000
$if x1=on then                <<debugging code>>                        53704000
      if debugging then                                                 53706000
         begin                                                          53708000
         say "*** END OF FILE ***" endsay;                              53710000
         send;                                                          53712000
         end;                                                           53714000
$if                           <<debugging code>>                        53716000
                                                                        53718000
      if labeled then         <<volume set close of labelled tape>>     53720000
         <<do nothing...already handled elsewhere>>                     53722000
                                                                        53724000
      else if final'reel then                                           53726000
         begin                <<need to indicate end-of-logical-reel>>  53728000
               <<write tape trailer label...>>                          53730000
         tl'zfield:=1;                                                  53732000
         if write'tape (tape'label'size, tape'label,                    53734000
                        true, tdbuf, false)                             53736000
               = failed then                                            53738000
            file'fail (t'num, sr'tape'write'fail);                      53740000
                                                                        53742000
         if write'tape'mark (parms'tempi'1) = failed then               53744000
            if parms'tempi'1 <> eotcode then                            53746000
               file'fail (t'num, sr'tape'write'fail);                   53748000
                                                                        53750000
         if write'tape'mark (parms'tempi'1) = failed then               53752000
            if parms'tempi'1 <> eotcode then                            53754000
               file'fail (t'num, sr'tape'write'fail);                   53756000
                                                                        53758000
         if t'num <> 0 then                                             53760000
            fclose (t'num, tape'close'disp, 0);                <<04726>>53762000
         t'num := 0;                                                    53764000
         end;                                                           53766000
                                                                        53768000
      end <<handle'end'of'reel sub>>;                                   53770000
$page                                                                   53772000
   <<--------------------->>                                            53774000
   <<  initialize'fstore  >>                                            53776000
   <<--------------------->>                                            53778000
                                                                        53780000
   subroutine initialize'fstore;                                        53782000
                                                                        53784000
         <<this routine initializes the variables of & used by          53786000
           fstore.                                                      53788000
                                                                        53790000
           note: this routine must not take an error exit...            53792000
           as the error exit will attempt to release the                53794000
           various extra data segments acquired by the                  53796000
           allocate'buffers routine, which won't be called until        53798000
           after this routine!                                 >>       53800000
                                                                        53802000
      begin                                                             53804000
                                                                        53806000
      enable'arithmetic'traps;                                          53808000
                                                                        53810000
      fstore:=good;                                                     53812000
                                                                        53814000
$if x1=on then                <<debugging code>>                        53816000
      if debugging then                                                 53818000
         begin                                                          53820000
         send;                                                          53822000
         say "FSTORE ENTERED" endsay;                                   53824000
         send;                                                          53826000
         say "G'NUM = " endsay;                                         53828000
         saynum (g'num);                                                53830000
         send;                                                          53832000
         say "FILES'TO'HANDLE = " endsay;                               53834000
         saydnum (files'to'handle);                                     53836000
         say ", FILE'NUMBER = " endsay;                                 53838000
         saydnum (file'number);                                         53840000
         send;                                                          53842000
         end;                                                           53844000
$if                           <<debugging code>>                        53846000
                                                                        53848000
            <<blank out tape label...>>                                 53850000
                                                                        53852000
      fill (tape'label, tape'label'size, 0);                            53854000
                                                                        53856000
            <<setup some variables...>>                                 53858000
                                                                        53860000
      sectors'per'tape'record:=double(tape'recsize/128);                53862000
      tape'reel:=1;                                                     53864000
$if x1=on then                <<debugging code>>                        53866000
      if debugging then                                                 53868000
         begin                                                          53870000
         say "*******TAPE'REEL:=1 ******" endsay;                       53872000
         send;                                                          53874000
         end;                                                           53876000
$if                           <<debugging code>>                        53878000
                                                                        53880000
            <<setup tape label...>>                                     53882000
                                                                        53884000
      move tape'label':=labeltext;     <<identifier>>                   53886000
      tl'recsize:=tape'recsize;                                         53888000
      tl'zfield:=0;                                                     53890000
      tl'reelnum:=1;          <<physical reel number...first reel>>     53892000
      tl'date:=calendar;      <<get date>>                              53894000
      tos:=clock;             <<get time of day>>                       53896000
            <<note: clock returned a double, first word = hours >>      53898000
            << & minutes, second = seconds & tenths             >>      53900000
      tl'sstt:=tos;                                                     53902000
      tl'hhmm:=tos;                                                     53904000
      move tl'iibid:="VIIB";                                            53906000
      tl'spantog:=0;          <<first file on first volume>>            53908000
      tl'fileinx:=0;                                                    53910000
                                                                        53912000
            <<someday, handle tape of type: $ctul and $ctur>>           53914000
                                                                        53916000
            <<compute checksum for tape label...>>                      53918000
                                                                        53920000
      tl'chksum:=0;                                                     53922000
      tl'chksum:=checksum (tape'label, tape'label'size);                53924000
                                                                        53926000
$if x1=on then                <<debugging code>>                        53928000
      if debugging then                                                 53930000
         begin                                                          53932000
         say "#sectors per tape record = " endsay;                      53934000
         saydnum (sectors'per'tape'record);                             53936000
         say ", @TDBUF = " endsay;                                      53938000
         sayoctal (@tdbuf);                                             53940000
         send;                                                          53942000
         end;                                                           53944000
$if                           <<debugging code>>                        53946000
                                                                        53948000
      end <<initialize'fstore sub>>;                                    53950000
$page                                                                   54022000
   <<----------------->>                                                54024000
   <<  recover'error  >>                                                54026000
   <<----------------->>                                                54028000
                                                                        54030000
   subroutine recover'error (errmsg);                                   54032000
            value   errmsg;                                             54034000
            integer errmsg;                                             54036000
                                                                        54038000
         <<------------------------------------------                   54040000
           this routine checks to see if the error can                  54042000
           be recovered from and if the user wants recovery.            54044000
                                                                        54046000
           if either of the above checks fail, we exit with             54048000
           an error message.                                            54050000
                                                                        54052000
           if we want to recover the error, we restore the              54054000
           locals and selected global variables to the state            54056000
           they were in at the last reel switch.  we then               54058000
           change the subroutine's return address (which is             54060000
           currently at s-0) to be the address passed to the            54062000
           most recent call on save'state.  a normal sxit is            54064000
           then done, which will return us to the code that             54066000
           is immediately after the last save'state call.               54068000
                                                                        54070000
           note: if spl allowed us to have a switch label               54072000
           that had subroutine-local labels in it, we could             54074000
           merely return an index back from this routine like           54076000
           the following:  go error'switch(recover'error(...))          54078000
           -------------------------------------------------->>         54080000
      begin                                                             54082000
                                                                        54084000
$if x1=on then                <<debugging code>>                        54086000
      if debugging then                                                 54088000
         begin                                                          54090000
         say "Recovering from tape error now" endsay;                   54092000
         say ", error'code=" endsay;                                    54094000
         saynum (error'code);                                           54096000
         say ", ERRMSG=" endsay;                                        54098000
         saynum (errmsg);                                               54100000
         send;                                                          54102000
         say "   ONERR=" endsay;                                        54104000
         saynum (on'err);                                               54106000
         say ", QUIT=" endsay;                                          54108000
         saynum (onerr'quit);                                           54110000
         send;                                                          54112000
         printfileinfo (t'num);                                         54114000
         end;                                                           54116000
$if                           <<debugging code>>                        54118000
                                                                        54120000
      if operator'abort then                                            54122000
         fail (sr'operator'abort);                                      54124000
                                                                        54126000
$if x1=on then                <<debugging code>>                        54128000
      if debugging then                                                 54130000
         begin                                                          54132000
         say "   ERROR IS A TAPE WRITE ERROR" endsay;                   54134000
         send;                                                          54136000
         end;                                                           54138000
$if                           <<debugging code>>                        54140000
                                                                        54142000
            <<don't recover if recovery was not requested,              54144000
              or this is the first reel of a sysdump tape!>>            54146000
                                                               <<04101>>54146100
      if dont'do'recovery then                                 <<04101>>54146200
         file'fail (t'num, errmsg);                            <<04101>>54146300
                                                               <<04101>>54146400
                                                                        54148000
      if on'err = onerr'quit or (sysdumping land tl'reelnum=1) then     54150000
         file'fail (t'num, errmsg);                                     54152000
                                                                        54154000
                                                                        54156000
            <<restore global & local state...>>                         54158000
                                                                        54160000
                                                                        54162000
      move first'local'array:=save'locals, (locals'len);                54164000
                                                                        54166000
      file'number:=local'file'number;                                   54172000
      tapemark'written := local'tapemark'written;              <<04101>>54173000
      file'address     := local'file'address;                  <<04104>>54173100
      file'ldev        := local'file'ldev;                     <<04104>>54173200
      move flab        := local'flab,       (file'label'size); <<04104>>54173300
      move curr'title' := local'title',     (max'std'len + 1); <<04104>>54173400
      move tape'label  := local'tape'label, (tape'label'size); <<04104>>54173500
                                                               <<04104>>54173600
                                                                        54174000
            <<tell user what is happening...>>                          54176000
                                                                        54178000
      sendmessage (m'blank'line);                                       54180000
      sendmessage (sr'will're'store);                                   54182000
      sendmessage (m'blank'line);                                       54184000
                                                                        54186000
$if x1=on then                <<debugging code>>                        54188000
      if debugging then                                                 54190000
         begin                                                          54192000
         say " ... RECOVER'LABEL = %" endsay;                           54194000
         sayoctal (recover'label);                                      54196000
         say ", STATE=" endsay;                                         54198000
         saynum (state);                                                54200000
         say ", FILE#:= " endsay;                                       54202000
         saydnum (file'number);                                         54204000
         send;                                                          54206000
         say "Recovery 1/3 done...opening new reel now" endsay;         54208000
         send;                                                          54210000
         end;                                                           54212000
$if                           <<debugging code>>                        54214000
                                                                        54216000
            <<change the subroutine's return address   >>               54218000
            <<to that of the label following the most  >>               54220000
            <<recent call to save'state...             >>               54222000
                                                                        54224000
      s0:=recover'label;                                                54226000
                                                                        54228000
            <<rewind current reel and mark it bad...>>                  54230000
                                                                        54232000
bad'reel:                                                      <<04102>>54232100
                                                               <<04102>>54232200
      mark'reel'bad;                                                    54234000
                                                                        54236000
            <<ask for next reel...special case for reel #1...>>         54238000
                                                                        54240000
      if tape'reel = 1 then                                             54242000
         begin                                                          54244000
         parms'tempi'1 := tape'reel;                                    54246000
         parms'tempi'2 := tape'ldev;                                    54248000
         sendmessage (sr'mount'next'reel,,true);                        54250000
         if fkontrol (t'num, rewind'unload) = failed then      <<04102>>54250100
            begin                                              <<04102>>54250200
            sendmessage (sr'tape'rewind'failed);               <<04102>>54250300
            goto bad'reel;                                     <<04102>>54250400
            end;                                               <<04102>>54250500
                                                               <<04102>>54250600
         end;                                                           54252000
                                                                        54254000
            <<restart the reel...>>                                     54256000
                                                                        54258000
      if state <> state'0 then                                          54260000
         if labeled then                                                54262000
            fail (sr'cant'recover'labeled'tapes)                        54264000
         else if start'reel (tdbuf, tl'reelnum)                         54266000
               = failed then                                            54268000
            fail (sr'no'next'reel);                                     54270000
                                                                        54272000
$if x1=on then                <<debugging code>>                        54274000
      if debugging then                                                 54276000
         begin                                                          54278000
         say "Recovery 2/3 done...checking PV stuff" endsay;            54280000
         send;                                                          54282000
         end;                                                           54284000
$if                           <<debugging code>>                        54286000
                                                                        54288000
            <<dismount the current set of private volumes               54290000
              (if any) ... black magic...>>                             54292000
                                                                        54294000
      check'for'dismount (pvinfo, gbuf(g'pvinfo'inx),                   54296000
                          old'gbuf, error'code);                        54298000
                                                                        54300000
$if x1=on then                <<debugging code>>                        54302000
      if debugging then                                                 54304000
         begin                                                          54306000
         say "Recovered from tape error." endsay;                       54308000
         send;                                                          54310000
         end;                                                           54312000
$if                           <<debugging code>>                        54314000
                                                                        54316000
      end <<recover'error sub>>;                                        54318000
$page                                                                   54320000
   <<-------------->>                                                   54322000
   <<  save'state  >>                                                   54324000
   <<-------------->>                                                   54326000
                                                                        54328000
   subroutine save'state (new'state);                                   54330000
      value new'state;                                                  54332000
      integer new'state;                                                54334000
                                                                        54336000
         <<this routine saves the information necessary                 54338000
           to restarting the store at the current point.>>              54340000
                                                                        54342000
      begin                                                             54344000
                                                                        54346000
$if x1=on then                <<debugging code>>                        54348000
      if debugging then                                                 54350000
         begin                                                          54352000
         say "START SAVE'STATE (" endsay;                               54354000
         saynum (new'state);                                            54356000
         say ") return to %" endsay;                                    54358000
         sayoctal (s0);                                                 54360000
         send;                                                          54362000
         end;                                                           54364000
$if                           <<debugging code>>                        54366000
                                                                        54368000
      recover'label:=s0;      <<copy of return address>>                54370000
      state:=new'state;                                                 54372000
                                                                        54374000
      local'file'number:=file'number;                                   54376000
      local'tapemark'written := tapemark'written;              <<04101>>54377000
      local'file'address    := file'address;                   <<04104>>54377100
      local'file'ldev       := file'ldev;                      <<04104>>54377200
      move local'flab       := flab,        (file'label'size); <<04104>>54377300
      move local'title'     := curr'title', (max'std'len + 1); <<04104>>54377400
      move local'tape'label := tape'label,  (tape'label'size); <<04104>>54377500
      move save'locals:=first'local'array, (locals'len);                54378000
                                                                        54380000
                                                                        54384000
$if x1=on then                <<debugging code>>                        54386000
      if debugging then                                                 54388000
         begin                                                          54390000
         say "END SAVE'STATE SUB" endsay;                               54392000
         send;                                                          54394000
         end;                                                           54396000
$if                           <<debugging code>>                        54398000
                                                                        54400000
      end <<save'state sub>>;                                           54402000
$page                                                                   54404000
   <<------------>>                                                     54406000
   <<  start'io  >>                                                     54408000
   <<------------>>                                                     54410000
                                                                        54412000
   logical subroutine start'io (sectors,should'write'tape'mark);        54414000
            value   sectors, should'write'tape'mark;                    54416000
            integer sectors;                                            54418000
            logical should'write'tape'mark;                             54420000
                                                                        54422000
      <<this routine starts up to num'io writes from the                54424000
        data segment cur'xds to the tape.  if they are                  54426000
        all started ok, cur'xds and cur'inx get bumped up               54428000
        to the next buffer xds/index pair (the indices                  54430000
        run from 0 to num'xds    -1, then back to 0.     >>             54432000
                                                                        54434000
      begin                                                             54436000
                                                                        54438000
$if x1=on then                <<debugging code>>                        54440000
      if debugging then                                                 54442000
         begin                                                          54444000
         say "   START'IO (" endsay;                                    54446000
         saynum (sectors);                                              54448000
         say " sectors)" endsay;                                        54450000
         send;                                                          54452000
         end;                                                           54454000
$if                           <<debugging code>>                        54456000
                                                                        54458000
      start'io:=failed;       <<initial assumption>>                    54460000
                                                                        54462000
      last'startio'wrote'eof := should'write'tape'mark;                 54464000
                                                                        54466000
            <<loop thru the cur'xds data, starting off                  54468000
              ios...>>                                                  54470000
                                                                        54472000
      io'inx:=first'io'inx(cur'inx) - 1;                                54474000
                                                                        54476000
      words'left:=sectors * 128;                                        54478000
      offset:=0;                                                        54480000
                                                                        54482000
      while (io'inx:=io'inx+1) <= last'io'inx(cur'inx) do               54484000
         begin                                                          54486000
                                                                        54488000
               <<see how many words to write to the tape...>>           54490000
                                                                        54492000
         if (len:=words'left) > tape'recsize then                       54494000
            len:=tape'recsize;                                          54496000
                                                                        54498000
         words'left:=words'left - len;                                  54500000
                                                                        54502000
         if len > 0 then                                                54504000
            begin                                                       54506000
                                                                        54508000
$if x1=on then                <<debugging code>>                        54510000
            if debugging then                                           54512000
               begin                                                    54514000
               say "   call attachio (" endsay;                         54516000
               saynum (tape'ldev); say ", 0, " endsay;                  54518000
               saynum (cur'xds);   say ", " endsay;                     54520000
               saynum (offset);    say ", wr, " endsay;                 54522000
               saynum (len);       say ", ...)" endsay;                 54524000
               send;                                                    54526000
               end;                                                     54528000
$if                           <<debugging code>>                        54530000
                                                                        54532000
            disable'arithmetic'traps;                                   54534000
                                                                        54536000
            io'queue'd(io'inx):=                                        54538000
                  attachio (                                            54540000
                     tape'ldev,                  << ldev              >>54542000
                     0,                          << qmisc             >>54544000
                     cur'xds,                    << data segment      >>54546000
                     offset,                     << offset in data seg>>54548000
                     attio'write,                << do a write        >>54550000
                     len,                        << length of write   >>54552000
                     0,                          << parameter 1       >>54554000
                     4,       <<write past eot>> << parameter 2       >>54556000
                     0);      <<no wake,impede>> << flags             >>54558000
                                                                        54560000
            enable'arithmetic'traps;                                    54562000
                                                                        54564000
$if x1=on then                <<debugging code>>                        54566000
            if debugging then                                           54568000
               begin                                                    54570000
               say "      --> IOQ'1 = %" endsay;                        54572000
               sayoctal (io'queue(io'inx*2));                           54574000
               say ", IOQ'2 = %" endsay;                                54576000
               sayoctal (io'queue(io'inx*2+1));                         54578000
               send;                                                    54580000
               end;                                                     54582000
$if                           <<debugging code>>                        54584000
            io'len(io'inx):=len;                                        54586000
            offset:=offset + len;                                       54588000
            end                                                         54590000
         else                                                           54592000
            begin                                                       54594000
            io'queue'd(io'inx):=0d;                                     54596000
            io'len(io'inx):=0;                                          54598000
            end;                                                        54600000
         end;                                                           54602000
                                                                        54604000
            <<write tape mark if necessary>>                            54606000
                                                                        54608000
      if should'write'tape'mark then                                    54610000
         begin                                                          54612000
            disable'arithmetic'traps;                                   54614000
                                                                        54616000
            io'wtm'd(cur'inx):=                                         54618000
                  attachio (                                            54620000
                     tape'ldev,                  << ldev              >>54622000
                     0,                          << qmisc             >>54624000
                     0,                          << data segment      >>54626000
                     0,                          << offset in data seg>>54628000
                     attio'wtm,                  << do a write        >>54630000
                     0,                          << length of write   >>54632000
                     0,                          << parameter 1       >>54634000
                     4,       <<write past eot>> << parameter 2       >>54636000
                     0);      <<no wake,impede>> << flags             >>54638000
                                                                        54640000
            enable'arithmetic'traps;                                    54642000
         end                                                            54644000
      else io'wtm'd (cur'inx) := 0d;                                    54646000
            <<bump the cur'inx...>>                                     54648000
                                                                        54650000
      if (cur'inx:=cur'inx+1) >= num'xds     then                       54652000
         cur'inx:=0;                                                    54654000
                                                                        54656000
      cur'xds:=buffer'xds(cur'inx);                                     54658000
                                                                        54660000
      start'io:=good;                                                   54662000
                                                                        54664000
$if x1=on then                <<debugging code>>                        54666000
      if debugging then                                                 54668000
         begin                                                          54670000
         say "   end of start'io" endsay;                               54672000
         send;                                                          54674000
         end;                                                           54676000
$if                           <<debugging code>>                        54678000
                                                                        54680000
      end <<start'io sub>>;                                             54682000
$page                                                          <<06309>>54682100
                                                               <<06309>>54682200
   <<------------------->>                                     <<06309>>54682300
   <<  failed'to'store  >>                                     <<06309>>54682400
   <<------------------->>                                     <<06309>>54682500
                                                               <<06309>>54682600
   subroutine failed'to'store (n);                             <<06309>>54682700
            value  n;                                          <<06309>>54682800
            integer n;                                         <<06309>>54682900
      begin                                                    <<06309>>54683000
      sendmessage (n);                                         <<06309>>54683100
                                                               <<06309>>54683200
      if n <> 0 then                                           <<06309>>54683300
         error'code:=n;                                        <<06309>>54683400
                                                               <<06309>>54683500
      good'store:=false;                                       <<06309>>54683600
                                                               <<06309>>54683700
      if first'record'of'file then                             <<06309>>54683800
         begin                <<need to write something!>>     <<06309>>54683900
         move fllocname := gbuf (g'title'inx),                 <<06309>>54684000
                               (3*file'part'size);             <<06309>>54684100
         fl'bad'file:=true;                                    <<06309>>54684200
                                                               <<06309>>54684300
         if using'attio then                                   <<06309>>54684400
            begin                                              <<06309>>54684500
            move'data'out (cur'xds, 0, flab, file'label'size); <<06309>>54684600
                                                               <<06309>>54684700
            if start'io (1, true) = failed then                <<06309>>54684800
               recover'error (sr'tape'write'fail);             <<06309>>54684900
            end                                                <<06309>>54685000
                                                               <<06309>>54685100
         else if write'tape (file'label'size, flab, false,     <<06309>>54685200
                          tdbuf, true) = failed then           <<06309>>54685300
            recover'error (sr'tape'write'fail);                <<06309>>54685400
         end                                                   <<06309>>54685500
                                                               <<06309>>54685510
      else if using'attio then                                 <<06309>>54685520
         if start'io (0, true) = failed then <<write tapemark>><<06309>>54685530
            recover'error (sr'tape'write'fail);                <<06309>>54685600
                                                               <<06309>>54685610
      end <<failed'to'store sub>>;                             <<06309>>54685700
$page                                                          <<06309>>54685800
   <<---------------->>                                                 54686000
   <<  store'a'file  >>                                                 54688000
   <<---------------->>                                                 54690000
                                                                        54692000
   logical subroutine store'a'file;                                     54694000
                                                                        54696000
         <<attempts to store the current file.  if it fails,            54698000
           returns failed, otherwise good.            >>                54700000
                                                                        54702000
      begin                                                             54704000
                                                                        54706000
$if x1=on then                <<debugging code>>                        54708000
      if debugging then                                                 54710000
         begin                                                          54712000
         say "STORE'A'FILE entered, TAPE'REEL = " endsay;               54714000
         saynum (tape'reel);                                            54716000
         send;                                                          54718000
         end;                                                           54720000
$if                           <<debugging code>>                        54722000
                                                                        54724000
      check'break;            <<wont come back if break sensed>>        54726000
                                                                        54728000
      good'store:=true;       <<this file is ok, so far>>               54730000
                                                               <<04996>>54730100
      tapemark'written := false;                               <<04996>>54730200
                                                                        54732000
      if first'time'in then                                             54734000
         begin                                                          54736000
         first'time'in:=false;                                          54738000
         save'state (state'0);                                          54740000
         if start'reel (tdbuf, 1) = failed then                         54742000
            recover'error (sr'no'first'reel);                           54744000
         save'state (state'7);                                          54746000
         end;                                                           54758000
                                                                        54760000
      first'reel:=tape'reel;  <<remember reel # file started on>>       54762000
                                                                        54764000
      fpoint (g'num, file'number - 1d);                                 54766000
                                                                        54768000
      if <> then                                                        54770000
         file'fail (g'num, sr'g'num'error);                             54772000
                                                                        54774000
      read'good'file;         <<handles '<' errors>>                    54776000
                                                                        54778000
      if > then                                                         54780000
         file'fail (g'num, sr'g'num'sequence);                          54782000
                                                                        54784000
      if file'number <> gbuf'd (g'filenum'inx'd) then                   54786000
         file'fail (no'file, sr'g'num'sequence);                        54788000
                                                                        54790000
      file'address:=gbuf'd(g'address'inx'd);                            54792000
      file'ldev:=gbuf(g'ldev'inx);                                      54794000
      pvinfo:=gbuf(g'pvinfo'inx);                              <<04988>>54795000
                                                                        54796000
      display'3'to'standard (gbuf'(g'file'inx'), gbuf'(g'group'inx'),   54798000
                             gbuf'(g'acct'inx'),                        54800000
                             curr'title',                               54802000
                             error'code);                               54804000
$if x1=on then                <<debugging code>>                        54806000
      if debugging then                                                 54808000
         begin                                                          54810000
         send;                                                          54812000
         say "   FSTORE: " endsay;                                      54814000
         say'standard (curr'title');                                    54816000
         say "   " endsay;                                              54818000
         saynum (file'ldev);                                            54820000
         say "%" endsay;                                                54822000
         sayoctal (file'addr'1);                                        54824000
         send;                                                          54826000
         end;                                                           54828000
$if                           <<debugging code>>                        54830000
                                                                        54832000
      check'for'dismount (pvinfo, gbuf(g'pvinfo'inx),                   54834000
                          old'gbuf, error'code);                        54836000
                                                                        54838000
                                                                        54840000
$if x1=on then                <<debugging code>>                        54842000
      if debugging then                                                 54844000
         begin                                                          54846000
         say "      FILE SIZE = " endsay;                               54848000
         saydnum (file'sectors);                                        54850000
         say " SECTORS,  #EXTENTS = " endsay;                           54852000
         saynum (flnumexts);                                            54854000
         say ", STORE TO REEL # " endsay;                               54856000
         saynum (tl'reelnum);                                           54858000
         send;                                                          54860000
         end;                                                           54862000
$if                           <<debugging code>>                        54864000
                                                                        54866000
      disj'extent'num:=0;                                               54868000
      first'record'of'file:=true;                                       54870000
                                                                        54872000
      sectors'filled:=0d;                                               54874000
                                                                        54876000
               <<put addresses in dextmap - ldev in                     54878000
                 leftmost byte...>>                                     54880000
                                                                        54882000
      disj'ext'addr (0) := gbuf'd (g'address'inx'd);                    54884000
      disj'ext'addr'ldev := gbuf (g'ldev'inx);                          54886000
      disj'ext'len (0) := gbuf'd (g'extsize'inx'd);                     54888000
      file'sectors := gbuf'd (g'file'sectors'inx'd);                    54890000
      file'sectors'left := file'sectors;                                54892000
$page                                                                   54894000
                                                                        54896000
         <<------------------------------------------------------->>    54898000
         << note: the following algorithm takes advantage of the  >>    54900000
         << fact that sectors within an extent are contiguous.    >>    54902000
         << (i.e: one attachio reads multiple sectors).           >>    54904000
         <<------------------------------------------------------->>    54906000
                                                                        54908000
            <<write out the extents of the file...>>                    54910000
                                                                        54912000
      do                                                                54914000
         begin                <<per extent>>                            54916000
                                                                        54918000
$if x1=on then                <<debugging code>>                        54920000
         if debugging then                                              54922000
            begin                                                       54924000
            say "      HANDLE DISJOINT EXTENT # " endsay;               54926000
            saynum(disj'extent'num);                                    54928000
            say ", SIZE=" endsay;                                       54930000
            saydnum (disj'ext'len (disj'extent'num) );                  54932000
            say ", FILE'SECTORS'LEFT = " endsay;                        54934000
            saydnum (file'sectors'left);                                54936000
            send;                                                       54938000
            end;                                                        54940000
$if                           <<debugging code>>                        54942000
                                                                        54944000
         sector'address:=disj'ext'addr(disj'extent'num);                54946000
         if sector'address = 0d then                                    54948000
            go nullext;       <<null extent>>                           54950000
                                                                        54952000
                                                                        54954000
               <<adjust file'sectors'left by subtracting the            54956000
                 number of sectors we are about to store from           54958000
                 the current extent...>>                                54960000
                                                                        54962000
         if file'sectors'left < disj'ext'len (disj'extent'num) then     54964000
            begin                                                       54966000
            extent'sectors'left := file'sectors'left;                   54968000
            file'sectors'left   := 0d;                                  54970000
            end                                                         54972000
         else                                                           54974000
            begin                                                       54976000
            extent'sectors'left := disj'ext'len (disj'extent'num);      54978000
            file'sectors'left   := file'sectors'left                    54980000
                                      - extent'sectors'left;            54982000
            end;                                                        54984000
                                                                        54986000
$if x1=on then                <<debugging code>>                        54988000
         if debugging then                                              54990000
            begin                                                       54992000
            say "         EXTENT'SECTORS'LEFT := " endsay;              54994000
            saydnum (extent'sectors'left);                              54996000
            say ",  FILE'SECTORS'LEFT := " endsay;                      54998000
            saydnum (file'sectors'left);                                55000000
            send;                                                       55002000
            end;                                                        55004000
$if                           <<debugging code>>                        55006000
                                                                        55008000
                                                                        55010000
               <<extract ldev...>>                                      55012000
                                                                        55014000
         ldev:=sector'address'ldev;                                     55016000
                                                                        55018000
               <<convert sector'address to a simple address...>>        55020000
                                                                        55022000
         sector'address'ldev:=0;                                        55024000
                                                                        55026000
         while extent'sectors'left > 0d do                              55028000
            begin             <<sectors within extent disj'extent'num>> 55030000
                                                                        55032000
                  <<read as many sectors as are left in                 55034000
                    the tape buffer...>>                                55036000
                                                                        55038000
            if using'attio then                                         55040000
               sectors'this'read:=double(xds'sectors)                   55042000
            else                                                        55044000
               sectors'this'read:=sectors'per'tape'record               55046000
                                     - sectors'filled;                  55048000
                                                                        55050000
                  <<if the above is more than is left, dont read        55052000
                    that much...>>                                      55054000
                                                                        55056000
            if extent'sectors'left <= sectors'this'read then            55058000
               sectors'this'read:=extent'sectors'left;                  55060000
                                                                        55062000
                  <<decrement number of sectors left...>>               55064000
                                                                        55066000
            extent'sectors'left:=extent'sectors'left                    55068000
                                    - sectors'this'read;                55070000
                                                                        55072000
$if x1=on then                <<debugging code>>                        55074000
            if debugging then                                           55076000
               begin                                                    55078000
               say "         READ " endsay;                             55080000
               saydnum (sectors'this'read);                             55082000
               say " FROM " endsay;                                     55084000
               saynum (ldev);                                           55086000
               say1 ("%");                                              55088000
               saydoctal (sector'address);                              55090000
               say "  (EXTENT'SECTORS'LEFT = " endsay;                  55092000
               saydnum (extent'sectors'left);                           55094000
               say1 (")");                                              55096000
               send;                                                    55098000
               end;                                                     55100000
$if                           <<debugging code>>                        55102000
                                                                        55104000
            if using'attio then                                         55106000
               begin                                                    55108000
                     <<wait for old ios from this xds to                55110000
                       tape to finish, and see if they worked           55112000
                       ok...>>                                          55114000
               save'reel:=tl'reelnum;                                   55116000
               if check'io'status (wait'current) = failed then          55118000
                  recover'error (sr'tape'write'fail);                   55120000
               if save'reel <> tl'reelnum then                          55122000
                  save'state (state'1);                                 55124000
                                                                        55126000
               read'disk (ldev, sector'address,                         55128000
                          cur'xds,                                      55130000
                          0,  <<read into start of xds>>                55132000
                          logical(sectors'this'read) & lsl(7),          55134000
                          iob);                                         55136000
               end                                                      55138000
            else                                                        55140000
               read'disk (ldev, sector'address,                         55142000
                          0,     << = stack>>                           55144000
                          @tdbuf(logical(sectors'filled) & lsl(7)),     55146000
                          logical(sectors'this'read) & lsl(7),          55148000
                          iob);                                         55150000
                                                                        55152000
$if x1=on then                <<debugging code>>                        55154000
            if debug'errors and                                         55156000
                  attio'status.attio'statusf = attio'good then          55158000
               begin                                                    55160000
               say "READ-ATTACHIO WORKED...INJECT ERROR? " endsay;      55162000
               sendstop;                                                55164000
               affirm (yes, false);                                     55166000
               if yes then                                              55168000
                  begin                                                 55170000
                  iob'1:=%000014;                                       55172000
                  iob'2:=%000000;                                       55174000
                  move flab' := "3333333333333333X";           <<06309>>55175000
                  say "ERROR INJECTED!" endsay;                         55176000
                  send;                                                 55178000
                  end;                                                  55180000
               end;                                                     55182000
$if                           <<debugging code>>                        55184000
                                                               <<06361>>55184100
            last'file := (file'number = files'to'handle);      <<06361>>55184200
                                                                        55186000
            if attio'status.attio'statusf <> attio'good then            55188000
               begin          <<rewrite file label and unlock...>>      55190000
               sendmessage (m'blank'line);                              55192000
               parms'tempi'1:=ldev;                                     55194000
               parms'tempi'2:=integer(sectors'this'read);               55196000
               parms'tempd'1:=sector'address;                           55198000
               parms'tempd'2:=iob;                                      55200000
               sendmessage (m'disk'read'failed);                        55202000
               sendmessage (m'blank'line);                              55204000
               unlock'current'file;                                     55206000
               failed'to'store (sr'attio'fail);                         55208000
               go l'failed'to'store;                                    55210000
               end;                                                     55212000
                                                                        55214000
            if first'record'of'file then                                55216000
               begin          <<note: file label is first data!>>       55218000
                                                                        55220000
               if using'attio then                                      55222000
                  move'data'in (cur'xds, 0, tdbuf, file'label'size);    55224000
               move flab := tdbuf, (file'label'size);                   55226000
                                                                        55228000
               vtabtoldev (extmap'd (1), flextmap'd'1, flnumexts,       55230000
                           pvinfo.pv'mvtabxf );                         55232000
                                                                        55234000
               join'contiguous'extents (num'disjoint'extents,           55236000
                  disj'ext'addr (1), disj'ext'len (1), extmap'd (1),    55238000
                  flnumexts, flextsize'd, fllastextsize'd);    <<lb.rs>>55240000
                                                                        55242000
               num'disjoint'extents := num'disjoint'extents + 1;        55244000
                                                                        55246000
                     <<set release bit...>>                             55248000
                                                                        55250000
               tdbuf(fl'sr'release'inx).fl'sr'release'bit:=             55252000
                  release'flag;                                         55254000
                                                                        55256000
                     <<set new acct, if needed...>>                     55258000
                                                                        55260000
               if res'acct' <> " " then                                 55262000
                  move tdbuf'(fl'acct''inx) :=                          55264000
                        res'acct', (file'part'size);                    55266000
                                                                        55268000
                     <<set new group, if needed...>>                    55270000
                                                                        55272000
               if res'group' <> " " then                                55274000
                  move tdbuf'(fl'group''inx) :=                         55276000
                        res'group', (file'part'size);                   55278000
                                                                        55280000
                     <<calculate new checksum...>>                      55282000
                                                                        55284000
               flab'checksum;                                           55286000
                                                                        55288000
               if using'attio and                                       55290000
                     (release'flag or seen'acct or seen'group or        55292000
                        seen'local )                            then    55294000
                  move'data'out (cur'xds, 0, tdbuf, file'label'size);   55296000
                                                                        55298000
               first'record'of'file:=false;                             55300000
               end;                                                     55302000
                                                                        55304000
            sectors'filled:=sectors'filled + sectors'this'read;         55306000
                                                                        55308000
            if sectors'filled >= sectors'per'tape'record                55310000
                  or using'attio then                                   55312000
               begin                                                    55314000
                                                                        55316000
                     <<save reel# so we can detect reel                 55318000
                       switch...>>                                      55320000
                                                                        55322000
               save'reel:=tl'reelnum;                                   55324000
                                                                        55326000
                     <<write the buffer out to tape...>>                55328000
                                                                        55330000
               if using'attio then                                      55332000
                  if start'io (logical(sectors'this'read),              55334000
                               ((file'sectors'left = 0d) land           55336000
                               (extent'sectors'left = 0d)    ))         55338000
                        = failed then                                   55340000
                     recover'error (sr'tape'write'fail)                 55342000
                  else                                                  55344000
               else if write'tape (tape'recsize, tdbuf, false, tdbuf,   55346000
                  (file'sectors'left=0d land extent'sectors'left=0d))   55348000
                     = failed then                                      55350000
                  recover'error (sr'tape'write'fail);                   55352000
                                                                        55354000
                     <<if we switched reels, remember                   55356000
                       state...>>                                       55358000
                                                                        55360000
               if save'reel <> tl'reelnum then                          55362000
                  save'state (state'2);                                 55364000
                                                                        55366000
               sectors'filled:=0d;                                      55368000
                                                                        55370000
               end;                                                     55372000
                                                                        55374000
            sector'address:=sector'address+sectors'this'read;           55376000
                                                                        55378000
            end;              <<sectors within an extent loop>>         55380000
                                                                        55382000
   nullext:                                                             55384000
         disj'extent'num:=disj'extent'num+1;                            55386000
         end                  <<per extent loop>>                       55388000
      until                                                             55390000
         file'sectors'left <= 0d  or                                    55392000
            disj'extent'num > num'disjoint'extents;                     55394000
                                                                        55396000
                                                                        55398000
            <<we have, supposedly, finished storing the                 55400000
              current file...we now double check and see                55402000
              if we have stored too many or too few                     55404000
              sectors...if we have, some piece of information           55406000
              that we relied upon to calculate things like              55408000
               extents and sectors was inconsistent...       >>         55410000
                                                                        55412000
                                                                        55414000
      if file'sectors'left <> 0d then                                   55416000
         begin                                                          55418000
$if x1=on then                <<debugging code>>                        55420000
         if debugging then                                              55422000
            begin                                                       55424000
            send;                                                       55426000
            say "***OH OH, SECTORS SHOULD BE 0, NOT: " endsay;          55428000
            saydnum (file'sectors'left);                                55430000
            send;                                                       55432000
            send;                                                       55434000
            end;                                                        55436000
$if                           <<debugging code>>                        55438000
         sendmessage (sr'sectors'not'equal'0);                          55440000
         if not show'flag then                                 <<06156>>55440100
            sendmessage (m'title);                             <<06156>>55440200
         end;                                                           55442000
                                                                        55444000
         <<---------------------------------------------->>             55446000
         << end of disk file.  flush partial tape buffer >>             55448000
         << & write an eof.  then unlock the file.       >>             55450000
         <<---------------------------------------------->>             55452000
                                                                        55454000
      if sectors'filled > 0d  then                                      55456000
         begin                                                          55458000
                                                                        55460000
               <<note: this code won't be executed when                 55462000
                 using'attio is true!                  >>               55464000
                                                                        55466000
         len:=logical(sectors'filled) * 128;    <<sectors-->words>>     55468000
         save'reel:=tl'reelnum;                                         55470000
         if write'tape (len, tdbuf, false, tdbuf, true)                 55472000
               = failed then                                            55474000
            recover'error (sr'tape'write'fail);                         55476000
         if save'reel <> tl'reelnum then                                55478000
            save'state (state'3);                                       55480000
         sectors'filled:=0d;                                            55482000
         end;                                                           55484000
                                                                        55486000
<<    if using'attio then                                               55488000
         begin                                                          55490000
         save'reel:=tl'reelnum;                                         55492000
         if check'io'status (wait'all) = failed then                    55494000
            recover'error (sr'tape'write'fail);                         55496000
         if save'reel <> tl'reelnum then                                55498000
            begin                                                       55500000
            handle'end'of'reel (false);                                 55502000
            save'state (state'4);                                       55504000
            end;                                                        55506000
         end;             >>                                            55508000
$page                                                                   55510000
         <<----------------------------------------------->>            55512000
         << through with the file, one way or the other...>>            55514000
         <<----------------------------------------------->>            55516000
                                                                        55518000
   l'failed'to'store:                                                   55520000
                                                                        55522000
                                                                        55524000
      if labeled then                                                   55526000
         begin                <<labelled tape>>                         55528000
                                                                        55530000
$if x1=on then                <<debugging code>>                        55532000
         if debugging then                                              55534000
            begin                                                       55536000
            say "   call NEXTTAPEFILE" endsay;                          55538000
            send;                                                       55540000
            end;                                                        55542000
$if                           <<debugging code>>                        55544000
                                                               <<04966>>55544900
         if not last'file then                                 <<04966>>55545000
         begin                                                 <<04966>>55545100
         disable'arithmetic'traps;                                      55546000
         if nexttapefile (t'num) <> 0 then                              55548000
            file'fail (t'num, sr'cant'reopen'tape);                     55550000
                                                                        55552000
         if ldirectf (t'num) or need'directory then                     55554000
            begin             <<write directory on reel switch>>        55556000
            if direc'to'tape (tdbuf) = failed then                      55558000
               file'fail (t'num, error'code);                           55560000
            if nexttapefile (t'num) <> 0 then                           55562000
               file'fail (t'num, sr'cant'reopen'tape);                  55564000
            end;                                                        55566000
         enable'arithmetic'traps;                                       55568000
         end;                                                  <<04966>>55569000
                                                               <<04966>>55569100
         end                                                            55570000
                                                                        55572000
      else if not using'attio and not tapemark'written then    <<04996>>55574000
         begin                <<unlabelled tape...>>                    55576000
         save'reel:=tl'reelnum;                                         55578000
                                                                        55580000
         if write'tape'mark (parms'tempi'1) = failed then               55582000
            if parms'tempi'1 <> eotcode then                            55584000
               recover'error (sr'tape'write'fail)                       55586000
            else                                                        55588000
               begin                                                    55590000
               if finish'reel (tdbuf, true) = failed then               55592000
                  recover'error (sr'tape'write'fail);                   55594000
               if tl'zfield = 0 then                                    55596000
                  if start'reel (tdbuf, tape'reel+1) = failed then      55598000
                     recover'error (sr'unable'to'start'reel);           55600000
               end;                                                     55602000
                                                                        55604000
         if save'reel <> tl'reelnum then                                55606000
            save'state (state'5);                                       55608000
         end;                                                           55610000
                                                                        55612000
                                                                        55614000
      if good'store then                                                55616000
         begin                                                          55618000
         store'a'file:=good;                                            55620000
         good'count:=good'count + 1d;                                   55622000
         save'reel:=tape'reel;                                          55624000
         tape'reel:=first'reel;                                         55626000
         if show'flag then sendmessage (m'stored);                      55628000
         tape'reel:=save'reel;                                          55630000
         if show'security'flag then                                     55632000
            sendmessage (m'security);                                   55634000
         if seen'purge then                                             55634100
            begin                                                       55634200
            g'purge'bit := true;                                        55634300
            update'good'file;                                           55634400
            end;                                                        55634500
         end                                                            55636000
      else                                                              55638000
         begin                                                          55640000
         store'a'file:=failed;                                          55642000
         failed'count:=failed'count + 1d;                               55644000
         end;                                                           55646000
                                                                        55648000
      unlock'current'file;                                              55650000
                                                                        55652000
$if x1=on then                <<debugging code>>                        55654000
      if debugging then                                                 55656000
         begin                                                          55658000
         send;                                                          55660000
         end;                                                           55662000
$if                           <<debugging code>>                        55664000
                                                                        55666000
      end <<store'a'file sub>>;                                         55668000
$page ";STORE=  FSTORE --- OUTER BLOCK"                                 55670000
                                                                        55672000
         <<the following code initializes the two integer               55674000
           pointers used for state saving/restoring...this              55676000
           code must be the first executable code of the                55678000
           routine!>>                                                   55680000
                                                                        55682000
         <<@first'local is the db address of the first                  55684000
           local worth storing.  s is the db address of                 55686000
           of the first cell after all the local storage.               55688000
           then, s-@first'local = length of locals storage, including   55690000
           arrays which is stored into locals'len.                      55692000
                                                                        55694000
           then, push s again, save it in @save'locals, and             55696000
           do an adds of locals'len to allocate a storage space         55698000
           of equal size to the space occupied by the locals.           55700000
                                                                        55702000
           we are assured that maxdata will not be breached             55704000
           because of the call to zsize in cxstore'restore  >>          55706000
                                                                        55708000
                                                                        55710000
                                                                        55712000
   push (s);                  <<get current db-rel addr>>               55714000
   locals'len:= tos - @first'local;                                     55716000
                                                                        55718000
         <<allocate the two arrays...>>                                 55720000
                                                                        55722000
   push (s);                  <<get current db-rel addr>>               55724000
   @save'locals:=tos;                                                   55726000
   tos:=locals'len;                                                     55728000
   allocate'stack'space;      <<allocate space for locals>>             55730000
                                                                        55732000
   @first'local'array := @first'local;                                  55734000
                                                                        55736000
$if x1=on then                <<debugging code>>                        55738000
   if debugging then                                                    55740000
      begin                                                             55742000
      say "Allocated space for local & tape label storage"              55744000
         endsay;                                                        55746000
      send;                                                             55748000
      end;                                                              55750000
$if                           <<debugging code>>                        55752000
$page                                                                   55754000
                                                                        55756000
   initialize'fstore;                                                   55758000
                                                                        55760000
   if using'attio then                                                  55762000
      if allocate'buffers = failed then                                 55764000
         begin                                                          55766000
         using'filesys:=true;                                           55768000
         using'attio:=false;                                            55770000
         tape'recsize:=default'tape'recsize;                            55772000
         initialize'fstore;                                             55774000
$if x1=on then                <<debugging code>>                        55776000
      if debugging then                                                 55778000
         begin                                                          55780000
         say "Failed to allocate XDS buffers!" endsay;                  55782000
         send;                                                          55784000
         end;                                                           55786000
$if                           <<debugging code>>                        55788000
         end;                                                           55790000
                                                                        55792000
$if x1=on then                <<debugging code>>                        55794000
   if debugging then                                                    55796000
      begin                                                             55798000
      say "Using: " endsay;                                             55800000
      if using'attio then                                               55802000
         say "ATTIO" endsay                                             55804000
      else                                                              55806000
         say "FILESYS" endsay;                                          55808000
      send;                                                             55810000
      end;                                                              55812000
$if                           <<debugging code>>                        55814000
                                                                        55816000
                                                                        55818000
         <<------------------------------->>                            55820000
         << now dump all disk files to    >>                            55822000
         << tape, one file per tape file. >>                            55824000
         <<------------------------------->>                            55826000
                                                                        55828000
   if show'flag then                                                    55830000
      begin                                                             55832000
      sendmessage (m'blank'line);                                       55834000
      sendmessage (m'heading);                                          55836000
      sendmessage (m'blank'line);                                       55838000
      end;                                                              55840000
                                                                        55842000
   file'number:=1d;                                                     55844000
                                                                        55846000
   save'state (state'6);                                                55848000
                                                                        55850000
   while file'number <= files'to'handle do                              55852000
      begin                                                             55854000
                                                                        55856000
      store'a'file;                                                     55862000
                                                                        55864000
      file'number:=file'number + 1d;                                    55866000
                                                                        55868000
      end;                                                              55870000
                                                                        55872000
   last'file := true;                                          <<06361>>55872100
                                                               <<06361>>55872200
         <<--------------------------------------------->>              55874000
         <<wait for all io to complete                  >>              55876000
         <<--------------------------------------------->>              55878000
                                                                        55880000
   if using'attio then                                                  55882000
      begin                                                             55884000
      save'reel := tl'reelnum;                                          55886000
      if check'io'status (wait'all) = failed then                       55888000
         recover'error (sr'tape'write'fail);                            55890000
      end;                                                              55892000
                                                                        55894000
         <<--------------------------------------------->>              55908000
         <<all files have now been stored and unlocked. >>              55910000
         <<close logical reel now.                      >>              55912000
         <<--------------------------------------------->>              55914000
                                                                        55916000
                                                                        55918000
   finish'reel (tdbuf, true);                   <<end of final reel>>   55920000
                                                                        55922000
   if t'num <> 0 then                                                   55924000
      fclose (t'num, tape'close'disp, 0);                      <<04726>>55926000
   t'num := 0;                                                          55928000
                                                                        55930000
   if using'attio then release'buffers;                                 55932000
                                                                        55934000
                                                                        55936000
end'fstore:                                                             55938000
                                                                        55940000
         <<copy local good/failed counts into globals...>>              55942000
                                                                        55944000
   failed'file'count:=failed'count;                                     55946000
   good'file'count:=good'count;                                         55948000
                                                                        55950000
   unlock'files (all'files, 0);                                         55952000
                                                                        55954000
$if x1=on then                <<debugging code>>                        55956000
   if debugging then                                                    55958000
      begin                                                             55960000
      say "END FSTORE" endsay;                                          55962000
      send;                                                             55964000
      send;                                                             55966000
      end;                                                              55968000
$if                           <<debugging code>>                        55970000
                                                                        55972000
   end <<fstore proc>>;                                                 55974000
!control nolist      !list                                              60000000
$page "[RESTORE]  IRESTORE --- produce list of files to be RESTOREd"    60001000
<<*****************************************************************>>   60002000
$control segment=irestore                                               60003000
logical procedure irestore (tdbuf);                                     60004000
         integer array tdbuf;                                           60005000
         option privileged, uncallable;                                 60006000
                                                                        60007000
   begin                                                                60008000
                                                                        60009000
                                                                        60010000
   double array                                                         60011000
      gbuf'd      (0:g'recsize/2);                                      60012000
                                                                        60013000
   double                                                               60014000
      c'rec             := 0d,                                          60014100
      first'file'on'vol := 0d;                                          60015000
                                                                        60016000
   integer array                                                        60017000
      buffer  (0:d'blocksize-1),                                        60018000
      candidat'buf (0:candidat'recsize-1),                              60019000
      gbuf        (*) = gbuf'd (0);                                     60020000
                                                                        60021000
   integer                                                              60022000
      directory'tape'recsize := max'7970'recsize,                       60023000
      dummy'i,                                                          60024000
      left'over   := 0,                                                 60025000
      len'tape    := 0,                                                 60026000
      ml          := 0,                                                 60027000
      savx        := 0;                                                 60028000
                                                                        60029000
   logical                                                              60030000
      done        := false,                                             60031000
      yes;                                                              60032000
                                                                        60033000
   byte array                                                           60034000
      tdbuf'      (*) = tdbuf (0);                                      60035000
                                                                        60036000
   equate                                                               60037000
      max'directory'tape'recsize = max'7970'recsize;                    60038000
                                                                        60039000
   label                                                                60040000
      end'irestore;                                                     60041000
                                                                        60042000
$page "[RESTORE]  IRESTORE --- error handling subroutines"              60043000
   <<------------------------>>                                         60044000
   <<  fail                  >>                                         60045000
   <<------------------------>>                                         60046000
                                                                        60047000
   subroutine fail (errnum);                                            60048000
            value   errnum;                                             60049000
            integer errnum;                                             60050000
      begin                                                             60051000
                                                                        60052000
      unlock'files (all'files, 0);                                      60053000
                                                                        60054000
      if errnum <> 0 then                                               60055000
         sendmessage (errnum);                                          60056000
                                                                        60057000
      close'files (no'file);                                            60058000
                                                                        60059000
      irestore:=failed;                                                 60060000
                                                                        60061000
      go end'irestore;                                                  60062000
                                                                        60063000
      end <<fail sub>>;                                                 60064000
                                                                        60065000
   <<------------------------>>                                         60066000
   <<  file'fail             >>                                         60067000
   <<------------------------>>                                         60068000
                                                                        60069000
   subroutine file'fail (fid, errnum);                                  60070000
            value   fid, errnum;                                        60071000
            integer fid, errnum;                                        60072000
      begin                                                             60073000
                                                                        60074000
      print'file'error (fid);                                           60075000
                                                                        60076000
      fail (errnum);                                                    60077000
                                                                        60078000
      end <<file'fail sub>>;                                            60079000
$page "[RESTORE]  IRESTORE -- utility subroutines"                      60080000
                                                                        60081000
<<------------------------>>                                            60082000
<< evaluate               >>                                            60083000
<<------------------------>>                                            60084000
                                                                        60085000
subroutine evaluate(n);                                                 60086000
   value n;                                                             60087000
   integer n;                                                           60088000
begin                                                                   60089000
   if (n<>0) then fail(n);                                              60090000
end;                                                                    60091000
   <<---------------------->>                                           60092000
   <<  increment'rejected  >>                                           60093000
   <<---------------------->>                                           60094000
                                                                        60095000
   subroutine increment'rejected (subtype);                             60096000
            double subtype;                                             60097000
                                                                        60098000
      begin                                                             60099000
                                                                        60100000
      files'rejected:=files'rejected + 1d;                              60101000
                                                                        60102000
      subtype:=subtype + 1d;                                            60103000
                                                                        60104000
      end <<increment'rejected sub>>;                                   60105000
$page                                                                   60106000
   <<-------------------->>                                             60107000
   <<  add'file'to'good  >>                                             60108000
   <<-------------------->>                                             60109000
                                                                        60110000
   subroutine add'file'to'good;                                         60111000
                                                                        60112000
      begin                                                             60113000
                                                                        60114000
      if (files'selected:=files'selected + 1d) = 1d then                60115000
         first'file'selected:=files'on'tape;                            60116000
                                                                        60117000
            <<build info for good file...array consists of              60118000
              file#, file part, group part, acct part,                  60119000
              label address, disc ldev...>>                             60120000
                                                                        60121000
      fill (gbuf, g'recsize, 0);                                        60122000
                                                                        60123000
      gbuf'd(g'filenum'inx'd) := files'on'tape;                         60124000
      gbuf'd(g'address'inx'd) := file'address;                          60125000
      gbuf  (g'ldev'inx)      := file'ldev;                             60126000
      move gbuf(g'title'inx) := tdbuf(ml), (3*file'part'words);         60127000
                                                                        60128000
      files'to'handle := files'to'handle+ 1d;                           60129000
                                                                        60130000
      fwrite (g'num, gbuf, g'recsize, 0);                               60131000
                                                                        60132000
      if < then                                                         60133000
         file'fail (g'num, sr'g'num'error)                              60134000
      else if > then                                                    60135000
         fail (rs'good'file'full);                                      60136000
                                                                        60137000
      end <<add'file'to'good sub>>;                                     60138000
$page                                                                   60139000
   <<----------------------------->>                                    60140000
   <<  check'file'access          >>                                    60141000
   <<----------------------------->>                                    60142000
                                                                        60143000
   logical subroutine check'file'access;                                60144000
                                                                        60145000
            <<returns good if file is an accessible file, else          60146000
              a failed.                                                 60147000
                                                                        60148000
              file title is in look'title', look'file',                 60149000
              look'group', look'acct', and look'lock'>>                 60150000
                                                                        60151000
      begin                                                             60152000
                                                                        60153000
      check'file'access:=failed;                                        60154000
                                                                        60155000
            <<well, the user wants this file...see if                   60156000
              he is allowed to restore it into the                      60157000
              correct group & account (as determined                    60158000
              by the file's group & account and by                      60159000
              the group/acct/local keywords)...>>                       60160000
                                                                        60161000
      if sm'tog or local'flag or seen'acct or                           60162000
            (logon'acct'=look'acct',(file'part'size) land               60163000
                (cap'am lor seen'group lor                              60164000
                    (logon'group'=look'group',(file'part'size))         60165000
                )                                                       60166000
            )                                                           60167000
            then                                                        60168000
         check'file'access:=good                                        60169000
                                                                        60170000
      else                                                              60171000
         begin                                                          60172000
         move curr'title':=look'title',(max'std'len);                   60173000
         sendmessage (m'cant'restore'this'file);                        60174000
         end;                                                           60175000
                                                                        60176000
      end <<check'file'access sub>>;                                    60177000
$page                                                                   60177010
   <<----------------------------->>                                    60177020
   <<  check'unused'candidat      >>                                    60177030
   <<----------------------------->>                                    60177040
                                                                        60177050
   subroutine check'unused'candidats;                                   60177060
                                                                        60177061
      ! tell user which files were not found on tape                    60177062
                                                                        60177063
      begin                                                             60177070
      fcontrol (candidat, rewind, dummy'i);                             60177080
                                                                        60177090
      if <> then                                                        60177100
         file'fail (candidat, rs'rewind'candidat'fail);                 60177110
                                                                        60177120
      fread (candidat, candidat'buf, candidat'recsize);                 60177130
                                                                        60177140
      while = do                                                        60177150
         begin                                                          60177160
         if not logical (candidat'used) then                            60177170
            begin                                                       60177171
            move look'patterns := candidat'buf (file'part'words + 1),   60177172
                                     (look'patterns'length);            60177173
            sendmessage (m'not'on'tape);                                60177180
            bad'file'count := bad'file'count + 1d;                      60177181
            end;                                                        60177190
         fread (candidat, candidat'buf, candidat'recsize);              60177280
         end;                                                           60177380
                                                                        60177390
      end;                                                              60177480
$page                                                                   60178000
   <<----------------------------->>                                    60179000
   <<  check'wanted'file          >>                                    60180000
   <<----------------------------->>                                    60181000
                                                                        60182000
   logical subroutine check'wanted'file (p');                           60183000
            value        p';                                            60184000
            byte pointer p';                                            60185000
                                                                        60186000
            <<returns good if file is a wanted file, otherwise          60187000
              a failed...>>                                             60188000
                                                                        60189000
      begin                                                             60190000
                                                                        60191000
$if x1=on then                <<debugging code>>                        60192000
      if debug'dir then                                                 60193000
         begin                                                          60194000
         say "         check'wanted'file: " endsay;                     60195000
         say p',(24) endsay;                                            60196000
         send;                                                          60197000
         end;                                                           60198000
$if                           <<debugging code>>                        60199000
                                                                        60200000
      check'wanted'file:=failed;                                        60201000
                                                                        60202000
$if x1=on then                <<debugging code>>                        60203000
      if debug'irestore then                                            60204000
         begin                                                          60205000
         say "Inject error into file title from tape? " endsay;         60206000
         send;                                                          60207000
         affirm (yes, false);                                           60208000
         if yes then                                                    60209000
            go fake'err;                                                60210000
         end;                                                           60211000
$if                           <<debugging code>>                        60212000
                                                                        60213000
      fill' (look'title', max'std'len, 0);                              60214000
                                                                        60215000
      if display'3'to'standard (p', p'(8), p'(16), look'title',         60216000
                                error'code) = failed then               60217000
         begin                                                          60218000
fake'err:                                                               60219000
         parms'tempi'1:=@p';                                            60220000
         parms'tempi'2:=24;            <<length of title>>              60221000
         sendmessage (m'bad'irestore'title);                            60222000
         return;              <<note: doesn't terminate!>>              60223000
         end;                                                           60224000
                                                                        60225000
      standard'to'3'display (look'title',                               60226000
            look'file', look'group', look'acct', error'code);           60227000
                                                                        60228000
            <<see if this title matches any title in                    60229000
              the candidat file...>>                                    60230000
                                                                        60231000
      c'rec := 0d;                                                      60232000
                                                                        60233000
      while true do                 <<do until hit candidat eof>>       60237000
         begin                                                          60238000
                                                                        60239000
               <<read: look'acct', ..., look'acct'pat, ...>>            60240000
               <<and: not'acct'pat...                     >>            60241000
                                                                        60242000
         freaddir (candidat, candidat'buf, candidat'recsize, c'rec);    60243000
                                                                        60244000
         if < then                                                      60245000
            file'fail (candidat, rs'read'candidat'fail);                60246000
                                                                        60247000
         if > then                                                      60248000
            return;                    <<failed to find match>>         60249000
                                                                        60250000
         c'rec := c'rec + 1d;                                           60250100
                                                                        60250200
         move look'lock := candidat'buf (1), (file'part'words);         60251000
         move look'patterns := candidat'buf (file'part'words + 1),      60252000
                                (look'patterns'length);                 60253000
                                                                        60254000
$if x1=on then                <<debugging code>>                        60255000
         if debug'dir then                                              60256000
            begin                                                       60257000
            say "            pattern: " endsay;                         60258000
            say'pattern (look'file'pat);                                60259000
            say1 (".");                                                 60260000
            say'pattern (look'group'pat);                               60261000
            say1 (".");                                                 60262000
            say'pattern (look'acct'pat);                                60263000
            say "  -  " endsay;                                         60264000
            say'pattern (not'file'pat);                                 60265000
            say1 (".");                                                 60266000
            say'pattern (not'group'pat);                                60267000
            say1 (".");                                                 60268000
            say'pattern (not'acct'pat);                                 60269000
            send;                                                       60270000
            end;                                                        60271000
$if                           <<debugging code>>                        60272000
                                                                        60273000
         if pattern'3'match (p', p'(8), p'(16),                         60274000
                  look'file'pat, look'group'pat, look'acct'pat,         60275000
                  error'code)                                           60276000
               = good then                                              60277000
            begin                   <<it matches...>>                   60278000
$if x1=on then                <<debugging code>>                        60279000
            if debug'dir then                                           60280000
               begin                                                    60281000
               say "               matched! " endsay;                   60282000
               send;                                                    60283000
               end;                                                     60284000
$if                           <<debugging code>>                        60285000
            if not'file'pat <> 0 then                                   60286000
               begin                <<check vs exception title>>        60287000
               if pattern'3'match (p', p'(8), p'(16),                   60288000
                             not'file'pat, not'group'pat,               60289000
                             not'acct'pat, error'code)                  60290000
                     = good then                                        60291000
                  begin                                                 60292000
$if x1=on then                <<debugging code>>                        60293000
      if debug'dir then                                                 60294000
                     begin                                              60295000
                     say "   " endsay;                                  60296000
                     say "         matches exception title" endsay;     60297000
                     send;                                              60298000
                     end;                                               60299000
$if                           <<debugging code>>                        60300000
                  end                                                   60301000
               else                                                     60302000
                  begin                                                 60303000
                  check'wanted'file:=good;                              60304000
                  if not logical (candidat'used) then                   60304100
                     begin                                              60304200
                     candidat'used := true;                             60304300
                     fupdate (candidat, candidat'buf, candidat'recsize);60304400
                     end;                                               60304500
                  return;           <<we like it!>>                     60305000
                  end                                                   60306000
               end                                                      60307000
                                                                        60308000
            else                                                        60309000
               begin                                                    60310000
               check'wanted'file:=good;                                 60311000
                  if not logical (candidat'used) then                   60311100
                     begin                                              60311200
                     candidat'used := true;                             60311300
                     fupdate (candidat, candidat'buf, candidat'recsize);60311400
                     end;                                               60311500
               return;                                                  60312000
               end;                                                     60313000
                                                                        60314000
            end;                                                        60315000
         end;                                                           60316000
                                                                        60317000
      end <<check'wanted'file sub>>;                                    60318000
$page                                                                   60319000
   <<----------------------------->>                                    60320000
   <<  get'prior'volume           >>                                    60321000
   <<----------------------------->>                                    60322000
                                                                        60323000
   double subroutine get'prior'volume;                                  60324000
                                                                        60325000
      begin                                                             60326000
                                                                        60327000
      error'code:=0;                                                    60328000
                                                                        60329000
      if labeled then                                                   60330000
         get'prior'volume:=get'prior'labeled'volume                     60331000
      else                                                              60332000
         get'prior'volume:=get'prior'unlabeled'volume;                  60333000
                                                                        60334000
      if error'code <> 0 then                                           60335000
         fail (0);            <<message already printed>>               60336000
                                                                        60337000
      end <<get'prior'volume sub>>;                                     60338000
$page                                                                   60339000
   <<----------------------------->>                                    60340000
   <<  handle'directory'record    >>                                    60341000
   <<----------------------------->>                                    60342000
                                                                        60343000
   subroutine handle'directory'record;                                  60344000
                                                                        60345000
      begin                                                             60346000
                                                                        60347000
$if x1=on then                <<debugging code>>                        60348000
      if debug'dir then                                                 60349000
         begin                                                          60350000
         say "   HANDLE'DIRECTORY'RECORD" endsay;                       60351000
         send;                                                          60352000
         end;                                                           60353000
$if                           <<debugging code>>                        60354000
                                                                        60355000
      if (len'tape mod tape'dir'recsize) <> 0 then                      60356000
         fail (rs't'bad'recsize);       !help bad message               60357000
                                                                        60358000
      if len'tape > tape'recsize then                                   60359000
         fail (rs't'bad'blocksize);                                     60360000
                                                                        60361000
      ml:=-tape'dir'recsize;                                            60362000
                                                                        60363000
$if x1=on then                <<debugging code>>                        60364000
      if debug'dir then                                                 60365000
         begin                                                          60366000
         say "      ML = " endsay; saynum (ml);                         60367000
         say ", LEN'TAPE = " endsay; saynum (len'tape);                 60368000
         send;                                                          60369000
         end;                                                           60370000
$if                           <<debugging code>>                        60371000
                                                                        60372000
      while (ml:=ml+tape'dir'recsize) < len'tape do                     60373000
         begin                   <<process directory record>>           60374000
                                                                        60375000
         files'on'tape:=files'on'tape + 1d;                             60376000
                                                                        60377000
$if x1=on then                <<debugging code>>                        60378000
         if debug'dir then                                              60379000
            begin                                                       60380000
            say "      DIR: " endsay;                                   60381000
            say tdbuf'(ml*2),(24) endsay;                               60382000
            send;                                                       60383000
            end;                                                        60384000
$if                           <<debugging code>>                        60385000
                                                                        60386000
         if check'wanted'file (tdbuf'(ml*2)) = good then                60387000
            begin                                                       60388000
$if x1=on then                <<debugging code>>                        60389000
            if debug'dir then                                           60390000
               begin                                                    60391000
               say "         want the file! " endsay;                   60392000
               send;                                                    60393000
               end;                                                     60394000
$if                           <<debugging code>>                        60395000
                                                                        60396000
            if check'file'access = failed then                          60397000
               increment'rejected (files'rej'access)                    60398000
            else                                                        60399000
               add'file'to'good;                                        60400000
            end                                                         60401000
                                                                        60402000
         else                                                           60403000
            increment'rejected (files'rej'title);                       60404000
                                                                        60405000
         end;                                                           60406000
                                                                        60407000
                                                                        60408000
      ml := 0;                                                          60409000
      while ml < len'tape do                                            60410000
         if len'tape - ml + left'over >= d'blocksize then               60411000
            begin                                                       60412000
            move buffer (left'over) := tdbuf (ml),                      60413000
                   (d'blocksize - left'over);                           60414000
            fwrite (d'num, buffer, d'blocksize, 0);                     60415000
            if < then fail (rs'd'file'error)                            60416000
            else if > then fail (rs'eof'd'file);                        60417000
            ml := ml + d'blocksize - left'over;                         60418000
            left'over := 0;                                             60419000
            end                                                         60420000
         else                                                           60421000
            begin                                                       60422000
            move buffer (left'over) := tdbuf (ml), (len'tape - ml);     60423000
            left'over := left'over + len'tape - ml;                     60424000
            ml := len'tape;                                             60425000
            end;                                                        60426000
                                                                        60427000
$if x1=on then                <<debugging code>>                        60428000
      if debug'dir then                                                 60429000
         begin                                                          60430000
         say "   END HANDLE'DIRECTORY" endsay;                          60431000
         send;                                                          60432000
         end;                                                           60433000
$if                           <<debugging code>>                        60434000
                                                                        60435000
      end <<handle'directory'record sub>>;                              60436000
$page                                                                   60437000
   <<----------------------->>                                          60438000
   <<  initialize'irestore  >>                                          60439000
   <<----------------------->>                                          60440000
                                                                        60441000
   subroutine initialize'irestore;                                      60442000
                                                                        60443000
      begin                                                             60444000
                                                                        60445000
$if x1=on then                <<debugging code>>                        60446000
      if debugging then                                                 60447000
         begin                                                          60448000
         say "Started IRESTORE,  # of CANDIDAT records: " endsay;       60449000
         saydnum (c'rec'count);                                         60450000
         send;                                                          60451000
         end;                                                           60452000
$if                           <<debugging code>>                        60453000
                                                                        60454000
      if tape'recsize > max'directory'tape'recsize then                 60455000
         directory'tape'recsize := max'directory'tape'recsize           60456000
      else                                                              60457000
         directory'tape'recsize := tape'recsize;                        60458000
                                                                        60459000
      files'on'tape := -1d;                                             60460000
      irestore:=good;                                                   60461000
                                                                        60462000
      end <<initialize'irestore sub>>;                                  60463000
$page                                                                   60464000
   <<----------------->>                                                60465000
   <<  position'tape  >>                                                60466000
   <<----------------->>                                                60467000
                                                                        60468000
   subroutine position'tape;                                            60469000
                                                                        60470000
      begin                                                             60471000
                                                                        60472000
      if labeled then                                                   60473000
         return;                                                        60474000
                                                                        60475000
      if not reel'1'mounted then                                        60476000
         return;                                                        60477000
                                                                        60478000
      issue'skip (true);                                                60479000
      if error'code <> 0 then                                           60480000
         file'fail (t'num, rs't'fsf'fail);                              60481000
                                                                        60482000
      end <<position'tape sub>>;                                        60483000
$page "[RESTORE]  IRESTORE --- outer block"                             60484000
   <<--------------------------------------------------------->>        60485000
   <<   outer block of irestore                               >>        60486000
   <<--------------------------------------------------------->>        60487000
                                                                        60488000
   initialize'irestore;                                                 60489000
                                                                        60490000
   position'tape;                                                       60491000
                                                                        60492000
                                                                        60493000
         <<at this point, the candidat file has c'rec'count records,    60494000
           each of which is a single fileset name (with or              60495000
           without wildcards.  we now proceed to read the               60496000
           tape directory and compare each file title in the            60497000
           directory to the filesets in candidat.  as soon as           60498000
           a file title matches any fileset name in candidat,           60499000
           it is written to the good file (and, therefore, is           60500000
           going to be restored later on). >>                           60501000
                                                                        60502000
                                                                        60503000
         <<loop thru tape directory...>>                                60504000
                                                                        60505000
                                                                        60506000
                                                                        60507000
   done:=false;                                                         60508000
                                                                        60509000
   while not done do                                                    60510000
      begin                                                             60511000
                                                                        60512000
      check'break;            <<wont come back if break sensed>>        60513000
                                                                        60514000
      issue'read (tdbuf, directory'tape'recsize, true);                 60515000
      len'tape := read'tape'len;                                        60516000
                                                                        60517000
      if error'code <> 0 then                                           60518000
         file'fail (t'num, rs't'read'dir'fail);                         60519000
                                                                        60520000
      if read'tape'eof then                                             60521000
         begin                                                          60522000
            if labeled then                                             60523000
               if nexttapefile(t'num) <> 0 then                         60524000
                  file'fail (t'num, rs't'read'dir'fail);                60525000
            done := true;                                               60526000
         end;                                                           60527000
                                                                        60528000
$if x1=on then                <<debugging code>>                        60529000
      if debugging then                                                 60530000
         begin                                                          60531000
         say "READ LEN=" endsay;                                        60532000
         saynum (len'tape);                                             60533000
         say ", TEXT = " endsay;                                        60534000
         send;                                                          60535000
         say tdbuf',(80) endsay;                                        60536000
         send;                                                          60537000
         end;                                                           60538000
$if                           <<debugging code>>                        60539000
                                                                        60540000
                                                                        60541000
      if not done then                                                  60542000
         handle'directory'record;                                       60543000
                                                                        60544000
$if x1=on then                <<debugging code>>                        60545000
      if debugging then                                                 60546000
         begin                                                          60547000
         say "Back to first main loop in IRESTORE..." endsay;           60548000
         send;                                                          60549000
         say "DONE = " endsay;                                          60550000
         saynum (done.(15:01));                                         60551000
         send;                                                          60552000
         end;                                                           60553000
$if                           <<debugging code>>                        60554000
                                                                        60555000
      end;                                                              60556000
                                                                        60557000
$page                                                                   60558000
                                                                        60559000
   if left'over > 0 then                                                60560000
      begin                                                             60561000
      fwrite (d'num, buffer, left'over, 0);                             60562000
      if < then fail (rs'd'file'error)                                  60563000
      else if > then fail (rs'eof'd'file);                              60564000
      end;                                                              60565000
                                                                        60566000
$if x1=on then                <<debugging code>>                        60567000
   if debugging then                                                    60568000
      begin                                                             60569000
      say "#FILES ON TAPE = " endsay;                                   60570000
      saydnum (files'on'tape);                                          60571000
      say ", FIRST'FILE'SELECTED = " endsay;                            60572000
      saydnum (first'file'selected);                                    60573000
      first'file'on'vol := double (tl'fileinx);                         60574000
      say ", FIRST'FILE'ON'VOL = " endsay;                              60575000
      saydnum (first'file'on'vol);                                      60576000
      send;                                                             60577000
      say "#SELECTED = " endsay;                                        60578000
      saydnum (files'selected);                                         60579000
      say ", #REJECTED = " endsay;                                      60580000
      saydnum (files'rejected);                                         60581000
      send;                                                             60582000
      say "   ACCESS   = " endsay; saydnum (files'rej'access);send;     60583000
      say "   RELOAD   = " endsay; saydnum (files'rej'reload);send;     60584000
      say "   TITLE    = " endsay; saydnum (files'rej'title);send;      60585000
      end;                                                              60586000
$if                           <<debugging code>>                        60587000
                                                                        60588000
   check'unused'candidats;                                              60588100
                                                                        60589000
   first'file'on'vol := double (tl'fileinx+tl'spantog);                 60590000
                                                                        60591000
   if seen'starthere then                                               60592000
      begin                                                             60593000
         rewind'good'file;                                              60594000
         read'good'file;                                                60595000
         while = and (gbuf'd (g'filenum'inx'd) < first'file'on'vol) do  60596000
            begin                                                       60597000
               g'ignore'bit := true;                                    60598000
               update'good'file;                                        60599000
               read'good'file;                                          60600000
            end;                                                        60601000
         if > then fail (rs'no'files'after'here);                       60602000
      end                                                               60603000
                                                                        60604000
   else if files'selected > 0d then                                     60605000
      begin                                                             60606000
         while (first'file'selected<first'file'on'vol) do               60607000
                                                                        60608000
            first'file'on'vol := get'prior'volume;                      60609000
                                                                        60610000
         if first'file'on'vol < 0d then                                 60611000
            fail (rs't'op'could'not'find'tape);                         60612000
         sendmessage (m'restore'preview);                               60613000
                                                                        60614000
         if not labeled and tl'spantog then                             60615000
            begin                                                       60616000
            issue'skip (true);                                          60617000
            if error'code <> 0 then fail (rs'skipping'partial'file);    60618000
            end;                                                        60619000
      end;                                                              60620000
                                                                        60621000
end'irestore:                                                           60622000
                                                                        60623000
$if x1=on then                <<debugging code>>                        60624000
   if debugging then                                                    60625000
      begin                                                             60626000
      say "END OF IRESTORE PROC" endsay;                                60627000
      send;                                                             60628000
      end;                                                              60629000
$if                           <<debugging code>>                        60630000
                                                                        60631000
   end <<irestore proc>>;                                               60632000
$page "[RESTORE]  GET'NEXT'VOLUME --- get correct continuation tape"    60633000
$control segment=irestore                                               60634000
<<*****************************************************************>>   60635000
integer procedure get'next'volume (destination, distance);              60636000
         value destination;                                             60637000
         double destination, distance;                                  60638000
         option privileged, uncallable;                                 60639000
      <<if the reel switch fails, failed is returned, otherwise         60640000
        good.  two types of errors occur: (1)  wrong tape was           60641000
        mounted;  (2) bad tape was mounted.  >>                         60642000
   begin                                                                60643000
                                                                        60644000
                                                                        60645000
   integer array                                                        60646000
      itmp        (0:3),                                                60647000
      save'tape'label (0:tape'label'size);                              60648000
                                                                        60649000
   integer                                                              60650000
      len,                                                              60651000
      reply;                                                            60652000
                                                                        60653000
   byte array                                                           60654000
      itmp'       (*) = itmp;                                           60655000
                                                                        60656000
   double array                                                         60657000
      itmp'd      (*) = itmp;                                           60658000
                                                                        60659000
   label                                                                60660000
      end'proc;                                                         60661000
                                                                        60662000
   define                                                               60663000
      newreel     = itmp(0) #;                                          60664000
                                                                        60665000
   <<-------------------------->>                                       60666000
   subroutine fail (n); value n; integer n;                             60667000
      begin                                                             60668000
                                                                        60669000
      move tape'label:=save'tape'label,(tape'label'size);               60670000
                                                                        60671000
      if n <> 0 then                                                    60672000
         sendmessage (n);                                               60673000
                                                                        60674000
      get'next'volume:=n;                                               60675000
                                                                        60676000
      go end'proc;                                                      60677000
                                                                        60678000
      end <<fail sub>>;                                                 60679000
   <<-------------------------->>                                       60680000
                                                                        60681000
   get'next'volume:=0;                                                  60682000
                                                                        60683000
   if using'attio then                                                  60684000
      wait'for'all'attio;                                               60685000
                                                                        60686000
   newreel:=tl'reelnum+1;                                               60687000
   tl'reelnum:=newreel;                                                 60688000
                                                                        60689000
   move itmp:=tl'reelnum,(4);    <<reel, date, time>>                   60690000
                                                                        60691000
   fcontrol (t'num, rewind'unload, len);  <<rewind old tape>>           60692000
                                                                        60693000
   if <> then                                                           60694000
      fail (rs't'rewind'fail);                                          60695000
                                                                        60696000
   ffileinfo (t'num, item'ldev, tape'ldev);                             60697000
   if <> then                                                           60698000
      fail (rs't'fgetinfo'fail);                                        60699000
                                                                        60700000
   move save'tape'label:=tape'label,(tape'label'size);                  60701000
                                                                        60702000
         <<ask for continuation reel...>>                               60703000
                                                                        60704000
   genmsg (1, 20, %11000, newreel, tape'ldev, , , , 0);                 60705000
                                                                        60706000
next:                                                                   60707000
                                                                        60708000
   issue'read (tape'label, tape'label'size+1, true);                    60709000
                                                                        60710000
   if read'tape'eof then                                                60711000
      issue'read (tape'label, tape'label'size+1, true);                 60712000
                                                                        60713000
   if read'tape'eof then                                                60714000
      issue'read (tape'label, tape'label'size+1, true);                 60715000
                                                                        60716000
   len := read'tape'len;                                                60717000
                                                                        60718000
   if error'code <> 0 then                                              60719000
      fail (rs't'read'sr'label);                                        60720000
                                                                        60721000
   if read'tape'eof or len <> tape'label'size or                        60722000
                       tape'label' <> labeltext then                    60723000
      begin                            <<wrong tape mounted>>           60724000
      sendmessage (sr'not'a'store'restore'tape,,true);                  60725000
wrongtape:                                                              60726000
      parms'tempi'1 := newreel;                                         60727000
      parms'tempi'2 := itmp (1);                                        60728000
      parms'tempd'1 := itmp'd (1);                                      60729000
      sendmessage (m'tape'desired,,true);                               60730000
      fcontrol (t'num, rewind'unload, len);                             60731000
            <<is another reel available?>>                              60732000
      genmsg (1, 10, %10000, tape'ldev, , , , , 0, 1, @reply);          60733000
      if reply=0 then                                                   60734000
         fail (rs't'op'could'not'find'tape);                            60735000
      goto next;                                                        60736000
      end;                                                              60737000
                                                                        60738000
   if (tl'date' <> itmp' (2), (6)) lor          <<checks: date,time>>   60739000
      ((destination = 0d) land (newreel <> tl'reelnum)) lor             60740000
      ((destination <> 0d) land                                         60741000
         (double (tl'fileinx + tl'spantog) > destination)) then         60742000
                                                                        60743000
      begin                                                             60744000
      parms'tempi'1 := tl'reelnum;                                      60745000
      parms'tempi'2 := tl'date;                                         60746000
      parms'tempd'1'1 := tl'hhmm;                                       60747000
      parms'tempd'1'2 := tl'sstt;                                       60748000
      sendmessage (m'reel'supplied,,true);                              60749000
      go wrongtape;                                                     60750000
      end;                                                              60751000
                                                                        60752000
   issue'skip (true);                                                   60753000
   if error'code <> 0 then                                              60754000
      fail (rs't'fsf'fail);                                             60755000
                                                                        60756000
   distance := destination - double (tl'fileinx);                       60757000
end'proc:                                                               60758000
   end <<get'next'volume proc>> ;                                       60759000
$page "[RESTORE]  GET'PRIOR'LABELED'VOLUME"                             60760000
!control list        !list                                              60761000
$control segment=irestore                                               60762000
<<*****************************************************************>>   60763000
double procedure get'prior'labeled'volume;                              60764000
         option privileged,uncallable;                                  60765000
   begin                                                                60766000
                                                                        60767000
                                                                        60768000
   integer array                                                        60769000
      itmp        (0:5),                                                60770000
      save'tape'label (0:tape'label'size);                              60771000
                                                                        60772000
   integer                                                              60773000
      len,                                                              60774000
      reply;                                                            60775000
                                                                        60776000
   logical                                                              60777000
      done        := false;                                             60778000
                                                                        60779000
   byte array                                                           60780000
      itmp'       (*) = itmp (0);                                       60781000
                                                                        60782000
   label                                                                60783000
      end'proc;                                                         60784000
                                                                        60785000
   define                                                               60786000
      prevreel    = itmp(0) #;                                          60787000
                                                                        60788000
   <<---------------------------->>                                     60789000
   subroutine fail (n); value n; integer n;                             60790000
      begin                                                             60791000
                                                                        60792000
      move tape'label:=save'tape'label,(tape'label'size);               60793000
                                                                        60794000
      if n <> 0 then                                                    60795000
         sendmessage (n);                                               60796000
                                                                        60797000
      get'prior'labeled'volume := -1d;                                  60798000
                                                                        60799000
      go end'proc;                                                      60800000
                                                                        60801000
      end <<fail sub>>;                                                 60802000
   <<----------------------------->>                                    60803000
   subroutine ask'for'another'reel;                                     60804000
      begin                                                             60805000
            <<are previous reels available?>>                           60806000
                                                                        60807000
      move tape'label:=save'tape'label,(tape'label'size);               60808000
                                                                        60809000
      genmsg (1, 10, %10000, tape'ldev, , , , , 0, 1, @reply);          60810000
                                                                        60811000
      if reply = 0 then                                                 60812000
         fail (rs't'op'could'not'find'tape);                            60813000
                                                                        60814000
      end <<ask'for'another'reel sub>>;                                 60815000
   <<----------------------------->>                                    60816000
                                                                        60817000
                                                                        60818000
   prevreel:=tl'reelnum-1;                                              60819000
   move itmp(1):=tl'iibid, (2);                                         60820000
   move itmp(3):=tl'date, (3);                                          60821000
                                                                        60822000
   fgetinfo (t'num, , tape'foptions, tape'aoptions);                    60823000
   if <> then                                                           60824000
      fail (rs't'fgetinfo'fail);                                        60825000
   ffileinfo (t'num, item'ldev, tape'ldev);                             60825100
   if <> then                                                           60825200
      fail (rs't'fgetinfo'fail);                                        60825300
                                                                        60826000
   move save'tape'label:=tape'label,(tape'label'size);                  60827000
                                                                        60828000
   done:=false;                                                         60829000
                                                                        60830000
   while not done do                                                    60831000
      begin                                                             60832000
      reelswitch (tape'ldev, -prevreel);                                60833000
      if < then fail (rs'mount'prev'fail);                              60834000
                                                                        60835000
      freadlabel (t'num, tape'label, tape'label'size);                  60836000
                                                                        60837000
      if <> then                                                        60838000
         fail (rs't'read'sr'label);                                     60839000
                                                                        60840000
      if tape'label' <> labeltext then                                  60841000
         ask'for'another'reel                                           60842000
                                                                        60843000
      else                                                              60844000
         begin             <<examine the label...>>                     60845000
!        do                                                             60846000
!           begin                                                       60847000
!           len:=fread (t'num, itmp, 2);      <<short read>>            60848000
!           reopen'file (t'num,                                         60849000
!                        tape'name, tape'foptions, tape'aoptions,       60850000
!                        4096);                                         60851000
!           end                                                         60852000
!        until                                                          60853000
!           prevreel = 1;              <<past dir & cont>>              60854000
                                                                        60855000
         if tl'iibid' <> itmp'(2),(4) then                              60856000
            ask'for'another'reel                                        60857000
         else if tl'date' <> itmp'(6),(6) then                          60858000
            ask'for'another'reel                                        60859000
         else if tl'reelnum > prevreel then                             60860000
            ask'for'another'reel                                        60861000
         else                                                           60862000
            done:=true;                                                 60863000
                                                                        60864000
         end <<apparently valid label>>;                                60865000
      end <<while not done loop>>;                                      60866000
                                                                        60867000
   if double(tl'fileinx + tl'spantog) <= first'file'selected then       60868000
      begin    <<this tape is ok - position tape>>                      60869000
         if tl'reelnum <> 1 then                                        60870000
            begin                           ! skip over file continuatio60871000
               nexttapefile (t'num);                                    60872000
               if < then fail(rs'mount'prev'fail);                      60873000
               if > then ask'for'another'reel;                          60874000
            end;                                                        60875000
                                                                        60876000
         nexttapefile (t'num);                                          60877000
         if < then fail(rs'mount'prev'fail);                            60878000
         if > then ask'for'another'reel;                                60879000
      end;                                                              60880000
                                                                        60881000
   get'prior'labeled'volume:=double(tl'fileinx+tl'spantog);             60882000
                                                                        60883000
end'proc:                                                               60884000
                                                                        60885000
   end <<get'prior'labeled'volume proc>>;                               60886000
!control nolist      !list                                              60887000
$page "[RESTORE]  GET'PRIOR'UNLABELED'VOLUME"                           60888000
$control segment=irestore                                               60889000
<<*****************************************************************>>   60890000
double procedure get'prior'unlabeled'volume;                            60891000
         option privileged,uncallable;                                  60892000
   begin                                                                60893000
                                                                        60894000
                                                                        60895000
   integer array                                                        60896000
      itmp        (0:5),                                                60897000
      save'tape'label (0:tape'label'size);                              60898000
                                                                        60899000
   integer                                                              60900000
      dummy,                                                            60901000
      len,                                                              60902000
      reply;                                                            60903000
                                                                        60904000
   logical                                                              60905000
      done;                                                             60906000
                                                                        60907000
   byte array                                                           60908000
      itmp'       (*) = itmp (0);                                       60909000
                                                                        60910000
   label                                                                60911000
      end'proc;                                                         60912000
                                                                        60913000
   define                                                               60914000
      prevreel    = itmp(0) #;                                          60915000
                                                                        60916000
   <<---------------------------->>                                     60917000
   subroutine fail (n); value n; integer n;                             60918000
      begin                                                             60919000
                                                                        60920000
      move tape'label:=save'tape'label,(tape'label'size);               60921000
                                                                        60922000
      if n <> 0 then                                                    60923000
         sendmessage (n);                                               60924000
                                                                        60925000
      get'prior'unlabeled'volume := -1d;                                60926000
                                                                        60927000
      go end'proc;                                                      60928000
                                                                        60929000
      end <<fail sub>>;                                                 60930000
   <<---------------------------->>                                     60931000
   subroutine ask'for'another'reel;                                     60932000
      begin                                                             60933000
                                                                        60934000
      move tape'label:=save'tape'label,(tape'label'size);               60935000
                                                                        60936000
      fcontrol (t'num, rewind'unload, dummy);                           60937000
      if <> then                                                        60938000
         fail (rs't'rewind'fail);                                       60939000
                                                                        60940000
            <<are prev reels available>>                                60941000
      genmsg (1, 10, %10000, tape'ldev, , , , , 0, 1, @reply);          60942000
                                                                        60943000
      if reply = 0 then                                                 60944000
         fail (rs't'op'could'not'find'tape);                            60945000
                                                                        60946000
      end <<ask'for'another'reel sub>>;                                 60947000
   <<----------------------------->>                                    60948000
                                                                        60949000
   prevreel:=tl'reelnum-1;                                              60950000
   move itmp(1):=tl'iibid, (2);                                         60951000
   move itmp(3):=tl'date, (3);                                          60952000
                                                                        60953000
   fgetinfo (t'num, , tape'foptions, tape'aoptions);                    60954000
   if <> then                                                           60955000
      fail (rs't'fgetinfo'fail);                                        60956000
   ffileinfo (t'num, item'ldev, tape'ldev);                             60956100
   if <> then                                                           60956200
      fail (rs't'fgetinfo'fail);                                        60956300
                                                                        60957000
   move save'tape'label:=tape'label,(tape'label'size);                  60958000
                                                                        60959000
   fcontrol (t'num, rewind'unload, dummy);                              60960000
   if <> then                                                           60961000
      fail (rs't'rewind'fail);                                          60962000
                                                                        60963000
         <<ask for a prev reel>>                                        60964000
   genmsg (1, 21, %11000, prevreel, tape'ldev, , , , 0);                60965000
                                                                        60966000
   done:=false;                                                         60967000
                                                                        60968000
loop:                                                                   60969000
                                                                        60970000
   while not done do                                                    60971000
      begin                                                             60972000
                                                                        60973000
      issue'read (tape'label, tape'label'size+1, true);                 60974000
      if error'code <> 0 then fail (rs't'read'sr'label);                60975000
      len := read'tape'len;                                             60976000
                                                                        60977000
      if read'tape'eof then                                             60978000
         begin                                                          60979000
         issue'skip (true);                                             60980000
         if error'code <> 0 then fail (rs't'fsf'fail);                  60981000
         issue'read (tape'label, tape'label'size+1, true);              60982000
         if error'code <> 0 then fail (rs't'read'sr'label);             60983000
         len := read'tape'len;                                          60984000
         end                                                            60985000
                                                                        60986000
      else if len <> tape'label'size then                               60987000
         begin                                                          60988000
         issue'skip (true);                                             60989000
         if error'code <> 0 then fail (rs't'fsf'fail);                  60990000
         issue'skip (true);                                             60991000
         if error'code <> 0 then fail (rs't'fsf'fail);                  60992000
         issue'read (tape'label, tape'label'size+1, true);              60993000
         if error'code <> 0 then fail (rs't'read'sr'label);             60994000
         len := read'tape'len;                                          60995000
         end;                                                           60996000
                                                                        60997000
                                                                        60998000
      if read'tape'eof then                                             60999000
         ask'for'another'reel                                           61000000
      else if len <> tape'label'size or tape'label' <> labeltext then   61001000
         ask'for'another'reel          <<wrong tape mounted>>           61002000
      else if tl'iibid' <> itmp'(2),(4) then                            61003000
         ask'for'another'reel                                           61004000
      else if tl'date' <> itmp'(6),(6) then                             61005000
         ask'for'another'reel                                           61006000
      else if tl'reelnum > prevreel then                                61007000
         ask'for'another'reel                                           61008000
      else                                                              61009000
         done:=true;                                                    61010000
      end <<while not done loop>>;                                      61011000
                                                                        61012000
   issue'skip (true);                                                   61013000
                                                                        61014000
   if error'code <> 0 then                                              61015000
      fail (rs't'fsf'fail);                                             61016000
                                                                        61017000
   if tl'reelnum = 1 then                                               61018000
      begin                                                             61019000
      issue'skip (true);                                                61020000
      if error'code <> 0 then                                           61021000
         fail (rs't'fsf'fail);                                          61022000
      end;                                                              61023000
                                                                        61024000
   get'prior'unlabeled'volume:=double(tl'fileinx+tl'spantog);           61025000
                                                                        61026000
end'proc:                                                               61027000
   end <<get'prior'unlabeled'volume proc>>;                             61028000
$page "CREATE'DIR'ENTRY"                                                70000000
$control segment=restore                                                70001000
<<------------------------------>>                                      70002000
<< create'dir'entry             >>                                      70003000
<<------------------------------>>                                      70004000
                                                                        70005000
integer procedure create'dir'entry (level, name);                       70006000
   value level;                                                         70007000
   integer level;                                                       70008000
   logical array name;                                                  70009000
                                                                        70010000
   << this procedure creates either an acct, a group, or a user.  >>    70011000
   << the command intrinsic is called with the correct string to  >>    70012000
   << do this.                                                    >>    70013000
                                                                        70014000
begin                                                                   70015000
   logical array ntry'group (0:9) = pb :=                               70016000
      "NEWGROUP  ", "        ", %006415;                                70017000
   logical array ntry'acct  (0:11) = pb :=                              70018000
      "NEWACCT   ", "        ", ",MGR", %006415;                        70019000
   logical array ntry'user  (0:9) = pb :=                               70020000
      "NEWUSER   ", "        ", %006415;                                70021000
                                                                        70022000
   logical array                                                        70023000
      buffer  (0:30);                                                   70024000
                                                                        70025000
   integer                                                              70026000
      com'error := 0,                                                   70027000
      com'parm  := 0;                                                   70028000
                                                                        70029000
   << create the string for the command intrinsic >>                    70030000
                                                                        70031000
   if level=grouplevel then                                             70032000
      move buffer := ntry'group, (10)                                   70033000
   else if level=acctlevel then                                         70034000
      move buffer := ntry'acct,  (12)                                   70035000
   else if level=userlevel then                                         70036000
      move buffer := ntry'user,  (10);                                  70037000
                                                                        70038000
   move buffer(5) := name, (file'part'words);                           70039000
                                                                        70040000
   << call the command intrinsic and process the return>>               70041000
                                                                        70042000
   command (buffer,com'error,com'parm);                                 70043000
   if com'error<>0 then create'dir'entry := m'no'create                 70044000
   else                                                                 70045000
      begin                                                             70046000
      parms'tempi'1 := level;                                           70047000
      sendmessage (m'created'dir'entry);                                70048000
      create'dir'entry := 0;                                            70049000
      end;                                                              70050000
end;                                                                    70051000
$page "MOUNT'VOLUME'SET"                                                70052000
$control segment=restore                                                70053000
<<-------------------->>                                                70054000
<<  mount'volume'set  >>                                                70055000
<<-------------------->>                                                70056000
                                                                        70057000
logical procedure mount'volume'set (vsgroup', vsacct', info);           70058000
   integer info;                                                        70059000
   byte array vsgroup', vsacct';                                        70060000
                                                                        70061000
   << performs "mount *.vsgroup.vsacct" returning info for dismount>>   70062000
   << the mount actually performs a bind which allows direcscan to >>   70063000
   << find files on private volumes without giving the pvinfo      >>   70064000
                                                                        70065000
begin                                                                   70066000
   integer req'type;                                                    70067000
                                                                        70068000
$if x1=on then                                                          70069000
   if debugging then                                                    70070000
      begin                                                             70071000
      say "MOUNT'VOLUME'SET - *" endsay;                                70072000
      say vsgroup', (file'part'size) endsay;                            70073000
      say "." endsay;                                                   70074000
      say vsacct', (file'part'size) endsay;                             70075000
      send;                                                             70076000
      end;                                                              70077000
$if                                                                     70078000
                                                                        70079000
   req'type := condmount'bind;                                          70080000
   mount (star, vsgroup', vsacct', req'type, -1, info);                 70081000
   if < then mount'volume'set := failed                                 70082000
   else                                                                 70083000
      begin                                                             70084000
      mounted'vs := true;                                               70085000
      mount'volume'set := good;                                         70086000
      info.(pvf) := pv;                                                 70087000
                                                                        70088000
$if x1=on then                                                          70089000
      if debugging then                                                 70090000
         begin                                                          70091000
         say "   successful - pvinfo = %" endsay;                       70092000
         sayoctal (info);                                               70093000
         send;                                                          70094000
         end;                                                           70095000
$if                                                                     70096000
                                                                        70097000
      end;                                                              70098000
end;                                                                    70099000
$page "DISMOUNT'VOLUME'SET"                                             70100000
$control segment=restore                                                70101000
<<----------------------->>                                             70102000
<<  dismount'volume'set  >>                                             70103000
<<----------------------->>                                             70104000
                                                                        70105000
procedure dismount'volume'set (vsgroup', vsacct', info);                70106000
   byte array vsgroup', vsacct';                                        70107000
   integer info;                                                        70108000
                                                                        70109000
   << performs "dismount *.vsgroup'.vsacct'". info comes from >>        70110000
   << mount'volume'set. performs unbinding.                   >>        70111000
                                                                        70112000
begin                                                                   70113000
   integer req'type;                                                    70114000
                                                                        70115000
$if x1=on then                                                          70116000
   if debugging then                                                    70117000
      begin                                                             70118000
      say "DISMOUNT'VOLUME'SET - *." endsay;                            70119000
      say vsgroup', (file'part'size) endsay;                            70120000
      say "." endsay;                                                   70121000
      say vsacct', (file'part'size) endsay;                             70122000
      say " - PVINFO = %" endsay;                                       70123000
      sayoctal (info);                                                  70124000
      send;                                                             70125000
      end;                                                              70126000
$if                                                                     70127000
                                                                        70128000
   req'type := conddismount'bind;                                       70129000
   dismount (star, vsgroup', vsacct', req'type, info);                  70130000
   info := 0;                                                           70131000
   mounted'vs := false;                                                 70132000
end;                                                                    70133000
$page "DIRECTORY'ERROR"                                                 70134000
$control segment=restore                                                70135000
<<---------------------------------------->>                            70136000
<<  directory'error                       >>                            70137000
<<---------------------------------------->>                            70138000
                                                                        70139000
integer procedure directory'error (direc'ret);                          70140000
   value direc'ret;                                                     70141000
   double direc'ret;                                                    70142000
                                                                        70143000
   ! this procedure provides the capability of turning a directory      70144000
   ! error into a store/restore error.  this procedure can be called    70145000
   ! with the return of any of the directory routines.                  70146000
                                                                        70147000
begin                                                                   70148000
   integer                                                              70149000
      dra         = direc'ret + 1,                                      70150000
      drb         = direc'ret;                                          70151000
                                                                        70152000
   parms'tempd'2 := direc'ret;       ! holds return for using in msg    70153000
                                                                        70154000
   if dra=0 or dra=1 then                                               70155000
      directory'error := m'direc'unxpected'error                        70156000
   else if dra=2 then                                                   70157000
      if drb=grouplevel then directory'error := m'no'group              70158000
      else if drb=acctlevel then directory'error := m'no'acct           70159000
      else directory'error := m'direc'unxpected'error                   70160000
   else if dra=3 then                                                   70161000
      if drb=grouplevel then directory'error := m'group'save'access     70162000
      else if drb=acctlevel then directory'error := m'acct'save'access  70163000
      else directory'error := m'direc'unxpected'error                   70164000
   else if dra=4 or dra=5 or dra=6 then                                 70165000
      directory'error := m'direc'no'room                                70166000
   else if dra=7 then                                                   70167000
      directory'error := m'direc'unxpected'error                        70168000
   else if dra=8 then                                                   70169000
      if drb=grouplevel then directory'error := m'group'disc'space      70170000
      else if drb=acctlevel then directory'error := m'acct'disc'space   70171000
      else directory'error := m'direc'unxpected'error                   70172000
   else directory'error := m'direc'unxpected'error;                     70173000
                                                                        70174000
   enable'arithmetic'traps;                                             70175000
$if x1=on then                                                          70176000
   if debugging then                                                    70177000
      begin                                                             70178000
      say "DIRECTORY ERROR - DRA = " endsay;                            70179000
      saynum (dra);                                                     70180000
      say "; DRB = " endsay;                                            70181000
      saynum (drb);                                                     70182000
      send;                                                             70183000
      end;                                                              70184000
$if                                                                     70185000
end;                                                                    70186000
$page "RC'LOCK'DIRECTORY"                                               70187000
$control segment=restore                                                70188000
<<---------------------------------------->>                            70189000
<<  rc'lock'directory                     >>                            70190000
<<---------------------------------------->>                            70191000
                                                                        70192000
integer procedure rc'lock'directory (element, level, parms, sir);       70193000
   value level, parms, sir;                                             70194000
   integer level, parms;                                                70195000
   integer array element;                                               70196000
   double sir;                                                          70197000
   option privileged, uncallable;                                       70198000
                                                                        70199000
   << this procedure is the recipient procedure of a       >>           70200000
   << direcscan call.  rc'lock'directory ups the use count >>           70201000
   << for the group entry and possibly the acct entry.     >>           70202000
   << it also fills in the global variables acct'index'ptr >>           70203000
   << and group'index'ptr.                                 >>           70204000
                                                                        70205000
   << the parms array is as follows                        >>           70206000
   <<     word 0     - if true then do both acct and group     >>       70207000
   <<                  else do just group                      >>       70208000
   <<     word 1     - error return                            >>       70209000
   <<     word 2     - account-group index pointer             >>       70210000
   <<     word 3     - account-user  index pointer             >>       70211000
   <<     word 4,5   - group-file index pointer                >>       70212000
   <<     word 6     - if true then lock else unlock           >>       70213000
   <<     word 7-10  - account name                            >>       70214000
   <<     word 11-14 - group   name                            >>       70215000
                                                                        70216000
                                                                        70217000
begin                                                                   70218000
                                                                        70219000
   define                                                               70220000
      p'do'acct        = arq (parms+0).(15:1) #,                        70221000
      p'do'group       = arq (parms+0).(14:1) #,                        70222000
      p'error          = arq (parms+1) #,                               70223000
      p'group'inx      = arq (parms+2) #,                               70224000
      p'user'inx       = arq (parms+3) #,                               70225000
      p'file'inx'1     = arq (parms+4) #,                               70226000
      p'file'inx'2     = arq (parms+5) #,                               70227000
      p'lock           = arq (parms+6) #,                               70228000
      p'acct'name      = arq (parms+7) #,                               70229000
      p'group'name     = arq (parms+11) #;                              70230000
                                                                        70231000
   integer array                                                        70232000
      arq        (*)  =  q+0,                                           70233000
      dseg       (*)  =  db+0;                                          70234000
                                                                        70235000
   logical array                                                        70236000
      dseg'l     (*)  =  dseg;                                          70237000
                                                                        70238000
   logical                                                              70239000
      need'rel'dsir   := false,                                         70240000
      still'have'dsir := true;                                          70241000
                                                                        70242000
   integer                                                              70243000
      entry'loc,                                                        70244000
      sir'number      =  sir,                                           70245000
      sir'info        =  sir + 1;                                       70246000
                                                                        70247000
   define                                                               70248000
      contents        =  dseg(%243)  #,                                 70249000
      index'addr      =  dseg(%257)  #,                                 70250000
      dadirty         =  dseg'l(%221).(15:01) #,                        70251000
      dbdirty         =  dseg'l(%247).(15:01) #;                        70252000
                                                                        70253000
   parms := parms - arq;                                                70254000
                                                                        70255000
   if p'error <> 0 then                                                 70256000
      rc'lock'directory := rc'stop                                      70257000
                                                                        70258000
   else if level = 2 then                                               70259000
      begin                                                             70260000
      p'group'inx := element (a'agipntr);                               70261000
      p'user'inx  := element (a'auipntr);                               70262000
      rc'lock'directory := 0;                                           70263000
      end                                                               70264000
                                                                        70265000
   else if level = 1 then      <<group>>                                70266000
      begin                                                             70267000
      if logical (p'do'acct) then                                       70268000
         begin                                                          70269000
         if logical (p'lock) then                                       70270000
            index'addr := index'addr + 1                                70271000
         else                                                           70272000
            index'addr := index'addr - 1;                               70273000
         dbdirty := true;                                               70274000
         end;                                                           70275000
                                                                        70276000
      if logical (p'do'group) then                                      70277000
         begin                                                          70278000
         p'file'inx'2 := element (gfipntr);                             70279000
         if element (glinkage).(pvf)  = pv then                         70280000
            begin                                                       70281000
            if dbdirty then          << clean out data area b>>         70282000
               begin                                                    70283000
               dirwrite (data'area'b);                                  70284000
               dbdirty := false;                                        70285000
               end;                                                     70286000
                                                                        70287000
            tos := sir;                                                 70288000
            relsir (sir'number, sir'info);                              70289000
            need'rel'dsir := true;                                      70290000
            still'have'dsir := false;                                   70291000
                                                                        70292000
            exchangedb (0);                                             70293000
            if logical (p'lock) then                                    70294000
               begin                                                    70295000
               if mount'volume'set (p'group'name, p'acct'name, pv'info) 70296000
                                                       = failed then    70297000
                  begin                                                 70298000
                  p'error := m'mount'failed;                            70299000
                  rc'lock'directory := rc'stop;                         70300000
                  end                                                   70301000
               else                                                     70302000
                  p'file'inx'1 := pv'info;                              70303000
               end                                                      70304000
            else                                                        70305000
               dismount'volume'set (p'group'name, p'acct'name, pv'info);70306000
                                                                        70307000
            sir'info := getsir (sir'number);                            70308000
            still'have'dsir := true;                                    70309000
                                                                        70310000
            exchangedb (dirdst);                                        70311000
                                                                        70312000
            end;                                                        70313000
                                                                        70314000
         if p'error = 0 then                                            70315000
            begin                                                       70316000
            dirread (p'file'inx'2, data'area'b, 0<<?>>, 0<<?>>);        70317000
                                                                        70318000
            if logical (p'lock) then                                    70319000
               index'addr := index'addr + 1                             70320000
            else                                                        70321000
               index'addr := index'addr - 1;                            70322000
            dbdirty := true;                                            70323000
            rc'lock'directory := 0;                                     70324000
            p'error := 0;                                               70325000
            end;                                                        70326000
         end;                                                           70327000
      end                                                               70328000
                                                                        70329000
   else   <<illegal level>>                                             70330000
      begin                                                             70331000
      rc'lock'directory := rc'stop;                                     70332000
      p'error := sr'dir'bad'level;                                      70333000
      end;                                                              70334000
                                                                        70335000
   if need'rel'dsir then                                                70336000
      begin                                                             70337000
      relsir (sir'number, sir'info);                                    70338000
      still'have'dsir := false;                                         70339000
      end;                                                              70340000
                                                                        70341000
   rc'lock'directory.(15:1) := still'have'dsir;                         70342000
                                                                        70343000
end;                                                                    70344000
$page "LOCK'DIRECTORY"                                                  70345000
$control segment=restore                                                70346000
<<---------------------------------------->>                            70347000
<<  lock'directory                        >>                            70348000
<<---------------------------------------->>                            70349000
                                                                        70350000
integer procedure lock'directory;                                       70351000
                                                                        70352000
   << this procedure unlocks the last group and acct and then locks >>  70353000
   << the current group and acct.  if last'acct is blank then no    >>  70354000
   << account is unlocked.  if res'acct is blank then no account is >>  70355000
   << locked.  if last'acct = res'acct then only groups are unlocked>>  70356000
   << and locked.  if the create flag is set and the current group  >>  70357000
   << and/or account are not in the directory then they will be     >>  70358000
   << created.  if the lastgroup was on a private volume then it    >>  70359000
   << will be dismounted.  if the current group is on a private     >>  70360000
   << volume then it will be mounted.                               >>  70361000
                                                                        70362000
   << locking a group or account means incrementing the access count>>  70363000
   << unlocking a group or acct means decrementing the access count.>>  70364000
                                                                        70365000
   << the variables file'index'ptr, group'index'ptr, and            >>  70366000
   << user'index'ptr are updated when appropriate                   >>  70367000
                                                                        70368000
   << this routine calls direcscan with rc'lock'directory as the    >>  70369000
   << recipient procedure.  see comment in rc'lock'directory for    >>  70370000
   << description of the passed parms parameter.                    >>  70371000
                                                                        70372000
begin                                                                   70373000
                                                                        70374000
   define                                                               70375000
      p'do'acct        = parms(0).(15:1) #,                             70376000
      p'do'group       = parms(0).(14:1) #,                             70377000
      p'do'neither     = (parms(0).(14:2) = 0) #,                       70378000
      p'error          = parms(1) #,                                    70379000
      p'group'inx      = parms(2) #,                                    70380000
      p'user'inx       = parms(3) #,                                    70381000
      p'file'inx       = parms'd (2) #,                                 70382000
      p'file'inx'1     = parms(4) #,                                    70383000
      p'file'inx'2     = parms(5) #,                                    70384000
      p'lock           = parms(6) #,                                    70385000
      p'acct'name      = parms(7) #,                                    70386000
      p'group'name     = parms(11) #,                                   70387000
      p'size           = 15 #;                                          70388000
                                                                        70389000
   integer array                                                        70390000
      parms       (0:p'size-1);                                         70391000
                                                                        70392000
   double array                                                         70393000
      parms'd     (*) = parms;                                          70394000
                                                                        70395000
   logical array                                                        70396000
      ntry      (0:gsize);                                              70397000
                                                                        70398000
   integer                                                              70399000
      type := 0;                                                        70400000
                                                                        70401000
   double                                                               70402000
      dr;                                                               70403000
                                                                        70404000
   integer                                                              70405000
      dra = dr+1,                                                       70406000
      drb = dr;                                                         70407000
                                                                        70408000
   subroutine fail (num);                                               70409000
      value num;                                                        70410000
      integer num;                                                      70411000
   begin                                                                70412000
      lock'directory := num;                                            70413000
      last'group'error := num;                                          70414000
      goto end'lock'directory;                                          70415000
   end;                                                                 70416000
                                                                        70417000
   subroutine eval'return (n);                                          70418000
      value n;                                                          70419000
      integer n;                                                        70420000
   begin                                                                70421000
      if n <> 0 then                                                    70422000
         fail (n);                                                      70423000
   end;                                                                 70424000
                                                                        70425000
                                                                        70426000
   lock'directory := 0;                                                 70427000
                                                                        70428000
   fill (parms, p'size, 0);                                             70429000
                                                                        70430000
   if res'acct' = last'acct', (file'part'size) then                     70431000
      if res'group' = last'group', (file'part'size) then                70432000
         fail (last'group'error)    <<same group and acct>>             70433000
      else                                                              70434000
         p'do'acct := false    <<same acct>>                            70435000
   else                                                                 70436000
      p'do'acct := true;       <<different acct>>                       70437000
                                                                        70438000
   move p'acct'name := res'acct, (file'part'words);                     70439000
   move p'group'name := res'group,  (file'part'words);                  70440000
                                                                        70441000
   type.(13:03) := if group'index'ptr = 0 then 0  <<startlevel>>        70442000
                   else 1;                                              70443000
   type.(10:03) := grouplevel; <<endlevel = groups>>                    70444000
   type.(09:01) := 0;          <<allflag  = false >>                    70445000
   type.(06:03) := grouplevel; <<tolevel  = groups>>                    70446000
   type.(05:01) := 1;          <<hitflag  = true  >>                    70447000
                                                                        70448000
   if group'index'ptr <> 0 then                                         70449000
      begin                                                             70450000
      p'lock := false;                                                  70451000
      move p'acct'name := last'acct, (file'part'words);                 70452000
      move p'group'name := last'group,  (file'part'words);              70453000
      if last'group' <> " " then                                        70454000
         p'do'group := true;                                            70455000
                                                                        70456000
      if not p'do'neither then                                          70457000
         begin                                                          70458000
         disable'arithmetic'traps;                                      70459000
         dr := direcscan (type, double (group'index'ptr), last'acct,    70460000
                          last'group, last'group,                       70461000
                          rc'lock'directory, parms, 0);                 70462000
         enable'arithmetic'traps;                                       70463000
         end;                                                           70464000
                                                                        70465000
      if logical (p'do'acct) then                                       70466000
         begin                                                          70467000
         group'index'ptr := 0;                                          70468000
         user'index'ptr  := 0;                                          70469000
         last'acct' := " ";                                             70470000
         end;                                                           70471000
      file'index'ptr := 0d;                                             70472000
      last'group' := " ";                                               70473000
      end;                                                              70474000
                                                                        70475000
   if res'acct' <> " " then                                             70476000
      begin                                                             70477000
                                                                        70478000
try'again:                                                              70479000
                                                                        70480000
      if res'group' = " " then                                          70481000
         p'do'group := false                                            70482000
      else                                                              70483000
         p'do'group := true;                                            70484000
                                                                        70485000
      type.(13:03) := if logical (p'do'acct) then 0                     70486000
                      else 1;                                           70487000
      p'lock := true;                                                   70488000
      move p'acct'name := res'acct, (file'part'words);                  70489000
      move p'group'name := res'group,  (file'part'words);               70490000
                                                                        70491000
      if not logical(p'do'group) then                                   70492000
         begin                                                          70493000
         type.(10:03) := acctlevel;                                     70494000
         type.(06:03) := acctlevel;                                     70495000
         end;                                                           70496000
                                                                        70497000
      disable'arithmetic'traps;                                         70498000
      dr := direcscan (type, double (group'index'ptr), res'acct,        70499000
                       res'group, res'group,                            70500000
                       rc'lock'directory, parms, 0);                    70501000
      enable'arithmetic'traps;                                          70502000
      if <> then                                                        70503000
         if dra = 2 then                                                70504000
            if drb = grouplevel and create'group'flag then              70505000
               begin                                                    70506000
               eval'return (create'dir'entry (grouplevel, res'group));  70507000
               goto try'again;                                          70508000
               end                                                      70509000
            else if drb = acctlevel and create'acct'flag then           70510000
               begin                                                    70511000
               eval'return (create'dir'entry (acctlevel, res'acct));    70512000
               goto try'again;                                          70513000
               end                                                      70514000
            else                                                        70515000
               begin                                                    70516000
               parms'tempi'1 := drb;                                    70517000
               fail (directory'error(dr));                              70518000
               end                                                      70519000
         else                                                           70520000
            fail (directory'error (dr));                                70521000
                                                                        70522000
      if logical (p'do'acct) then                                       70523000
         begin                                                          70524000
         group'index'ptr  := p'group'inx;                               70525000
         user'index'ptr   := p'user'inx;                                70526000
         end;                                                           70527000
                                                                        70528000
      if logical (p'do'group) then                                      70529000
         begin                                                          70530000
         move last'group' := res'group', (file'part'size);              70531000
         move last'acct'  := res'acct',  (file'part'size);              70532000
         file'index'ptr := p'file'inx;                                  70533000
         end;                                                           70534000
                                                                        70535000
      if p'error <> 0 then fail (p'error);                              70536000
                                                                        70537000
      if mounted'vs then                                                70538000
         begin                                                          70539000
         dr := direcfind (%10, double (group'index'ptr), res'acct,      70540000
                          res'group, res'group, ntry);                  70541000
         if <> then fail (sr'dir'lock'unxpctd);                         70542000
         file'indx'2 := ntry (gfipntr);                                 70543000
         end;                                                           70544000
      end;                                                              70545000
                                                                        70546000
   last'group'error := 0;                                               70547000
                                                                        70548000
end'lock'directory:                                                     70549000
                                                                        70550000
end;                                                                    70551000
$page "CHECK'TAPE'LABEL"                                                70552000
$control segment=restore                                                70553000
<<---------------------------------------->>                            70554000
<<  check'tape'label                      >>                            70555000
<<---------------------------------------->>                            70556000
                                                                        70557000
logical procedure check'tape'label (tdbuf);                             70558000
   logical array tdbuf;   << tape buffer  (r/o)                       >>70559000
                                                                        70560000
   << this routine checks to see if the current buffer is             >>70561000
   << a valid tape label.  the information is first moved to          >>70562000
   << the global array tape'label and then the checks are made        >>70563000
                                                                        70564000
                                                                        70565000
begin                                                                   70566000
   byte array                                                           70567000
      tdbuf' (*) = tdbuf;              << tape buffer                 >>70568000
                                                                        70569000
   check'tape'label := true;           << innocent until proven guilty>>70570000
                                                                        70571000
   move'to'tape'label;                                                  70572000
                                                                        70573000
   if tape'label' <> labeltext then    << does label begin correctly  >>70574000
      check'tape'label := false;                                        70575000
                                                                        70576000
end;                                                                    70577000
$page "PRE'SCAN'FOR'MATCH"                                              70578000
$control segment=restore                                                70579000
<<---------------------------------------->>                            70580000
<<  pre'scan'for'match                    >>                            70581000
<<---------------------------------------->>                            70582000
                                                                        70583000
logical procedure pre'scan'for'match (tdbuf, gbuf, len, errornum,       70584000
                                      eofs'left);                       70585000
   logical array                                                        70586000
      tdbuf,                           << tape buffer  (r/o)          >>70587000
      gbuf;                            << buffer for good record (r/o)>>70588000
                                                                        70589000
   integer                                                              70590000
      errornum,                        << error return   (w/o)        >>70591000
                                       <<    -1 = terminate           >>70592000
      len;                             << length of read (w/o)        >>70593000
                                                                        70594000
   double                                                               70595000
      eofs'left;                       << # of eofs left (r/w)        >>70596000
                                                                        70597000
   << this routine scans through the buffers that are outstanding     >>70598000
   << looking for the tape file that is passed in the gbuf array.     >>70599000
   << this code is used for the attachio method only.  every          >>70600000
   << read that comes after an eof is checked to see if it is the     >>70601000
   << correct file, or if it is necessary to switch volumes.          >>70602000
                                                                        70603000
                                                                        70604000
begin                                                                   70605000
   byte array                                                           70606000
      gbuf'      (*)   =  gbuf,           << buffer for good record   >>70607000
      tdbuf'     (*)   =  tdbuf;          << tape buffer              >>70608000
                                                                        70609000
   double array                                                         70610000
      gbuf'd     (*)   =  gbuf;           << buffer for good record   >>70611000
                                                                        70612000
   logical                                                              70613000
      foundflag        := false,          << did a match occur?       >>70614000
      keep'going       := true,           << should we keep going?    >>70615000
      last'one'was'eof := false;          << was last read an eof?    >>70616000
                                                                        70617000
   double                                                               70618000
      attio'ret            := 0d;         << return from waitforio    >>70619000
                                                                        70620000
   integer                                                              70621000
      attio'ret'1          =  attio'ret,     << 1st word of attio'ret >>70622000
      attio'ret'2          =  attio'ret + 1; << 2nd word of attio'ret >>70623000
$page "FAIL of PRE'SCAN'FOR'MATCH"                                      70624000
   <<---------------------------------------->>                         70625000
   <<  fail of pre'scan'for'match            >>                         70626000
   <<---------------------------------------->>                         70627000
                                                                        70628000
   subroutine fail;                                                     70629000
                                                                        70630000
      << called to start the termination of the process.  a return of >>70631000
      << -1 means to stop the entire program.                         >>70632000
                                                                        70633000
   begin                                                                70634000
      errornum := -1;                        << set error number to qu>>70635000
      goto end'pre'scan'for'match;           << get out of here       >>70636000
   end;                                                                 70637000
$page                                                                   70638000
   if not using'attio then                   << must be using attachio>>70639000
      return;                                                           70640000
                                                                        70641000
   len                     := 0;                                        70642000
   foundflag               := false;                                    70643000
   errornum                := 0;                                        70644000
                                                                        70645000
   << loop through outstanding ios.  if the last read was a tapemark  >>70646000
   << then check to see if this read contains the file label of the   >>70647000
   << desired file.  if this read is prior error abort then ignore it >>70648000
   << because if there really was an error we have already stopped, an>>70649000
   << if it was just an eof then its ok.                              >>70650000
                                                                        70651000
   while keep'going do                                                  70652000
      begin                                                             70653000
                                                                        70654000
      if outstanding'ios = 0 then                   << no ios left    >>70655000
         keep'going := false                                            70656000
      else                                                              70657000
         begin                                                          70658000
                                                                        70659000
         curr'wait'buffer := curr'wait'buffer + 1;  << update bufnum  >>70660000
         if curr'wait'buffer = num'buffers then                         70661000
            curr'wait'buffer := 0;                                      70662000
                                                                        70663000
         << wait for the io.  mark io as finished. decrement number of>>70664000
         << outstanding ios                                           >>70665000
                                                                        70666000
         attio'ret := waitforio (io'queue (2*curr'wait'buffer) );       70667000
         io'queue'd (curr'wait'buffer) := 0d;                           70668000
         outstanding'ios := outstanding'ios - 1;                        70669000
                                                                        70670000
$if x1=on then                                                          70671000
         if debugging then                                              70672000
            begin                                                       70673000
            say "PRESCANNING FOR MATCH - IOS = " endsay;                70674000
            saynum (outstanding'ios);                                   70675000
            say " - BUFFER = " endsay;                                  70676000
            saynum (curr'wait'buffer);                                  70677000
            say " - STATUS = " endsay;                                  70678000
            sayoctal (attio'ret'1.(08:08));                             70679000
            if attio'ret'1.(13:3)=attio'good and last'read'was'eof then 70680000
               begin                                                    70681000
               say " - LEN = " endsay;                                  70682000
               saynum (attio'ret'2);                                    70683000
               say " - '" endsay;                                       70684000
               move'data'in (buffer'xds (curr'wait'buffer),             70685000
                             buffer'offset (curr'wait'buffer),          70686000
                             tdbuf, 3*file'part'words);                 70687000
               say tdbuf', (3*file'part'size) endsay;                   70688000
               say "'" endsay;                                          70689000
               end;                                                     70690000
            send;                                                       70691000
            end;                                                        70692000
$if                                                                     70693000
                                                                        70694000
         if attio'ret'1.(13:3) = attio'eof then    << tape mark       >>70695000
            begin                                                       70696000
            eofs'left        := eofs'left - 1d;                         70697000
            last'one'was'eof := true;                                   70698000
            end                                                         70699000
                                                                        70700000
         else if attio'ret'1.(8:8) = attio'prior'error then             70701000
            << ignore - prior error abort                             >>70702000
                                                                        70703000
         else if attio'ret'1.(13:3) <> attio'good then    << error    >>70704000
            begin                                                       70705000
            errornum := attio'ret'1.(8:8);                              70706000
            keep'going := false;                                        70707000
            end                                                         70708000
                                                                        70709000
         else                                 << successful read      >>70710000
            begin                                                       70711000
                                                                        70712000
            len := attio'ret'2;                                         70713000
                                                                        70714000
            if len = tape'label'size then     << store/restore label  >>70715000
               begin                                                    70716000
               check'tape'label (tdbuf);                                70717000
               if last'reel then end'of'tape'set := true                70718000
               else if get'next'volume (gbuf'd (g'filenum'inx'd),       70719000
                                        parms'tempd'1) <> 0 then fail;  70720000
               last'one'was'eof := not tl'spantog;                      70721000
               keep'going := false;                                     70722000
               end                                                      70723000
                                                                        70724000
            else if last'one'was'eof then     << this is a read after >>70725000
               begin                                                    70726000
               move'to'tdbuf;                                           70727000
               if tdbuf' = gbuf' (g'title'inx'), (3*file'part'size) then70728000
                  begin                                                 70729000
                  foundflag  := true;         << yay, found it.       >>70730000
                  eofs'left  := 0d;                                     70731000
                  keep'going := false;                                  70732000
                  end;                                                  70733000
               last'one'was'eof := false;                               70734000
               end;                                                     70735000
            end;                                                        70736000
         end;                                                           70737000
      end;                                                              70738000
                                                                        70739000
   if last'one'was'eof and eofs'left = 0d then  << next read shld be i>>70740000
      begin                                                             70741000
      start'a'read (tape'recsize);                                      70742000
      issue'read (tdbuf, tape'recsize, false);                          70743000
      move'to'tdbuf;                                                    70744000
      end;                                                              70745000
                                                                        70746000
end'pre'scan'for'match:                                                 70747000
                                                                        70748000
   pre'scan'for'match := foundflag;             << set return         >>70749000
                                                                        70750000
end;                                                                    70751000
$page "LOOK'FOR'EOF"                                                    70752000
$control segment=restore                                                70753000
<<---------------------------------------->>                            70754000
<<  look'for'eof                          >>                            70755000
<<---------------------------------------->>                            70756000
                                                                        70757000
integer procedure look'for'eof (gbuf,  stop'for'error);                 70758000
   value stop'for'error;                                                70759000
   logical stop'for'error;          << should we stop for error(r/o)  >>70760000
   logical array                                                        70761000
      gbuf;                         << buffer for good record  (r/o)  >>70762000
                                                                        70763000
   << this routine checks through all the outstanding i/o looking     >>70764000
   << for a tape mark.  if a tape mark is found attio'eof is returned >>70765000
   << if no error occurs attio'good is returned.  if an error occurs  >>70766000
   << the error number is returned.  this code is only used by the    >>70767000
   << attachio code.                                                  >>70768000
                                                                        70769000
begin                                                                   70770000
   logical                                                              70771000
      keep'going       := true;     << should we keep looping         >>70772000
                                                                        70773000
   double                                                               70774000
      attachio'ret     := 0d;       << return from waitforio          >>70775000
                                                                        70776000
   integer pointer                                                      70777000
      tdbuf;                        << dummy pointer                  >>70778000
                                                                        70779000
   integer                                                              70780000
      attachio'ret'1   =  attachio'ret,                                 70781000
      attachio'ret'2   =  attachio'ret + 1,                             70782000
      new'wait'buffer;              << temp var. for buffer number    >>70783000
                                                                        70784000
   double array                                                         70785000
      gbuf'd (*)       = gbuf;      << buffer for good record         >>70786000
                                                                        70787000
   <<---------------------------------------->>                         70788000
   <<  fail of look'for'eof                  >>                         70789000
   <<---------------------------------------->>                         70790000
                                                                        70791000
   subroutine fail;                                                     70792000
                                                                        70793000
      << this procedure starts the termination of the program.        >>70794000
                                                                        70795000
   begin                                                                70796000
      look'for'eof := -1;                                               70797000
      goto end'look'for'eof;                                            70798000
   end;                                                                 70799000
$page                                                                   70800000
   if not using'attio then       << terminate if not using attachio co>>70801000
      return;                                                           70802000
                                                                        70803000
   while keep'going do                                                  70804000
      begin                                                             70805000
                                                                        70806000
      if outstanding'ios = 0 then                   << no more ios    >>70807000
         keep'going := false                                            70808000
      else                                                              70809000
         begin                                                          70810000
         curr'wait'buffer := curr'wait'buffer + 1;  << update buff num>>70811000
         if curr'wait'buffer = num'buffers then                         70812000
            curr'wait'buffer := 0;                                      70813000
                                                                        70814000
         << wait for io.  decrement num of ios.  clear ioq entry.     >>70815000
                                                                        70816000
         attachio'ret := waitforio (io'queue (2*curr'wait'buffer) );    70817000
         outstanding'ios := outstanding'ios - 1;                        70818000
         io'queue'd (curr'wait'buffer) := 0d;                           70819000
                                                                        70820000
         << intepret waitforio return                                 >>70821000
                                                                        70822000
         if attachio'ret'1.(8:8) = attio'prior'error then               70823000
            keep'going := true    ! ignore - prior error abort          70824000
                                                                        70825000
         else if attachio'ret'2 = tape'label'size then   ! tape label   70826000
            begin                                                       70827000
            keep'going := false;                                        70828000
            check'tape'label (tdbuf);                                   70829000
            if last'reel then end'of'tape'set := true                   70830000
            else if get'next'volume (gbuf'd (g'filenum'inx'd),          70831000
                                     parms'tempd'1) <>   0 then fail;   70832000
            if tl'spantog then attachio'ret'1 := attio'good             70833000
            else attachio'ret'1 := attio'eof;                           70834000
            end                                                         70835000
                                                                        70836000
         else if attachio'ret'1.(13:3) = attio'good then                70837000
            keep'going := true           ! not an eof                   70838000
                                                                        70839000
         else if attachio'ret'1.(13:3) = attio'eof  then                70840000
            keep'going := false          ! an eof was found.            70841000
                                                                        70842000
         else                            ! an error was found.          70843000
            keep'going := not stop'for'error;                           70844000
                                                                        70845000
$if x1=on then                                                          70846000
            if debugging then                                           70847000
               begin                                                    70848000
               say "LOOKING FOR EOF - IOS = " endsay;                   70849000
               saynum (outstanding'ios);                                70850000
               say " - BUFFER = " endsay;                               70851000
               saynum (curr'wait'buffer);                               70852000
               say " - STATUS = " endsay;                               70853000
               sayoctal (attachio'ret'1.(8:8));                         70854000
               send;                                                    70855000
               end;                                                     70856000
$if                                                                     70857000
         end;                                                           70858000
      end;                                                              70859000
                                                                        70860000
end'look'for'eof:                                                       70861000
                                                                        70862000
   look'for'eof := attachio'ret'1.(13:3);    ! set return to last status70863000
                                                                        70864000
end;                                                                    70865000
$page "START'A'READ"                                                    70866000
$control segment=restore                                                70867000
<<---------------------------------------->>                            70868000
<<  start'a'read                          >>                            70869000
<<---------------------------------------->>                            70870000
                                                                        70871000
procedure start'a'read (readlength);                                    70872000
   value readlength;                                                    70873000
   integer readlength;             ! length of read (r/o)               70874000
                                                                        70875000
   ! this procedure calls attachio which starts a read of length        70876000
   ! readlength.  if there are no available buffers, no call is         70877000
   ! made.  this procedure is only used in the attachio code.           70878000
                                                                        70879000
begin                                                                   70880000
   if not using'attio then              ! must be using attachio code   70881000
      return;                                                           70882000
                                                                        70883000
$if x1=on then                                                          70884000
   if debugging then                                                    70885000
      begin                                                             70886000
      say "START'A'READ - BUFFER " endsay;                              70887000
      saynum (curr'read'buffer);                                        70888000
      say " - LENGTH " endsay;                                          70889000
      saynum (readlength);                                              70890000
      send;                                                             70891000
      end;                                                              70892000
$if                                                                     70893000
                                                                        70894000
   if outstanding'ios = num'buffers then     ! is there room for another70895000
      return;                                ! read?                    70896000
                                                                        70897000
   disable'arithmetic'traps;                                            70898000
                                                                        70899000
   io'queue'd (curr'read'buffer) := attachio (                          70900000
                  tape'ldev,                          <<ldev>>          70901000
                  0,                                  <<qmisc>>         70902000
                  buffer'xds (curr'read'buffer),      <<dst #>>         70903000
                  buffer'offset (curr'read'buffer),   <<offset>>        70904000
                  attio'read,                         <<read>>          70905000
                  readlength,                         <<buff size>>     70906000
                  0,                                  <<p1>>            70907000
                  0,                                  <<p2>>            70908000
                  0);                                 <<unblocked>>     70909000
                                                                        70910000
   enable'arithmetic'traps;                                             70911000
                                                                        70912000
   outstanding'ios := outstanding'ios + 1;                              70913000
                                                                        70914000
   curr'read'buffer := curr'read'buffer + 1;   ! update read buffer num 70915000
   if curr'read'buffer = num'buffers then                               70916000
      curr'read'buffer := 0;                                            70917000
                                                                        70918000
$if x1=on then                                                          70919000
   if debugging then                                                    70920000
      begin                                                             70921000
      say "   ISSUED - NEW READ'BUFFER IS " endsay;                     70922000
      saynum (curr'read'buffer);                                        70923000
      send;                                                             70924000
      end;                                                              70925000
$if                                                                     70926000
                                                                        70927000
end;                                                                    70928000
$page "ISSUE'READ"                                                      70929000
$control segment=restore                                                70930000
<<---------------------------------------->>                            70931000
<<  issue'read                            >>                            70932000
<<---------------------------------------->>                            70933000
                                                                        70934000
procedure issue'read (buffer, readlength, use'wait'io);                 70935000
   value readlength, use'wait'io;                                       70936000
   logical array buffer;      ! buffer for read (w/o)                   70937000
   integer readlength;        ! length of read (w/o)                    70938000
   logical use'wait'io;       ! use blocked io? (r/o)                   70939000
                                                                        70940000
   ! this procedure does a read from the tape.  there are three types   70941000
   ! of read.  in all cases, length is returned in read'tape'len, an    70942000
   ! error is indicated by a nonzero value in error'code, and           70943000
   ! a tape mark is indicated by a true in read'tape'eof.               70944000
   !                                                                    70945000
   !    filesys read - read is done by fread.  error'code is set to     70946000
   !                   file system error number.  data is placed in     70947000
   !                   buffer.  this method is used when not using the  70948000
   !                   attachio code.                                   70949000
   !                                                                    70950000
   !    wait read    - read is done by attachio.  the attachio uses a   70951000
   !                   blocked read.  error'code is set to the          70952000
   !                   attachio error number. data is placed in buffer. 70953000
   !                   this method is used when using the attachio code 70954000
   !                   and use'wait'io is true.                         70955000
   !                                                                    70956000
   !    nowait read  - read is done by attachio.  the attachio uses an  70957000
   !                   unblocked read.  error'code is set to the        70958000
   !                   attachio error number.  data is placed in the    70959000
   !                   extra data segment buffer pointed to by          70960000
   !                   curr'wait'buffer.  this method is used when      70961000
   !                   using the attachio code and use'wait'io is       70962000
   !                   false.                                           70963000
                                                                        70964000
begin                                                                   70965000
                                                                        70966000
   byte array                                                           70967000
      buffer' (*) = buffer;            ! buffer for read                70968000
                                                                        70969000
   double                                                               70970000
      attachio'ret;                    ! return from attachio/waitforio 70971000
                                                                        70972000
   integer                                                              70973000
      attachio'ret'1 = attachio'ret,                                    70974000
      attachio'ret'2 = attachio'ret + 1;                                70975000
$page "WRITE'DEBUGGING'INFO of ISSUE'READ"                              70976000
   <<---------------------------------------->>                         70977000
   <<  write'debugging'info of issue'read    >>                         70978000
   <<---------------------------------------->>                         70979000
                                                                        70980000
   subroutine write'debugging'info;                                     70981000
                                                                        70982000
      ! this routin writes out information about this call of issue'read70983000
                                                                        70984000
   begin                                                                70985000
$if x1=on then                                                          70986000
      if debugging then                                                 70987000
         begin                                                          70988000
         say "ISSUE'READ " endsay;                                      70989000
         if using'attio and not use'wait'io then                        70990000
            begin                                                       70991000
            say " - BUFFER = " endsay;                                  70992000
            saynum (curr'wait'buffer);                                  70993000
            say " -" endsay;                                            70994000
            end;                                                        70995000
         if read'tape'eof then                                          70996000
            say "*EOF FOUND*" endsay                                    70997000
         else if error'code <> 0 then                                   70998000
            begin                                                       70999000
            say "***ERROR=" endsay;                                     71000000
            saynum (error'code);                                        71001000
            end                                                         71002000
         else                                                           71003000
            begin                                                       71004000
            say "-LEN=" endsay;                                         71005000
            saynum (read'tape'len);                                     71006000
            if using'attio and not use'wait'io then                     71007000
               begin                                                    71008000
               move'data'in (buffer'xds (curr'wait'buffer),             71009000
                             buffer'offset (curr'wait'buffer),          71010000
                             buffer, 10);                               71011000
               end;                                                     71012000
            say "-'" endsay;                                            71013000
            say buffer', (20) endsay;                                   71014000
            say1 ("'");                                                 71015000
            end;                                                        71016000
         send;                                                          71017000
         end;                                                           71018000
$if                                                                     71019000
   end;                                                                 71020000
$page "DEBUG'ISSUE'READ of ISSUE'READ"                                  71021000
   <<---------------------------------------->>                         71022000
   <<  debug'issue'read of issue'read        >>                         71023000
   <<---------------------------------------->>                         71024000
                                                                        71025000
   subroutine debug'issue'read;                                         71026000
                                                                        71027000
      ! for testing only - changes the return values of successful reads71028000
                                                                        71029000
   begin                                                                71030000
$if x1=on then                                                          71031000
      if debug'errors then                                              71032000
         begin                                                          71033000
         say "FREAD ON TAPE WORKED OK - INJECT'ERROR? " endsay;         71034000
         sendstop;                                                      71035000
         affirm (parms'tempi'1,false);                                  71036000
         if logical (parms'tempi'1) then                                71037000
            begin                                                       71038000
            buffer := "  ";                                             71039000
            say "EOF? " endsay;                                         71040000
            sendstop;                                                   71041000
            affirm (parms'tempi'1, false);                              71042000
            if logical (parms'tempi'1) then read'tape'eof := true       71043000
            else error'code := 3;                                       71044000
            end;                                                        71045000
         end;                                                           71046000
$if                                                                     71047000
   end;                                                                 71048000
$page "ISSUE'READ'FILE'SYS of ISSUE'READ"                               71049000
   <<---------------------------------------->>                         71050000
   <<  issue'read'file'sys of issue'read     >>                         71051000
   <<---------------------------------------->>                         71052000
                                                                        71053000
   subroutine issue'read'file'sys;                                      71054000
                                                                        71055000
      ! this routine calls fread against the tape                       71056000
                                                                        71057000
   begin                                                                71058000
      read'tape'len := fread (t'num, buffer, readlength);               71059000
      if = then debug'issue'read                                        71060000
      else if > then read'tape'eof := true                              71061000
      else if < then fcheck (t'num, error'code);                        71062000
   end;                                                                 71063000
$page "ISSUE'READ'WAIT'ATTIO of ISSUE'READ"                             71064000
   <<---------------------------------------->>                         71065000
   <<  issue'read'wait'attio of issue'read   >>                         71066000
   <<---------------------------------------->>                         71067000
                                                                        71068000
   subroutine issue'read'wait'attio;                                    71069000
                                                                        71070000
      ! this routine issues a read with a waited attachio               71071000
                                                                        71072000
   begin                                                                71073000
      disable'arithmetic'traps;                                         71074000
      attachio'ret := attachio (tape'ldev,      <<ldev>>                71075000
                                 0,              <<qmisc>>              71076000
                                 0,              <<use stack>>          71077000
                                 @buffer,        <<buffer>>             71078000
                                 attio'read,     <<read>>               71079000
                                 readlength,     <<buffer size>>        71080000
                                 0,              <<p1>>                 71081000
                                 0,              <<p2>>                 71082000
                                 1);             <<blocked>>            71083000
                                                                        71084000
      enable'arithmetic'traps;                                          71085000
                                                                        71086000
      if attachio'ret'1.(13:3) = attio'eof then         <<eof>>         71087000
         read'tape'eof := true                                          71088000
      else if attachio'ret'1.(13:3) <> attio'good then                  71089000
         error'code := attachio'ret'1.(08:08)                           71090000
      else                                                              71091000
         begin                                                          71092000
         read'tape'len := attachio'ret'2;                               71093000
         debug'issue'read;                                              71094000
         end;                                                           71095000
   end;                                                                 71096000
$page "ISSUE'READ'NO'WAIT'ATTIO of ISSUE'READ"                          71097000
   <<---------------------------------------->>                         71098000
   <<  issue'read'no'wait'attio of issue'read>>                         71099000
   <<---------------------------------------->>                         71100000
                                                                        71101000
   subroutine issue'read'no'wait'attio;                                 71102000
                                                                        71103000
      ! this routine waits for an already started read to finish        71104000
                                                                        71105000
   begin                                                                71106000
                                                                        71107000
start'again:                                                            71108000
                                                                        71109000
      if outstanding'ios = 0 then                                       71110000
         start'a'read (tape'recsize);                                   71111000
                                                                        71112000
      curr'wait'buffer := curr'wait'buffer + 1;                         71113000
      if curr'wait'buffer = num'buffers then                            71114000
         curr'wait'buffer := 0;                                         71115000
                                                                        71116000
      if io'queue'd (curr'wait'buffer) = 0d then                        71117000
         error'code := 1                                                71118000
      else                                                              71119000
         begin                                                          71120000
         disable'arithmetic'traps;                                      71121000
                                                                        71122000
         attachio'ret := waitforio (io'queue (2*curr'wait'buffer) );    71123000
                                                                        71124000
         enable'arithmetic'traps;                                       71125000
                                                                        71126000
         outstanding'ios := outstanding'ios - 1;                        71127000
                                                                        71128000
         io'queue'd (curr'wait'buffer) := 0d;                           71129000
                                                                        71130000
         if attachio'ret'1.(13:3) = attio'eof then         <<eof>>      71131000
            read'tape'eof := true                                       71132000
         else if attachio'ret'1.(8:8) = attio'prior'error then          71133000
            begin                                                       71134000
            start'a'read (readlength);                                  71135000
            go to start'again;                                          71136000
            end                                                         71137000
         else if attachio'ret'1.(13:3) <> attio'good then               71138000
            error'code := attachio'ret'1.(08:08)  ! error               71139000
                                                                        71140000
         else                       ! read was successful               71141000
            begin                                                       71142000
            read'tape'len := attachio'ret'2;   ! set length             71143000
            debug'issue'read;                                           71144000
            end;                                                        71145000
                                                                        71146000
         end;                                                           71147000
                                                                        71148000
   end;                                                                 71149000
$page "ISSUE'READ mainline"                                             71150000
   ! initialize return variables                                        71151000
                                                                        71152000
   buffer        := "  ";                                               71153000
   error'code    := 0;                                                  71154000
   read'tape'eof := false;                                              71155000
   read'tape'len := 0;                                                  71156000
                                                                        71157000
   if end'of'tape'set then                                              71158000
      begin                                                             71159000
      read'tape'eof := true;                                            71160000
      return;                                                           71161000
      end;                                                              71162000
                                                                        71163000
   ! call appropriate subroutine                                        71164000
                                                                        71165000
   if not using'attio then                                              71166000
      issue'read'file'sys                                               71167000
                                                                        71168000
   else if use'wait'io then                                             71169000
      issue'read'wait'attio                                             71170000
                                                                        71171000
   else                                                                 71172000
      issue'read'no'wait'attio;                                         71173000
                                                                        71174000
   write'debugging'info;                                                71175000
                                                                        71176000
end;                                                                    71177000
$page "ISSUE'CTRL"                                                      71178000
$control segment=restore                                                71179000
<<---------------------------------------->>                            71180000
<<  issue'ctrl                            >>                            71181000
<<---------------------------------------->>                            71182000
                                                                        71183000
procedure issue'ctrl (func);                                            71184000
   value   func;                                                        71185000
   logical func;           ! function to be performed (r/o)             71186000
                                                                        71187000
   ! this procedure issues a control statement to the tape drive.       71188000
   ! if an error occurs error'code will be set to a nonzero  value.     71189000
   ! if using the attachio code, issue'ctrl uses attachio. otherwise,   71190000
   ! fcontrol is used.  func is the control function to be performed.   71191000
                                                                        71192000
begin                                                                   71193000
                                                                        71194000
   double                                                               71195000
      attachio'ret;        ! return from attachio                       71196000
                                                                        71197000
   integer                                                              71198000
      attachio'ret'1 = attachio'ret,                                    71199000
      attachio'ret'2 = attachio'ret + 1;                                71200000
                                                                        71201000
   <<---------------------------------------->>                         71202000
   <<  issue'ctrl'file'sys of issue'ctrl     >>                         71203000
   <<---------------------------------------->>                         71204000
                                                                        71205000
   subroutine issue'ctrl'file'sys;                                      71206000
                                                                        71207000
      ! routine calls fcontrol and sets error'code if an error occurs   71208000
                                                                        71209000
   begin                                                                71210000
      fcontrol (t'num, func, parms'tempi'1);                            71211000
      if <> then                                                        71212000
         fcheck (t'num, error'code);                                    71213000
   end;                                                                 71214000
                                                                        71215000
                                                                        71216000
                                                                        71217000
                                                                        71218000
   <<---------------------------------------->>                         71219000
   <<  issue'ctrl'attio of issue'ctrl        >>                         71220000
   <<---------------------------------------->>                         71221000
                                                                        71222000
   subroutine issue'ctrl'attio;                                         71223000
                                                                        71224000
      ! routine calls attachio and sets error'code if an error occurs   71225000
                                                                        71226000
   begin                                                                71227000
      disable'arithmetic'traps;                                         71228000
      attachio'ret := attachio ( tape'ldev,      <<ldev>>               71229000
                                  0,              <<qmisc>>             71230000
                                  0,              <<use stack>>         71231000
                                  0,              <<buffer addr>>       71232000
                                  func,           <<file skip fwd>>     71233000
                                  0,              <<count>>             71234000
                                  0,              <<p1>>                71235000
                                  0,              <<p2>>                71236000
                                  1);             <<wait>>              71237000
                                                                        71238000
      enable'arithmetic'traps;                                          71239000
                                                                        71240000
      if attachio'ret'1.(13:3) <> attio'good then                       71241000
         error'code := attachio'ret'1.(8:8);                            71242000
   end;                                                                 71243000
                                                                        71244000
                                                                        71245000
$if x1=on then                                                          71246000
   if debugging then                                                    71247000
      begin                                                             71248000
      say "ENTERING ISSUE'CTRL - FUNC = " endsay;                       71249000
      saynum (func);                                                    71250000
      send;                                                             71251000
      end;                                                              71252000
$if                                                                     71253000
                                                                        71254000
   ! zero error'code and call appropriate subroutine.                   71255000
                                                                        71256000
   error'code := 0;                                                     71257000
                                                                        71258000
   if end'of'tape'set then                                              71259000
      return;                                                           71260000
                                                                        71261000
   if not using'attio then                                              71262000
      issue'ctrl'file'sys                                               71263000
   else                                                                 71264000
      issue'ctrl'attio;                                                 71265000
                                                                        71266000
$if x1=on then                                                          71267000
   if debugging then                                                    71268000
      begin                                                             71269000
      say "   CTRL COMPLETED - ERROR'CODE = " endsay;                   71270000
      saynum (error'code);                                              71271000
      send;                                                             71272000
      end;                                                              71273000
$if                                                                     71274000
end;                                                                    71275000
$page "ISSUE'SKIP"                                                      71276000
$control segment=restore                                                71277000
<<---------------------------------------->>                            71278000
<<  issue'skip                            >>                            71279000
<<---------------------------------------->>                            71280000
                                                                        71281000
procedure issue'skip (use'wait'io);                                     71282000
   value use'wait'io;                                                   71283000
   logical use'wait'io;                                                 71284000
                                                                        71285000
   ! this procedure issues a file-skip-forward to the tape drive.  if   71286000
   ! an error occurs, error'code will be set to a nonzero value.        71287000
   ! there are four different ways this procedure talks to the tape     71288000
   ! drive.                                                             71289000
   !                                                                    71290000
   !   unlabeled filesys  - calls issue'ctrl which uses fcontrol.       71291000
   !   labeled   filesys  - issues a nexttapefile.                      71292000
   !   wait      attachio - calls issue'ctrl which uses blocked attachio71293000
   !   nowait    attachio - issues a waitforio against an io started by 71294000
   !                        start'a'skip.                               71295000
                                                                        71296000
begin                                                                   71297000
                                                                        71298000
   double                                                               71299000
      attachio'ret;                                                     71300000
                                                                        71301000
   integer                                                              71302000
      attachio'ret'1         = attachio'ret,                            71303000
      attachio'ret'2         = attachio'ret;                            71304000
$page "ISSUE'SKIP'LABELED of ISSUE'SKIP"                                71305000
   <<---------------------------------------->>                         71306000
   <<  issue'skip'labeled of issue'skip      >>                         71307000
   <<---------------------------------------->>                         71308000
                                                                        71309000
   subroutine issue'skip'labeled;                                       71310000
                                                                        71311000
      ! calls nexttapefile to skip to the next file on a labeled tape   71312000
                                                                        71313000
   begin                                                                71314000
      error'code := nexttapefile (t'num);                               71315000
      if = then error'code := 0;                                        71316000
   end;                                                                 71317000
                                                                        71318000
   <<---------------------------------------->>                         71319000
   <<  issue'skip'no'wait'io of issue'skip   >>                         71320000
   <<---------------------------------------->>                         71321000
                                                                        71322000
   subroutine issue'skip'no'wait'io;                                    71323000
                                                                        71324000
      ! waits for an already started attachio (code=7) to complete      71325000
                                                                        71326000
   begin                                                                71327000
      disable'arithmetic'traps;                                         71328000
                                                                        71329000
      attachio'ret := waitforio (ioq'fsf (0));                          71330000
                                                                        71331000
      ioq'fsf'd (0) := ioq'fsf'd (1);                                   71332000
      ioq'fsf'd (1) := 0d;                                              71333000
                                                                        71334000
      enable'arithmetic'traps;                                          71335000
                                                                        71336000
      if attachio'ret'1.(13:3) <> attio'good then                       71337000
         error'code := attachio'ret'1.(8:8);                            71338000
   end;                                                                 71339000
$page "ISSUE'SKIP MAINLINE"                                             71340000
   ! call appropriate routine                                           71341000
                                                                        71342000
   error'code := 0;                                                     71343000
                                                                        71344000
   if end'of'tape'set then                                              71345000
      return;                                                           71346000
                                                                        71347000
   if labeled then                                                      71348000
      issue'skip'labeled                                                71349000
   else if not using'attio or use'wait'io then                          71350000
      issue'ctrl (attio'fsf)                                            71351000
   else                                                                 71352000
      issue'skip'no'wait'io;                                            71353000
end;                                                                    71354000
$page "START'A'SKIP"                                                    71355000
$control segment=restore                                                71356000
<<---------------------------------------->>                            71357000
<<  start'a'skip                          >>                            71358000
<<---------------------------------------->>                            71359000
                                                                        71360000
procedure start'a'skip;                                                 71361000
                                                                        71362000
   ! this procedure starts a skip by calling attachio with unblocked    71363000
   ! io.  at most, two skips may be outstanding.  if one skip is        71364000
   ! pending, then this adds the new skip after the old one.            71365000
   ! this code is used only with the attachio code.                     71366000
                                                                        71367000
begin                                                                   71368000
   integer queue'num;                                                   71369000
   integer stat;                                                        71370000
                                                                        71371000
   if end'of'tape'set then                                              71372000
      return;                                                           71373000
                                                                        71374000
   if not using'attio then                                              71375000
      return;                                                           71376000
                                                                        71377000
   if ioq'fsf'd = 0d then queue'num := 0                                71378000
   else queue'num := 1;                                                 71379000
                                                                        71380000
$if x1=on then                                                          71381000
   if debugging then                                                    71382000
      begin                                                             71383000
      say "START'A'SKIP - QUEUE NUM = " endsay;                         71384000
      saynum (queue'num);                                               71385000
      end;                                                              71386000
$if                                                                     71387000
                                                                        71388000
!  stat := look'for'eof;                                                71389000
!  if stat = attio'good then                                            71390000
   if true then                                                         71391000
      begin                                                             71392000
      disable'arithmetic'traps;                                         71393000
                                                                        71394000
      ioq'fsf'd (queue'num) := attachio (                               71395000
                                  tape'ldev,      <<ldev>>              71396000
                                  0,              <<qmisc>>             71397000
                                  0,              <<use stack>>         71398000
                                  0,              <<buffer addr>>       71399000
                                  attio'fsf,      <<file skip fwd>>     71400000
                                  0,              <<count>>             71401000
                                  0,              <<p1>>                71402000
                                  0,              <<p2>>                71403000
                                  0);             <<wait>>              71404000
                                                                        71405000
      enable'arithmetic'traps;                                          71406000
      end                                                               71407000
                                                                        71408000
   else if stat <> attio'eof then                                       71409000
      error'code := stat;                                               71410000
                                                                        71411000
$if x1=on then                                                          71412000
   if debugging then                                                    71413000
      begin                                                             71414000
      say "   ATTACHIO ISSUED" endsay;                                  71415000
      send;                                                             71416000
      end;                                                              71417000
$if                                                                     71418000
                                                                        71419000
end;                                                                    71420000
$page "ADJUSTFPTR"                                                      71421000
$control segment=restore                                                71422000
<<---------------------------------------->>                            71423000
<<  adjust'fptr                           >>                            71424000
<<---------------------------------------->>                            71425000
                                                                        71426000
integer procedure adjust'fptr (element, level, parms, sir);             71427000
   value level,parms,sir;                                               71428000
   integer level, parms;                                                71429000
   integer array element;                                               71430000
   double sir;                                                          71431000
   option privileged, uncallable;                                       71432000
                                                                        71433000
   ! this procedure is the recipient procedure of direcscan.  when      71434000
   ! called (at the file level), adjust'fptr changes the file label     71435000
   ! disc address of the file entry to the double word value in the     71436000
   ! first two words of parms.  the dirty bit is then set and away it   71437000
   ! goes.                                                              71438000
                                                                        71439000
begin                                                                   71440000
   integer array arq (*) = q+0;                                         71441000
   logical array dseg (*) = db+0;                                       71442000
   define dadirty = dseg(%221).(15:01) #;                               71443000
                                                                        71444000
   parms := parms-arq;                                                  71445000
   element (4) := arq (parms);                                          71446000
   element (5) := arq (parms+1);                                        71447000
   dadirty := 1;                                                        71448000
   adjust'fptr := 1;                                                    71449000
end;                                                                    71450000
$page "DISPLAY'3'TO'DISPLAY"                                            71451000
<<----------------------------->>                                       71452000
<< display'3'to'display        >>                                       71453000
<<----------------------------->>                                       71454000
                                                                        71455000
$control segment=restore                                                71456000
procedure display'3'to'display (target,len,filename,groupname,acctname);71457000
   integer len;                         ! return length of target  (w/o)71458000
   byte array                                                           71459000
      target,                           ! target string            (w/o)71460000
      filename,                         ! file name                (r/o)71461000
      groupname,                        ! group name               (r/o)71462000
      acctname;                         ! account name             (r/o)71463000
                                                                        71464000
   ! takes filename, groupname, and accountname                         71465000
   ! and places in target a string that is the concatenation of         71466000
   ! the above with proper seperators.  len is the return length        71467000
   ! of target. blanks are suppressed.  maximum of len is 26.           71468000
   !                                                                    71469000
   !    filename.groupname.acctname                                     71470000
                                                                        71471000
begin                                                                   71472000
   define                                                               71473000
      blanks'27  = "                           "#;                      71474000
   byte pointer                                                         71475000
      scanstop;                         ! position where scan stopped   71476000
                                                                        71477000
   move target := blanks'27;                                            71478000
                                                                        71479000
   move target := filename, (file'part'size);                           71480000
   scan target until "  ",1;                                            71481000
   @scanstop := tos;                                                    71482000
   scanstop := ".";                                                     71483000
                                                                        71484000
   move scanstop(1) := groupname, (file'part'size);                     71485000
   scan scanstop until "  ", 1;                                         71486000
   @scanstop := tos;                                                    71487000
   scanstop := ".";                                                     71488000
                                                                        71489000
   move scanstop(1) := acctname, (file'part'size);                      71490000
   scan scanstop until "  ", 1;                                         71491000
   @scanstop := tos;                                                    71492000
   len := logical (@scanstop) - logical (@target);                      71493000
                                                                        71494000
                                                                        71495000
$if x1=on then                <<debugging code>>                        71496000
   if debugging then                                                    71497000
      begin                                                             71498000
      say "FILE TITLE IS '" endsay;                                     71499000
      say target, (len) endsay;                                         71500000
      say "'" endsay;                                                   71501000
      send;                                                             71502000
      end;                                                              71503000
$if                                                                     71504000
                                                                        71505000
end <<display'3'to'display>>;                                           71506000
$page "MATCH'LOCKWORD"                                                  71507000
$control segment=restore                                                71508000
<<---------------------------------------->>                            71509000
<<  match'lockword                        >>                            71510000
<<---------------------------------------->>                            71511000
                                                                        71512000
logical procedure match'lockword (mess',len,pass');                     71513000
   value len;                                                           71514000
   integer len;                         ! length of passed message (r/o)71515000
   byte array                                                           71516000
      mess',                            ! message to be printed    (r/o)71517000
      pass';                            ! password to be matched   (r/o)71518000
                                                                        71519000
   ! sends mess' to the terminal and waits for a reply.                 71520000
   ! if reply matches pass' then returns good, otherwise it             71521000
   ! returns failed                                                     71522000
                                                                        71523000
begin                                                                   71524000
   byte array hold' (0:80);             ! buffer passed to freply  (r/w)71525000
                                                                        71526000
   move hold' := mess' , (len);                                         71527000
                                                                        71528000
   hold'(len) := "?";                                                   71529000
   if not freply (hold', len+1) then                                    71530000
      match'lockword := failed                                          71531000
   else if hold' = pass', (file'part'size) then                         71532000
      match'lockword := good                                            71533000
   else                                                                 71534000
      match'lockword := failed;                                         71535000
end <<match'lockword>>;                                                 71536000
$page "CHANGE'JIT'ACCT"                                                 71537000
$control segment=restore                                                71538000
<<----------------------------->>                                       71539000
<< change'jit'acct             >>                                       71540000
<<----------------------------->>                                       71541000
procedure change'jit'acct (dstno, acctname);                            71542000
   value dstno;                                                         71543000
   integer dstno;                                                       71544000
   logical array acctname;                                              71545000
                                                                        71546000
   ! changes the account field in the jit to res'acct.  this is what    71547000
   ! makes it possible for restore to build files in other accounts.    71548000
                                                                        71549000
begin                                                                   71550000
   move'data'out (dstno, 16, acctname, 4);                              71551000
end;                                                                    71552000
$page "GET'JITDST"                                                      71553000
$control segment=restore                                                71554000
<<----------------------------->>                                       71555000
<< get'jitdst                  >>                                       71556000
<<----------------------------->>                                       71557000
integer procedure get'jitdst;                                           71558000
                                                                        71559000
   << this procedure returns the dst number of the jit. >>              71560000
   << may be called in split stack mode.                >>              71561000
                                                                        71562000
begin                                                                   71563000
                                                                        71564000
   integer                                                              71565000
      pcbglobloc,        << q-relative pointer to pcbx global>>         71566000
      s0  = s-0;                                                        71567000
                                                                        71568000
   integer array                                                        71569000
      qarray (*) = q + 0;                                               71570000
                                                                        71571000
   pxglobal;                                                            71572000
   get'jitdst := pxg'jitdst;                                            71572100
end;                                                                    71572200
$page "LABELIO"                                                         71573000
$control segment=restore                                                71574000
<<--------------------------->>                                         71575000
<< labelio                   >>                                         71576000
<<--------------------------->>                                         71577000
                                                                        71578000
integer procedure labelio (target, ldev, address, rw, filename);        71579000
   value ldev, address, rw;                                             71580000
   logical array target, filename;                                      71581000
   logical ldev, rw;                                                    71582000
   double address;                                                      71583000
                                                                        71584000
   ! this routine reads/writes a file label from/to disc.  in a         71585000
   ! read, the label is read from the disc address specified by         71586000
   ! ldev/address and placed into target.  in a write, the label        71587000
   ! is taken from target and written to the disc address specified     71588000
   ! by ldev/address.  returns 0 if good, error number otherwise.       71589000
                                                                        71590000
begin                                                                   71591000
   integer errcode;                                                     71592000
                                                                        71593000
$if x1=on then                                                          71594000
   if debugging then                                                    71595000
      begin                                                             71596000
      say "   LABELIO LDEV=" endsay;                                    71597000
      saynum (ldev);                                                    71598000
      say "; ADRESS=%" endsay;                                          71599000
      saydoctal (address);                                              71600000
      if rw=0 then say "; READ" endsay                                  71601000
      else say "; WRITE" endsay;                                        71602000
      send;                                                             71603000
      end;                                                              71604000
$if                                                                     71605000
   errcode := flabio (ldev, address, rw, target);                       71606000
                                                                        71607000
   if errcode <> 0 then                                                 71608000
      begin                                                             71609000
                                                                        71610000
$if x1=on then                                                          71611000
      if debugging then                                                 71612000
         begin                                                          71613000
         say "FLABIO RETURNS ERRCODE = " endsay;                        71614000
         saynum (errcode);                                              71615000
         send;                                                          71616000
         end;                                                           71617000
$if                                                                     71618000
                                                                        71619000
      flabioerr (errcode, 0, @filename);                                71620000
      if rw=attio'read then labelio := m'read'file'label'failed         71621000
      else labelio := m'write'file'label'failed;                        71622000
      end                                                               71623000
   else                                                                 71624000
      labelio := 0;                                                     71625000
$if x1=on then                                                          71626000
   if debugging then                                                    71627000
      begin                                                             71628000
      if errcode =  0 then say "   LABELIO OK" endsay                   71629000
      else say "   LABELIO FAILED" endsay;                              71630000
      send;                                                             71631000
      end;                                                              71632000
$if                                                                     71633000
end;                                                                    71634000
$page "PICK A DEVICE"                                                   71635000
<<----------------------------->>                                       71636000
<< pick'a'device               >>                                       71637000
<<----------------------------->>                                       71638000
                                                                        71639000
$control segment=irestore                                               71640000
logical procedure  pick'a'device (ext'sizes);                           71641000
   double array                                                         71642000
      ext'sizes;                                                        71643000
                                                                        71644000
   ! this procedure finds disc space for the file.                      71645000
   !                                                                    71646000
   ! note: this procedure will attempt to find one large contiguous     71647000
   !       area for the file.  if it fails to do that then it will      71648000
   !       try to find space for the file, extent by extent.            71649000
   !       therefore it is possible that the following algorithm may    71650000
   !       be gone through twice.  once for contiguous space, and if    71651000
   !       that fails then another time for disjoint space.             71652000
   !                                                                    71653000
   ! the algorithm is                                                   71654000
   !                                                                    71655000
   !    if the user specified the dev parameter then                    71656000
   !       if we can get space on specified device then                 71657000
   !          success                                                   71658000
   !       else                                                         71659000
   !          failure                                                   71660000
   !                                                                    71661000
   !    else                                                            71662000
   !       if we can get space on device class in file label then       71663000
   !          success                                                   71664000
   !       else if we can get space on a device with the same device    71665000
   !                type and subtype as in the file label then          71666000
   !          success                                                   71667000
   !       else if we can get space on a device with the same device    71668000
   !                type as in the file label then                      71669000
   !          success                                                   71670000
   !       else if we can get space on device class "DISC" then         71671000
   !          success                                                   71672000
   !       else                                                         71673000
   !          failure                                                   71674000
   !                                                                    71675000
   ! failure means pick'a'device returns failed.                        71676000
   ! success means pick'a'device returns good.                          71677000
                                                                        71678000
begin                                                                   71679000
                                                                        71680000
   double                                                               71681000
      chunk'addr;                       ! address of first extent       71682000
                                                                        71683000
   integer                                                              71684000
      chunk'addr'1  = chunk'addr,       ! address of first extent       71685000
      chunk'ldev,                       ! ldev                          71686000
      chunk'vtab,                       ! vtab                          71687000
      entry'size,                       ! entry size-logical device tabl71688000
      hold'pvinfo,                      ! holder for private vol info   71689000
      i,                                ! counter                       71690000
      last'ldev,                        ! the highest number ldev on sys71691000
      numexts,                          ! number of extents             71692000
      ldt'index,                        ! offset into logical dev table 71693000
      lpdt'index,                       ! offset into lpdt              71694000
      sir'info,                         ! getsir return                 71695000
      sub'ldn,                          ! loop counter - log dev numsm  71696000
      sub'ret;                          ! procedure return holder       71697000
                                                                        71698000
   logical                                                              71699000
      r'pick'a'device = pick'a'device,  ! return                        71700000
      sub'stop,                         ! flag                          71701000
      try'chunk;                        ! use chunk algorithm           71702000
                                                                        71703000
   integer array                                                        71704000
      info  (0:1+size'of'lpdt'entry+                                    71705000
             size'of'ldt'entry);        ! device information array      71706000
                                                                        71707000
   double array                                                         71708000
      extents (0:max'num'extents);      ! buffer for diskalloc          71709000
                                                                        71710000
   double pointer                                                       71711000
      fl'extmap'd  := @flextmap'd;                                      71712000
                                                                        71713000
   double                                                               71714000
      ext'len;                                                          71715000
$page "CHUNK'EXTENTS of PICK'A'DEVICE"                                  71716000
<<-------------------------------------->>                              71717000
<< chunk'extents of pick'a'device       >>                              71718000
<<-------------------------------------->>                              71719000
                                                                        71720000
subroutine chunk'extents (extsizes, bigextents, numexts);               71721000
   double array extsizes, bigextents;                                   71722000
   integer numexts;                                                     71723000
                                                                        71724000
   ! this routine takes the original extent size map and creates        71725000
   ! a new extent size map that has the same total space, but only      71726000
   ! one extent.                                                        71727000
                                                                        71728000
begin                                                                   71729000
   i := -1;                                                             71730000
                                                                        71731000
   bigextents (0) := 0d;                                                71732000
                                                                        71733000
   while (i:=i+1) < numexts do                                          71734000
      bigextents (0) := bigextents (0) + extsizes(i);                   71735000
                                                                        71736000
   numexts := 1;                                                        71737000
                                                                        71738000
$if x1=on then                                                          71739000
   if debugging then                                                    71740000
      begin                                                             71741000
      say "CHUNKED EXTENT SIZE = " endsay;                              71742000
      saydoctal (bigextents (0));                                       71743000
      send;                                                             71744000
      end;                                                              71745000
$if                                                                     71746000
                                                                        71747000
end;                                                                    71748000
$page "UNCHUNK'EXTENTS of PICK'A'DEVICE"                                71749000
<<-------------------------------------->>                              71750000
<< unchunk'extents of pick'a'device     >>                              71751000
<<-------------------------------------->>                              71752000
                                                                        71753000
subroutine unchunk'extents (ext'address, extsizes, flab'exts, numexts); 71754000
   value ext'address, numexts;                                          71755000
   double ext'address;                                                  71756000
   double array extsizes, flab'exts;                                    71757000
   integer numexts;                                                     71758000
                                                                        71759000
   ! this procedure undoes what chunk'extents does.  the one large      71760000
   ! disc extent is divided into extents of the correct size.           71761000
   !                                                                    71762000
   ! in addition the use count of the device in the ldt has to          71763000
   ! be adjusted to the correct number of extents.  (diskalloc bumps    71764000
   ! the usecount by the number of extents it allocates.  diskdealloc   71765000
   ! drops the usecount by the number of extents it deallocates.        71766000
   ! since we use diskdealloc with the correct number of extents, but   71767000
   ! we use diskalloc with one extent, this would result in dropping    71768000
   ! the usecount below zero, which would indeed be a bad thing.        71769000
                                                                        71770000
begin                                                                   71771000
   i := -1;                                                             71772000
                                                                        71773000
   while (i:=i+1) < numexts do                                          71774000
      if extsizes (i) <> 0d then                                        71775000
         begin                                                          71776000
         ext'len := extsizes (i);                                       71777000
         flab'exts (i) := ext'address;                                  71778000
         ext'address := ext'address + ext'len;                          71779000
         end;                                                           71780000
                                                                        71781000
   chunk'addr := flab'exts (0);                                         71782000
   chunk'vtab := chunk'addr'1.(0:8);                                    71783000
   chunk'ldev := lun (chunk'vtab, pvmvtabx);                            71784000
                                                                        71785000
   ! now up the use count.                                              71786000
   sir'info := getsir (ldt'sir);                                        71787000
   exchangedb (ldt'dst);                                                71788000
                                                                        71789000
   ldt'index := chunk'ldev * size'of'ldt'entry;                         71790000
   ldt'file'use'cnt := ldt'file'use'cnt + logical(numexts-1);           71791000
                                                                        71792000
   exchangedb (0);                                                      71793000
   relsir (ldt'sir, sir'info);                                          71794000
end;                                                                    71795000
$page "TRY'DISKALLOC of PICK'A'DEVICE"                                  71796000
<<---------------------------------------->>                            71797000
<<  try'diskalloc of pick'a'device        >>                            71798000
<<---------------------------------------->>                            71799000
                                                                        71800000
logical subroutine try'diskalloc (indx);                                71801000
   value indx;                                                          71802000
   integer indx;                                                        71803000
                                                                        71804000
   ! this routine calls diskalloc and inteprets the results.  if        71805000
   ! try'chunk is true then chunk'extents is called.  if try'chunk      71806000
   ! is true and diskalloc succeeds then unchunk'extents is called.     71807000
   !                                                                    71808000
   ! if diskalloc succeeds the subroutine returns true, and the global  71809000
   ! variables file'address and file'ldev are set.  otherwise the       71810000
   ! subroutine returns false.                                          71811000
                                                                        71812000
begin                                                                   71813000
   numexts := flnumexts+1;                                              71814000
   if try'chunk then                                                    71815000
      chunk'extents (ext'sizes, extents, numexts)                       71816000
   else                                                                 71817000
      move extents := ext'sizes, (2*(flnumexts+1));                     71818000
                                                                        71819000
   disable'arithmetic'traps;                                            71820000
   sub'ret := diskalloc (indx,numexts,extents,pv'info);                 71821000
                                                                        71822000
   enable'arithmetic'traps;                                             71823000
                                                                        71824000
   if sub'ret = 0 then                                                  71825000
      begin                                                             71826000
      try'diskalloc := good;                                            71827000
      if try'chunk then                                                 71828000
         unchunk'extents (extents, ext'sizes,                           71829000
                          fl'extmap'd, flnumexts+1)                     71830000
      else                                                              71831000
         move fl'extmap'd := extents, (2*(flnumexts+1));                71832000
                                                                        71833000
      file'address := flextmap'd;                                       71834000
      file'ldev := file'addr'1.(00:08);                                 71835000
      file'addr'1.(00:08) := 0;                                         71836000
                                                                        71837000
$if x1=on then                                                          71838000
      if debugging then                                                 71839000
         begin                                                          71840000
         say "   SUCCESSFUL" endsay;                                    71841000
         send;                                                          71842000
         say "      FILE'LDEV = " endsay;                               71843000
         saynum (file'ldev);                                            71844000
         say "      FILE'ADDRESS = %" endsay;                           71845000
         saydoctal (file'address);                                      71846000
         send;                                                          71847000
         sub'ret := -1;                                                 71848000
         while (sub'ret:=sub'ret+1) <= flnumexts do                     71849000
            begin                                                       71850000
            say "   %" endsay;                                          71851000
            saydoctal (fl'extmap'd (sub'ret));                          71852000
            if sub'ret mod 4 = 3 then send;                             71853000
            end;                                                        71854000
         if flnumexts+1 mod 4 <> 3 then send;                           71855000
         end;                                                           71856000
$if                                                                     71857000
      end                                                               71858000
   else                                                                 71859000
      begin                                                             71860000
      try'diskalloc := failed;                                          71861000
$if x1=on then                                                          71862000
      if debugging then                                                 71863000
         begin                                                          71864000
         say "   DISKALLOC RETURNS " endsay;                            71865000
         saynum (sub'ret);                                              71866000
         send;                                                          71867000
         end;                                                           71868000
$if                                                                     71869000
      end;                                                              71870000
end;                                                                    71871000
$page "TRY'DEFAULT'OR'PASSED'CLASS of PICK'A'DEVICE"                    71872000
<<----------------------------------------------->>                     71873000
<<  try'default'or'passed'class of pick'a'device >>                     71874000
<<----------------------------------------------->>                     71875000
                                                                        71876000
logical subroutine try'default'or'passed'class;                         71877000
                                                                        71878000
   ! this is a do-nothing subroutine that tries either the passed class 71879000
   ! (the user used the ;dev= parm.) or the default class of "DISC ".   71880000
                                                                        71881000
begin                                                                   71882000
                                                                        71883000
$if x1=on then                                                          71884000
   if debugging then                                                    71885000
      say "TRY'DEFAULT'OR'PASSED'CLASS" endsay;                         71886000
$if                                                                     71887000
                                                                        71888000
   try'default'or'passed'class := try'diskalloc (deviceinfo);           71889000
end;                                                                    71890000
$page "TRY'SAME'CLASS of PICK'A'DEVICE"                                 71891000
<<---------------------------------------->>                            71892000
<<  try'same'class of pick'a'device       >>                            71893000
<<---------------------------------------->>                            71894000
                                                                        71895000
logical subroutine try'same'class;                                      71896000
                                                                        71897000
   ! this subroutine calls try'diskalloc with the class from the file   71898000
   ! label.                                                             71899000
                                                                        71900000
begin                                                                   71901000
                                                                        71902000
$if x1=on then                                                          71903000
   if debugging then                                                    71904000
      begin                                                             71905000
      say "TRY'SAME'CLASS CLASS=" endsay;                               71906000
      say flclass', (file'part'size) endsay;                            71907000
      end;                                                              71908000
$if                                                                     71909000
                                                                        71910000
   sub'ret := getdevinfo (flclass, info);                               71911000
   if (sub'ret) = 0 and                 ! getdevinfo worked ok          71912000
      info(1).(10:3) = 0 then          ! and device was disc            71913000
         try'same'class := try'diskalloc (info);                        71914000
end;                                                                    71915000
$page "TRY'SAME'TYPE'AND'OR'SUBTYPE of PICK'A'DEVICE"                   71916000
<<-------------------------------------------------->>                  71917000
<< try'same'type'and'or'subtype of pick'a'device    >>                  71918000
<<-------------------------------------------------->>                  71919000
                                                                        71920000
logical subroutine try'same'type'and'or'subtype (checksub);             71921000
   value checksub;                                                      71922000
   logical checksub;                    ! check subtype flag            71923000
                                                                        71924000
   ! if checksub is set then this calls try'fopen for each              71925000
   ! device that has the same device type and subtype.  if              71926000
   ! checksub is not set then this calls try'fopen for each             71927000
   ! device that has the same device type.                              71928000
   !                                                                    71929000
   ! the device name it passes try'fopen is the ascii representation    71930000
   ! of the logical device number.                                      71931000
                                                                        71932000
begin                                                                   71933000
                                                                        71934000
$if x1=on then                                                          71935000
   if debugging then                                                    71936000
      begin                                                             71937000
      say "TRY SAME TYPE" endsay;                                       71938000
      if checksub then say " AND SUBTYPE" endsay;                       71939000
      send;                                                             71940000
      end;                                                              71941000
$if                                                                     71942000
                                                                        71943000
   sub'stop := false;                                                   71944000
   hold'pvinfo := pv'info;                                              71945000
                                                                        71946000
   exchangedb (ldt'dst);                                                71947000
                                                                        71948000
   last'ldev   := ldt'num'entries;                                      71949000
                                                                        71950000
   sub'ldn     := 0;                                                    71951000
   ldt'index   := 0;                                                    71952000
                                                                        71953000
   while not (sub'stop) and ( (sub'ldn := sub'ldn + 1) <= last'ldev) do 71954000
      begin                                                             71955000
      ldt'index  := sub'ldn * size'of'ldt'entry;                        71956000
      lpdt'index := sub'ldn * size'of'lpdt'entry;                       71957000
                                                                        71958000
      if ldt'avail'to'sys and ldt'device'type = fldevtype then          71959000
         if not (checksub) or lpdt'subtype = fldevsubtype then          71960000
                                                                        71961000
            if fldevtype = 0 then                                       71962000
               if lpdt'not'pv'or'sys or                                 71963000
                  (hold'pvinfo = 0 land lpdt'non'sys'domain)   or       71964000
                  (hold'pvinfo <> 0 land not lpdt'non'sys'domain)       71965000
               then <<null>>                                            71966000
               else                                                     71967000
                  begin                                                 71968000
                  exchangedb (0);                                       71969000
$if x1=on then                                                          71970000
                  if debugging then                                     71971000
                     begin                                              71972000
                     say "  TRYING LDEV #" endsay;                      71973000
                     saynum (sub'ldn);                                  71974000
                     end;                                               71975000
$if                                                                     71976000
                  sub'stop := try'diskalloc (sub'ldn);                  71977000
                  if not sub'stop then exchangedb (ldt'dst);            71978000
                  end;                                                  71979000
      end;                                                              71980000
                                                                        71981000
   exchangedb (0);                                                      71982000
                                                                        71983000
   different'device := true;                                            71984000
   if sub'stop then try'same'type'and'or'subtype := true                71985000
   else try'same'type'and'or'subtype := false;                          71986000
                                                                        71987000
end <<try'open'type'and'or'subtype of pick'a'device>>;                  71988000
$page "PICK'A'DEVICE mainline"                                          71989000
! for a description of the algorithm, see the block comment at the      71990000
! beginning of the procedure.                                           71991000
                                                                        71992000
$if x1=on then                <<debugging code>>                        71993000
if debugging then                                                       71994000
   begin                                                                71995000
   say "ENTERING PICK A DEVICE - EXTSIZES ARE" endsay;                  71996000
   send;                                                                71997000
   sub'ret := -1;                                                       71998000
   while (sub'ret:=sub'ret+1) <= flnumexts do                           71999000
      begin                                                             72000000
      say "   %" endsay;                                                72001000
      saydoctal (ext'sizes (sub'ret));                                  72002000
      if sub'ret mod 4 = 3 then send;                                   72003000
      end;                                                              72004000
   if flnumexts mod 4 <> 3 then send;                                   72005000
   end;                                                                 72006000
$if                                                                     72007000
try'chunk := true;                                                      72008000
                                                                        72009000
try'again:                                                              72010000
                                                                        72011000
if seen'dev then                                                        72012000
   if try'default'or'passed'class then                                  72013000
      pick'a'device := true                                             72014000
   else                                                                 72015000
      pick'a'device := false                                            72016000
else                                                                    72017000
   begin                                                                72018000
   if try'same'class then                                               72019000
      pick'a'device := true                                             72020000
   else if try'same'type'and'or'subtype (true) then                     72021000
      pick'a'device := true                                             72022000
   else if try'same'type'and'or'subtype (false) then                    72023000
      pick'a'device := true                                             72024000
   else if try'default'or'passed'class then                             72025000
      pick'a'device := true                                             72026000
   else                                                                 72027000
      pick'a'device := false;                                           72028000
   end;                                                                 72029000
                                                                        72030000
if try'chunk and not r'pick'a'device then                               72031000
   begin                                                                72032000
   try'chunk := false;                                                  72033000
   go to try'again;                                                     72034000
   end;                                                                 72035000
                                                                        72036000
end'proc:                                                               72037000
                                                                        72038000
$if x1=on then                <<debugging code>>                        72039000
if debugging then                                                       72040000
   begin                                                                72041000
   say "LEAVING PICK'A'DEVICE" endsay;                                  72042000
   send;                                                                72043000
   send;                                                                72044000
   end;                                                                 72045000
$if                                                                     72046000
                                                                        72047000
                                                                        72048000
end; <<pick'a'device>>                                                  72049000
$page "HIDE OLD COPY"                                                   72050000
!control list                 !list                                     72051000
<<----------------------------->>                                       72052000
<< hide'old'copy               >>                                       72053000
<<----------------------------->>                                       72054000
                                                                        72055000
$control segment=irestore                                               72056000
integer procedure hide'old'copy;                                        72057000
                                                                        72058000
   ! this routine checks to see if there is a disc file that will       72059000
   ! need to be purged.  if there isn't then set old'copy'exists to     72060000
   ! false and return.                                                  72061000
   !                                                                    72062000
   ! if there is and it is not busy, then the file is locked.           72063000
   ! after that access capabilities, privileged file code violations,   72064000
   ! lockword violations, and group and account file space limitations  72065000
   ! are checked.  if any of those things fail then the procedure will  72066000
   ! return a nonzero value, which will prohibit the file from being    72067000
   ! restored.  also the file will be unlocked.                         72068000
                                                                        72069000
begin                                                                   72070000
   integer array                                                        72071000
      file'ntry(0:5);                   ! file entry                    72072000
                                                                        72073000
   double array                                                         72074000
      file'ntry'd(*) = file'ntry;                                       72075000
                                                                        72076000
   byte array                                                           72077000
      mess' (0:72);                                                     72078000
                                                                        72079000
   double                                                               72080000
      dr;                                                               72081000
                                                                        72082000
   integer                                                              72083000
      dra          = dr + 1,                                            72084000
      drb          = dr,                                                72085000
      errcode,                                                          72086000
      hold,                                                             72087000
      i,                                                                72088000
      len,                                                              72089000
      title'len,                                                        72089100
      type;                                                             72090000
                                                                        72091000
   logical                                                              72092000
      file'locked     := false,                                         72093000
      secmx;                                                            72094000
                                                                        72095000
   double pointer                                                       72096000
      old'extmap'd := @old'extmapd;                                     72097000
                                                                        72098000
   define                                                               72099000
      file'ntry'address  = file'ntry'd (0)            #,                72100000
      file'ntry'group'sec= file'ntry'd (1)            #,                72101000
      file'ntry'acct'sec = file'ntry   (4)            #;                72102000
$page "HIDE'OLD'COPY - UNLOCK'OLD'COPY and RET and EVAL'RETURN"         72103000
<<---------------------------------->>                                  72104000
<< unlock'old'copy of hide'old'copy >>                                  72105000
<<---------------------------------->>                                  72106000
                                                                        72107000
subroutine unlock'old'copy;                                             72108000
                                                                        72109000
   ! unlocks the old copy of the file.  is called when hide'old'copy    72110000
   ! fails and the file is already locked.                              72111000
                                                                        72112000
begin                                                                   72113000
   hold := labelio (old'flab, old'ldev, old'address, attio'read,        72114000
                    res'title);                                         72115000
                                                                        72116000
   if hold <> 0 then                                                    72117000
      begin                                                             72118000
      sendmessage (hold);                                               72119000
      sendmessage (rs'unable'to'unlock'old'file);                       72120000
      return;                                                           72121000
      end;                                                              72122000
                                                                        72123000
   old'flstorerestore := no'lockv;                                      72124000
                                                                        72125000
   hold := labelio (old'flab, old'ldev, old'address, attio'write,       72126000
                    res'title);                                         72127000
   if hold <> 0 then                                                    72128000
      begin                                                             72129000
      sendmessage (hold);                                               72130000
      sendmessage (rs'unable'to'unlock'old'file);                       72131000
      return;                                                           72132000
      end;                                                              72133000
                                                                        72134000
end;                                                                    72135000
                                                                        72136000
<<----------------------------->>                                       72137000
<< ret of hide'old'copy        >>                                       72138000
<<----------------------------->>                                       72139000
                                                                        72140000
subroutine ret(a);                                                      72141000
   value a;                                                             72142000
   integer a;                                                           72143000
                                                                        72144000
   ! places the value passed into the procedure return and goes to      72145000
   ! the end of the procedure.  if the return value is nonzero then     72146000
   ! and the file was locked then unlock'old'copy is called.            72147000
                                                                        72148000
begin                                                                   72149000
   hide'old'copy := a;                                                  72150000
                                                                        72151000
   if a <> 0 and file'locked then unlock'old'copy;                      72152000
                                                                        72153000
   go to end'proc;                                                      72154000
end <<ret of hide'old'copy>>;                                           72155000
                                                                        72156000
                                                                        72157000
<<----------------------------->>                                       72158000
<< eval'return of hide'old'copy>>                                       72159000
<<----------------------------->>                                       72160000
                                                                        72161000
subroutine eval'return(retval);                                         72162000
   value retval;                                                        72163000
   integer retval;                                                      72164000
                                                                        72165000
   ! this routine is used to evaluate the return from another procedure.72166000
   ! if the return value is non-zero then hide'old'copy returns that    72167000
   ! same value                                                         72168000
                                                                        72169000
begin                                                                   72170000
   if retval <> 0 then ret(retval);                                     72171000
end <<eval'return of hide'old'copy>>;                                   72172000
$page "HIDE'OLD'COPY - FILE'CODE'CHECK"                                 72173000
<<----------------------------------->>                                 72174000
<< file'code'check of hide'old'copy  >>                                 72175000
<<----------------------------------->>                                 72176000
subroutine file'code'check;                                             72177000
                                                                        72178000
   ! this routine checks to see that there is no privileged file code   72179000
   ! violation.  if the file has a negative filecode and the user       72180000
   ! has neither pm, sm nor op capabilities then the user cannot purge  72181000
   ! the file and therefore the current file cannot be restored.        72182000
                                                                        72183000
begin                                                                   72184000
   if (old'fcode < 0) and (not sm'tog) and (not cap'pm) and             72185000
      not ignore'priv'check'flag then                                   72186000
         ret (m'negative'filecode);                                     72187000
                                                                        72188000
$if x1=on then                                                          72189000
   if debugging then                                                    72190000
      begin                                                             72191000
      say "   OLD FILECODE OK" endsay;                                  72192000
      send;                                                             72193000
      end;                                                              72194000
$if                                                                     72195000
                                                                        72196000
end;                                                                    72197000
$page "OLD'LOCKWORD'CHECK of HIDE'OLD'COPY"                             72199000
<<-------------------------------------->>                              72200000
<< old'lockword'check of hide'old'copy  >>                              72201000
<<-------------------------------------->>                              72202000
                                                                        72203000
subroutine old'lockword'check;                                          72204000
                                                                        72205000
   ! this routine does the lockword checking on the old file.  if the   72206000
   ! user has sm, op, or am capabilities or if there is no lockword     72207000
   ! then no checking occurs.  the user is prompted for the correct     72208000
   ! password.  if it is not given then the file is not restored.       72209000
                                                                        72210000
begin                                                                   72211000
   if sm'tog or cap'am then                                             72212000
   else if fllockword' = old'lockword', (file'part'size) then           72213000
   else if look'lock'  = old'lockword', (file'part'size) then           72213100
   else if old'lockword' = " " then                                     72214000
   else                                                                 72214100
      begin                                                             72215000
      sendmessage (rs'lockwords'different);                             72216000
      sendmessage (rs'mess'disc'lockword,,,mess');                      72216100
      scan mess' until 0, 1;                                            72216200
      len := tos - @mess';                                              72216300
      mess' (len) := " ";                                               72216400
      standard'to'display (curr'title',mess'(len+1),errcode,title'len); 72217000
      len := len + title'len + 1;                                       72218000
      mess' (len) := "?";                                               72219000
      len := len + 1;                                                   72220000
      if freply (mess', len) = false then                               72221000
         ret (m'lockword'viol)                                          72222000
      else if mess' <> old'lockword', (file'part'size) then             72223000
         ret (m'lockword'viol);                                         72224000
      end;                                                              72225000
                                                                        72225300
$if x1=on then                                                          72226000
   if debugging then                                                    72227000
      begin                                                             72228000
      say "   OLD LOCKWORD OK" endsay;                                  72229000
      send;                                                             72230000
      end;                                                              72231000
$if                                                                     72232000
end;                                                                    72233000
$page "ADJUST'SECTORS of HIDE'OLD'COPY"                                 72234000
<<---------------------------------------->>                            72235000
<<  adjust'sectors of hide'old'copy       >>                            72236000
<<---------------------------------------->>                            72237000
                                                                        72238000
subroutine adjust'sectors;                                              72239000
                                                                        72240000
   ! this routine adjusts the disc sector counts for the group and acct.72241000
                                                                        72242000
begin                                                                   72243000
                                                                        72244000
   disable'arithmetic'traps;                                            72245000
                                                                        72246000
   dr := direcadjust (file'max'sectors - old'sectors,                   72247000
                      parms'tempi'1, res'acct, res'group, pvmvtabx);    72248000
                                                                        72249000
   if <> then ret (directory'error (dr));                               72250000
                                                                        72251000
   enable'arithmetic'traps;                                             72252000
                                                                        72253000
end;                                                                    72254000
$page "HIDE'OLD'COPY - DOES'OLD'COPY'EXIST"                             72255000
<<-------------------------------------->>                              72256000
<< does'old'copy'exist of hide'old'copy >>                              72257000
<<-------------------------------------->>                              72258000
                                                                        72259000
logical subroutine does'old'copy'exist;                                 72260000
                                                                        72261000
   ! boolean routine determining whether or not a disc file exists      72262000
   ! if the file exists then the global variables old'address,          72263000
   ! old'ldev, g'security, and a'security are set.                      72264000
                                                                        72265000
begin                                                                   72266000
                                                                        72267000
$if x1=on then                 <<debugging code>>                       72268000
   if debugging then                                                    72269000
      begin                                                             72270000
      say "   ENTERING DOES'OLD'COPY'EXIST" endsay;                     72271000
      send;                                                             72272000
      end;                                                              72273000
$if                                                                     72274000
   old'ldev := 0;                                                       72275000
   does'old'copy'exist := false;                                        72276000
                                                                        72277000
   disable'arithmetic'traps;                                            72278000
                                                                        72279000
   type := 2;   <<start at file level - go to file level>>              72280000
                                                                        72281000
   dr := direcfindfile (filelevel, file'index'ptr,res'acct, res'group,  72282000
                        res'file, file'ntry, pvmvtabx );                72283000
                                                                        72284000
   if <> then                                                           72285000
      begin                                                             72286000
      enable'arithmetic'traps;                                          72287000
                                                                        72288000
      if dra <> 2 then ret (rs'dir'find'old)                            72289000
      else if drb=acctlevel and not create'acct'flag then               72290000
         ret (m'no'acct)                                                72291000
      else if drb=grouplevel and not create'group'flag then             72292000
         ret (m'no'group)                                               72293000
      else if drb=filelevel then does'old'copy'exist := false           72294000
      else ret (rs'dir'find'old);                                       72295000
      end                                                               72296000
                                                                        72297000
   else                                                                 72298000
      begin                                                             72299000
      enable'arithmetic'traps;                                          72300000
                                                                        72301000
      does'old'copy'exist := true;                                      72302000
      old'address := file'ntry'address;                                 72303000
      old'ldev := lun (old'addr'1.(00:08), pvmvtabx);                   72304000
      old'addr'1.(00:08) := 0;                                          72305000
      g'security := file'ntry'group'sec;                                72306000
      a'security := file'ntry'acct'sec;                                 72307000
      end;                                                              72308000
                                                                        72309000
$if x1=on then                <<debugging code>>                        72310000
   if debugging then                                                    72311000
      begin                                                             72312000
      send;                                                             72313000
      if old'ldev = 0 then say "      OLD COPY DOESN'T EXIST" endsay    72314000
      else                                                              72315000
         begin                                                          72316000
         say "      OLD COPY EXISTS" endsay;                            72317000
         send;                                                          72318000
         say "         OLD'LDEV = " endsay;                             72319000
         saynum (old'ldev);                                             72320000
         send;                                                          72321000
         say "         OLD'ADDR = %" endsay;                            72322000
         saydoctal(old'address);                                        72323000
         end;                                                           72324000
      send;                                                             72325000
      end;                                                              72326000
$if                                                                     72327000
                                                                        72328000
end <<does'old'copy'exist of hide'old'copy>>;                           72329000
$page "LOCK'OLD'COPY, WRITE'ACCESS'CHECK and ASSERT'NOT'BUSY",&         72330000
$     " OF HIDE'OLD'COPY"                                               72331000
<<---------------------------------------->>                            72332000
<<  lock'old'file of hide'old'copy        >>                            72333000
<<---------------------------------------->>                            72334000
                                                                        72335000
subroutine lock'old'file;                                               72336000
                                                                        72337000
   ! locks the file by setting the storerestore bits and writing to disc72338000
                                                                        72339000
begin                                                                   72340000
   old'flstorerestore := restore'lockv;                                 72341000
   eval'return (labelio (old'flab, old'ldev, old'address, attio'write,  72342000
                         res'title));                                   72343000
   file'locked := true;                                                 72344000
                                                                        72345000
$if x1=on then                                                          72346000
   if debugging then                                                    72347000
      begin                                                             72348000
      say "   OLD FILE LOCKED" endsay;                                  72349000
      send;                                                             72350000
      end;                                                              72351000
$if                                                                     72352000
                                                                        72353000
end;                                                                    72354000
                                                                        72355000
                                                                        72356000
                                                                        72357000
<<---------------------------------------->>                            72358000
<<  write'access'check of hide'old'copy   >>                            72359000
<<---------------------------------------->>                            72360000
                                                                        72361000
subroutine write'access'check;                                          72362000
                                                                        72363000
   ! this routine checks to see if the user has purge access to the     72364000
   ! file.  if the user does not have purge access to the file then     72365000
   ! the file cannot be restored.                                       72366000
                                                                        72367000
begin                                                                   72368000
   if old'secure and                                                    72369000
      not acccheck (filelevel, res'acct', a'security,                   72370000
                    res'group', g'security,                             72371000
                    res'creator, old'flsecmx    ).(writef) then         72372000
         ret (m'cant'purge'disc'file);                                  72373000
                                                                        72374000
$if x1=on then                                                          72375000
   if debugging then                                                    72376000
      begin                                                             72377000
      say "   WRITE'ACCESS'OK" endsay;                                  72378000
      send;                                                             72379000
      end;                                                              72380000
$if                                                                     72381000
end;                                                                    72382000
                                                                        72383000
                                                                        72384000
                                                                        72385000
<<---------------------------------------->>                            72386000
<<  assert'not'busy of hide'old'copy      >>                            72387000
<<---------------------------------------->>                            72388000
                                                                        72389000
subroutine assert'not'busy;                                             72390000
                                                                        72391000
   ! checks to see if the file is busy. a busy file is one that is      72392000
   ! being stored or restored by another process, a file that is        72393000
   ! loaded, a file that is open for read and/or write access, or       72394000
   ! a file that is being accessed exclusively.                         72395000
                                                                        72396000
begin                                                                   72397000
   if old'flclid = cold'load'id then                                    72398000
      if old'flsrlx <> 0 or old'flrw <> 0 then                          72399000
         begin                                                          72400000
         if old'flstorerestore = store'lockv then ret (m'open'for'store)72401000
         else if old'flstorerestore = restore'lockv then                72402000
            ret (m'open'for'restore)                                    72403000
         else if old'loaded then                                        72404000
            ret (m'loaded)                                              72405000
         else if old'reading then                                       72406000
            ret (m'open'for'read)                                       72407000
         else if old'writing then                                       72408000
            ret (m'open'for'write)                                      72409000
         else if old'rw then                                            72410000
            ret (m'open'for'rw)                                         72411000
         else if old'excl'acc then                                      72412000
            ret (m'file'excl'acc);                                      72413000
         end;                                                           72414000
                                                                        72415000
$if x1=on then                                                          72416000
   if debugging then                                                    72417000
      begin                                                             72418000
      say "   OLD FILE IS NOT BUSY" endsay;                             72419000
      send;                                                             72420000
      end;                                                              72421000
$if                                                                     72422000
                                                                        72423000
end;                                                                    72424000
$page "GET'OLD'FILE'SIZE of HIDE'OF'COPY"                               72425000
<<---------------------------------------->>                            72426000
<<  get'old'file'size of hide'of'copy     >>                            72427000
<<---------------------------------------->>                            72428000
                                                                        72429000
subroutine get'old'file'size;                                           72430000
                                                                        72431000
   ! finds the size of the file to be purged, so that the adjustment    72432000
   ! to the group and acct disc space used can be made.                 72433000
                                                                        72434000
begin                                                                   72435000
                                                                        72436000
   i := -1;                                                             72437000
                                                                        72438000
   old'sectors := 0d;                                                   72439000
                                                                        72440000
   while (i:=i+1) < old'numexts do                                      72441000
      if old'extmap'd (i) <> 0d then                                    72442000
         old'sectors := old'sectors + old'extsize'd;                    72443000
                                                                        72444000
   if old'extmap'd (old'numexts) <> 0d then                             72445000
      old'sectors := old'sectors + old'lastextsiz'd;                    72446000
                                                                        72447000
$if x1=on then                                                          72448000
   if debugging then                                                    72449000
      begin                                                             72450000
      say "   OLD'SECTORS = " endsay;                                   72451000
      saydnum (old'sectors);                                            72452000
      send;                                                             72453000
      end;                                                              72454000
$if                                                                     72455000
                                                                        72456000
end;                                                                    72457000
$page "HIDE'OLD'COPY - mainline"                                        72458000
$if x1=on then                <<debugging code>>                        72459000
   if debugging then                                                    72460000
      begin                                                             72461000
      say "ENTERING HIDE'OLD'COPY" endsay;                              72462000
      send;                                                             72463000
      end;                                                              72464000
$if                                                                     72465000
                                                                        72466000
   get'sirs (true, true);                                               72467000
                                                                        72468000
   old'copy'exists := does'old'copy'exist;                              72469000
                                                                        72470000
   if old'copy'exists then                                              72471000
      begin                                                             72472000
                                                                        72473000
      if keep'flag then ret(m'keep'old'copy);                           72474000
      eval'return (labelio (old'flab, old'ldev, old'address, attio'read,72475000
                            res'title));                                72476000
      assert'not'busy;                                                  72477000
      lock'old'file;                                                    72478000
      release'sirs (true, true);                                        72479000
      write'access'check;                                               72480000
      file'code'check;                                                  72481000
      old'lockword'check;                                               72482000
      get'old'file'size;                                                72483000
      adjust'sectors;                                                   72484000
      end;                                                              72485000
                                                                        72486000
end'proc:                                                               72487000
   release'sirs (true, true);                                           72488000
                                                                        72489000
$if x1=on then                <<debugging code>>                        72490000
   if debugging then                                                    72491000
      begin                                                             72492000
      say "LEAVING HIDE'OLD'COPY" endsay;                               72493000
      send;                                                             72494000
      send;                                                             72495000
      end;                                                              72496000
$if                                                                     72497000
                                                                        72498000
                                                                        72499000
end <<hide'old'copy>>;                                                  72500000
$page "WAIT'FOR'ALL'ATTIO"                                              72501000
$control segment=restore                                                72502000
<<---------------------------------------->>                            72503000
<<  wait'for'all'attio                    >>                            72504000
<<---------------------------------------->>                            72505000
                                                                        72506000
integer procedure wait'for'all'attio;                                   72507000
                                                                        72508000
   ! this procedure clears all outstanding io.  the return value is     72509000
   ! the status of any of the ios which is not attio'good.  if there    72510000
   ! is more than one that did not return attio'good then the first     72511000
   ! one is returned.  if all ios return attio'good then the return     72512000
   ! value is attio'good.                                               72513000
                                                                        72514000
begin                                                                   72515000
                                                                        72516000
   double                                                               72517000
      io'ret;                                                           72518000
                                                                        72519000
   integer                                                              72520000
      cbuff,                                                            72521000
      curr'status      := attio'good,                                   72522000
      i,                                                                72523000
      io'ret'1         =  io'ret,                                       72524000
      io'ret'2         =  io'ret + 1;                                   72525000
                                                                        72526000
   define                                                               72527000
      attio'status     =  io'ret'1.attio'statusf #;                     72528000
                                                                        72529000
   if not using'attio then                                              72530000
      return;                                                           72531000
                                                                        72532000
   cbuff := curr'read'buffer;                                           72533000
   i := -1;                                                             72534000
                                                                        72535000
   while (i:=i+1) < num'buffers do                                      72536000
      begin                                                             72537000
                                                                        72538000
      cbuff := cbuff + 1;                                               72539000
      if cbuff = num'buffers then                                       72540000
         cbuff := 0;                                                    72541000
                                                                        72542000
                                                                        72543000
      if io'queue'd (cbuff) <> 0d then                                  72544000
         begin                                                          72545000
         io'ret := waitforio (io'queue(cbuff*2));                       72546000
         outstanding'ios := outstanding'ios - 1;                        72547000
         if curr'status = attio'good then                               72548000
            curr'status := attio'status;                                72549000
         io'queue'd(cbuff) := 0d;                                       72550000
         end;                                                           72551000
                                                                        72552000
$if x1=on then                                                          72553000
      if debugging then                                                 72554000
         begin                                                          72555000
         say "IN WAIT'FOR'ALL'ATTIO LOOP - I=" endsay;                  72556000
         saynum(i);                                                     72557000
         say ";CBUFF=" endsay;                                          72558000
         saynum(cbuff);                                                 72559000
         say ";STATUS=" endsay;                                         72560000
         saynum(attio'status);                                          72561000
         send;                                                          72562000
         end;                                                           72563000
$if                                                                     72564000
      end;                                                              72565000
                                                                        72566000
      if ioq'fsf'd (0) <> 0d then                                       72567000
         begin                                                          72568000
         io'ret := waitforio (ioq'fsf (0));                             72569000
         if curr'status = attio'good then                               72570000
            curr'status := attio'status;                                72571000
         ioq'fsf'd (0) := 0d;                                           72572000
         end;                                                           72573000
                                                                        72574000
      if ioq'fsf'd (1) <> 0d then                                       72575000
         begin                                                          72576000
         io'ret := waitforio (ioq'fsf (1*2));                           72577000
         if curr'status = attio'good then                               72578000
            curr'status := attio'status;                                72579000
         ioq'fsf'd (1) := 0d;                                           72580000
         end;                                                           72581000
                                                                        72582000
$if x1=on then                                                          72583000
   if debugging then                                                    72584000
      begin                                                             72585000
      say "ALL ATTIO HAS BEEN COMPLETED-BUFNO=0-CURR'STATUS=" endsay;   72586000
      saynum (curr'status);                                             72587000
      send;                                                             72588000
      end;                                                              72589000
$if                                                                     72590000
                                                                        72591000
   curr'wait'buffer := num'buffers - 1;                                 72592000
   curr'read'buffer := 0;                                               72593000
   wait'for'all'attio := curr'status;                                   72594000
                                                                        72595000
end;                                                                    72596000
$page "READ'ALL'ATTIO"                                                  72597000
$control segment=restore                                                72598000
<<---------------------------------------->>                            72599000
<<  read'all'attio                        >>                            72600000
<<---------------------------------------->>                            72601000
                                                                        72602000
procedure read'all'attio;                                               72603000
                                                                        72604000
   ! this procedure starts reads for all of the buffers that do not     72605000
   ! have reads pending.  the current wait buffer is also not read      72606000
   ! so that it remains valid.                                          72607000
                                                                        72608000
begin                                                                   72609000
                                                                        72610000
   integer                                                              72611000
      i,                                                                72612000
      num'reads;                                                        72613000
                                                                        72614000
   i := -1;                                                             72615000
                                                                        72616000
   num'reads := num'buffers - outstanding'ios - 1;                      72617000
                                                                        72618000
   disable'arithmetic'traps;                                            72619000
                                                                        72620000
$if x1=on then                                                          72621000
   if debugging then                                                    72622000
      begin                                                             72623000
      say "ENTERING READ'ALL'ATTIO - " endsay;                          72624000
      say " #IO = " endsay;                                             72625000
      saynum (outstanding'ios);                                         72626000
      say " - " endsay;                                                 72627000
      say "READ BUF=" endsay;                                           72628000
      saynum (curr'read'buffer);                                        72629000
      say " - WAIT BUF=" endsay;                                        72630000
      saynum (curr'wait'buffer);                                        72631000
      say " - NUM READS=" endsay;                                       72632000
      saynum (num'reads);                                               72633000
      send;                                                             72634000
      end;                                                              72635000
$if                                                                     72636000
                                                                        72637000
   while ((i := i+1) < (num'reads)) do                                  72638000
      begin                                                             72639000
                                                                        72640000
$if x1=on then                                                          72641000
      if debugging then                                                 72642000
         begin                                                          72643000
         say "   IN READ'ALL'ATTIO LOOP - I=" endsay;                   72644000
         saynum(i);                                                     72645000
         say ";CURR'READ'BUFFER=" endsay;                               72646000
         saynum(curr'read'buffer);                                      72647000
         say ";XDS=" endsay;                                            72648000
         saynum(buffer'xds(curr'read'buffer));                          72649000
         say ";OFFSET=" endsay;                                         72650000
         saynum(buffer'offset(curr'read'buffer));                       72651000
         send;                                                          72652000
         end;                                                           72653000
$if                                                                     72654000
                                                                        72655000
      io'queue'd (curr'read'buffer) := attachio (                       72656000
                                  tape'ldev,                            72657000
                                  0,                                    72658000
                                  buffer'xds(curr'read'buffer),         72659000
                                  buffer'offset(curr'read'buffer),      72660000
                                  attio'read,                           72661000
                                  tape'recsize,                         72662000
                                  0,                                    72663000
                                  0,                                    72664000
                                  0                                     72665000
                                  );                                    72666000
                                                                        72667000
      outstanding'ios := outstanding'ios + 1;                           72668000
                                                                        72669000
      curr'read'buffer := curr'read'buffer + 1;                         72670000
      if curr'read'buffer = num'buffers then                            72671000
         curr'read'buffer := 0;                                         72672000
                                                                        72673000
      end;                                                              72674000
                                                                        72675000
   enable'arithmetic'traps;                                             72676000
                                                                        72677000
                                                                        72678000
$if x1=on then                                                          72679000
   if debugging then                                                    72680000
      begin                                                             72681000
      say "READ'ALL'ATTIO DONE" endsay;                                 72682000
      send;                                                             72683000
      end;                                                              72684000
$if                                                                     72685000
                                                                        72686000
end;                                                                    72687000
$page "FIND'CURR'FILENO"                                                72688000
<<---------------------------------------->>                            72689000
<<  find'curr'fileno                      >>                            72690000
<<---------------------------------------->>                            72691000
                                                                        72692000
double procedure find'curr'fileno (title, start, errnum);               72693000
   value start;                                                         72694000
   logical array title;                                                 72695000
   double start;                                                        72696000
   integer errnum;                                                      72697000
                                                                        72698000
   ! this procedure finds the offset into the directory of the file     72699000
   ! with name title.  the search begins at the offset start.  if       72700000
   ! title is not found in the directory, - (start + 1) is returned.    72701000
   !                                                                    72702000
   ! if the distance is greater than max'synch'files then it is         72703000
   ! considered not found.                                              72704000
                                                                        72705000
begin                                                                   72706000
   logical pointer                                                      72707000
      dbuf;                                                             72708000
                                                                        72709000
   logical array                                                        72710000
      buffer (0:d'blocksize-1);                                         72711000
                                                                        72712000
   byte array                                                           72713000
      title'     (*) = title;                                           72714000
                                                                        72715000
   byte pointer                                                         72716000
      dbuf';                                                            72717000
                                                                        72718000
   double                                                               72719000
      last'd'read    := -1d,                                            72720000
      retval;                                                           72721000
                                                                        72722000
   logical                                                              72723000
      stop  := false;                                                   72724000
                                                                        72725000
   integer                                                              72726000
      distance := 0;                                                    72727000
                                                                        72728000
   subroutine ret (return'val, error'val);                              72729000
      value return'val, error'val;                                      72730000
      double return'val;                                                72731000
      integer error'val;                                                72732000
   begin                                                                72733000
      retval := return'val;                                             72734000
      errnum := error'val;                                              72735000
      goto end'find'curr'fileno;                                        72736000
   end;                                                                 72737000
                                                                        72738000
   subroutine readdir (filenum, target, tcount, recnum, last'read,      72739000
                       blockfactor, buffer);                            72740000
      value filenum, tcount, recnum, blockfactor;                       72741000
      integer filenum;                                                  72742000
      logical tcount, blockfactor;                                      72743000
      logical pointer target;                                           72744000
      double recnum, last'read;                                         72745000
      logical array buffer;                                             72746000
                                                                        72747000
      ! the dir file is written out in records of blockfactor*tcount    72748000
      ! words in length.  this routine deblocks those records.          72749000
                                                                        72750000
   begin                                                                72751000
      if last'read = -1d or                                             72752000
         last'read / double (blockfactor) <>                            72753000
            recnum / double (blockfactor) then                          72754000
               begin                                                    72755000
               freaddir (filenum, buffer, blockfactor * tcount,         72756000
                         recnum / double (blockfactor));                72757000
               if = then                                                72758000
                  begin                                                 72759000
                  end                                                   72760000
               else if > then                                           72761000
                  ret (-(start+1d), 0)                                  72762000
               else if < then                                           72763000
                  ret (start, rs'fread'on'dir);                         72764000
                                                                        72765000
               end;                                                     72766000
                                                                        72767000
      @target := @buffer ((recnum modd blockfactor)*tcount);            72768000
                                                                        72769000
      last'read := recnum;                                              72770000
                                                                        72771000
      if target = 0 then                                                72772000
         ret (-(start+1d), 0);                                          72773000
   end;                                                                 72774000
                                                                        72775000
                                                                        72776000
   errnum := 0;                                                         72777000
                                                                        72778000
$if x1=on then                                                          72779000
   if debugging then                                                    72780000
      begin                                                             72781000
      say "ENTERING FIND'CURR'FILENO - TITLE = " endsay;                72782000
      say title', (24) endsay;                                          72783000
      say " - CURR'FILE'NO = %"  endsay;                                72784000
      saydnum (start);                                                  72785000
      send;                                                             72786000
      end;                                                              72787000
$if                                                                     72788000
   if last'read'was'eof then        ! last read was not valid file label72789000
      begin                                                             72790000
      if end'of'tape'set then                                           72791000
         ret (%10000000000d, 0)                                         72792000
      else                                                              72793000
         ret (-(start+1d), 0);                                          72794000
      end;                                                              72795000
                                                                        72796000
   retval := start - 1d;                                                72797000
                                                                        72798000
   do                                                                   72799000
      begin                                                             72800000
                                                                        72801000
      retval := retval + 1d;                                            72802000
      distance := distance + 1;                                         72803000
                                                                        72804000
      readdir (d'num, dbuf, d'recsize, retval, last'd'read,             72805000
               d'blockfactor, buffer);                                  72806000
                                                                        72807000
      @dbuf' := @dbuf &lsl(1);                                          72808000
                                                                        72809000
$if x1=on then                                                          72810000
      if debugging then                                                 72811000
         begin                                                          72812000
         say "                   DIR ENTRY - " endsay;                  72813000
         say dbuf', (3*file'part'size) endsay;                          72814000
         send;                                                          72815000
         end;                                                           72816000
$if                                                                     72817000
      if distance > max'synch'files then                                72818000
         ret (-(start+1d), 0);                                          72819000
      end                                                               72820000
   until stop or dbuf' = title', (3*file'part'size);                    72821000
                                                                        72822000
end'find'curr'fileno:                                                   72823000
                                                                        72824000
   find'curr'fileno := retval;                                          72825000
                                                                        72826000
$if x1=on then                                                          72827000
   if debugging then                                                    72828000
      begin                                                             72829000
      say "      RETURNS %" endsay;                                     72830000
      saydnum (retval);                                                 72831000
      send;                                                             72832000
      end;                                                              72833000
$if                                                                     72834000
end;                                                                    72835000
$page "SKIP'AND'READ'TAPE"                                              72836000
!control nolist               !list                                     72837000
<<---------------------------------------->>                            72838000
<<  skip'and'read'tape                    >>                            72839000
<<---------------------------------------->>                            72840000
                                                                        72841000
logical procedure skip'and'read'tape (tdbuf, error'level, gbuf);        72842000
   value error'level;                                                   72843000
   logical array tdbuf;                                                 72844000
   integer error'level;                                                 72845000
   integer array gbuf;                                                  72846000
                                                                        72847000
   ! this routine keeps doing file-skip-forwards until the file that is 72848000
   ! located in gbuf is found.  if we go past the file in gbuf, that    72849000
   ! file is reported as lost during resynchronization and another      72850000
   ! record is read from the good file into gbuf and the process begins 72851000
   ! again.  since skip'and'read'tape is called by read'tape and        72852000
   ! recursively by itself when a tape error occurs, error'level keeps  72853000
   ! track of the depth of the error recovery.  if that depth reaches   72854000
   ! max'error'level, then restore aborts even if error recovery is in  72855000
   ! effect.  if a reel change is necessary, it is performed.           72856000
                                                                        72857000
begin                                                                   72858000
   byte array                                                           72859000
      gbuf'    (*)         =  gbuf,                                     72860000
      tdbuf'   (*)         =  tdbuf;                                    72861000
                                                                        72862000
   double array                                                         72863000
      gbuf'd   (*)         =  gbuf;                                     72864000
                                                                        72865000
   logical                                                              72866000
      found                := false,                                    72867000
      need'an'extra'skip   := false,                                    72868000
      need'to'do'find      := false,                                    72869000
      used'error'recovery  := false;                                    72870000
                                                                        72871000
   double                                                               72872000
      num'skips            := 0d;                                       72873000
                                                                        72874000
   label                                                                72875000
      start'again,                                                      72876000
      end'proc;                                                         72877000
                                                                        72878000
<<---------------------------------------->>                            72879000
<<  eval'return of skip'and'read'tape     >>                            72880000
<<---------------------------------------->>                            72881000
                                                                        72882000
subroutine eval'return (retcode);                                       72883000
   value retcode;                                                       72884000
   integer retcode;                                                     72885000
begin                                                                   72886000
   if retcode <> 0 then                                                 72887000
      begin                                                             72888000
      if retcode > 0 then sendmessage (retcode);                        72889000
      goto end'proc;                                                    72890000
      end;                                                              72891000
end;                                                                    72892000
                                                                        72893000
                                                                        72894000
<<---------------------------------------->>                            72895000
<<  file'fail of skip'and'read'tape       >>                            72896000
<<---------------------------------------->>                            72897000
                                                                        72898000
subroutine file'fail (fid, msgno);                                      72899000
   value fid, msgno;                                                    72900000
   integer fid, msgno;                                                  72901000
begin                                                                   72902000
   if fid <> 0 then print'file'error (fid);                             72903000
   if msgno <> 0 then sendmessage (msgno);                              72904000
   goto end'proc;                                                       72905000
end;                                                                    72906000
$page "RECOVER'ERROR of SKIP'AND'READ'TAPE"                             72907000
<<---------------------------------------->>                            72908000
<<  recover'error of skip'and'read'tape   >>                            72909000
<<---------------------------------------->>                            72910000
                                                                        72911000
subroutine recover'error (msgno);                                       72912000
   value msgno;                                                         72913000
   integer msgno;                                                       72914000
                                                                        72915000
   ! this routine performs error recovery for  skip'and'read'tape.  if  72916000
   ! a tape error occurs then a message is sent out and restore tells   72917000
   ! you whether or not it will do error recovery.  if it is doing      72918000
   ! error recovery then it just starts all over again, looking for     72919000
   ! the correct file.                                                  72920000
                                                                        72921000
begin                                                                   72922000
   sendmessage (msgno);                                                 72923000
                                                                        72924000
   if error'level = max'error'level then                                72925000
      begin                                                             72926000
      sendmessage (rs'error'level'too'deep);                            72927000
      skip'and'read'tape := failed;                                     72928000
      goto end'proc;                                                    72929000
      end                                                               72930000
   else if on'err = onerr'quit then                                     72931000
      begin                                                             72932000
      sendmessage (rs'onerr'quit);                                      72933000
      skip'and'read'tape := failed;                                     72934000
      goto end'proc;                                                    72935000
      end                                                               72936000
   else if on'err = onerr'skipfile then                                 72937000
      begin                                                             72938000
      sendmessage (rs'onerr'skipfile);                                  72939000
recover'skipfile:                                                       72940000
      used'error'recovery := true;                                      72941000
      skip'and'read'tape := good'skipfile;                              72942000
      goto start'again;                                                 72943000
      end                                                               72944000
   else if on'err = onerr'skiprecord then                               72945000
      begin                                                             72946000
      sendmessage (rs'onerr'skiprecord);                                72947000
      goto recover'skipfile;                                            72948000
      end;                                                              72949000
end;                                                                    72950000
$page "SKIP'UNLABELED"                                                  72951000
<<---------------------------------------->>                            72952000
<<  skip'unlabeled of skip'and'read'tape  >>                            72953000
<<---------------------------------------->>                            72954000
                                                                        72955000
subroutine skip'unlabeled;                                              72956000
begin                                                                   72957000
   found := false;                                                      72958000
                                                                        72959000
   if end'of'tape'set then                                              72960000
      begin                                                             72961000
      last'read'was'eof := true;                                        72962000
      return;                                                           72963000
      end;                                                              72964000
                                                                        72965000
   do                                                                   72966000
      begin                                                             72967000
                                                                        72968000
      num'skips := gbuf'd (g'filenum'inx'd) - curr'fileno;              72969000
      if need'an'extra'skip then num'skips := num'skips + 1d;           72970000
                                                                        72971000
      if using'attio then                                               72972000
         begin                                                          72973000
         found := pre'scan'for'match (tdbuf, gbuf, read'tape'len,       72974000
                                      error'code, num'skips);           72975000
         if error'code = -1 then                                        72976000
            eval'return (-1)                                            72977000
                                                                        72978000
         else if error'code <> 0 then                                   72979000
            recover'error (rs'io'read'unlab);                           72980000
                                                                        72981000
         if num'skips > 0d then                                         72982000
            begin                                                       72983000
            start'a'skip;                                               72984000
            start'a'read (tape'recsize);                                72985000
            end;                                                        72986000
         end;                                                           72987000
                                                                        72988000
      while (num'skips := num'skips - 1d) >= 0d do                      72989000
         begin                                                          72990000
                                                                        72991000
$if x1=on then                                                          72992000
         if debugging then                                              72993000
            begin                                                       72994000
            say "IN SKIP'UNLABELED-PERFORMING SKIP-NUM'SKIPS =" endsay; 72995000
            saydnum (num'skips);                                        72996000
            send;                                                       72997000
            end;                                                        72998000
$if                                                                     72999000
         if using'attio and num'skips > 0d then                         73000000
            begin                                                       73001000
            start'a'skip;                                               73002000
            start'a'read (tape'recsize);                                73003000
            end;                                                        73004000
                                                                        73005000
         issue'skip (false);                                            73006000
         if error'code <> 0 then                                        73007000
            recover'error (rs'io'skip'unlab);                           73008000
                                                                        73009000
         issue'read (tdbuf, tape'recsize, false);                       73010000
                                                                        73011000
         move'to'tdbuf;                                                 73012000
                                                                        73013000
         if read'tape'eof then                                          73014000
            recover'error (rs'2'eofs)                                   73015000
                                                                        73016000
         else if error'code <> 0 then                                   73017000
            recover'error (rs'io'read'unlab)                            73018000
                                                                        73019000
         else if read'tape'len = tape'label'size then                   73020000
            begin                                                       73021000
            check'tape'label (tdbuf);                                   73022000
            if last'reel then end'of'tape'set := true                   73023000
            else                                                        73024000
               eval'return (                                            73025000
                  get'next'volume (gbuf'd (g'filenum'inx'd), num'skips) 73026000
                           );                                           73027000
                                                                        73028000
            if num'skips = 0d then found := true                        73029000
            else                                                        73030000
               begin                                                    73031000
               start'a'skip;                                            73032000
               start'a'read (tape'recsize);                             73033000
               end;                                                     73034000
                                                                        73035000
            end                                                         73036000
                                                                        73037000
         else if tdbuf' = gbuf' (g'title'inx'), (3*file'part'size) then 73038000
            begin                                                       73039000
            found := true;                                              73040000
            if using'attio and num'skips <> 0d then                     73041000
               begin                                                    73042000
               issue'skip (false);              ! wait for skip         73043000
               if error'code <> 0 then recover'error (rs'backing'up);   73044000
                                                                        73045000
               issue'read (tdbuf, tape'recsize, false);  ! wait for read73046000
               if error'code <> 0 then recover'error (rs'backing'up);   73047000
                                                                        73048000
               issue'ctrl (attio'bsr);          ! reverse read          73049000
               if error'code <> 0 then recover'error (rs'backing'up);   73050000
                                                                        73051000
               issue'ctrl (attio'bsf);          ! reverse skip          73052000
               if error'code <> 0 then recover'error (rs'backing'up);   73053000
                                                                        73054000
               issue'skip (true);               ! pass the tape mark    73055000
               if error'code <> 0 then recover'error (rs'backing'up);   73056000
                                                                        73057000
               start'a'read (tape'recsize);     ! start a new read      73058000
               if error'code <> 0 then recover'error (rs'backing'up);   73059000
                                                                        73060000
               issue'read (tdbuf, tape'recsize, false);  ! should match 73061000
               if error'code <> 0 then recover'error (rs'backing'up);   73062000
                                                                        73063000
               if tdbuf' = gbuf' (g'file'inx'), (3*file'part'size) then 73064000
                  recover'error (rs'backing'up);                        73065000
               end;                                                     73066000
            num'skips := 0d;                                            73067000
            end                                                         73068000
                                                                        73069000
         end;                                                           73070000
                                                                        73071000
      if not found then                                                 73072000
         begin                                                          73073000
                                                                        73074000
         curr'fileno := find'curr'fileno (tdbuf, curr'fileno,           73075000
                                          parms'tempi'1 );              73076000
                                                                        73077000
         if curr'fileno < 0d then                                       73078000
            begin                                                       73079000
            curr'fileno := -curr'fileno - 1d;                           73080000
            need'an'extra'skip := true;                                 73081000
            end                                                         73082000
         else                                                           73083000
            begin                                                       73084000
            need'an'extra'skip := false;                                73085000
            if gbuf'd (g'filenum'inx'd) = curr'fileno then              73086000
               found := true;                                           73087000
            end;                                                        73088000
                                                                        73089000
         eval'return (parms'tempi'1);                                   73090000
                                                                        73091000
         while not found and (gbuf'd (g'filenum'inx'd) < curr'fileno) do73092000
            begin                                                       73093000
                                                                        73094000
            failed'file'count := failed'file'count + 1d;                73095000
                                                                        73096000
            sendmessage (m'synchronizing);                              73097000
                                                                        73098000
            read'good'file;                                             73099000
            if > then                                                   73100000
               begin                                                    73101000
               curr'fileno := -1d;                                      73102000
               found := true;                                           73103000
               end;                                                     73104000
                                                                        73105000
            if display'3'to'standard (                                  73106000
                     gbuf'(g'file'inx'),                                73107000
                     gbuf'(g'group'inx'),                               73108000
                     gbuf'(g'acct'inx'),                                73109000
                     curr'title',                                       73110000
                     error'code  )                                      73111000
                  = failed then                                         73112000
               file'fail (0, sr'd'2's'failed);     <<d'3'to's failed>>  73113000
                                                                        73114000
            if (gbuf'd (g'filenum'inx'd) - curr'fileno) = 0d and        73115000
               not need'an'extra'skip then                              73116000
                  found := true;                                        73117000
            end;                                                        73118000
         end;                                                           73119000
      end                                                               73120000
   until found;                                                         73121000
                                                                        73122000
!  if using'attio then read'all'attio;                                  73123000
                                                                        73124000
end;                                                                    73125000
$page "SKIP'AND'READ'TAPE mainline"                                     73126000
                                                                        73127000
$if x1=on then                                                          73128000
   if debugging then                                                    73129000
      begin                                                             73130000
      say "ENTERING SKIP'AND'READ'TAPE - CURR'FILENO=" endsay;          73131000
      saydnum (curr'fileno);                                            73132000
      say "-GBUF FILENO=" endsay;                                       73133000
      saydnum (gbuf'd(g'filenum'inx'd));                                73134000
      send;                                                             73135000
      end;                                                              73136000
$if                                                                     73137000
                                                                        73138000
   skip'and'read'tape := good;                                          73139000
   used'error'recovery := false;                                        73140000
                                                                        73141000
   error'level := error'level - 1;                                      73142000
start'again:                                                            73143000
   error'level := error'level + 1;                                      73144000
                                                                        73145000
   if using'attio then skip'unlabeled !help                             73146000
   else if labeled then skip'unlabeled                                  73147000
   else skip'unlabeled;                                                 73148000
                                                                        73149000
                                                                        73150000
                                                                        73151000
$if x1=on then                                                          73152000
   if debugging then                                                    73153000
      begin                                                             73154000
      say "DONE WITH SKIP'AND'READ'TAPE " endsay;                       73155000
      if used'error'recovery then say "**USED ERROR RECOVERY**" endsay; 73156000
      if last'read'was'eof then say "**EOF FOUND**" endsay;             73157000
      if end'of'tape'set then say "**END OF TAPE SET**" endsay;         73158000
      send;                                                             73159000
      if not last'read'was'eof then                                     73160000
         begin                                                          73161000
         say "FIRST 40 CHARACTERS = '" endsay;                          73162000
         if using'attio then                                            73163000
            move'data'in (buffer'xds (curr'wait'buffer),                73164000
                          buffer'offset (curr'wait'buffer),             73165000
                          tdbuf, 20);                                   73166000
         say tdbuf', (40) endsay;                                       73167000
         say1 ("'");                                                    73168000
         send;                                                          73169000
         end;                                                           73170000
      end;                                                              73171000
$if                                                                     73172000
                                                                        73173000
end'proc:                                                               73174000
                                                                        73175000
end;                                                                    73176000
$page "READ'TAPE"                                                       73177000
<<---------------------------------------->>                            73178000
<<  read'tape                             >>                            73179000
<<---------------------------------------->>                            73180000
                                                                        73181000
logical procedure read'tape (tdbuf, gbuf);                              73182000
   integer array tdbuf,gbuf;                                            73183000
                                                                        73184000
   ! this procedure does a logical read from the tape.  the difference  73185000
   ! between this procedure and issue'read is that issue'read only does 73186000
   ! the read.  issue'read just returns error codes, eof flags and data.73187000
   ! read'tape inteprets this information and does reel switching, and  73188000
   ! error recovery.                                                    73189000
   !                                                                    73190000
   ! whenever read'tape finds a tape mark (on an unlabeled tape), the   73191000
   ! next record has to be checked to insure that this is a true end    73192000
   ! of file marker and not just an end of reel marker (with            73193000
   ! continuation on the next reel.                                     73194000
   !                                                                    73195000
   ! the length of the read is returned in read'tape'len.  if the last  73196000
   ! read was an eof then last'read'was'eof is true.  data is placed    73197000
   ! in either tdbuf or into the buffer pointed to by curr'wait'buffer. 73198000
   ! if last'read'was'eof and the next record was already read then     73199000
   ! read'was'already'done is set to true.                              73200000
                                                                        73201000
begin                                                                   73202000
                                                                        73203000
   byte array tdbuf' (*) = tdbuf;                                       73204000
                                                                        73205000
   logical used'error'recovery := false;                                73206000
   integer error'level         := 0;                                    73207000
                                                                        73208000
<<---------------------------------------->>                            73209000
<<  fail of read'tape                     >>                            73210000
<<---------------------------------------->>                            73211000
                                                                        73212000
subroutine fail;                                                        73213000
begin                                                                   73214000
   read'tape := failed;                                                 73215000
   goto end'proc;                                                       73216000
end;                                                                    73217000
$page "RECOVER'ERROR of READ'TAPE"                                      73218000
<<---------------------------------------->>                            73219000
<<  recover'error of read'tape            >>                            73220000
<<---------------------------------------->>                            73221000
                                                                        73222000
subroutine recover'error(msgno);                                        73223000
   value msgno;                                                         73224000
   integer msgno;                                                       73225000
begin                                                                   73226000
   sendmessage (msgno);                                                 73227000
                                                                        73228000
   if on'err = onerr'quit then                                          73229000
      begin                                                             73230000
      sendmessage (rs'onerr'quit);                                      73231000
      read'tape := failed;                                              73232000
      goto end'proc;                                                    73233000
      end                                                               73234000
                                                                        73235000
   else if on'err = onerr'skipfile then                                 73236000
      begin                                                             73237000
                                                                        73238000
      sendmessage (rs'onerr'skipfile);                                  73239000
                                                                        73240000
recover'skipfile:                                                       73241000
                                                                        73242000
      error'level := error'level + 1;                                   73243000
      used'error'recovery := true;                                      73244000
      read'tape := good'skipfile;                                       73245000
                                                                        73246000
      parms'tempi'1 := look'for'eof (gbuf, false);                      73247000
      if parms'tempi'1 = -1 then                                        73248000
         fail                                                           73249000
      else if parms'tempi'1 <> attio'eof then                           73250000
         issue'skip (true);                                             73251000
                                                                        73252000
      eof'read := true;                                                 73253000
                                                                        73254000
      if error'code <> 0 then                                           73255000
         if error'level <= max'error'level then                         73256000
            goto recover'skipfile                                       73257000
         else                                                           73258000
            begin                                                       73259000
            sendmessage (rs'error'level'too'deep);                      73260000
            read'tape := failed;                                        73261000
            goto end'proc;                                              73262000
            end;                                                        73263000
                                                                        73264000
!     read'tape := skip'and'read'tape (tdbuf, 1, gbuf);  !fix           73265000
      end                                                               73266000
                                                                        73267000
   else if on'err = onerr'skiprecord then                               73268000
      begin                                                             73269000
      sendmessage (rs'onerr'skiprecord);                                73270000
      goto recover'skipfile;                                            73271000
      end;                                                              73272000
end;                                                                    73273000
$page "READ'LABELED'TAPE of READ'TAPE"                                  73274000
<<---------------------------------------->>                            73275000
<<  read'labeled'tape of read'tape        >>                            73276000
<<---------------------------------------->>                            73277000
                                                                        73278000
subroutine read'labeled'tape;                                           73279000
begin                                                                   73280000
   issue'read (tdbuf, tape'recsize, false);                             73281000
                                                                        73282000
   if error'code <> 0 then                                              73283000
      recover'error (rs'io'read'lab)                                    73284000
                                                                        73285000
   else if read'tape'eof then                                           73286000
      begin                                                             73287000
      last'read'was'eof := true;                                        73288000
                                                                        73289000
new'tape:                                                               73290000
                                                                        73291000
      error'code := nexttapefile (t'num);                               73292000
                                                                        73293000
      if <> then                                                        73294000
         begin                                                          73295000
                                                                        73296000
         if error'code = fs'lab'end'of'volume'set then                  73297000
            end'of'tape'set := true                                     73298000
         else if error'code = fs'dev'unavail then                       73299000
            recover'error (rs'operator'reject)                          73300000
         else                                                           73301000
            recover'error (rs'nexttapefile);                            73302000
                                                                        73303000
         end                                                            73304000
                                                                        73305000
      else if lrelsw (t'num) then                                       73306000
         goto new'tape;                                                 73307000
      end                                                               73308000
                                                                        73309000
   else                                                                 73310000
      last'read'was'eof := false;                                       73311000
                                                                        73312000
end;                                                                    73313000
$page "READ'UNLABELED'TAPE of READ'TAPE"                                73314000
<<---------------------------------------->>                            73315000
<<  read'unlabeled'tape of read'tape      >>                            73316000
<<---------------------------------------->>                            73317000
                                                                        73318000
subroutine read'unlabeled'tape;                                         73319000
begin                                                                   73320000
   if end'of'tape'set then                                              73321000
      begin                                                             73322000
      last'read'was'eof := true;                                        73323000
      return;                                                           73324000
      end;                                                              73325000
                                                                        73326000
   last'read'was'eof := false;                                          73327000
                                                                        73328000
   if read'was'already'done then                                        73329000
      begin                                                             73330000
      read'was'already'done := false;                                   73331000
      return;                                                           73332000
      end;                                                              73333000
                                                                        73334000
   issue'read (tdbuf, tape'recsize, false);                             73335000
   if error'code <> 0 then recover'error (rs'io'read'unlab)             73336000
   else if read'tape'len = tape'label'size then goto t'label'read       73337000
   else if read'tape'eof then                                           73338000
      begin                                                             73339000
      if using'attio then start'a'read (tape'recsize);                  73340000
                                                                        73341000
      last'read'was'eof := true;                                        73342000
                                                                        73343000
      issue'read (tdbuf, tape'recsize, false);                          73344000
                                                                        73345000
      if read'tape'eof then recover'error (rs'2'eofs)                   73346000
      else if error'code<>0 then recover'error (rs'io'read'unlab)       73347000
      else if read'tape'len = tape'label'size then                      73348000
         begin                                                          73349000
                                                                        73350000
t'label'read:                                                           73351000
                                                                        73352000
         check'tape'label (tdbuf);                                      73353000
         if last'reel then                                              73354000
            begin                                                       73355000
            last'read'was'eof := true;                                  73356000
            end'of'tape'set := true;                                    73357000
            end                                                         73358000
         else                                                           73359000
            begin                                                       73360000
            last'read'was'eof := tl'xfield;                             73361000
            if get'next'volume (0d, parms'tempd'1) <> 0 then fail;      73362000
            if last'read'was'eof then                                   73363000
               start'a'read (tape'recsize)                              73364000
            else                                                        73365000
               read'all'attio;                                          73366000
            read'was'already'done := false;                             73367000
            issue'read (tdbuf, tape'recsize, false);                    73368000
            if read'tape'eof then recover'error (rs'2'eofs)             73369000
            else if error'code<>0 then recover'error (rs'io'read'unlab) 73370000
            else read'was'already'done := last'read'was'eof;            73371000
            end;                                                        73372000
         end                                                            73373000
      else                                                              73374000
         begin                                                          73375000
         read'was'already'done := true;                                 73376000
         start'a'read (tape'recsize);                                   73377000
         end;                                                           73378000
      end                                                               73379000
   else                                                                 73380000
      start'a'read (tape'recsize);                                      73381000
end;                                                                    73382000
$page "READ'TAPE mainline"                                              73383000
   read'tape := good;                                                   73384000
                                                                        73385000
   if using'attio then read'unlabeled'tape !help! read'attio'tape       73386000
   else if labeled then read'labeled'tape                               73387000
   else read'unlabeled'tape;                                            73388000
                                                                        73389000
   if last'read'was'eof and not used'error'recovery then                73390000
      curr'fileno := curr'fileno + 1d;                                  73391000
                                                                        73392000
   if used'error'recovery then                                          73393000
      begin                                                             73394000
      last'read'was'eof := true;                                        73395000
!     read'was'already'done := true;     !fix                           73396000
      end;                                                              73397000
                                                                        73398000
$if x1=on then                                                          73399000
   if debugging then                                                    73400000
      begin                                                             73401000
      say "DONE WITH READ'TAPE " endsay;                                73402000
      if used'error'recovery then say "**USED ERROR RECOVERY**" endsay; 73403000
      if last'read'was'eof then say "**EOF FOUND**" endsay;             73404000
      if end'of'tape'set then say "**END OF TAPE SET**" endsay;         73405000
      send;                                                             73406000
      if not last'read'was'eof then                                     73407000
         begin                                                          73408000
         say "FIRST 40 CHARACTERS = '" endsay;                          73409000
         if using'attio then                                            73410000
            move'data'in (buffer'xds (curr'wait'buffer),                73411000
                          buffer'offset (curr'wait'buffer),             73412000
                          tdbuf, 20);                                   73413000
         say tdbuf', (40) endsay;                                       73414000
         say1 ("'");                                                    73415000
         send;                                                          73416000
         end;                                                           73417000
      end;                                                              73418000
$if                                                                     73419000
                                                                        73420000
end'proc:                                                               73421000
                                                                        73422000
end;                                                                    73423000
$page "CHECK'DIREC"                                                     73424000
$page "CHECK'USER"                                                      73425000
$control segment=restore                                                73426000
<<---------------------------------------->>                            73427000
<<  check'user                           >>                             73428000
<<---------------------------------------->>                            73429000
                                                                        73430000
logical procedure check'user(acctname,username,errcode);                73431000
   byte array                                                           73432000
      acctname,                                   ! account name        73433000
      username;                                   ! user name           73434000
   integer errcode;                               ! error code          73435000
                                                                        73436000
   ! this procedure can be used to determine whether or not an          73437000
   ! user is in the directory.  if the entry                            73438000
   ! exists then true is returned.  if the entry doesn't exist          73439000
   ! then false is returned and the reason is placed into errcode.      73440000
   !                                                                    73441000
   ! if the entry does not exist and the create parameter was specified 73442000
   ! then this procedure will try to create the directory entry with    73443000
   ! the command newuser.  all default values are                       73444000
   ! used.                                                              73445000
                                                                        73446000
begin                                                                   73447000
                                                                        73448000
   integer                                                              73449000
      com'error,                                                        73450000
      com'parm,                                                         73451000
      type      := 0;                             ! level for direcfind 73452000
                                                                        73453000
   logical                                                              73454000
      continue  := false,                                               73455000
      ret = check'user;         <<debugging code>>                      73456000
                                                                        73457000
   logical array                                                        73458000
      dummy'ntry(0:20),                                                 73459000
      dummy'l(0:3),                               ! dummy string        73460000
      acctname'l(*) = acctname,                   ! account name        73461000
      username'l(*) = username;                   ! user name           73462000
                                                                        73463000
   logical array ntry'user  (0:9) = pb :=                               73464000
      "NEWUSER   ", "        ", %006415;                                73465000
                                                                        73466000
   double dr; integer dra = dr+ 1, drb = dr + 0; ! direcfind return     73467000
                                                                        73468000
$if x1=on then                <<debugging code>>                        73469000
   if debugging then                                                    73470000
      begin                                                             73471000
      say "ENTERING CHECK USER" endsay;                                 73472000
      send;                                                             73473000
      end;                                                              73474000
$if                                                                     73475000
                                                                        73476000
   check'user := failed;                          ! initialize return   73477000
                                                                        73478000
   type := 0;                                                           73479000
   type.(10:3) := userlevel;                      ! search for user     73480000
   type.(13:3) := 0;                              ! start at root       73481000
                                                                        73482000
   linkage := double (user'index'ptr);                                  73483000
                                                                        73484000
   do                                                                   73485000
      begin                                                             73486000
      continue := false;                                                73487000
      tos := 0d;                               ! space for direcfind    73488000
                                                                        73489000
      disable'arithmetic'traps;                                         73490000
                                                                        73491000
      dr := direcfind (type, linkage, acctname'l, username'l,           73492000
                       dummy'l, dummy'ntry);                            73493000
                                                                        73494000
      if <> then                               ! error                  73495000
         if dra <> 2 then errcode := -1        !    non-level error     73496000
         else                                  !    not in directory    73497000
            begin                                                       73498000
            enable'arithmetic'traps;                                    73499000
                                                                        73500000
            if ((drb = userlevel) land create'user'flag) then           73501000
               begin                                                    73502000
               move dummy'ntry := ntry'user,  (10);                     73503000
               move dummy'ntry(5) := username'l, (4);                   73504000
                                                                        73505000
               command (dummy'ntry,com'error,com'parm);                 73506000
               if com'error<>0 then errcode := nocreate                 73507000
               else                                                     73508000
                  begin                                                 73509000
                  parms'tempi'1 := drb;                                 73510000
                  sendmessage (m'created'dir'entry);                    73511000
                  errcode := 0;                                         73512000
                  continue := true;                                     73513000
                  end;                                                  73514000
               end                                                      73515000
            else errcode := drb;                                        73516000
            end                                                         73517000
                                                                        73518000
      else                                           ! good             73519000
         begin                                                          73520000
         errcode:=0;                                                    73521000
         check'user := good;                                            73522000
         end;                                                           73523000
                                                                        73524000
      enable'arithmetic'traps;                                          73525000
                                                                        73526000
      end                                                               73527000
   until not continue;                                                  73528000
                                                                        73529000
   parms'tempi'1 := userlevel;                                          73530000
   parms'tempi'2 := (errcode = userlevel);                              73531000
                                                                        73532000
$if x1=on then                <<debugging code>>                        73533000
   if debugging then                                                    73534000
      begin                                                             73535000
      say "LEAVING CHECK DIREC - RETURNING " endsay;                    73536000
      if ret then say "TRUE" endsay                                     73537000
      else say "FALSE" endsay;                                          73538000
      say ";  ERRCODE = " endsay;                                       73539000
      saynum (errcode);                                                 73540000
      send;                                                             73541000
      end;                                                              73542000
$if                                                                     73543000
                                                                        73544000
                                                                        73545000
end <<check'user>>;                                                     73546000
$page "WRITE'THE'FILE"                                                  73547000
$control segment=restore                                                73548000
<<---------------------------------------->>                            73549000
<<  write'the'file                        >>                            73550000
<<---------------------------------------->>                            73551000
                                                                        73552000
integer procedure write'the'file (tdbuf, gbuf);                         73553000
   integer array tdbuf, gbuf;                                           73554000
                                                                        73555000
   ! this procedure writes the file to disc.  if more data is necessary 73556000
   ! read'tape is called.                                               73557000
                                                                        73558000
begin                                                                   73559000
   double array                                                         73560000
      disj'ext'len (0:31),                                              73561000
      disj'ext'addr (0:31);                                             73562000
                                                                        73563000
   double                                                               73564000
      local'iob,                                                        73565000
      sector'address,                                                   73566000
      sectors,                                                          73567000
      sectors'to'write,                                                 73568000
      sub'iob;                                                          73569000
                                                                        73570000
   integer                                                              73571000
      attio'status         = local'iob,                                 73572000
      disc'ldev,                                                        73573000
      ext,                                                              73574000
      num'disj'exts,                                                    73575000
      sector'addr'1        = sector'address,                            73576000
      sector'addr'2        = sector'address + 1,                        73577000
      sectors'left'in'buf,                                              73578000
      sectors'this'write,                                               73579000
      tape'buff'offset;                                                 73580000
                                                                        73581000
   logical                                                              73582000
      read'tape'ret;                                                    73583000
                                                                        73584000
   define                                                               73585000
      change'from'sectors = &lsl (7) #,                                 73586000
      change'to'sectors   = &lsr (7) #;                                 73587000
$page "RET, DIMIN, and MIN of WRITE'THE'FILE"                           73588000
<<----------------------------->>                                       73589000
<< ret of write'the'file       >>                                       73590000
<<----------------------------->>                                       73591000
   subroutine ret(a);                                                   73592000
      value a;                                                          73593000
      integer a;                                                        73594000
   begin                                                                73595000
      write'the'file := a;                                              73596000
      goto end'write'the'file;                                          73597000
   end;                                                                 73598000
<<----------------------------->>                                       73599000
<< dimin of write'the'file     >>                                       73600000
<<----------------------------->>                                       73601000
                                                                        73602000
integer subroutine dimin (a,b);                                         73603000
   value a,b;                                                           73604000
   double a;                          ! the two values                  73605000
   logical b;                                                           73606000
                                                                        73607000
   ! returns the minimum of the two passed values                       73608000
                                                                        73609000
begin                                                                   73610000
   if a < double (b) then                                               73611000
      dimin := integer (a)                                              73612000
   else                                                                 73613000
      dimin := b;                                                       73614000
end <<dimin>>;                                                          73615000
                                                                        73616000
                                                                        73617000
                                                                        73618000
<<----------------------------->>                                       73619000
<< min of write'the'file       >>                                       73620000
<<----------------------------->>                                       73621000
                                                                        73622000
integer subroutine min(a,b);                                            73623000
   value a,b;                                                           73624000
   integer a,b;                         ! the two values  (r/o)         73625000
                                                                        73626000
   ! returns the minimum of the two values                              73627000
                                                                        73628000
begin                                                                   73629000
   min := if a < b then a else b;                                       73630000
end <<min>>;                                                            73631000
$page "WRITE'DISC of WRITE'THE'FILE"                                    73632000
<<----------------------------->>                                       73633000
<< write'disc of write'the'file>>                                       73634000
<<----------------------------->>                                       73635000
integer subroutine write'disc (dst, buffer, sects, iob);                73636000
         value   dst, buffer, sects;  <<name iob;>>                     73637000
         integer dst, buffer, sects;                                    73638000
         double  iob;                                                   73639000
                                                                        73640000
         <<this routine reads the specified number of                   73641000
           words/bytes from disk to the designated buffer.              73642000
           (if len >= 0, is in units of words; if < 0, is               73643000
           in units of bytes.)                                          73644000
           if dst = 0, then buffer is a db relative stack               73645000
           address; if dst > 0 then buffer is the offset into           73646000
           the data segment.>>                                          73647000
                                                                        73648000
   begin                                                                73649000
                                                                        73650000
                                                                        73651000
                                                                        73652000
$if x1=on then                <<debugging code>>                        73653000
   if debugging then                                                    73654000
      begin                                                             73655000
      say "WRITE'DISC (" endsay;                                        73656000
      saynum (disc'ldev);                                               73657000
      say1 ("%");                                                       73658000
      saydoctal (sector'address);                                       73659000
      say " -> " endsay;                                                73660000
      saynum (dst);                                                     73661000
      say " @ %" endsay;                                                73662000
      sayoctal (buffer);                                                73663000
      say " for " endsay;                                               73664000
      saynum (sects);                                                   73665000
      send;                                                             73666000
      end;                                                              73667000
$if                           <<debugging code>>                        73668000
                                                                        73669000
         <<read from disk...for explanation of attachio                 73670000
           parameters, see i/o system ims...>>                          73671000
                                                                        73672000
   disable'arithmetic'traps;                                            73673000
                                                                        73674000
   local'iob:=attachio (                                                73675000
                  disc'ldev,                                            73676000
                  0,             <<qmisc>>                              73677000
                  dst,           << 0 = stack, >0 = dst>>               73678000
                  buffer,        <<offset into stack/dst of data>>      73679000
                  attio'write,   << 0 = read, 1 = write>>               73680000
                  sects change'from'sectors,  <<length in words>>       73681000
                  sector'addr'1, << top half of disc address>>          73682000
                  sector'addr'2, << bottom half of disc address>>       73683000
                  1);            << request=blocked...wait til done>>   73684000
                                                                        73685000
   iob:=local'iob;                                                      73686000
                                                                        73687000
   if attio'status.attio'statusf = attio'good then                      73688000
      write'disc := 0                                                   73689000
   else                                                                 73690000
      write'disc := m'disk'write'failed;                                73691000
                                                                        73692000
                                                                        73693000
$if x1=on then                <<debugging code>>                        73694000
   if debugging then                                                    73695000
      begin                                                             73696000
      say "   WRITE'DISC --> " endsay;                                  73697000
      say1 ("%");                                                       73698000
      sayoctal (attio'status);                                          73699000
      say " (status=" endsay;                                           73700000
      saynum (attio'status.attio'statusf);                              73701000
      say1 (")");                                                       73702000
      send;                                                             73703000
      end;                                                              73704000
$if                           <<debugging code>>                        73705000
                                                                        73706000
   <<enable'arithmetic'traps;  ... not done because the                 73707000
     procedure exit will restore them to the caller's                   73708000
     old state.>>                                                       73709000
                                                                        73710000
   end <<write'disc>>;                                                  73711000
$page "XEQ'TAPE'READ of WRITE'THE'FILE"                                 73712000
<<---------------------------------------->>                            73713000
<<  xeq'read'tape of write'the'file       >>                            73714000
<<---------------------------------------->>                            73715000
                                                                        73716000
subroutine xeq'read'tape;                                               73717000
                                                                        73718000
   ! interface to read'tape                                             73719000
                                                                        73720000
begin                                                                   73721000
   read'tape'ret := read'tape (tdbuf, gbuf);                            73722000
   if read'tape'ret = failed then                                       73723000
      begin                                                             73724000
      kill'restore := true;                                             73725000
      ret (-1);                                                         73726000
      end                                                               73727000
   else if read'tape'ret = good'skipfile then                           73728000
      begin                                                             73729000
      sendmessage (m'contained'tape'error);                             73730000
      ret (-1);                                                         73731000
      end;                                                              73732000
                                                                        73733000
   if last'read'was'eof then                                            73734000
      begin                                                             73735000
      eof'read := true;                                                 73736000
      ret (m'not'all'sectors'written);                                  73737000
      end;                                                              73738000
                                                                        73739000
   if read'tape'len mod sectorsize <> 0 then                            73740000
      ret (rs't'bad'recsize);                                           73741000
end;                                                                    73742000
$page "XEQ'DISK'WRITE of WRITE'THE'FILE"                                73743000
<<---------------------------------------->>                            73744000
<<  xeq'write'disc of write'the'file      >>                            73745000
<<---------------------------------------->>                            73746000
                                                                        73747000
subroutine xeq'write'disc (sects);                                      73748000
   value sects;                                                         73749000
   integer sects;                                                       73750000
                                                                        73751000
   ! interface to write'disc                                            73752000
                                                                        73753000
begin                                                                   73754000
   if using'attio then                                                  73755000
      write'disc (                                                      73756000
                  buffer'xds (curr'wait'buffer),                        73757000
                  buffer'offset (curr'wait'buffer) +                    73758000
                      (tape'buff'offset change'from'sectors),           73759000
                  sects,                                                73760000
                  sub'iob)                                              73761000
   else                                                                 73762000
      write'disc (                                                      73763000
                  0,                                                    73764000
                  @tdbuf (tape'buff'offset change'from'sectors),        73765000
                  sects,                                                73766000
                  sub'iob);                                             73767000
end;                                                                    73768000
$page "WRITE'EXTENT of WRITE'THE'FILE"                                  73769000
<<---------------------------------------->>                            73770000
<<  write'extent of write'the'file        >>                            73771000
<<---------------------------------------->>                            73772000
                                                                        73773000
subroutine write'extent (extent'num);                                   73774000
   value extent'num;                                                    73775000
   integer extent'num;                                                  73776000
                                                                        73777000
   ! writes out a single disjoint extent to disc.  calls are made to    73778000
   ! xeq'read'tape and xeq'write'disc                                   73779000
                                                                        73780000
begin                                                                   73781000
   sectors'to'write := disj'ext'len (extent'num);                       73782000
   sector'address := disj'ext'addr (extent'num);                        73783000
   disc'ldev := lun (sector'addr'1.(00:08), pvmvtabx);                  73784000
   sector'addr'1 . (0:8) := 0;                                          73785000
                                                                        73786000
   if extent'num = 0 then                                               73787000
      begin                                                             73788000
      sectors'to'write := sectors'to'write - 1d;                        73789000
      sector'address := sector'address + 1d;                            73790000
      end;                                                              73791000
                                                                        73792000
$if x1=on then                                                          73793000
   if debugging then                                                    73794000
      begin                                                             73795000
      say "      EXTENT = " endsay;                                     73796000
      saynum (extent'num);                                              73797000
      say "; DISC'LDEV = " endsay;                                      73798000
      saynum (disc'ldev);                                               73799000
      send;                                                             73800000
      end;                                                              73801000
$if                                                                     73802000
                                                                        73803000
   while (sectors'to'write > 0d) do                                     73804000
      begin                                                             73805000
      if sectors'left'in'buf = 0 then                                   73806000
         begin                                                          73807000
         xeq'read'tape;                                                 73808000
         sectors'left'in'buf := read'tape'len change'to'sectors;        73809000
         tape'buff'offset := 0;                                         73810000
         end;                                                           73811000
                                                                        73812000
      sectors'this'write := dimin (sectors'to'write,                    73813000
                                   sectors'left'in'buf );               73814000
                                                                        73815000
      xeq'write'disc (sectors'this'write);                              73816000
                                                                        73817000
$if x1=on then                                                          73818000
      if debugging then                                                 73819000
         begin                                                          73820000
         say "         SECTORS'TO'WRITE = " endsay;                     73821000
         saydnum (sectors'to'write);                                    73822000
         say "; SECTORS'LEFT'IN'BUF = " endsay;                         73823000
         saynum (sectors'left'in'buf);                                  73824000
         send;                                                          73825000
         say "         SECTOR'ADDRESS = %" endsay;                      73826000
         saydoctal (sector'address);                                    73827000
         say "; TAPE'BUFF'OFFSET = %" endsay;                           73828000
         sayoctal (tape'buff'offset);                                   73829000
         send;                                                          73830000
         say "         SECTORS'THIS'WRITE = " endsay;                   73831000
         saynum (sectors'this'write);                                   73832000
         send;                                                          73833000
         end;                                                           73834000
$if                                                                     73835000
      sector'address := sector'address + double (sectors'this'write);   73836000
      sectors'left'in'buf := sectors'left'in'buf - sectors'this'write;  73837000
      tape'buff'offset := tape'buff'offset + sectors'this'write;        73838000
      sectors'to'write := sectors'to'write - double (sectors'this'write)73839000
      end;                                                              73840000
end;                                                                    73841000
$page "SCRUNCH'EXTENTS"                                                 73842000
<<---------------------------------------->>                            73843000
<<  scrunch'extents of write'the'file     >>                            73844000
<<---------------------------------------->>                            73845000
                                                                        73846000
subroutine scrunch'extents;                                             73847000
                                                                        73848000
   ! this procedure creates an extent map of contiguous extents that    73849000
   ! are going to be used by write'the'file.  after joining contiguous  73850000
   ! extents, the disjoint extents are trimmed down to just the number  73851000
   ! of sectors that are in the file.                                   73852000
                                                                        73853000
begin                                                                   73854000
   join'contiguous'extents (num'disj'exts, disj'ext'addr,               73855000
                            disj'ext'len, flextmap'd, flnumexts+1,      73856000
                            flextsize'd, fllastextsize'd);              73857000
                                                                        73858000
   sectors := 0d;                                                       73859000
   ext := -1;                                                           73860000
                                                                        73861000
   ! trim down the file.                                                73862000
                                                                        73863000
   while (ext := ext+1) <= num'disj'exts do                             73864000
      begin                                                             73865000
      sectors := sectors + disj'ext'len (ext);                          73866000
      if sectors >= file'sectors then                                   73867000
         begin                                                          73868000
         num'disj'exts := ext;                                          73869000
         disj'ext'len (ext) := disj'ext'len (ext) -                     73870000
                                  (sectors - file'sectors);             73871000
         end;                                                           73872000
      end;                                                              73873000
                                                                        73874000
$if x1=on then                                                          73875000
   if debugging then                                                    73876000
      begin                                                             73877000
      say "AFTER SCRUNCHING EXTENTS" endsay;                            73878000
      send;                                                             73879000
      ext := -1;                                                        73880000
      while (ext:=ext+1) <= num'disj'exts do                            73881000
         begin                                                          73882000
         say "   DISJOINT EXTENT #" endsay;                             73883000
         saynum (ext);                                                  73884000
         say " AT ADDRESS %" endsay;                                    73885000
         saydoctal (disj'ext'addr(ext));                                73886000
         say " FOR " endsay;                                            73887000
         saydnum (disj'ext'len(ext));                                   73888000
         send;                                                          73889000
         end;                                                           73890000
      end;                                                              73891000
$if                                                                     73892000
end;                                                                    73893000
$page "WRITE'THE'FILE mainline"                                         73894000
   scrunch'extents;                                                     73895000
                                                                        73896000
   tape'buff'offset := 1;                                               73897000
   sectors'left'in'buf := (read'tape'len change'to'sectors) - 1;        73898000
                                                                        73899000
   ext := 0;                                                            73900000
                                                                        73901000
   do                                                                   73902000
      begin                                                             73903000
      write'extent (ext);                                               73904000
      ext := ext + 1;                                                   73905000
      end                                                               73906000
   until (ext > num'disj'exts);                                         73907000
                                                                        73908000
   read'tape'ret := read'tape (tdbuf, gbuf);                            73909000
   if read'tape'ret = failed then                                       73910000
      begin                                                             73911000
      kill'restore := true;                                             73912000
      ret(-1);                                                          73913000
      end;                                                              73914000
                                                                        73915000
   if not last'read'was'eof then ret(m'missing'eof)                     73916000
   else eof'read := true;                                               73917000
                                                                        73918000
end'write'the'file:                                                     73919000
                                                                        73920000
end;                                                                    73921000
$page "[RESTORE]  FRESTORE --- RESTORE files from tape to disk"         73922000
$control segment=irestore                                               73923000
<<*****************************************************************>>   73924000
<<---------------------------------------->>                            73925000
<<  frestore                              >>                            73926000
<<---------------------------------------->>                            73927000
                                                                        73928000
logical procedure frestore (tdbuf);                                     73929000
   integer array tdbuf;                                                 73930000
   option privileged, uncallable;                                       73931000
                                                                        73932000
   ! this is the main procedure for restoring all the files             73933000
   ! that are to be restored.  the two major parts of this              73934000
   ! procedure are finding the file to be restored and then             73935000
   ! restoring it.  the first part is done by the subroutines           73936000
   ! internal to this procedure.  the second part is done by            73937000
   ! a call to restore'a'file.                                          73938000
                                                                        73939000
   <<-------------------------------------------------                  73940000
     note: the following parms standard-form titles                     73941000
     are used in this routine:                                          73942000
                                                                        73943000
        curr'title' ... this is the std-form of the                     73944000
                        file title just read from the                   73945000
                        good file.                                      73946000
     ----------------------------------------------->>                  73947000
                                                                        73948000
begin                                                                   73949000
         <<declarations for file label and tape header...>>             73950000
                                                                        73951000
                                                                        73952000
   double array                                                         73953000
      gbuf'd      (0:g'recsize/2);                                      73954000
                                                                        73955000
   integer array                                                        73956000
      gbuf        (*) = gbuf'd (0),                                     73957000
      new'flab    (0:file'label'size),   <<1 word extra>>               73958000
      scratch     (0:d'recsize);                                        73959000
                                                                        73960000
   integer                                                              73961000
      buf'inx,                                                          73962000
      cur'inx,                                                          73963000
      cur'xds,                                                          73964000
      i           := 0,                                                 73965000
      len         := 0,       <<length of last fread from tape>>        73966000
      jitdst      := 0,       <<dst of jit>>                            73967000
      num'io      := 0,       <<number of ioq's per xds>>               73968000
      req'type    := 0,       <<requisition type for dismount>>         73969000
      state       := 0,       <<state this routine is in>>              73970000
      sub'code,                                                         73971000
      x           := 0,       <<used by checksum>>                      73972000
      xds'size;                                                         73973000
                                                                        73974000
   byte array                                                           73975000
      gbuf'    (*) = gbuf,                                              73976000
      scratch' (*) = scratch;                                           73977000
                                                                        73978000
   byte pointer                                                         73979000
      tdbuf';                                                           73980000
                                                                        73981000
   logical                                                              73982000
      break'sensed;                                                     73983000
                                                                        73984000
   label                                                                73985000
      end'frestore;                                                     73986000
                                                                        73987000
   equate                                                               73988000
         <<states...>>                                                  73989000
                                                                        73990000
      initializing'state    = 0;                                        73991000
                                                                        73992000
   define                                                               73993000
      nonsysvs    = r (glinkage).(pvf) = pv #;                          73994000
$page "[RESTORE]  FRESTORE --- error handling subroutines"              73995000
<<---------------------------------------->>                            73996000
<<  release'buffers of frestore           >>                            73997000
<<---------------------------------------->>                            73998000
                                                                        73999000
                                                                        74000000
subroutine release'buffers;                                             74001000
                                                                        74002000
   <<this routine releases any xds buffers obtained by                  74003000
     the allocate'buffers subroutine.  this may entail                  74004000
     unfreezing and unlocking prior to releasing.     >>                74005000
                                                                        74006000
begin                                                                   74007000
                                                                        74008000
   cur'inx:=-1;                                                         74009000
                                                                        74010000
   while (cur'inx:=cur'inx+1) < num'xds     do                          74011000
      begin                                                             74012000
                                                                        74013000
$if x1=on then                                                          74014000
      if debugging then                                                 74015000
         begin                                                          74016000
         say "CURRENT BUFFER = " endsay;                                74017000
         saynum (cur'inx);                                              74018000
         say " ; XDS #" endsay;                                         74019000
         saynum (xds'num(cur'inx));                                     74020000
         send;                                                          74021000
         end;                                                           74022000
$if                                                                     74023000
                                                                        74024000
            <<note: the order here is important!!!>>                    74025000
                                                                        74026000
      if xds'status(cur'inx) = bufstat'frozen then                      74027000
         begin                                                          74028000
         unfreeze (xds'num(cur'inx), 1, 0);                             74029000
         xds'status(cur'inx):=bufstat'locked;                           74030000
$if x1=on then                                                          74031000
         if debugging then                                              74032000
            begin                                                       74033000
            say "   BUFFER UNFROZEN" endsay;                            74034000
            send;                                                       74035000
            end;                                                        74036000
$if                                                                     74037000
         end;                                                           74038000
                                                                        74039000
      if xds'status(cur'inx) = bufstat'locked then                      74040000
         begin                                                          74041000
         unlockseg (xds'num(cur'inx), 1, 0);                            74042000
         xds'status(cur'inx):=bufstat'allocated;                        74043000
$if x1=on then                                                          74044000
         if debugging then                                              74045000
            begin                                                       74046000
            say "   BUFFER UNLOCKED" endsay;                            74047000
            send;                                                       74048000
            end;                                                        74049000
$if                                                                     74050000
         end;                                                           74051000
                                                                        74052000
      if xds'status(cur'inx) = bufstat'allocated then                   74053000
         begin                                                          74054000
         reldataseg (xds'num(cur'inx));                                 74055000
         xds'status(cur'inx):=bufstat'empty;                            74056000
$if x1=on then                                                          74057000
         if debugging then                                              74058000
            begin                                                       74059000
            say "   BUFFER RELEASED" endsay;                            74060000
            send;                                                       74061000
            end;                                                        74062000
$if                                                                     74063000
         end;                                                           74064000
                                                                        74065000
      end;                                                              74066000
                                                                        74067000
end <<release'buffers sub>>;                                            74068000
$page "[RESTORE]  FRESTORE --- utility subroutines"                     74069000
<<---------------------------------------->>                            74070000
<<  allocate'buffers of frestore          >>                            74071000
<<---------------------------------------->>                            74072000
                                                                        74073000
logical subroutine allocate'buffers;                                    74074000
                                                                        74075000
   <<this routine allocates num'xds     extra data segments.            74076000
     if it fail in this, it returns failed and releases                 74077000
     any buffers it got.                                                74078000
                                                                        74079000
     it tries to get num'xds     data segment buffers,                  74080000
     each of which is large enough to hold max'io areas                 74081000
     of tape'recsize words in length.  if this fails,                   74082000
     it starts decrementing num'io (initially set to max'io)            74083000
     until it gets that many or until num'io < 1.  if it                74084000
     fails to allocate the buffers, a failed is returned                74085000
     and all buffers it did get (if any) are released.                  74086000
     if it succeeds, all buffers are locked & frozen into               74087000
     memory and a good is returned.                                     74088000
                                                                        74089000
     note: we must investigate whether or not these buffers             74090000
     really need to be locked & frozen...attachio may be                74091000
     sufficiently smart in mpe-iv to temporarily lock them              74092000
     in memory while in use.  if so, we should probably                 74093000
     remove the locking/freezing code unless we decide                  74094000
     (after performance analysis) that we know better than              74095000
     mpe-iv's memory manager.                                           74096000
                                                                        74097000
     note: attachio is not sufficiently smart to lock them              74098000
     in memory, so we have to.                                          74099000
                                                             >>         74100000
                                                                        74101000
begin                                                                   74102000
                                                                        74103000
   allocate'buffers:=failed;        <<assumption>>                      74104000
                                                                        74105000
   i:=num'xds    *max'io;                                               74106000
   fill (xds'status, num'xds    , bufstat'empty);                       74107000
   fill (buffer'xds,    i          , 0);                                74108000
   fill (io'queue,      i*2,         0);                                74109000
   fill (io'len,        i,           0);                                74110000
   ioq'fsf'd := 0d;                                                     74111000
                                                                        74112000
         <<see how big xds'size should be...>>                          74113000
         <<warning: since max'xds'size is near 32767,                   74114000
           be careful not to change this code and cause                 74115000
           an integer overflow!                        >>               74116000
                                                                        74117000
   num'io:=(max'xds'size - xds'overhead)/tape'recsize;                  74118000
   if num'io > max'io then                                              74119000
      num'io:=max'io;                                                   74120000
   xds'size:=num'io*tape'recsize + xds'overhead;                        74121000
                                                                        74122000
   cur'inx:=-1;                                                         74123000
   buf'inx := 0;                                                        74124000
                                                                        74125000
   while (cur'inx:=cur'inx+1) < num'xds     do                          74126000
      begin                                                             74127000
                                                                        74128000
$if x1=on then                <<debugging code>>                        74129000
      if debugging then                                                 74130000
         begin                                                          74131000
         say "Allocate buffer # " endsay;                               74132000
         saynum (cur'inx);                                              74133000
         say " of " endsay;                                             74134000
         saynum (xds'size);                                             74135000
         say " words,  NUM'IO = " endsay;                               74136000
         saynum (num'io);                                               74137000
         send;                                                          74138000
         end;                                                           74139000
$if                           <<debugging code>>                        74140000
                                                                        74141000
         <<allocate a buffer of size xds'size words...>>                74142000
                                                                        74143000
      cur'xds:=getdataseg (xds'size, 0);                                74144000
                                                                        74145000
      if < then                                                         74146000
         begin          <<error grabbing an xds>>                       74147000
                                                                        74148000
$if x1=on then                <<debugging code>>                        74149000
         if debugging then                                              74150000
            begin                                                       74151000
            say "   failed...too large, XDS'SIZE was " endsay;          74152000
            saynum (xds'size);                                          74153000
            send;                                                       74154000
            end;                                                        74155000
$if                           <<debugging code>>                        74156000
                                                                        74157000
               <<this error means that the system does                  74158000
                 not want to give us a data segment as                  74159000
                 large as we asked for...so shrink the                  74160000
                 asking size down...                  >>                74161000
                                                                        74162000
         num'io:=num'io-1;                                              74163000
         xds'size:=num'io*tape'recsize + xds'overhead;                  74164000
                                                                        74165000
               <<we should have no buffers at this point,               74166000
                 but we release them anyway...>>                        74167000
                                                                        74168000
         release'buffers;                                               74169000
                                                                        74170000
               <<see if num'io is now too small...>>                    74171000
                                                                        74172000
         if num'io < 1 then                                             74173000
            begin                                                       74174000
            sendmessage (sr'buffer'allocate'fail);                      74175000
            return;     <<exit from routine>>                           74176000
            end;                                                        74177000
                                                                        74178000
               <<"restart" loop by setting cur'inx to -1...>>           74179000
                                                                        74180000
         cur'inx:=-1;                                                   74181000
         end                                                            74182000
      else if cur'xds = 0 then                                          74183000
         begin          <<unable to get xds>>                           74184000
                                                                        74185000
$if x1=on then                <<debugging code>>                        74186000
         if debugging then                                              74187000
            begin                                                       74188000
            say "   unable to get XDS for some reason" endsay;          74189000
            send;                                                       74190000
            end;                                                        74191000
$if                           <<debugging code>>                        74192000
         release'buffers;                                               74193000
         sendmessage (sr'buffer'allocate'fail);                         74194000
         return;        <<exit from routine>>                           74195000
         end                                                            74196000
      else                                                              74197000
         begin          <<got the xds!>>                                74198000
                                                                        74199000
$if x1=on then                <<debugging code>>                        74200000
         if debugging then                                              74201000
            begin                                                       74202000
            say "   got XDS, # = " endsay;                              74203000
            saynum (cur'xds);                                           74204000
            send;                                                       74205000
            end;                                                        74206000
$if                           <<debugging code>>                        74207000
         xds'status(cur'inx):=bufstat'allocated;                        74208000
         xds'num (cur'inx) := cur'xds;                                  74209000
         i := -tape'recsize;                                            74210000
         while (i := i+tape'recsize) < (xds'size - xds'overhead) do     74211000
            begin                                                       74212000
            buffer'xds(buf'inx) := cur'xds;                             74213000
            buffer'offset(buf'inx) := i;                                74214000
            buf'inx := buf'inx+1;                                       74215000
            end;                                                        74216000
         end;                                                           74217000
      end;                                                              74218000
                                                                        74219000
$if x1=on then                <<debugging code>>                        74220000
   if debugging then                                                    74221000
      begin                                                             74222000
      say "XDS Buffers allocated" endsay;                               74223000
      send;                                                             74224000
      end;                                                              74225000
$if                           <<debugging code>>                        74226000
                                                                        74227000
         <<all num'xds     xds are allocated.>>                         74228000
         <<now lock and freeze them...>>                                74229000
                                                                        74230000
   cur'inx:=-1;                                                         74231000
   while (cur'inx:=cur'inx+1) < num'xds     do                          74232000
      begin                                                             74233000
                                                                        74234000
$if x1=on then                <<debugging code>>                        74235000
      if debugging then                                                 74236000
         begin                                                          74237000
         say "   lock&freeze buffer # " endsay;                         74238000
         saynum (cur'inx);                                              74239000
         send;                                                          74240000
         end;                                                           74241000
$if                           <<debugging code>>                        74242000
                                                                        74243000
      lockseg (xds'num(cur'inx), 1, 0);                                 74244000
      if < then                                                         74245000
         begin             <<error locking buffer>>                     74246000
         release'buffers;                                               74247000
         sendmessage (sr'buffer'lock'fail);                             74248000
         return;           <<exit from routine>>                        74249000
         end;                                                           74250000
      xds'status(cur'inx):=bufstat'locked;                              74251000
                                                                        74252000
      freeze (xds'num(cur'inx), 1, 0);                                  74253000
      if < then                                                         74254000
         begin             <<error freezing buffer>>                    74255000
         release'buffers;                                               74256000
         sendmessage (sr'buffer'freeze'fail);                           74257000
         return;           <<exit from routine>>                        74258000
         end;                                                           74259000
      xds'status(cur'inx):=bufstat'frozen;                              74260000
                                                                        74261000
      end;                                                              74262000
                                                                        74263000
   allocate'buffers:=good;                                              74264000
                                                                        74265000
   num'buffers := buf'inx;                                              74266000
   curr'read'buffer  := 0;                                              74267000
   curr'wait'buffer  := num'buffers - 1;                                74268000
   cur'inx:=0;                                                          74269000
   cur'xds:=buffer'xds(0);                                              74270000
                                                                        74271000
                                                                        74272000
$if x1=on then                <<debugging code>>                        74273000
   if debugging then                                                    74274000
      begin                                                             74275000
      say "   # of sectors per XDS = " endsay;                          74276000
      send;                                                             74277000
      end;                                                              74278000
$if                           <<debugging code>>                        74279000
                                                                        74280000
end <<allocate'buffers sub>>;                                           74281000
$page "[RESTORE]  FRESTORE --- Error handling subroutines"              74282000
<<---------------------------------------->>                            74283000
<<  cleanup of frestore                   >>                            74284000
<<---------------------------------------->>                            74285000
                                                                        74286000
subroutine cleanup;                                                     74287000
                                                                        74288000
      <<this routine does state-determined cleanup.>>                   74289000
                                                                        74290000
begin                                                                   74291000
   if using'attio then                                                  74292000
      begin                                                             74293000
      wait'for'all'attio;                                               74294000
      release'buffers;                                                  74295000
      end;                                                              74296000
                                                                        74297000
   res'acct' := " ";                                                    74298000
   lock'directory;                                                      74299000
                                                                        74300000
   if sm'tog then change'jit'acct(jitdst,logon'acct);                   74301000
                                                                        74302000
   if mounted'vs then                                                   74303000
      dismount'volume'set (last'group', last'acct', pv'info);           74304000
                                                                        74305000
end <<cleanup sub>>;                                                    74306000
$page                                                                   74307000
<<---------------------------------------->>                            74308000
<<  fail of frestore                      >>                            74309000
<<---------------------------------------->>                            74310000
                                                                        74311000
subroutine fail (errnum);                                               74312000
         value   errnum;                                                74313000
         integer errnum;                                                74314000
begin                                                                   74315000
                                                                        74316000
   frestore:=failed;                                                    74317000
                                                                        74318000
   if errnum <> 0 then                                                  74319000
      sendmessage (errnum);                                             74320000
                                                                        74321000
        <<clear up remaining files - tag them as >>                     74322000
        <<   not restored: previous catastrophic error >>               74323000
                                                                        74324000
   fread (g'num, gbuf, g'recsize);                                      74325000
                                                                        74326000
   break'sensed := false;                                               74327000
                                                                        74328000
   while = do                                                           74329000
      begin                                                             74330000
      if requestservice then                                            74331000
         break'sensed := true;                                          74332000
                                                                        74333000
      if not break'sensed then                                          74334000
         display'3'to'standard (                                        74335000
            gbuf' (g'file'inx'),                                        74336000
            gbuf' (g'group'inx'),                                       74337000
            gbuf' (g'acct'inx'),                                        74338000
            curr'title',                                                74339000
            error'code  );                                              74340000
                                                                        74341000
      failed'file'count := failed'file'count + 1d;                      74342000
                                                                        74343000
      if not break'sensed then sendmessage (m'prev'catastrophic);       74344000
      fread (g'num, gbuf, g'recsize);                                   74345000
      end;                                                              74346000
                                                                        74347000
   go end'frestore;                                                     74348000
                                                                        74349000
end <<fail sub>>;                                                       74350000
                                                                        74351000
<<---------------------------------------->>                            74352000
<<  file'fail of frestore                 >>                            74353000
<<---------------------------------------->>                            74354000
                                                                        74355000
subroutine file'fail (fid, errnum);                                     74356000
         value        fid, errnum;                                      74357000
         integer      fid, errnum;                                      74358000
begin                                                                   74359000
                                                                        74360000
   if fid <> no'file then                                               74361000
      print'file'error (fid);                                           74362000
                                                                        74363000
   fail (errnum);                                                       74364000
                                                                        74365000
   end <<file'fail sub>>;                                               74366000
$page "SYNCHRONIZE'GOOD'FILE'WITH'TAPE"                                 74367000
<<---------------------------------->>                                  74368000
<< synchronize'good'file'with'tape  >>                                  74369000
<<---------------------------------->>                                  74370000
                                                                        74371000
logical subroutine synchronize'good'file'with'tape;                     74372000
                                                                        74373000
   ! this procedure is used to synchronize the good file with the       74374000
   ! tape.  when this procedure is called the last read from the        74375000
   ! tape was a tapemark.  the first thing that this procedure does     74376000
   ! is to read the tape to get a valid file label into the tape        74377000
   ! buffer.  then using the direc file and the procedure               74378000
   ! find'curr'fileno to find which file on the tape that file          74379000
   ! label corresponds with.  a record is read from the good            74380000
   ! file.  if this file occurred earlier in the tape set then the      74381000
   ! file was lost during synchronization and a corresponding message   74382000
   ! will be displayed on syslist and another record will be read from  74383000
   ! the good file.  records are read from the good file until a        74384000
   ! file is found that is later in the tapeset than our current        74385000
   ! position in the tapeset.                                           74386000
                                                                        74387000
                                                                        74388000
begin                                                                   74389000
$if x1=on then                                                          74390000
   if debugging then                                                    74391000
      begin                                                             74392000
      say "ENTERING SYNCHRONIZE'GOOD'FILE - CURR'FILENO=" endsay;       74393000
      saydnum(curr'fileno);                                             74394000
      send;                                                             74395000
      end;                                                              74396000
$if                                                                     74397000
   read'good'file;                                                      74398000
   if > then                                                            74399000
      begin                                                             74400000
      synchronize'good'file'with'tape := failed;                        74401000
      return;                                                           74402000
      end;                                                              74403000
                                                                        74404000
   if display'3'to'standard (                                           74405000
            gbuf'(g'file'inx'),                                         74406000
            gbuf'(g'group'inx'),                                        74407000
            gbuf'(g'acct'inx'),                                         74408000
            curr'title',                                                74409000
            error'code  )                                               74410000
         = failed then                                                  74411000
      fail (sr'd'2's'failed);     <<d'3'to's failed>>                   74412000
                                                                        74413000
   do                                                                   74414000
      if read'tape (tdbuf, gbuf) = failed then fail (0)                 74415000
   until end'of'tape'set or not last'read'was'eof;                      74416000
                                                                        74417000
   move'from'tape'buff'to'flab;                                         74418000
   move tdbuf := flab, (3*file'part'words);                             74419000
                                                                        74420000
   synchronize'good'file'with'tape := good;                             74421000
                                                                        74422000
   curr'fileno := find'curr'fileno (tdbuf, curr'fileno, error'code);    74423000
   if curr'fileno < 0d then curr'fileno  := - (curr'fileno) - 1d;       74424000
                                                                        74425000
   if error'code <> 0 then file'fail (d'num, rs'd'file'error);          74426000
                                                                        74427000
$if x1=on then                                                          74428000
   if debugging then                                                    74429000
      begin                                                             74430000
         say "   CURR'FILENO IS NOW " endsay;                           74431000
         saydnum(curr'fileno);                                          74432000
         say " - GBUF FILENO IS " endsay;                               74433000
         saydnum(gbuf'd(g'filenum'inx'd));                              74434000
         send;                                                          74435000
      end;                                                              74436000
$if                                                                     74437000
                                                                        74438000
   while gbuf'd(g'filenum'inx'd) < curr'fileno do                       74439000
      begin                                                             74440000
                                                                        74441000
      failed'file'count := failed'file'count + 1d;                      74442000
                                                                        74443000
      sendmessage (m'synchronizing);                                    74444000
                                                                        74445000
      read'good'file;                                                   74446000
      if > then                                                         74447000
         begin                                                          74448000
         synchronize'good'file'with'tape := failed;                     74449000
         return;                                                        74450000
         end;                                                           74451000
                                                                        74452000
      if display'3'to'standard (                                        74453000
               gbuf'(g'file'inx'),                                      74454000
               gbuf'(g'group'inx'),                                     74455000
               gbuf'(g'acct'inx'),                                      74456000
               curr'title',                                             74457000
               error'code  )                                            74458000
            = failed then                                               74459000
         fail (sr'd'2's'failed);     <<d'3'to's failed>>                74460000
                                                                        74461000
      end;                                                              74462000
                                                                        74463000
$if x1=on then                                                          74464000
   if debugging then                                                    74465000
      begin                                                             74466000
      say "TAPE'SYNCHRONIZED" endsay;                                   74467000
      send;                                                             74468000
      end;                                                              74469000
$if                                                                     74470000
end <<synchronize'good'file'with'tape>>;                                74471000
!control nolist               !list                                     74472000
$page                                                                   74473000
<<---------------------------------------->>                            74474000
<<  get'good'record of frestore           >>                            74475000
<<---------------------------------------->>                            74476000
                                                                        74477000
logical subroutine get'good'record;                                     74478000
                                                                        74479000
   ! this procedure gets the next valid record in the good file.  most  74480000
   ! of the work is done by synchronize'good'file'with'tape.  after     74481000
   ! a valid record is found, the file title is converted to standard   74482000
   ! form and placed into curr'title'                                   74483000
                                                                        74484000
begin                                                                   74485000
                                                                        74486000
$if x1=on then                <<debugging code>>                        74487000
   if debugging then                                                    74488000
      begin                                                             74489000
      say "   GET'GOOD'RECORD" endsay;                                  74490000
      send;                                                             74491000
      end;                                                              74492000
$if                           <<debugging code>>                        74493000
                                                                        74494000
                                                                        74495000
   if synchronize'good'file'with'tape = failed then                     74496000
      begin                                                             74497000
      get'good'record := failed;                                        74498000
      return;                                                           74499000
      end;                                                              74500000
                                                                        74501000
$if x1=on then                <<debugging code>>                        74502000
   if debugging then                                                    74503000
      begin                                                             74504000
      say "      read: " endsay;                                        74505000
      say gbuf'(g'title'inx'),(24) endsay;                              74506000
      send;                                                             74507000
      end;                                                              74508000
$if                           <<debugging code>>                        74509000
                                                                        74510000
   if display'3'to'standard (                                           74511000
            gbuf'(g'file'inx'),                                         74512000
            gbuf'(g'group'inx'),                                        74513000
            gbuf'(g'acct'inx'),                                         74514000
            curr'title',                                                74515000
            error'code  )                                               74516000
         = failed then                                                  74517000
      fail (sr'd'2's'failed);     <<d'3'to's failed>>                   74518000
                                                                        74519000
$if x1=on then                <<debugging code>>                        74520000
   if debugging then                                                    74521000
      begin                                                             74522000
      say "GET'GOOD'RECORD --> " endsay;                                74523000
      say'standard (curr'title');                                       74524000
      send;                                                             74525000
      end;                                                              74526000
$if                           <<debugging code>>                        74527000
                                                                        74528000
   get'good'record:=good;                                               74529000
                                                                        74530000
end <<get'good'record sub>>;                                            74531000
$page                                                                   74532000
<<---------------------------------------->>                            74533000
<<  initialize'frestore of frestore       >>                            74534000
<<---------------------------------------->>                            74535000
                                                                        74536000
subroutine initialize'frestore;                                         74537000
                                                                        74538000
   ! this procedure does the initialization for frestore                74539000
                                                                        74540000
begin                                                                   74541000
                                                                        74542000
$if x1=on then                <<debugging code>>                        74543000
   if debugging then                                                    74544000
      begin                                                             74545000
      say "START OF FRESTORE" endsay;                                   74546000
      send;                                                             74547000
      end;                                                              74548000
$if                           <<debugging code>>                        74549000
                                                                        74550000
   frestore:=failed;                                                    74551000
                                                                        74552000
   state:=initializing'state;                                           74553000
                                                                        74554000
   new'flab(128):="  ";                <<for getdevinfo>>               74555000
                                                                        74556000
   rewind'good'file;                                                    74557000
                                                                        74558000
   @tdbuf':=@tdbuf & lsl(1);       <<byte address of tdbuf>>            74559000
                                                                        74560000
   jitdst:=get'jitdst;             <<get the dst of the jit>>           74561000
                                                                        74562000
   curr'fileno       := 0d;                                             74563000
                                                                        74564000
   failed'file'count := 0d;                                             74565000
   good'file'count   := 0d;                                             74566000
                                                                        74567000
   move last'acct'   := res'acct',  (file'part'size);                   74568000
   move last'group'  := res'group', (file'part'size);                   74569000
                                                                        74570000
   last'read'was'eof := false;                                          74571000
                                                                        74572000
   num'buffers := 0;                                                    74573000
                                                                        74574000
   if show'flag then               << print out the show heading >>     74575000
      begin                                                             74576000
      sendmessage (m'blank'line);                                       74577000
      sendmessage (m'heading);                                          74578000
      sendmessage (m'blank'line);                                       74579000
      end;                                                              74580000
                                                                        74581000
                                                                        74582000
$if x1=on then                <<debugging code>>                        74583000
   if debugging then                                                    74584000
      begin                                                             74585000
      say " end initializing FRESTORE" endsay;                          74586000
      send;                                                             74587000
      end;                                                              74588000
$if                           <<debugging code>>                        74589000
                                                                        74590000
end <<initialize'frestore sub>>;                                        74591000
$page                                                                   74592000
<<---------------------------------------->>                            74593000
<<  locate'good'tape'file of frestore     >>                            74594000
<<---------------------------------------->>                            74595000
                                                                        74596000
subroutine locate'good'tape'file;                                       74597000
                                                                        74598000
      <<this routine scans forward on the tape looking                  74599000
        for the file specified by the record just read                  74600000
        from the good file.  if the file is                             74601000
        not found on the tape, we judge the tape to be                  74602000
        in error and terminate with an error message,                   74603000
        otherwise the tape is left positioned at the                    74604000
        second record of the file and tdbuf has the contents            74605000
        of the first record in it.>>                                    74606000
                                                                        74607000
begin                                                                   74608000
                                                                        74609000
$if x1=on then                <<debugging code>>                        74610000
   if debugging then                                                    74611000
      begin                                                             74612000
      say "LOCATE'GOOD'TAPE'FILE started" endsay;                       74613000
      send;                                                             74614000
      end;                                                              74615000
$if                           <<debugging code>>                        74616000
                                                                        74617000
                                                                        74618000
   check'break;         <<wont return if break sensed>>                 74619000
                                                                        74620000
   while (gbuf'(g'title'inx') <> tdbuf', (3 * file'part'size)) do       74621000
      begin                            <<we found it!>>                 74622000
                                                                        74623000
      if skip'and'read'tape (tdbuf, 0, gbuf) = failed then              74624000
         fail (0);                                                      74625000
                                                                        74626000
      move'from'tape'buff'to'flab;                                      74627000
      move tdbuf := flab, (3*file'part'words);                          74628000
      check'break;                                                      74629000
                                                                        74630000
      end;                                                              74631000
                                                                        74632000
   curr'fileno := gbuf'd (g'filenum'inx'd);                             74633000
                                                                        74634000
end <<locate'good'tape'file sub>>;                                      74635000
$page "[RESTORE]  FRESTORE --- Outer Block"                             74636000
<<************************************************************>>        74637000
<<                outer block of frestore                     >>        74638000
<<************************************************************>>        74639000
                                                                        74640000
   initialize'frestore;                                                 74641000
   if using'attio then        ! initialize tape buffers, start tape     74642000
      begin                                                             74643000
      if allocate'buffers = failed then                                 74644000
         fail (rs'unable'to'allocate'buffers);                          74645000
      start'a'read (tape'recsize);                                      74646000
      end;                                                              74647000
                                                                        74648000
   while get'good'record = good do                                      74649000
      begin                                                             74650000
                                                                        74651000
      eof'read := false;                                                74652000
                                                                        74653000
      locate'good'tape'file;                                            74654000
                                                                        74655000
      if restore'a'file (tdbuf, gbuf, jitdst)=failed                    74656000
         then  fail(0);                                                 74657000
                                                                        74658000
      ! make sure that we are at a tapemark                             74659000
                                                                        74660000
      if not using'attio and not eof'read then                          74661000
         issue'skip (false)                                             74662000
      else if using'attio and not eof'read then                         74663000
         begin                                                          74664000
         parms'tempi'1 := look'for'eof (gbuf, true);                    74665000
         if parms'tempi'1 = -1 then                                     74666000
            fail (rs'look'for'eof)                                      74667000
         else if parms'tempi'1 <> attio'eof then                        74668000
            begin                                                       74669000
            start'a'skip;                                               74670000
            start'a'read (tape'recsize);                                74671000
            issue'skip (false);                                         74672000
            end                                                         74673000
         else if outstanding'ios = 0 then                               74674000
            start'a'read (tape'recsize);                                74675000
         end;                                                           74676000
                                                                        74677000
      end;                                                              74678000
                                                                        74679000
   frestore:=good;                                                      74680000
                                                                        74681000
end'frestore:                                                           74682000
                                                                        74683000
   cleanup;                                                             74684000
                                                                        74685000
                                                                        74686000
   end <<frestore proc>>;                                               74687000
$page "[RESTORE]  RESTORE'A'FILE --- RESTOREs a single file"            74688000
$control segment=restore                                                74689000
<<---------------------------------------->>                            74690000
<<  restore'a'file                        >>                            74691000
<<---------------------------------------->>                            74692000
                                                                        74693000
logical procedure restore'a'file (tdbuf, gbuf,                          74694000
                                  jitdst                          );    74695000
   value jitdst;                                                        74696000
   integer array tdbuf, gbuf;                                           74697000
   integer jitdst;                                                      74698000
   option privileged, uncallable;                                       74699000
                                                                        74700000
   ! this procedure restores a file.                                    74701000
                                                                        74702000
begin                                                                   74703000
                                                                        74704000
   define                                                               74705000
      a'any'sec          = %005251                    #,                74706000
      g'any'sec          = %04102041020d              #;                74707000
                                                                        74708000
   double pointer                                                       74709000
      fl'extmapd    := @flextmap'd,               ! ext map array (dbl) 74710000
      old'extmap'd  := @old'extmapd;              ! old ext map         74711000
                                                                        74712000
   integer array                                                        74713000
      scan'parms (0:1);                                                 74714000
                                                                        74715000
   byte array                                                           74716000
      lockword'quest   (0:72),                   ! lockword question    74716100
      title'           (0:26);                   ! file title           74717000
                                                                        74718000
   double array                                                         74719000
      extent'sizes  (0:max'num'extents-1),       ! size of extents      74720000
      old'disj'addr (0:max'num'extents-1),       ! addresses of disj ext74721000
      old'disj'len  (0:max'num'extents-1),       ! lengths of disj ext  74722000
      scan'parms'd (*) = scan'parms;                                    74723000
                                                                        74724000
                                                                        74725000
   double                                                               74726000
      dr,                                        ! return from dir funcs74727000
      faddr,                                     ! file address holder  74728000
      release'addr;                              ! release address      74729000
                                                                        74730000
   integer                                                              74731000
      faddr'1              = faddr,                                     74732000
      i,                                         ! counter              74733000
      len,                                       ! length of lockword'qu74733100
      old'disj'exts,                             ! num of disj exts     74734000
      release'ldev,                              ! release ldev         74735000
      req'type,                                  ! requisition type for 74736000
                                                 !    mount/dismount    74737000
      sub'code,                                  ! error code           74738000
      title'len,                                 ! length of title      74739000
      type                 := 0;                 ! type for direcscan   74740000
                                                                        74741000
   byte                                                                 74742000
      release'addr'b1    = release'addr;         ! release ldev         74743000
                                                                        74744000
   logical                                                              74745000
      directory'switched            := false,                           74746000
      disc'space'allocated          := false,                           74747000
      file'inserted'into'directory  := false,                           74748000
      old'file'hidden               := false;                           74749000
                                                                        74750000
   label                                                                74751000
      end'restore'a'file;                                               74752000
$page "CLEANUP of RESTORE'A'FILE"                                       74753000
<<---------------------------------------->>                            74754000
<<  cleanup of restore'a'file             >>                            74755000
<<---------------------------------------->>                            74756000
                                                                        74757000
subroutine cleanup;                                                     74758000
                                                                        74759000
   ! this procedure does cleanup based on various flags.                74760000
                                                                        74761000
begin                                                                   74762000
   get'sirs (true, true);                                               74763000
   disable'arithmetic'traps;                                            74764000
                                                                        74765000
   if old'copy'exists then                                              74766000
      begin                                                             74767000
                                                                        74768000
      if directory'switched then          ! switch it back              74769000
         begin                                                          74770000
         scan'parms'd := old'address;                                   74771000
         scan'parms . (08:08) := old'vtab;                              74772000
         type := 2;   << start at file level - go to file level>>       74773000
         dr := direcscan (type, file'index'ptr, res'acct,               74774000
                          res'group, res'file, adjust'fptr, scan'parms, 74775000
                          pvmvtabx);                                    74776000
         if <> then sendmessage (directory'error (dr));                 74777000
         end;                                                           74778000
                                                                        74779000
      if old'file'hidden then             ! unlock the file and make    74780000
         begin                            ! disc space adjustments      74781000
         dr := direcadjust (old'sectors - file'max'sectors,             74782000
            parms'tempi'1, res'acct, res'group, pvmvtabx);              74783000
         if <> then sendmessage (directory'error (dr));                 74784000
         old'flstorerestore := no'lockv;                                74785000
         labelio (old'flab, old'ldev, old'address, attio'write,         74786000
                  res'title);                                           74787000
         end;                                                           74788000
                                                                        74789000
      end                                                               74790000
                                                                        74791000
   else                                                                 74792000
      begin                                                             74793000
      if file'inserted'into'directory then  ! purge it                  74794000
         begin                                                          74795000
         dr := direcpurgefile (file'sectors, parms'tempi'1,             74796000
            res'acct, res'group, res'file, pvmvtabx);                   74797000
                                                                        74798000
         if <> then sendmessage (directory'error (dr));                 74799000
         end;                                                           74800000
      end;                                                              74801000
                                                                        74802000
   if disc'space'allocated then             ! deallocate it             74803000
      diskdealloc (flextsize'l, fllastextsize,                          74804000
                   flnumexts+1, flextmap'd);                            74805000
                                                                        74806000
   enable'arithmetic'traps;                                             74807000
   release'sirs (true, true);                                           74808000
                                                                        74809000
end <<cleanup of restore'a'file>>;                                      74810000
$page "FAIL of RESTORE'A'FILE"                                          74811000
<<---------------------------------------->>                            74812000
<<  fail of restore'a'file                >>                            74813000
<<---------------------------------------->>                            74814000
                                                                        74815000
subroutine fail (errnum);                                               74816000
         value   errnum;                                                74817000
         integer errnum;                                                74818000
begin                                                                   74819000
                                                                        74820000
   if errnum > 0 then                                                   74821000
      sendmessage (errnum);                                             74822000
                                                                        74823000
        <<do state-determined cleanup...>>                              74824000
                                                                        74825000
   cleanup;                           <<clean up everything>>           74826000
                                                                        74827000
   failed'file'count := failed'file'count + 1d;                         74828000
                                                                        74829000
   if kill'restore then restore'a'file := failed                        74830000
   else restore'a'file := good;                                         74831000
                                                                        74832000
   go end'restore'a'file;                                               74833000
end <<fail of restore'a'file>>;                                         74834000
$page "EVAL'RETURN of RESTORE'A'FILE"                                   74835000
<<---------------------------------------->>                            74836000
<<  eval'return of restore'a'file         >>                            74837000
<<---------------------------------------->>                            74838000
                                                                        74839000
subroutine eval'return(retval);                                         74840000
   value retval;                                                        74841000
   integer retval;                                                      74842000
begin                                                                   74843000
   if retval <> 0 then fail(retval);                                    74844000
end <<eval'return of restore'a'file>>;                                  74845000
$page "FILE'FAIL of RESTORE'A'FILE"                                     74846000
<<---------------------------------------->>                            74847000
<<  file'fail of restore'a'file           >>                            74848000
<<---------------------------------------->>                            74849000
                                                                        74850000
subroutine file'fail (fid, errnum);                                     74851000
         value        fid, errnum;                                      74852000
         integer      fid, errnum;                                      74853000
begin                                                                   74854000
                                                                        74855000
   if fid <> no'file then                                               74856000
      print'file'error (fid);                                           74857000
                                                                        74858000
   fail (errnum);                                                       74859000
                                                                        74860000
end <<file'fail of restore'a'file>>;                                    74861000
$page "ASSERT'LOCKWORD of RESTORE'A'FILE"                               74862000
<<---------------------------------------->>                            74863000
<<  assert'lockword of restore'a'file     >>                            74864000
<<---------------------------------------->>                            74865000
                                                                        74866000
subroutine assert'lockword;                                             74867000
                                                                        74868000
   ! this routine checks the lockword and makes sure that it matches or 74869000
   ! the user has sm, op, or am capabilities.                           74870000
                                                                        74871000
begin                                                                   74872000
   if sm'tog or cap'am then                                             74873000
   else if fllockword' <> look'lock',(file'part'size) then              74874000
      if look'lock' = blanks'8   then                                   74875000
         begin                                                          74876000
         sendmessage (rs'mess'tape'lock,,,lockword'quest);              74877000
         scan lockword'quest until 0,1;                                 74877010
                                                                        74877011
         len := tos - @lockword'quest;                                  74877020
         lockword'quest (len) := " ";                                   74877030
                                                                        74877031
         move lockword'quest (len+1) := title', (title'len);            74877040
         lockword'quest (len+1+title'len) := "?";                       74877050
                                                                        74877051
         len := len + 1 + title'len + 1;                                74877060
                                                                        74877061
         if freply (lockword'quest, len) = false then                   74877070
            fail (m'tape'bad'lockword)                                  74877080
         else if lockword'quest <> fllockword', (file'part'size) then   74877090
            fail (m'tape'bad'lockword);                                 74877100
                                                                        74878000
         end                                                            74882000
      else fail(m'tape'bad'lockword);                                   74883000
end <<assert'lockword of restore'a'file>>;                              74884000
$page "ASSERT'READ'ACCESS of RESTORE'A'FILE"                            74885000
<<---------------------------------------->>                            74886000
<<  assert'read'access of restore'a'file  >>                            74887000
<<---------------------------------------->>                            74888000
                                                                        74889000
subroutine assert'read'access;                                          74890000
                                                                        74891000
   ! this routine makes sure that the user has read access to the       74892000
   ! tape file.  the user needs either the store release bit to be      74893000
   ! true or read access to the file.                                   74894000
                                                                        74895000
begin                                                                   74896000
   if not fl'sr'release and                                             74897000
      not acccheck (filelevel, flacctname', a'any'sec, flgrpname',      74898000
                    g'any'sec, fluserid', flsecmx) . (readf) then       74899000
         fail (m'cant'read'tape'file);                                  74900000
                                                                        74901000
end <<assert'read'access of restore'a'file>>;                           74902000
$page "ASSERT'FILECODES'OK of RESTORE'A'FILE"                           74903000
<<---------------------------------------->>                            74904000
<<  assert'filecodes'ok of restore'a'file >>                            74905000
<<---------------------------------------->>                            74906000
                                                                        74907000
subroutine assert'filecodes'ok;                                         74908000
                                                                        74909000
   ! this routine checks to make sure that the file code of the         74910000
   ! file to restored is ok.  the filecode must fall between            74911000
   ! filecode'low and filecode'high.  if the filecode is negative       74912000
   ! then the user must have sm or op or pm capabilities or the         74913000
   ! global flag ignore'priv'check'flag must be true.                   74914000
                                                                        74915000
begin                                                                   74916000
   if (filecode'low > flfilecode) or (filecode'high < flfilecode) then  74917000
      fail(m'filecode'not'in'range);                                    74918000
                                                                        74919000
   if (flfilecode < 0) and not(sm'tog) and not(cap'pm) and              74920000
      not(ignore'priv'check'flag) then                                  74921000
         fail(m'negative'filecode);                                     74922000
                                                                        74923000
                                                                        74924000
$if x1=on then                <<debugging code>>                        74925000
   if debugging then                                                    74926000
      begin                                                             74927000
      say "FILECODES OK" endsay;                                        74928000
      send;                                                             74929000
      end;                                                              74930000
$if                                                                     74931000
                                                                        74932000
end <<assert'filecodes'ok of restore'a'file>>;                          74933000
$page "DERIVE'RES'CREATOR of RESTORE'A'FILE"                            74934000
<<---------------------------------------->>                            74935000
<<  derive'res'creator of restore'a'file  >>                            74936000
<<---------------------------------------->>                            74937000
                                                                        74938000
subroutine derive'res'creator;                                          74939000
begin                                                                   74940000
   if check'user (res'acct',res'creator',sub'code) = failed   then      74941000
      if res'acct' = logon'acct',(file'part'size) then                  74942000
         begin                                                          74943000
            move res'creator' := logon'user',(file'part'size);          74944000
            sendmessage (m'w'creator'changed);                          74945000
         end << res'acct = logon'acct >>                                74946000
      else                                                              74947000
         begin                                                          74948000
         move res'creator' := "RESTORE ";                               74949000
         sendmessage (m'w'creator'changed);                             74950000
         end; << else - res'acct = logon'acct >>                        74951000
                                                                        74952000
                                                                        74953000
$if x1=on then                <<debugging code>>                        74954000
   if debugging then                                                    74955000
      begin                                                             74956000
      say "RES'CREATOR IS " endsay;                                     74957000
      say res'creator',(file'part'size) endsay;                         74958000
      send;                                                             74959000
      end;                                                              74960000
$if                                                                     74961000
                                                                        74962000
end <<derive'res'creator of restore'a'file>>;                           74963000
$page "ASSERT'USER'EXISTENCE of RESTORE'A'FILE"                         74964000
<<------------------------------------------>>                          74965000
<<  assert'user'existence of restore'a'file >>                          74966000
<<------------------------------------------>>                          74967000
                                                                        74968000
subroutine assert'user'existence;                                       74969000
begin                                                                   74970000
   if dont'chk'user then return;                                        74971000
   if last'acct' = res'acct', (file'part'size) land                     74972000
      last'user' = res'creator', (file'part'size) then                  74973000
         move res'creator' := last'res'user', (file'part'size)          74974000
   else                                                                 74975000
      begin                                                             74976000
      move last'user' := res'creator', (file'part'size);                74977000
                                                                        74978000
      if (not seen'creator) and (not create'user'flag) then             74979000
         derive'res'creator                                             74980000
      else if check'user (res'acct',res'creator',sub'code) = failed     74981000
         then                                                           74982000
            if sub'code = 2 then fail(m'no'acct)                        74983000
            else if sub'code = 3 then fail(m'no'creator)                74984000
            else fail(m'error'user'validation);                         74985000
                                                                        74986000
      move last'res'user' := res'creator', (file'part'size);            74987000
      end;                                                              74988000
                                                                        74989000
$if x1=on then                <<debugging code>>                        74990000
   if debugging then                                                    74991000
      begin                                                             74992000
      say "CREATOR EXISTS" endsay;                                      74993000
      send;                                                             74994000
      end;                                                              74995000
$if                                                                     74996000
                                                                        74997000
end <<assert'user'existence of restore'a'file>>;                        74998000
$page "GET'SIZES of RESTORE'A'FILE"                                     74999000
<<---------------------------------------->>                            75000000
<<  get'sizes of restore'a'file           >>                            75001000
<<---------------------------------------->>                            75002000
                                                                        75003000
subroutine get'sizes;                                                   75004000
begin                                                                   75005000
   file'sectors := find'file'size (file'size'minv, extent'sizes);       75006000
   file'max'sectors := find'file'size (file'size'maxv, extent'sizes);   75007000
end <<get'sizes of restore'a'file>>;                                    75008000
$page "ADJUST'FLAB of RESTORE'A'FILE"                                   75009000
<<---------------------------------------->>                            75010000
<<  adjust'flab of restore'a'file         >>                            75011000
<<---------------------------------------->>                            75012000
                                                                        75013000
subroutine adjust'flab;                                                 75014000
                                                                        75015000
begin                                                                   75016000
                                                                        75017000
$if x1=on then                <<debugging code>>                        75018000
   if debugging then                                                    75019000
      begin                                                             75020000
      say "ENTERING ADJUST'FLAB" endsay;                                75021000
      send;                                                             75022000
      end;                                                              75023000
$if                                                                     75024000
                                                                        75025000
   move fllocname' := res'file', (file'part'size);                      75026000
   move flgrpname' := res'group',(file'part'size);                      75027000
   move flacctname' := res'acct',(file'part'size);                      75028000
   move fluserid'   := res'creator', (file'part'size);                  75029000
                                                                        75030000
   fl'sr'release := 0;                                                  75031000
                                                                        75032000
   if not olddate'flag then                                             75033000
      begin                                                             75034000
      fllastacc := todays'date;                                         75035000
      fllastmod := todays'date;                                         75036000
      end;                                                              75037000
                                                                        75038000
   flpvinfo := 0;                                                       75039000
   flfcbvect := 0d;                                                     75040000
                                                                        75041000
   if old'copy'exists then flsrlx := %(2)0000                           75042000
   else flsrlx := %(2)1100;                                             75043000
                                                                        75044000
   fldevtype := ldevtotype (file'ldev);                                 75045000
   fldevsubtype := ldevtosubtype (file'ldev);                           75046000
                                                                        75047000
   flrw := 0;                                                           75048000
                                                                        75049000
   flclid := cold'load'id;                                              75050000
                                                                        75051000
   ldevtovtab (flextmap'd, flextmap'd, flnumexts+1, pvmvtabx<>0);       75052000
                                                                        75053000
   flalloctime := clock;                                                75054000
   flallocdate'l := calendar;                                           75055000
                                                                        75056000
   << fldevname has already been changed >> !help                       75057000
                                                                        75058000
$if x1=on then                <<debugging code>>                        75059000
   if debugging then                                                    75060000
      begin                                                             75061000
      say "LEAVING ADJUST'FLAB" endsay;                                 75062000
      send;                                                             75063000
      end;                                                              75064000
$if                                                                     75065000
                                                                        75066000
                                                                        75067000
end <<adjust'flab of restore'a'file>>;                                  75068000
$page "FINISHUP of RESTORE'A'FILE"                                      75069000
<<---------------------------------------->>                            75070000
<<  finishup of restore'a'file            >>                            75071000
<<---------------------------------------->>                            75072000
                                                                        75073000
subroutine finishup;                                                    75074000
begin                                                                   75075000
   if not old'copy'exists then                                          75076000
      begin                                                             75077000
      flstorerestore := 0;                                              75078000
      eval'return (labelio (flab, file'ldev, file'address, attio'write, 75079000
                            res'title));                                75080000
      end;                                                              75081000
   good'file'count := good'file'count + 1d;                             75082000
   if show'flag then sendmessage (m'restored);                          75083000
   if show'security'flag then                                           75084000
      sendmessage (m'security);                                         75085000
end <<finishup of restore'a'file>>;                                     75086000
$page "GET'TARGETS of RESTORE'A'FILE"                                   75087000
<<---------------------------------------->>                            75088000
<<  get'targets of restore'a'file         >>                            75089000
<<---------------------------------------->>                            75090000
                                                                        75091000
subroutine get'targets;                                                 75092000
begin                                                                   75093000
   move res'file' := fllocname', (file'part'size);                      75094000
                                                                        75095000
   if local'flag or seen'acct then                                      75096000
   else move res'acct' := flacctname', (file'part'size);                75097000
                                                                        75098000
   if local'flag or seen'group then                                     75099000
   else move res'group' := flgrpname', (file'part'size);                75100000
                                                                        75101000
   if blank'creator then                                                75102000
      move res'creator' := fluserid', (file'part'size)                  75103000
   else if seen'creator then                                            75104000
      ! already in res'creator'                                         75105000
   else if seen'local then                                              75106000
      begin                                                             75107000
      move res'creator' := logon'user', (file'part'size);               75108000
      dont'chk'user := true;                                            75109000
      end                                                               75110000
   else                                                                 75111000
      move res'creator' := fluserid', (file'part'size);                 75112000
                                                                        75113000
$if x1=on then                <<debugging code>>                        75114000
   if debugging then                                                    75115000
      begin                                                             75116000
      say "GET'TARGETS DONE" endsay;                                    75117000
      send;                                                             75118000
      say "   RES'ACCT'    = " endsay;                                  75119000
      say res'acct',(file'part'size) endsay;                            75120000
      send;                                                             75121000
      say "   RES'GROUP'   = " endsay;                                  75122000
      say res'group',(file'part'size) endsay;                           75123000
      send;                                                             75124000
      say "   RES'CREATOR' = " endsay;                                  75125000
      say res'creator',(file'part'size) endsay;                         75126000
      send;                                                             75127000
      end;                                                              75128000
$if                                                                     75129000
                                                                        75130000
end <<get'targets of restore'a'file>>;                                  75131000
$page "SWITCH'TO'NEW'FILE of RESTORE'A'FILE"                            75132000
<<---------------------------------------->>                            75133000
<<  switch'to'new'file of restore'a'file  >>                            75134000
<<---------------------------------------->>                            75135000
                                                                        75136000
subroutine switch'to'new'file;                                          75137000
begin                                                                   75138000
                                                                        75139000
   if old'copy'exists then                                              75140000
      begin                                                             75141000
      scan'parms'd := file'address;                                     75142000
      scan'parms.(00:08) := file'vtab;                                  75143000
                                                                        75144000
      type := 2;    <<start at file level - goto file level>>           75145000
                                                                        75146000
      disable'arithmetic'traps;                                         75147000
                                                                        75148000
      dr := direcscan (type, file'index'ptr, res'acct, res'group,       75149000
                       res'file, adjust'fptr, scan'parms, pvmvtabx);    75150000
                                                                        75151000
      enable'arithmetic'traps;                                          75152000
                                                                        75153000
      if <> then fail (directory'error (dr));                           75154000
                                                                        75155000
      directory'switched := true;                                       75156000
                                                                        75157000
$if x1=on then                                                          75158000
      if debugging then                                                 75159000
         begin                                                          75160000
         say "   SWITCHED TO NEW FILE AT %" endsay;                     75161000
         saydoctal (scan'parms'd);                                      75162000
         send;                                                          75163000
         end;                                                           75164000
$if                                                                     75165000
      end;                                                              75166000
end <<switch'to'new'file of restore'a'file>>;                           75167000
$page "INSERT'NEW'FILE of RESTORE'A'FILE"                               75168000
<<---------------------------------------->>                            75169000
<<  insert'new'file                       >>                            75170000
<<---------------------------------------->>                            75171000
                                                                        75172000
subroutine insert'new'file;                                             75173000
begin                                                                   75174000
                                                                        75175000
   if not old'copy'exists then                                          75176000
      begin                                                             75177000
                                                                        75178000
      faddr := file'address;                                            75179000
      faddr'1 . (00:08) := file'vtab;                                   75180000
                                                                        75181000
      get'sirs (true, true);                                            75182000
      disable'arithmetic'traps;                                         75183000
                                                                        75184000
      dr := direcinsertfile (file'sectors, parms'tempi'1, res'acct,     75185000
                             res'group, res'file, faddr, pvmvtabx);     75186000
                                                                        75187000
      if <> then                                                        75188000
         fail (directory'error (dr));                                   75189000
                                                                        75190000
      enable'arithmetic'traps;                                          75191000
      release'sirs (true, true);                                        75192000
                                                                        75193000
      file'inserted'into'directory := true;                             75194000
$if x1=on then                                                          75195000
      if debugging then                                                 75196000
         begin                                                          75197000
         say "NEW FILE INSERTED INTO DIRECTORY" endsay;                 75198000
         send;                                                          75199000
         end;                                                           75200000
$if                                                                     75201000
      end;                                                              75202000
end;                                                                    75203000
$page "PURGE'OLD'FILE of RESTORE'A'FILE"                                75204000
<<---------------------------------------->>                            75205000
<<  purge'old'file of restore'a'file      >>                            75206000
<<---------------------------------------->>                            75207000
                                                                        75208000
subroutine purge'old'file;                                              75209000
begin                                                                   75210000
                                                                        75211000
   if old'copy'exists then                                              75212000
      begin                                                             75213000
                                                                        75214000
      join'contiguous'extents (old'disj'exts, old'disj'addr,            75215000
                               old'disj'len,  old'extmap'd,             75216000
                               old'numexts+1, old'extsize'd,            75217000
                               old'lastextsiz'd);                       75218000
                                                                        75219000
      disable'arithmetic'traps;                                         75220000
                                                                        75221000
      i := -1;                                                          75222000
      while (i:=i+1) <= old'disj'exts do                                75223000
         if old'disj'addr (i) <> 0d then                                75224000
            begin                                                       75225000
            release'addr := old'disj'addr (i);                          75226000
            release'ldev := logical (release'addr'b1);                  75227000
            release'addr'b1 := 0;                                       75228000
            return'disc'space (release'ldev, release'addr,              75229000
                               old'disj'len (i));                       75230000
            end;                                                        75231000
                                                                        75232000
      enable'arithmetic'traps;                                          75233000
                                                                        75234000
      end;                                                              75235000
                                                                        75236000
end <<purge'old'file of restore'a'file>>;                               75237000
$page "INIT'RESTORE'A'FILE of RESTORE'A'FILE"                           75238000
<<---------------------------------------->>                            75239000
<<  init'restore'a'file of restore'a'file >>                            75240000
<<---------------------------------------->>                            75241000
                                                                        75242000
subroutine init'restore'a'file;                                         75243000
begin                                                                   75244000
   tape'reel := tl'reelnum;                                             75245000
   file'was'opened := false;                                            75246000
   kill'restore := false;                                               75247000
   read'was'already'done := false;                                      75248000
   restore'a'file := good;                                              75249000
end <<init'restore'a'file of restore'a'file>>;                          75250000
$page "UNBUMP'DISC'USECOUNT of RESTORE'A'FILE"                          75251000
<<----------------------------------------->>                           75252000
<<  unbump'disc'usecount of restore'a'file >>                           75253000
<<----------------------------------------->>                           75254000
                                                                        75255000
subroutine unbump'disc'usecount;                                        75256000
begin                                                                   75257000
   diskdealloc (flextsize'l, fllastextsize, -(flnumexts+1), flextmap'd);75258000
                                                                        75259000
$if x1=on then                                                          75260000
   if debugging then                                                    75261000
      begin                                                             75262000
      say "DISC USECOUNT HAS BEEN UNBUMPED" endsay ;                    75263000
      send;                                                             75264000
      end;                                                              75265000
$if                                                                     75266000
end;                                                                    75267000
$page "RESTORE'A'FILE mainline"                                         75268000
$if x1=on then                <<debugging code>>                        75269000
   if debugging then                                                    75270000
      begin                                                             75271000
      say "ENTERING RESTORE'A'FILE" endsay;                             75272000
      send;                                                             75273000
      end;                                                              75274000
$if                                                                     75275000
                                                                        75276000
   init'restore'a'file;                                                 75277000
                                                                        75278000
   get'targets;                                                         75278100
                                                                        75278200
   display'3'to'display (title', title'len, fllocname',                 75279000
                         res'group', res'acct'          );              75280000
                                                                        75281000
   if sm'tog then change'jit'acct (jitdst, res'acct);                   75283000
   assert'filecodes'ok;                                                 75284000
   assert'read'access;                                                  75285000
   assert'lockword;                                                     75286000
                                                                        75287000
   get'sizes;                                                           75288000
                                                                        75289000
   eval'return (lock'directory);                                        75290000
   assert'user'existence;                                               75291000
                                                                        75292000
   eval'return  ( hide'old'copy );                                      75293000
   old'file'hidden := true;                                             75294000
                                                                        75295000
   if not pick'a'device (extent'sizes) then fail (m'out'of'disc'space); 75296000
   disc'space'allocated := true;                                        75297000
                                                                        75298000
   adjust'flab;                                                         75299000
                                                                        75300000
   eval'return (labelio (flab, file'ldev, file'address, attio'write,    75301000
                         res'title));                                   75302000
                                                                        75303000
   insert'new'file;                                                     75304000
                                                                        75305000
   if using'attio then read'all'attio;                                  75306000
                                                                        75307000
   eval'return ( write'the'file (tdbuf, gbuf) );                        75308000
                                                                        75309000
   purge'old'file;                                                      75310000
   switch'to'new'file;                                                  75311000
   unbump'disc'usecount;                                                75312000
   finishup;                  !help                                     75313000
                                                                        75314000
                                                                        75315000
                                                                        75316000
$if x1=on then                <<debugging code>>                        75317000
   if debugging then                                                    75318000
      begin                                                             75319000
      say "***************************************************" endsay; 75320000
      send;                                                             75321000
      say "***************************************************" endsay; 75322000
      send;                                                             75323000
      say "RESTORE'A'FILE SUCCESSFUL" endsay;                           75324000
      send;                                                             75325000
      send;                                                             75326000
      send;                                                             75327000
      end;                                                              75328000
$if                                                                     75329000
                                                                        75330000
end'restore'a'file:                                                     75331000
                                                                        75332000
                                                                        75333000
$if x1=on then                <<debugging code>>                        75334000
   if debugging then                                                    75335000
      begin                                                             75336000
      say "***************************************************" endsay; 75337000
      send;                                                             75338000
      say "***************************************************" endsay; 75339000
      send;                                                             75340000
      say "LEAVING RESTORE'A'FILE" endsay;                              75341000
      send;                                                             75342000
      send;                                                             75343000
      send;                                                             75344000
      end;                                                              75345000
$if                                                                     75346000
                                                                        75347000
   end <<restore'a'file>>;                                              75348000
$page ";SENDMESSAGE=  SENDMESSAGE --- OUTPUT ROUTINE"                   80000000
$control segment=sendmessage                                            80002000
<<***************************************************************>>     80004000
logical procedure sendmessage (msgno, send'no'crlf,            <<lb.rs>>80006000
                               tell'to'op, string);            <<lb.rs>>80006100
         value msgno, send'no'crlf, tell'to'op;                         80008000
         integer msgno;                                                 80010000
         logical send'no'crlf, tell'to'op;                              80012000
         byte array string;                                             80012100
         option variable, uncallable;                                   80014000
                                                                        80016000
      <<---------------------------------------------------->>          80018000
      << this procedure is the master message generator     >>          80020000
      << for store/restore.  two kinds of parameters are    >>          80022000
      << passed to msgno: things that look like m'... and   >>          80024000
      << things that look like sr'... or rs'...             >>          80026000
      <<                                                    >>          80028000
      << messages of the form sr'... or rs'... are simple   >>          80030000
      << messages and are merely system catalog message     >>          80032000
      << numbers from the sr'message'set set.               >>          80034000
      << these messages are generated and sent to the       >>          80036000
      << output files (syslist and/or offline), and then    >>          80038000
      << the routine returns to the caller.                 >>          80040000
      <<                                                    >>          80042000
      << for ease of testing, we check to see if we have    >>          80044000
      << opened a catalog file (rather than depending on    >>          80046000
      << catalog.pub.sys).  if we have, the variable        >>          80048000
      << store'catalog is non-zero; and we will use it      >>          80050000
      << to generate messages.  if store'catalog is zero,   >>          80052000
      << the system catalog is accessed (via formsg and     >>          80054000
      << genmsg) for all messages.                          >>          80056000
      <<                                                    >>          80058000
      << messages of the form m'... are special messages.   >>          80060000
      << each m'... message is converted into a list of     >>          80062000
      << smaller "parts" (by find'msg'template), which      >>          80064000
      << are then "executed" (or "invoked" or "interpreted")>>          80066000
      << by interpret'template.  this mechanism allows us   >>          80068000
      << to easily construct messages whose formatting goes >>          80070000
      << beyond what the mpe message system gives us.       >>          80072000
      << each m'... declared in the outer block should      >>          80074000
      << have a matching occurance in the msg'control array >>          80076000
      << declared in this procedure.  this array consists   >>          80078000
      << of varying size entries of the form:               >>          80080000
      <<      msg#, #parts, part1, part2, ..., partn        >>          80082000
      << the last entry in the array has a msg# of 0 and    >>          80084000
      << one part which is p'unknown.                       >>          80086000
      <<                                                    >>          80088000
      << to add a new kind of "part", add the appropriate   >>          80090000
      << equate below (in alphabetic order, please), and    >>          80092000
      << add it to the case statement in interpret'template.>>          80094000
      <<                                                    >>          80096000
      << to add a new m'... message, declare it in the      >>          80098000
      << outer block with the others (if you maintain alpha->>          80100000
      << betic order (which is nice), all modules refering  >>          80102000
      << to m'... numbers after your new one will have to   >>          80104000
      << be recompiled!), and add an entry for it in the    >>          80106000
      << msg'control array (in alphabetic order always).    >>          80108000
      <<                                                    >>          80110000
      << note that all m'... message numbers must be less   >>          80112000
      << than "FIRST'REAL'MSG" which is the message number  >>          80114000
      << of the first sr'... or rs'... message.  this allows>>          80116000
      << easy differentiation between the two kinds of      >>          80118000
      << messages.                                          >>          80120000
      <<                                                    >>          80122000
      << any time we look up the template for a m'... and   >>          80124000
      << cannot find it, it defaults to:  1, p'unknown.     >>          80126000
      <<                                                    >>          80128000
      << a couple of msgnos are handled specially:          >>          80130000
      <<    sr'break'sensed, m'stored, and m'restored       >>          80132000
      <<                                                    >>          80134000
      << sr'break'sensed is printed iff the flag            >>          80136000
      << break'msg'seen is false.  the flag is then set     >>          80138000
      << to true.  (this particular error filters back thru >>          80140000
      << many levels and, without this kludge, would appear >>          80142000
      << to the user more than once!)                       >>          80144000
      <<                                                    >>          80146000
      << m'stored and m'restored are ignored if show'flag   >>          80148000
      << is not set.  this is done here rather than in      >>          80150000
      << the caller (fstore and frestore) to minimize their >>          80152000
      << knowledge of output formatting and control.        >>          80154000
      <<                                                    >>          80154010
      << if send'no'crlf is passed and it is true then      >>          80154020
      << sendmessage will not add a carriage return-line    >> <<lb.rs>>80154030
      << feed to the message.                               >> <<lb.rs>>80154040
      <<                                                    >> <<lb.rs>>80154050
      << if tell'to'op is passed and it is true then        >> <<lb.rs>>80154060
      << sendmessage will send the output to the operator's >> <<lb.rs>>80154070
      << console instead of to syslist.                     >> <<lb.rs>>80154080
      <<                                                    >> <<lb.rs>>80154090
      << if string is passed then sendmessage will place    >> <<lb.rs>>80154100
      << the message in string instead of printing it to    >> <<lb.rs>>80154110
      << syslist.                                           >> <<lb.rs>>80154120
      <<---------------------------------------------------->>          80156000
                                                                        80158000
   begin                                                                80160000
                                                                        80162000
                                                                        80164000
   double                                                               80166000
      d;                                                                80168000
                                                                        80170000
   integer array                                                        80172000
      template    (0:15);     <<at most 16 parts in a template!>>       80174000
                                                                        80176000
   integer                                                              80178000
      control'code,                                                     80180000
      dummy,                                                            80182000
      fid         := 0,       <<used to handle wide/narrow stuff>>      80184000
      i           := 0,       <<scratch integer>>                       80186000
      inx         := 0,       <<index: msg'control & template>>         80188000
      len         := 0,                                                 80190000
      loc'lev,                                                          80192000
      loops       := 0,       <<will be either 1 or 2>>                 80194000
      msg'parts   := 0,       <<number of parts in a template.>>        80196000
      ptype       := 0,       <<type of a template part>>               80198000
      recsize     := 0,       <<used for wide/narrow stuff>>            80200000
      syslistnum  := 0;                                                 80202000
                                                                        80202100
   integer                                                              80202200
      pat'char        := 0,                                             80202300
      pat'inx         := 1,                                             80202400
      pat'len         := 0,                                             80202500
      pat'parts       := 0,                                             80202600
      pat'total'len   := 0,                                             80202610
      pat'word        := 0;                                             80202700
                                                                        80204000
   logical array                                                        80206000
      scratch     (0:66),                                               80208000
      text1       (0:66),                                               80210000
      text2       (0:66);                                               80212000
                                                                        80214000
   double array                                                         80216000
      scratch'd   (*) = scratch (0);                                    80218000
                                                                        80220000
   logical                                                              80222000
      l1,                                                               80224000
      l2,                                                               80226000
      l3,                                                               80228000
      pmask  = q-4,           <<parameter mask>>                        80230000
      put'in'string := true,  <<use string instead of syslist>><<lb.rs>>80231000
      size'flags;             <<used to control output width>>          80232000
                                                                        80234000
   byte array                                                           80236000
      scratch'    (*) = scratch (0),                                    80238000
      text1'      (*) = text1 (0),                                      80240000
      text2'      (*) = text2 (0);                                      80242000
                                                                        80244000
   byte pointer                                                         80246000
      p,                                                                80248000
      ptext,                                                            80250000
      save'ptext;                                                       80252000
                                                                        80254000
$page                                                                   80256000
   equate                                                               80258000
         <<these equates are alphabetically ordered and monotonically   80260000
           increasing...>>                                              80262000
                                                                        80264000
      p'bad'filesize= 0         + 1, <<filesize was invalid>>           80266000
      p'changed'creator  = p'bad'filesize+1, <<creator was changed>>    80268000
      p'date      = p'changed'creator+1, <<appends the date/time>>      80270000
      p'date'range= p'date       + 1,<<adate...mdate not in range>>     80272000
      p'dateline  = p'date'range + 1,<<dateline intrinsic text>>        80274000
      p'direc     = p'dateline   + 1,<<acct,creator,group parms goofup>>80276000
      p'disk'err  = p'direc      + 1,<<disk io error>>                  80278000
      p'double'1  = p'disk'err   + 1,                                   80280000
      p'double'2  = p'double'1   + 1,                                   80282000
      p'errnum    = p'double'2   + 1, <<error number>>         <<lb.rs>>80283000
      p'fcheck    = p'errnum     + 1, <<file intrinsic ret>>   <<lb.rs>>80284000
      p'filecode'range=p'fcheck  + 1,<<filecode not in range>>          80286000
      p'flab'address=p'filecode'range+1,                                80288000
      p'flab'checksum=p'flab'address+1,                                 80290000
      p'flab'read = p'flab'checksum+1,                                  80292000
      p'flab'title= p'flab'read  + 1,                                   80294000
      p'flab'write= p'flab'title + 1,                                   80296000
      p'heading   = p'flab'write + 1,    <<heading line>>               80298000
      p'indent9   = p'heading    + 1,    << "         " >>              80300000
      p'info      = p'indent9   + 1, <<ldn%addrss reel code size typ>>  80302000
      p'level     = p'info      + 1, <<group grpname in acct acctname>> 80304000
                                     <<user  usrname in acct acctname>> 80306000
                                     <<acct acctname>>                  80308000
      p'line2     = p'level     + 1, <<switch to text2' buffer>>        80310000
      p'mnum      = p'line2     + 1, <<append message number>> <<06156>>80311000
      p'not'title = p'mnum      + 1, <<standard'not'title >>   <<06312>>80312000
      p'not'purged= p'not'title + 1, <<not purged>>                     80313000
      p'nsr       = p'not'purged+ 1, <<p'title, not stored/restored>>   80314000
      p'num       = p'nsr       + 1, <<write out parms'tempi'1>>        80316000
      p'open'fail = p'num       + 1, <<open'file failed>>               80318000
      p'pattern   = p'open'fail + 1, <<pattern>>                        80319000
      p'restore'p = p'pattern   + 1, <<preview of restore>>             80320000
      p'security  = p'restore'p + 1, <<security information>>           80322000
      p'summary   = p'security  + 1, <<store/restore summary count>>    80324000
      p'text      = p'summary   + 1, <<txt count in words, then txt>>   80326000
      p'title     = p'text      + 1, <<text: byte address and length>>  80328000
      p'unknown   = p'title     + 1, <<unknown ptype>>                  80330000
                                                                        80332000
         <<highest legal value of p'...>>                               80334000
                                                                        80336000
      p'max'p'    = p'unknown;                                          80338000
$page                                                                   80340000
                                                                        80342000
         <<these equates are used to access the message catalog...      80344000
           and are used only within sendmessage!                        80346000
           they are in the same order as within the message catalog...  80348000
           they must not be less than 1000!>>                           80350000
                                                                        80352000
   equate                                                               80354000
      msg'read'access'failure    = 1001,                                80356000
      msg'access'10'failure      = 1002,                                80358000
      msg'acct                   = 1003,                                80360000
      msg'adate                  = 1004,                                80362000
      msg'cdate                  = 1005,                                80364000
      msg'creator                = 1006,                                80366000
      msg'defective'file'label   = 1007,                                80368000
      msg'direcscan'error        = 1008,                                80370000
      msg'directory'error        = 1009,                                80372000
      msg'file                   = 1010,                                80374000
      msg'file'busy              = 1011,                                80376000
      msg'filecode'negative      = 1012,                                80378000
      msg'filecode               = 1013,                                80380000
      msg'file'io'busy           = 1014,                                80382000
      msg'file'read'busy         = 1015,                                80384000
      msg'file'write'busy        = 1016,                                80386000
      msg'group                  = 1017,                                80388000
      msg'bad'irestore'title     = 1018,                                80390000
      msg'tape'version           = 1019,                                80392000
      msg'inuse'restore          = 1020,                                80394000
      msg'inuse'store            = 1021,                                80396000
      msg'label'read'fail        = 1022,                                80398000
      msg'label'write'fail       = 1023,                                80400000
      msg'lockword'mismatch      = 1024,                                80402000
      msg'mdate                  = 1025,                                80404000
      msg'not'in'directory       = 1026,                                80406000
      msg'not'restored           = 1027,                                80408000
      msg'not'stored             = 1028,                                80410000
      msg'nounlock'write'failed  = 1029,                                80412000
      msg'program'running        = 1030,                                80414000
      msg'pv'mount'fail          = 1031,                                80416000
      msg'disc'lock              = 1032,                                80418000
      msg'will'restore           = 1033,                                80420000
      msg'inuse'write            = 1034,                                80422000
      msg'not'in'range           = 1035,                                80424000
      msg'files'on'tape          = 1036,                                80426000
      msg'released               = 1037,                                80428000
      msg'no'restore'files       = 1038,                                80430000
      msg'no'store'files         = 1039,                                80432000
      msg'disk'read'err          = 1040,                                80434000
      msg'disk'write'err         = 1041,                                80436000
      msg'address                = 1042,                                80438000
      msg'sectors                = 1044,                                80440000
      msg'error                  = 1045,                                80442000
      msg'curr'title             = 1046,                                80444000
      msg'last'title             = 1047,                                80446000
      msg'failed'to'restore      = 1048,                                80448000
      msg'failed'to'store        = 1049,                                80450000
      msg'store'io'error         = 1050,                                80452000
      msg'files'restored         = 1051,                                80454000
      msg'files'stored           = 1052,                                80456000
      msg'files'not'restored     = 1053,                                80458000
      msg'files'not'stored       = 1054,                                80460000
      msg'failed'restore'files   = 1055,                                80462000
      msg'failed'stored'files    = 1056,                                80464000
      msg'restore'io'error       = 1057,                                80466000
      msg'heading1               = 1058,                                80468000
      msg'heading2               = 1059,                                80470000
      msg'dateheading            = 1060,                                80472000
      msg'open'fail              = 1061,                                80474000
      msg'not'on'tape            = 1062,                                80476000
      msg'cant'access'this'file  = 1063,                                80478000
      msg'cant'restore'this'file = 1064,                                80480000
      msg'expected               = 1065,                                80482000
      msg'found                  = 1066,                                80484000
      msg'flab'address'mismatch  = 1067,                                80486000
      msg'label'address          = 1068,                                80488000
      msg'first'extent           = 1069,                                80490000
      msg'flab'checksum          = 1070,                                80492000
      msg'checksum'computed      = 1071,                                80494000
      msg'checksum'found         = 1072,                                80496000
      msg'flab'title             = 1073,                                80498000
      msg'pv'dismount'fail       = 1074,                                80500000
      msg'not'all'sectors'written= 1075,                                80502000
      msg'error'validating       = 1076,                                80504000
      msg'accross'accounts       = 1077,                                80506000
      msg'no'save'access         = 1078,                                80508000
      msg'disc'lockword          = 1079,                                80510000
      msg'tape'lockword          = 1080,                                80512000
      msg'cant'purge             = 1081,                                80514000
      msg'cant'read              = 1082,                                80516000
      msg'access'violation       = 1083,                                80518000
      msg'creator'changed        = 1084,                                80520000
      msg'to                     = 1085,                                80522000
      msg'volume'set             = 1087,                                80524000
      msg'mount'failed           = 1088,                                80526000
      msg'missing'eof            = 1089,                                80528000
      msg'reading'trlbl          = 1090,                                80530000
      msg'fcheck'returns         = 1091,                                80532000
      msg'bad'size               = 1092,                                80534000
      msg'user'specified         = 1093,                                80536000
      msg'logon'acct'assumed     = 1094,                                80538000
      msg'validation'failed      = 1095,                                80540000
      msg'getting'next'vol       = 1096,                                80542000
      msg'eof'labeled            = 1097,                                80544000
      msg'no'files'restored      = 1098,                                80546000
      msg'failed'to'purge        = 1099,                                80548000
      msg'writing'eof            = 1100,                                80550000
      msg'saving'restored'file   = 1101,                                80552000
      msg'keep                   = 1102,                                80554000
      msg'acct'group             = 1103,                                80556000
      msg'acct'user              = 1104,                                80558000
      msg'problem'verifying      = 1105,                                80560000
      msg'acct'exists            = 1106,                                80562000
      msg'user                   = 1107,                                80564000
      msg'loaded                 = 1108,                                80566000
      msg'synchronizing          = 1109,                                80568000
      msg'created'dir'entry      = 1110,                                80570000
      msg'no'create              = 1111,                                80572000
      msg'in                     = 1112,                                80574000
      msg'io'error               = 1113,                                80576000
      msg'eof'err                = 1114,                                80578000
      msg'clock'time             = 1115,                                80580000
      msg'cpu'time               = 1116,                                80582000
      msg'msecs                  = 1117,                                80584000
      msg'this'is'reel'no        = 1118,                                80586000
      msg'desired'reel'is'no     = 1119,                                80588000
      msg'from                   = 1120,                                80590000
      msg'prev'catastrophic      = 1121,                       <<lb.rs>>80592000
      msg'acct'disc'space        = 1122,                       <<lb.rs>>80592010
      msg'group'disc'space       = 1123,                       <<lb.rs>>80592020
      msg'acct'save'access       = 1124,                       <<lb.rs>>80592030
      msg'group'save'access      = 1125,                       <<lb.rs>>80592040
      msg'direc'no'room          = 1126,                       <<lb.rs>>80592050
      msg'direc'unknown          = 1127,                       <<lb.rs>>80592060
      msg'exclusive'access       = 1128,                       <<lb.rs>>80592070
      msg'bad'disc'lockword      = 1129,                       <<lb.rs>>80592080
      msg'out'of'disc'space      = 1130,                       <<lb.rs>>80592090
      msg'tape'error             = 1131,                       <<lb.rs>>80592100
      msg'not'purged             = 1132,                                80592110
      msg'holder                 =    0;                       <<lb.rs>>80593999
                                                                        80594000
$page                                                                   80596000
                                                                        80598000
            <<this array uses the p' and msg' equates to                80600000
              build messages...>>                                       80602000
                                                                        80604000
   integer array                                                        80606000
                                                                        80608000
      msg'control (*) = pb:=                                            80610000
                                                                        80612000
            <<message#>>                                                80614000
                                                                        80616000
               <<#pnn   ... template parts...>>                         80618000
                                                                        80620000
         m'read'access'failure,                                         80622000
               2,    p'nsr, msg'read'access'failure,                    80624000
         m'access'10'failure,                                           80626000
               2,    p'nsr, msg'access'10'failure,                      80628000
         m'acct'disc'space,                                    <<lb.rs>>80628100
               2,    p'nsr, msg'acct'disc'space,               <<lb.rs>>80628200
         m'acct'save'access,                                   <<lb.rs>>80628300
               2,    p'nsr, msg'acct'save'access,              <<lb.rs>>80628400
         m'adate'not'in'range,                                          80630000
               3,    p'nsr, msg'adate, p'date'range,                    80632000
         m'bad'irestore'title,                                          80634000
               3,    msg'bad'irestore'title, p'text, p'mnum,   <<06156>>80636000
         m'blank'line,                                                  80638000
               0,                                                       80640000
         m'cant'purge'disc'file,                                        80642000
               2,    p'nsr, msg'cant'purge,                             80644000
         m'cant'read'tape'file,                                         80646000
               2,    p'nsr, msg'cant'read,                              80648000
         m'cant'restore'this'file,                                      80650000
               2,    p'nsr, msg'cant'restore'this'file,                 80652000
         m'cdate'not'in'range,                                          80654000
               3,    p'nsr, msg'cdate, p'date'range,                    80656000
         m'contained'tape'error,                               <<lb.rs>>80656100
               2,    p'nsr, msg'tape'error,                    <<lb.rs>>80656200
         m'created'dir'entry,                                           80658000
               3,    p'level, msg'created'dir'entry, p'mnum,   <<06156>>80660000
         m'dateline,                                                    80662000
               1,    p'dateline,                                        80664000
         m'direc'no'room,                                      <<lb.rs>>80664100
               3,    p'nsr, msg'direc'no'room, p'errnum,       <<lb.rs>>80664200
         m'direc'unxpected,                                    <<lb.rs>>80664300
               3,    p'nsr, msg'direc'unknown, p'errnum,       <<lb.rs>>80664400
         m'direcscan'error,                                             80666000
               1,    msg'direcscan'error,                               80668000
         m'disk'read'failed,                                            80670000
               5,    msg'disk'read'err, p'title, p'line2,      <<06156>>80672000
                     p'disk'err, p'mnum,                       <<06156>>80674000
         m'disk'write'failed,                                           80676000
               5,    msg'disk'write'err, p'title, p'line2,     <<06156>>80678000
                     p'disk'err, p'mnum,                       <<06156>>80680000
         m'err'storing'file,                                            80682000
               4,    p'nsr, msg'store'io'error, p'line2, p'indent9,     80684000
         m'error'acct'validation,                              <<lb.rs>>80684100
               3,    p'nsr, msg'error'validating, msg'acct,    <<lb.rs>>80684200
         m'error'group'validation,                                      80686000
               3,    p'nsr, msg'error'validating, msg'group,            80688000
         m'error'user'validation,                                       80690000
               3,    p'nsr, msg'error'validating, msg'creator,          80692000
         m'file'excl'acc,                                      <<lb.rs>>80692100
               2,    p'nsr, msg'exclusive'access,              <<lb.rs>>80692200
         m'file'lockword'wrong,                                         80694000
               2,    p'nsr, msg'lockword'mismatch,                      80696000
         m'filecode'not'in'range,                                       80698000
               2,    msg'filecode, p'filecode'range,                    80700000
         m'flab'address'mismatch,                                       80702000
               2,    p'nsr, p'flab'address,                             80704000
         m'flab'checksum,                                               80706000
               2,    p'nsr, p'flab'checksum,                            80708000
         m'flab'title'mismatch,                                         80710000
               2,    p'nsr, p'flab'title,                               80712000
         m'group'disc'space,                                   <<lb.rs>>80712100
               2,    p'nsr, msg'group'disc'space,              <<lb.rs>>80712200
         m'group'save'access,                                  <<lb.rs>>80712300
               2,    p'nsr, msg'group'save'access,             <<lb.rs>>80712400
         m'keep'old'copy,                                               80714000
               2,    p'nsr, msg'keep,                                   80716000
         m'loaded,                                                      80718000
               2,    p'nsr, msg'loaded,                                 80720000
         m'heading,                                                     80722000
               1,    p'heading,                                         80724000
         m'lockword'viol,                                      <<lb.rs>>80724100
               2,    p'nsr, msg'bad'disc'lockword,             <<lb.rs>>80724200
         m'mdate'not'in'range,                                          80726000
               3,    p'nsr, msg'mdate, p'date'range,                    80728000
         m'missing'eof,                                                 80730000
               2,    p'nsr, msg'missing'eof,                            80732000
         m'mount'failed,                                                80734000
               2,    p'nsr, msg'mount'failed,                           80736000
         m'negative'filecode,                                           80738000
               2,    p'nsr, msg'filecode'negative,                      80740000
         m'no'acct,                                                     80742000
               3,    p'nsr, msg'acct,  msg'not'in'directory,            80744000
         m'no'create,                                                   80746000
               3,    p'nsr, p'level, msg'no'create,                     80748000
         m'no'creator,                                                  80750000
               3,    p'nsr, msg'creator, msg'not'in'directory,          80752000
         m'no'file,                                                     80754000
               3,    p'nsr, msg'file,  msg'not'in'directory,            80756000
         m'no'group,                                                    80758000
               3,    p'nsr, msg'group, msg'not'in'directory,            80760000
         m'no'files'to'restore,                                         80762000
               4,    p'indent9, p'line2, msg'no'restore'files, <<06156>>80764000
                     p'mnum,                                   <<06156>>80765000
         m'no'files'to'store,                                           80766000
               4,    p'indent9, p'line2, msg'no'store'files,   <<06156>>80768000
                     p'mnum,                                   <<06156>>80769000
         m'nolock'write'failed,                                         80770000
               2,    p'nsr, msg'label'write'fail,                       80772000
         m'not'all'sectors'written,                                     80774000
               2,    p'nsr, msg'not'all'sectors'written,                80776000
         m'not'purged,                                                  80776100
               1,    p'not'purged,                                      80776200
         m'nounlock'write'failed,                                       80778000
               2,    msg'nounlock'write'failed, p'mnum,        <<06156>>80780000
         m'open'fail,                                                   80782000
               2,    p'open'fail, p'mnum,                      <<06156>>80784000
         m'open'for'read,                                               80786000
               2,    p'nsr, msg'file'read'busy,                         80788000
         m'open'for'restore,                                            80790000
               2,    p'nsr, msg'inuse'restore,                          80792000
         m'open'for'rw,                                                 80794000
               2,    p'nsr, msg'file'io'busy,                           80796000
         m'open'for'store,                                              80798000
               2,    p'nsr, msg'inuse'store,                            80800000
         m'open'for'write,                                              80802000
               2,    p'nsr, msg'inuse'write,                            80804000
         m'out'of'disc'space,                                  <<lb.rs>>80804100
               2,    p'nsr, msg'out'of'disc'space,             <<lb.rs>>80804200
         m'pv'dismount'fail,                                            80806000
               3,    p'text, msg'pv'dismount'fail, p'mnum,     <<06156>>80808000
         m'pv'mount'problem,                                            80810000
               3,    p'title, msg'pv'mount'fail, p'mnum,       <<06156>>80812000
         m'pre'accross'accounts,                                        80814000
               3,    p'direc, msg'accross'accounts, p'mnum,    <<06156>>80816000
         m'pre'no'save'access,                                          80818000
               3,    p'direc, msg'no'save'access, p'mnum,      <<06156>>80820000
         m'prev'catastrophic,                                           80822000
               2,    p'nsr, msg'prev'catastrophic,                      80824000
         m'read'file'label'failed,                                      80826000
               2,    p'nsr, p'flab'read,                                80828000
         m'reel'supplied,                                               80830000
               5,    msg'this'is'reel'no, p'num, msg'from,     <<06156>>80832000
                     p'date, p'mnum,                           <<06156>>80833000
         m'res'acct'doesnt'exist,                                       80834000
               2,    p'direc, msg'not'in'directory,                     80836000
         m'res'acct'verify,                                             80838000
               2,    p'direc, msg'validation'failed,                    80840000
         m'res'group'doesnt'exist,                                      80842000
               2,    p'direc, msg'not'in'directory,                     80844000
         m'res'group'verify,                                            80846000
               2,    p'direc, msg'validation'failed,                    80848000
         m'res'user'doesnt'exist,                                       80850000
               2,    p'direc, msg'not'in'directory,                     80852000
         m'res'user'verify,                                             80854000
               2,    p'direc, msg'validation'failed,                    80856000
         m'restore'preview,                                             80858000
               1,    p'restore'p,                                       80860000
         m'restore'summary,                                             80862000
               1,    p'summary,                                         80864000
         m'restored,                                                    80866000
               1,    p'info,                                            80868000
         m'security,                                                    80870000
               2,    p'indent9, p'security,                             80872000
         m'setting'eof,                                                 80874000
               3,    p'nsr, msg'writing'eof, p'fcheck,                  80876000
         m'store'summary,                                               80878000
               1,    p'summary,                                         80880000
         m'synchronizing,                                               80882000
               2,    p'nsr, msg'synchronizing,                          80884000
         m'stored,                                                      80886000
               1,    p'info,                                            80888000
         m't'eof'taperead,                                              80890000
               4,    p'title, msg'reading'trlbl, msg'bad'size, <<06156>>80892000
                     p'mnum,                                   <<06156>>80893000
         m't'next'tape'file'error,                                      80894000
               3,    p'title, msg'getting'next'vol, p'mnum,    <<06156>>80896000
         m't'trlbl'error,                                               80898000
               4,    p'title, msg'reading'trlbl, p'fcheck,     <<06156>>80900000
                     p'mnum,                                   <<06156>>80901000
         m'tape'bad'lockword,                                           80902000
               2,    p'nsr, msg'tape'lockword,                          80904000
         m'tape'desired,                                                80906000
               5,    msg'desired'reel'is'no, p'num, msg'from,  <<06156>>80908000
                     p'date, p'mnum,                           <<06156>>80909000
         m'time'info,                                                   80910000
               2,    p'double'1,                                        80912000
                     p'double'2,                                        80914000
         m'title,                                              <<06156>>80914100
               1,    p'title,                                  <<06156>>80914200
         m'text,                                                        80916000
               1,    p'text,                                            80918000
         m'w'creator'changed,                                           80920000
               2,    p'changed'creator, p'mnum,                <<06156>>80922000
         m'write'file'label'failed,                                     80924000
               2,    p'nsr, p'flab'write,                               80926000
         m'not'on'tape,                                                 80926010
               2,    p'pattern, msg'not'on'tape,                        80926020
         0,                                                             80928000
               1,    p'unknown;                                         80930000
                                                                        80932000
$page                                                                   80934000
                                                                        80936000
   logical array                                               <<04752>>80938000
      reg'month'days  (*) = pb :=   0,  31,  59,  90, 120, 151,<<04752>>80940000
                             181, 212, 243, 273, 304, 334, 999;<<04752>>80942000
   logical array                                               <<04752>>80944000
      leap'month'days (*) = pb :=   0,  31,  60,  91, 121, 152,<<04752>>80946000
                             182, 213, 244, 274, 305, 335, 999;<<04752>>80948000
   logical array                                               <<04752>>80950000
      days'per'month (0:12);                                   <<04752>>80952000
   integer array                                                        80954000
      fo'format   (*) = pb:="F", "V", "U", "3";                         80956000
                                                                        80958000
   integer array                                                        80960000
      fo'binary'ascii(*)=pb:= "B", "A";                                 80962000
                                                                        80964000
   integer array                                                        80966000
      fo'filekind (*) = pb:=" ", " ", "R", "M", "O", "5", "6", "7";     80968000
                                                                        80970000
   byte array                                                           80972000
      file'security'bits' (*) = pb := "ANACALGUGLCR";                   80974000
                                                                        80976000
   define                                                               80978000
      append      = begin move ptext:= #,                               80980000
      compactv    = false #,           <<reverse of fixedv>>            80982000
      endappend   = ,2; @ptext:=tos; end #,                             80984000
      fixedv      = true #,                                             80986000
      octal       = 8 #,                                                80988000
            <<line size defines...>>                                    80990000
      big'line    = size'flags.(15:01) #,                               80992000
      medium'line = size'flags.(14:01) #,                               80994000
      short'line  = size'flags.(13:01) #,                               80996000
      showshortflag=size'flags.(12:01) #;                               80998000
                                                                        81000000
   <<------------->>                                                    81002000
   <<  space      >>                                                    81004000
   <<------------->>                                                    81006000
                                                                        81008000
   subroutine space (n);                                                81010000
            value    n;                                                 81012000
            integer  n;                                                 81014000
      begin                                                             81016000
                                                                        81018000
      fill' (ptext, n, " ");                                            81020000
      @ptext:=@ptext(n);                                                81022000
                                                                        81024000
      end <<space sub>>;                                                81026000
                                                                        81028000
   <<------------->>                                                    81030000
   <<  nextline   >>                                                    81032000
   <<------------->>                                                    81034000
                                                                        81036000
   subroutine nextline (n);                                             81038000
            value   n;                                                  81040000
            integer n;                                                  81042000
      begin                                                             81044000
                                                                        81046000
$if x1=on then                <<debugging code>>                        81048000
      if debug'sendmessage then                                         81050000
         begin                                                          81052000
         say "NEXTLINE (" endsay; saynum (n); say1 (")");               81054000
         send;                                                          81056000
         end;                                                           81058000
$if                           <<debugging code>>                        81060000
                                                                        81062000
      @ptext:=@text2';                                                  81064000
      space (n);                                                        81066000
                                                                        81068000
      end <<nextline sub>>;                                             81070000
                                                                        81072000
   <<------------->>                                                    81074000
   <<  write'msg  >>                                                    81076000
   <<------------->>                                                    81078000
                                                                        81080000
   subroutine write'msg (fnum);                                         81082000
            value fnum;                                                 81084000
            integer fnum;                                               81086000
      begin                                                             81088000
                                                                        81090000
$if x1=on then                <<debugging code>>                        81092000
      if debug'sendmessage then                                         81094000
         begin                                                          81096000
         say "   WRITE'MSG (" endsay; saynum (fnum);                    81098000
         say1 (")");                                                    81100000
         send;                                                          81102000
         end;                                                           81104000
$if                           <<debugging code>>                        81106000
                                                                        81108000
      if send'no'crlf then control'code := %320                         81110000
      else control'code := 0;                                           81112000
                                                                        81114000
      if fnum = 0 then                                                  81116000
         return;                                                        81118000
                                                                        81120000
      scan text1' until 0,1;           <<point to null at end.>>        81122000
      len:=tos - logical(@text1');     <<number of non-nulls.>>         81124000
                                                               <<lb.rs>>81124100
      if put'in'string then                                    <<lb.rs>>81124200
         begin                                                 <<lb.rs>>81124300
         move string := text1', (len+1);                       <<lb.rs>>81124400
         return;                                               <<lb.rs>>81124500
         end;                                                  <<lb.rs>>81124600
                                                                        81126000
      if tell'to'op then                                                81128000
         printop (text1, -len, control'code)                            81130000
      else                                                              81132000
         fwrite (fnum, text1, -len, control'code);                      81134000
                                                                        81136000
      if <> then                                                        81138000
         sendmessage:=failed;                                           81140000
                                                                        81142000
      scan text2' until 0,1;           <<point to null at end.>>        81144000
      len:=tos-logical(@text2');       <<number of non-nulls>>          81146000
                                                                        81148000
$if x1=on then                <<debugging code>>                        81150000
      if debug'sendmessage then                                         81152000
         begin                                                          81154000
         say "   LEN2 = " endsay; saynum (len);                         81156000
         send;                                                          81158000
         end;                                                           81160000
$if                           <<debugging code>>                        81162000
                                                                        81164000
      if len > 0 then                  <<write the second line>>        81166000
         begin                                                          81168000
         if tell'to'op then                                             81170000
            printop (text2, -len, control'code)                         81172000
         else                                                           81174000
            fwrite (fnum, text2, -len, control'code);                   81176000
                                                                        81178000
         if <> then                                                     81180000
            sendmessage:=failed;                                        81182000
         end;                                                           81184000
                                                                        81186000
      end <<write'msg sub>>;                                            81188000
                                                                        81190000
   <<--------------->>                                                  81192000
   <<  assure'room  >>                                                  81194000
   <<--------------->>                                                  81196000
                                                                        81198000
   subroutine assure'room (n);                                          81200000
            value   n;                                                  81202000
            logical n;                                                  81204000
                                                                        81206000
      begin                                                             81208000
                                                                        81210000
      if (logical(@ptext) - logical(@text1')) + n >= 70 then            81212000
         nextline (12);                                                 81214000
                                                                        81216000
      end <<assure'room sub>>;                                          81218000
                                                                        81220000
   <<----------->>                                                      81222000
   <<  append1  >>                                                      81224000
   <<----------->>                                                      81226000
                                                                        81228000
   subroutine append1 (char); value char; logical char;                 81230000
                                                                        81232000
      begin                                                             81234000
                                                                        81236000
      if char.(8:8) = 0 then                                            81238000
         char.(8:8):=char.(0:8);                                        81240000
                                                                        81242000
       if char.(8:8) = " " then        <<handle spl 'bug' of:     >>    81244000
         if char.(0:8) <> 0 then       << int arr a(*)=pb:=       >>    81246000
            char.(8:8):=char.(0:8);    << ... "S" ...  spl emits: >>    81248000
                                       <<     "S " !!!!!!!!!!!!!! >>    81250000
$if x1=on then                <<debugging code>>                        81252000
      if debug'sendmessage then                                         81254000
         begin                                                          81256000
         say "APPEND1 (" endsay;                                        81258000
         say1 (char);                                                   81260000
         say1(")");                                                     81262000
         send;                                                          81264000
         end;                                                           81266000
$if                           <<debugging code>>                        81268000
                                                                        81270000
      ptext:=char;                                                      81272000
      @ptext:=@ptext(1);                                                81274000
                                                                        81276000
      end <<append1 sub>>;                                              81278000
                                                                        81280000
   <<--------------------->>                                            81282000
   <<  append'fmti        >>                                            81284000
   <<--------------------->>                                            81286000
                                                                        81288000
   subroutine append'double (n);                                        81290000
      value n;                                                          81292000
      double n;                                                         81294000
   begin                                                                81296000
      if n<0d then                                                      81298000
         append1 ("-");                                                 81300000
                                                                        81302000
      @ptext := @ptext + dascii(\n\,10,ptext);                          81304000
   end;                                                                 81306000
                                                                        81308000
   <<--------------------->>                                            81310000
   <<  append'fmti        >>                                            81312000
   <<--------------------->>                                            81314000
                                                                        81316000
   subroutine append'fmti (dn, i, base, filler);                        81318000
            value dn, i, base, filler;                                  81320000
            double dn;                                                  81322000
            integer i;                                                  81324000
            logical base, filler;                                       81326000
      begin                                                             81328000
                                                                        81330000
$if x1=on then                <<debugging code>>                        81332000
      if debug'sendmessage then                                         81334000
         begin                                                          81336000
         say "   APPEND'FMTI (" endsay;                                 81338000
         saydnum (dn);                                                  81340000
         say ", " endsay; saynum (base);                                81342000
         say ", " endsay; say1 (filler);                                81344000
         say1 (")");                                                    81346000
         send;                                                          81348000
         end;                                                           81350000
$if                           <<debugging code>>                        81352000
                                                                        81354000
      len:=dascii (dn, base, scratch');                                 81356000
                                                                        81358000
      if base = octal then    <<dascii treats octal stupidly>>          81360000
         move scratch'(0):=scratch'(11-len),(len);                      81362000
            <<above does: scratch':=(11-len) drop scratch'>>            81364000
                                                                        81366000
      if (i:=i-len) > 0 then                                            81368000
         begin                                                          81370000
         ptext(0):=filler;                                              81372000
         if i > 1 then                                                  81374000
            move ptext(1):=ptext(0),(i-1);                              81376000
         @ptext:=integer(logical(@ptext)+logical(i));                   81378000
         end;                                                           81380000
                                                                        81382000
      append scratch',(len) endappend;                                  81384000
                                                                        81386000
      end <<append'fmti sub>>;                                          81388000
                                                                        81390000
   <<--------------------->>                                            81392000
   <<  append'filecode    >>                                            81394000
   <<--------------------->>                                            81396000
                                                                        81398000
   subroutine append'filecode (fcode, fopt);                            81400000
            value   fcode, fopt;                                        81402000
            integer fcode;                                              81404000
            logical        fopt;                                        81406000
      begin                                                             81408000
                                                                        81410000
      if fopt.(2:3) = 1 and fcode = 0 then                              81412000
         append "KSAM " endappend                                       81414000
      else if fcode = 0 then                                            81416000
         space (5)                                                      81418000
      else if fcode = 111 then                                          81420000
         append "111  " endappend                              <<05031>>81422000
      else                                                              81424000
         begin                                                          81426000
         move ptext:="     ";          << 5 blanks >>                   81428000
         get'filemnemonic (fcode, ptext, fopt);                         81430000
         if <> then           <<no mnemonic for this fcode>>            81432000
            if fcode < 0 then                                           81434000
               move ptext:="PRIV"                                       81436000
            else                                                        81438000
               ascii (fcode, 10, ptext);                                81440000
         @ptext:=@ptext(5);                                             81442000
         end;                                                           81444000
                                                                        81446000
      end <<append'filecode sub>>;                                      81448000
   <<--------------------->>                                            81448010
   <<  append'fserr       >>                                            81448020
   <<--------------------->>                                            81448030
                                                                        81448040
   subroutine append'fserr (fnum);                                      81448050
      value fnum;                                                       81448060
      integer fnum;                                                     81448070
   begin                                                                81448080
      fcheck (fnum, l1);                                                81448090
      ferrmsg (l1, scratch, l2);                                        81448100
      move ptext := scratch', (l2);                                     81448101
      @ptext := @ptext + integer(l2);                                   81448110
   end;                                                                 81448120
                                                                        81450000
   <<--------------------->>                                            81452000
   <<  append'msg         >>                                            81454000
   <<--------------------->>                                            81456000
                                                                        81458000
   subroutine append'msg (n); value n; integer n;                       81460000
                                                                        81462000
         <<appends the message 'n' (fetched from the                    81464000
            catalog) to ptext.  no leading/trailing                     81466000
           blanks are added. >>                                         81468000
                                                                        81470000
      begin                                                             81472000
                                                                        81474000
      len:=0;                                                           81476000
                                                                        81478000
      if store'catalog > 0 then                                         81480000
         len:=genmessage (store'catalog, sr'message'set, n,             81482000
                          ptext, 132, %133333,                          81484000
                          <<p1>>, <<p2>>, <<p3>>, <<p4>>, <<p5>>,       81486000
                          <<msgdest>>)                                  81488000
      else                                                              81490000
         formsg (scratch', sr'message'set, n, %133333,                  81492000
                 dummy, dummy, dummy, dummy, dummy, << = p1...p5>>      81494000
                 ptext, 132, len, -1, 0);                               81496000
                                                                        81498000
$if x1=on then                <<debugging code>>                        81500000
      if debug'sendmessage then                                         81502000
         begin                                                          81504000
         say "FORMSG...LEN=" endsay; saynum(len);                       81506000
         send;                                                          81508000
         say "  PTEXT=" endsay;                                         81510000
         say ptext,(len) endsay;                                        81512000
         say "//" endsay;                                               81514000
         send;                                                          81516000
         end;                                                           81518000
$if                           <<debugging code>>                        81520000
                                                                        81522000
      @ptext:=@ptext(len);                                              81524000
                                                                        81526000
      end <<append'msg sub>>;                                           81528000
                                                                        81530000
   <<--------------------->>                                            81532000
   <<  append'num         >>                                            81534000
   <<--------------------->>                                            81536000
                                                                        81538000
   subroutine append'num (n); value n; integer n;                       81540000
                                                                        81542000
      begin                                                             81544000
                                                                        81546000
      if n < 0 then                                                     81548000
         append1 ("-");                                                 81550000
                                                                        81552000
      @ptext:=@ptext+ascii (\n\, 10, ptext);                            81554000
                                                                        81556000
      end <<append'num sub>>;                                           81558000
                                                                        81560000
   <<---------------->>                                                 81562000
   <<  append'octal  >>                                                 81564000
   <<---------------->>                                                 81566000
                                                                        81568000
   subroutine append'octal (n);                                         81570000
            value           n;                                          81572000
            integer         n;                                          81574000
                                                                        81576000
         <<results in:     "%123456"  placed in ptext >>                81578000
                                                                        81580000
      begin                                                             81582000
                                                                        81584000
      ptext:="%";                                                       81586000
                                                                        81588000
      ascii (n, 8, ptext(1));                                           81590000
                                                                        81592000
      @ptext:=@ptext(7);      << 1 for "%", 6 for octal >>              81594000
                                                                        81596000
      end <<append'octal sub>>;                                         81598000
                                                                        81598100
   <<--------------------->>                                            81598200
   <<  append'pattern     >>                                            81598300
   <<--------------------->>                                            81598400
                                                                        81598410
   subroutine append'pattern (pat);                                     81598500
         integer array pat;                                             81598600
                                                                        81598700
   begin                                                                81598800
                                                                        81598900
   pat'char        := 0;                                                81599100
   pat'inx         := 1;                                                81599200
   pat'len         := 0;                                                81599300
   pat'parts       := 0;                                                81599400
   pat'word        := 0;                                                81599500
   pat'total'len   := 0;                                                81599600
                                                                        81599610
   pat'parts := pat(0);                                                 81599700
                                                                        81599800
   while (pat'parts := pat'parts - 1) >= 0 do                           81599900
      begin                                                             81600000
                                                                        81600100
      pat'word := pat (pat'inx);                                        81600200
      pat'len  := pat'word.patlenf;                                     81600300
      pat'total'len := pat'total'len + pat'len;                         81600310
      pat'char := pat'word.patcharf;                                    81600400
                                                                        81600500
      if pat'word.pattypef = anycharactersp then                        81600600
         len := 1;                                                      81600700
                                                                        81600800
      while (pat'len := pat'len - 1) >= 0 do                            81600900
         append1 (pat'char);                                            81601000
                                                                        81601100
      pat'inx := pat'inx+1;                                             81601200
                                                                        81601300
      end;                                                              81601400
                                                                        81601410
   space (file'part'size - pat'total'len);                              81601420
                                                                        81601500
   end <<say'pattern proc>>;                                            81601600
   <<------------------>>                                               81602000
   <<  append'address  >>                                               81604000
   <<------------------>>                                               81606000
                                                                        81608000
   subroutine append'address (ldev, addr);                              81610000
            value    ldev, addr;                                        81612000
            integer  ldev;                                              81614000
            double         addr;                                        81616000
      begin                                                             81618000
                                                                        81620000
      append'fmti (double(ldev), 3, octal, " ");                        81622000
      append1 ("%");                                                    81624000
      append'fmti (addr, 8, octal, "0");                                81626000
                                                                        81628000
      end <<append'address sub>>;                                       81630000
                                                                        81632000
   <<------------------->>                                              81634000
   << append'date'time  >>                                              81636000
   <<------------------->>                                              81638000
                                                                        81640000
   subroutine append'date'time (yyddd,hhmmsstt);                        81642000
             value yyddd, hhmmsstt;                                     81644000
             integer yyddd;                                             81646000
             double hhmmsstt;                                           81648000
      begin                                                             81650000
      fmtdate (yyddd, hhmmsstt, ptext);                                 81652000
      @ptext := @ptext(27);        <<date formatted 27 bytes>>          81654000
      end;                                                              81656000
                                                                        81658000
                                                                        81660000
   <<------------------->>                                              81662000
   <<  append'security  >>                                              81664000
   <<------------------->>                                              81666000
                                                                        81668000
   integer subroutine append'security (type, bits);                     81670000
            value   type, bits;                                         81672000
            logical type, bits;                                         81674000
                                                                        81676000
         <<returns the number of characters appended>>                  81678000
                                                                        81680000
      begin                                                             81682000
                                                                        81684000
      @save'ptext:=@ptext;                                              81686000
                                                                        81688000
      i:=-1;                                                            81690000
                                                                        81692000
      if bits = %(2)011111 or bits.(10:1) = 1 then                      81694000
         bits:= %(2)100000;   <<bit 10 = any, 11..15=ac,al,gu,gl,cr>>   81696000
                                                                        81698000
      while (i:=i+1) <= 5 do                                            81700000
         begin                                                          81702000
         if bits.(10:1) = 1 then                                        81704000
            begin                                                       81706000
            if @save'ptext = @ptext then                                81708000
               begin                   <<true if first time thru>>      81710000
               if len = 0 then                                          81712000
                  append1 ("(")                                         81714000
               else                                                     81716000
                  append "; " endappend;                                81718000
               append1 (type);                                          81720000
               append1 (":");                                           81722000
               end;                                                     81724000
            append file'security'bits' (i*2),(2) endappend;             81726000
            if i = 0 then                                               81728000
               append1 ("Y");    <<append the 'y' of 'any'>>            81730000
                                                                        81732000
                  <<any more to come?...>>                              81734000
                                                                        81736000
            if bits <> %(2)100000 then                                  81738000
               append1 (",");                                           81740000
            end;                                                        81742000
         bits:=bits.(11:5) & lsl(1); <<drop bit 10>>                    81744000
         end;                                                           81746000
                                                                        81748000
      append'security:=logical(@ptext) -  logical(@save'ptext);         81750000
                                                                        81752000
      end <<append'security sub>>;                                      81754000
                                                                        81756000
   <<--------------------->>                                            81758000
   <<  append'title       >>                                            81760000
   <<--------------------->>                                            81762000
                                                                        81764000
   subroutine append'title (pstd, how);                                 81766000
         value pstd, how;                                               81768000
         byte pointer pstd;                                             81770000
         logical how;                                                   81772000
                                                                        81774000
      begin                                                             81776000
                                                                        81778000
      if how = fixedv then                                              81780000
         begin      <<0123456789 123456789 12345>>                      81782000
         move ptext:="        .        .        ";                      81784000
         if res'file' <> " " then                              <<lb.rs>>81785000
            move ptext(0) := res'file',  (file'part'size)      <<lb.rs>>81785500
         else                                                  <<lb.rs>>81786000
            move ptext(0) := std'file',  (std'file'len);       <<lb.rs>>81786500
                                                               <<lb.rs>>81787000
         if res'group' <> " " then                             <<lb.rs>>81787500
            move ptext(9) := res'group', (file'part'size)      <<lb.rs>>81788000
         else                                                  <<lb.rs>>81788500
            move ptext(9) := std'group', (std'group'len);      <<lb.rs>>81789000
                                                               <<lb.rs>>81789500
         if res'acct' <> " " then                              <<lb.rs>>81790000
            move ptext(18) := res'acct', (file'part'size)      <<lb.rs>>81790500
         else                                                  <<lb.rs>>81791000
            move ptext(18) := std'acct', (std'acct'len);       <<lb.rs>>81791500
         @ptext:=@ptext(26);                                            81792000
         end                                                            81794000
      else                                                              81796000
         begin                                                          81798000
         standard'to'display (pstd, ptext, i, len);                     81800000
         @ptext:=@ptext(len);                                           81802000
         end;                                                           81804000
                                                                        81806000
      end <<append'title sub>>;                                         81808000
                                                                        81810000
   <<--------------->>                                                  81812000
   <<  append'type  >>                                                  81814000
   <<--------------->>                                                  81816000
                                                                        81818000
   subroutine append'type (fopt);                                       81820000
         value   fopt;                                                  81822000
         integer fopt;                                                  81824000
      begin                                                             81826000
                                                                        81828000
      append1 (fo'format(fopt.(08:02)));   <<f/v/u>>                    81830000
      append1 (fo'binary'ascii(fopt.(13:01))); <<b/a>>                  81832000
                                                                        81834000
      if fopt.(07:01) = 1 then                                          81836000
         begin                         <<cctl>>                         81838000
         append1 ("C");                                                 81840000
         append1 (fo'filekind(fopt.(02:03)));  << /r/m/c>>              81842000
         end                                                            81844000
      else                                                              81846000
         begin                                                          81848000
         append1 (fo'filekind(fopt.(02:03)));  << /r/m/c>>              81850000
         space (1);                    <<no cctl>>                      81852000
         end;                                                           81854000
                                                                        81856000
      end <<append'type sub>>;                                          81858000
                                                                        81860000
   <<--------------->>                                                  81862000
   <<  append'date  >>                                                  81864000
   <<--------------->>                                                  81866000
                                                                        81868000
   subroutine append'date (yyddd);                                      81870000
            value   yyddd;                                              81872000
            logical yyddd;                                              81874000
                                                                        81876000
         <<results in:  "mm/dd/yy" >>                                   81878000
                                                                        81880000
      begin                                                             81882000
                                                                        81884000
      l1:=yyddd.(0:7);        <<year>>                                  81886000
      l2:=yyddd.(7:9);        <<days since jan 0, 19yy>>                81888000
                                                                        81890000
$if x1=on then                <<debugging code>>                        81892000
      if debug'sendmessage then                                         81894000
         begin                                                          81896000
         say "    DATE = " endsay;                                      81898000
         saynum (l1); say1 ("/"); saynum (l2);                          81900000
         say "  = %" endsay;                                            81902000
         sayoctal (yyddd);                                              81904000
         send;                                                          81906000
         end;                                                           81908000
$if                           <<debugging code>>                        81910000
      if l1 mod 4 = 0 then                                     <<04752>>81912000
         move days'per'month := leap'month'days, (13)          <<04752>>81914000
      else move days'per'month := reg'month'days, (13);        <<04752>>81916000
      i:=1;                   <<index into days'per'month>>             81918000
      while days'per'month (i) < l2 and i < 12 do                       81920000
         i:=i+1;                                                        81922000
                                                                        81924000
            << i is month index  1..12>>                                81926000
                                                                        81928000
      append'fmti (double(i), 2, 10, " ");                              81930000
      l2:=l2-days'per'month(i-1);                                       81932000
      append1 ("/");                                                    81934000
      append'fmti (double(l2), 2, 10, "0");                             81936000
      append1 ("/");                                                    81938000
      append'fmti (double(l1), 2, 10, "0");                             81940000
                                                                        81942000
      end <<append'date sub>>;                                          81944000
                                                                        81946000
   <<--------------------->>                                            81948000
   <<  find'msg'template  >>                                            81950000
   <<--------------------->>                                            81952000
                                                                        81954000
   subroutine find'msg'template;                                        81956000
         <<looks for the message number msgno in the array              81958000
           msg'control.  each entry in the array is of the form:        81960000
              msgno (1 word), length (1 word), template ("length"       81962000
                                                         words)         81964000
           if the message number is found, msg'parts is set to the      81966000
           number of parts for this message's template.                 81968000
           the template itself is copied into the array template.       81970000
                                                                        81972000
           if the message is not found, the array default'template      81974000
           is used.      >>                                             81976000
      begin                                                             81978000
                                                                        81980000
      inx:=0;                                                           81982000
                                                                        81984000
      do                                                                81986000
         begin                                                          81988000
         i:=msg'control (inx);                                          81990000
         if i = msgno or i = 0 then                                     81992000
            begin                                                       81994000
            inx:=inx+1;                                                 81996000
            msg'parts:=msg'control (inx);                               81998000
            move template:=msg'control (inx+1), (msg'parts);            82000000
            return;                                                     82002000
            end                                                         82004000
         else                                                           82006000
            inx:=inx + msg'control (inx+1) + 2;                         82008000
         end                                                            82010000
      until inx > 32765;                                                82012000
                                                                        82014000
      end <<find'msg'template sub>>;                                    82016000
                                                                        82018000
   <<-------------------------->>                                       82020000
   <<  initialize'sendmessage  >>                                       82022000
   <<-------------------------->>                                       82024000
                                                                        82026000
   subroutine initialize'sendmessage;                                   82028000
      begin                                                             82030000
                                                                        82032000
      sendmessage:=good;                                                82034000
                                                                        82036000
      inx:=0;                                                           82038000
      len:=0;                                                           82040000
      msg'parts:=0;                                                     82042000
      ptype:=0;                                                         82044000
                                                                        82046000
      fill (text1, 67, 0);                                              82048000
      fill (text2, 67, 0);                                              82050000
                                                                        82052000
      if \recsize\ <= 99 then                                           82054000
         short'line:=true                                               82056000
      else if \recsize\ >= 132 then                                     82058000
         big'line:=true                                                 82060000
      else                                                              82062000
         medium'line:=true;                                             82064000
                                                                        82066000
      end <<initialize'sendmessage sub>>;                               82068000
                                                                        82070000
   <<---------------------->>                                           82072000
   <<  interpret'template  >>                                           82074000
   <<---------------------->>                                           82076000
                                                                        82078000
   subroutine interpret'template;                                       82080000
                                                                        82082000
         <<this routine takes the template found in the array           82084000
           template and builds one or two lines of output text          82086000
           from it.                                                     82088000
           a blank is added to ptext at the end of every loop,          82090000
           unless the last phrase was a p'line2.              >>        82092000
                                                                        82094000
      begin                                                             82096000
                                                                        82098000
      @ptext:=@text1';      <<initially accumulate into text1'>>        82100000
      inx:=-1;                                                          82102000
                                                                        82104000
      while (inx:=inx+1) < msg'parts do                                 82106000
         begin                                                          82108000
         ptype:=template(inx);                                          82110000
                                                                        82112000
$if x1=on then                <<debugging code>>                        82114000
         if debug'sendmessage then                                      82116000
            begin                                                       82118000
            say "INX=" endsay;                                          82120000
            saynum (inx);                                               82122000
            say ", PTYPE="endsay; saynum(ptype);                        82124000
            say ", @PTEXT=" endsay; sayoctal(@ptext);                   82126000
            send;                                                       82128000
            end;                                                        82130000
$if                           <<debugging code>>                        82132000
                                                                        82134000
         if 1 <= ptype <= p'max'p' then                                 82136000
            begin                                                       82138000
                                                                        82140000
            case ptype - 1 of                                           82142000
               begin                                                    82144000
                                                                        82146000
            <<p'bad'filesize:>>                                         82148000
               begin                                                    82150000
               append "Bad filesize...D=" endappend;                    82152000
               d:=find'file'size (file'size'minv, scratch'd);           82154000
               append'fmti (d, 7, 10, " ");                             82156000
               append " sectors, err=" endappend;                       82158000
               append'num (i);                                          82160000
               end;                                                     82162000
                                                                        82164000
            <<p'changed'creator:>>                                      82166000
               begin                                                    82168000
                  append'msg (msg'creator'changed);                     82170000
                  append " " endappend;                                 82172000
                  append fluserid',(8) endappend;                       82174000
                  append'msg (msg'to);                                  82176000
                  append " " endappend;                        <<lb.rs>>82176100
                  append res'creator', (8) endappend;                   82178000
               end;                                                     82180000
                                                                        82182000
            <<p'date:>>                                                 82184000
               begin                                                    82186000
                  append'date'time (parms'tempi'2, parms'tempd'1);      82188000
               end;                                                     82190000
                                                                        82192000
            <<p'date'range:>>                                           82194000
               begin                                                    82196000
               if msgno=m'adate'not'in'range then              <<04760>>82198000
                  l3 := fllastacc                              <<04760>>82200000
               else if msgno=m'cdate'not'in'range then         <<04760>>82202000
                  l3 := flcreate                               <<04760>>82204000
               else if msgno=m'mdate'not'in'range then         <<04760>>82206000
                  l3 := fllastmod;                             <<04760>>82208000
                                                               <<04760>>82210000
               space (1);                                      <<04760>>82212000
               append'date (l3);                               <<04760>>82214000
               end;                                                     82216000
                                                                        82218000
            <<p'dateline:>>                                             82220000
               begin                                                    82222000
               date'line (scratch');                                    82224000
               append scratch',(27) endappend;                          82226000
               end;                                                     82228000
                                                                        82230000
            <<p'direc:>>                                                82232000
               begin                                                    82234000
                  loc'lev := parms'tempi'1;                             82236000
                  append'msg (msg'user'specified);                      82238000
                  append " " endappend;                                 82240000
                                                                        82242000
                  if seen'acct then                                     82244000
                     begin                                              82246000
                        append'msg (msg'acct);                          82248000
                        append " = " endappend;                         82250000
                        append res'acct',(8) endappend;                 82252000
                        append "; " endappend;                          82254000
                     end;                                               82256000
                                                                        82258000
                  if loc'lev = acctlevel then                           82260000
                     begin                                              82262000
                        nextline (0);                                   82264000
                        append'msg (msg'acct);                          82266000
                     end                                                82268000
                  else if loc'lev = grouplevel then                     82270000
                     begin                                              82272000
                        append'msg (msg'group);                         82274000
                        append " = " endappend;                         82276000
                        append res'group', (8) endappend;               82278000
                     end                                                82280000
                  else                                                  82282000
                     begin                                              82284000
                        append'msg (msg'creator);                       82286000
                        append " = " endappend;                         82288000
                        append res'creator', (8) endappend;             82290000
                     end;                                               82292000
                                                                        82294000
                  if not seen'acct then                                 82296000
                     begin                                              82298000
                        append "; " endappend;                          82300000
                        append'msg (msg'logon'acct'assumed);            82302000
                     end;                                               82304000
                                                                        82306000
                  if loc'lev <> acctlevel then                          82308000
                     begin                                              82310000
                        nextline (0);                                   82312000
                        append'msg (msg'acct'exists);                   82314000
                        append ";  " endappend;                         82316000
                        if loc'lev = grouplevel then                    82318000
                           append'msg (msg'group)                       82320000
                        else                                            82322000
                           append'msg (msg'creator);                    82324000
                     end;                                               82326000
                                                                        82328000
               end;                                                     82330000
            <<p'disk'err: >>                                            82332000
               begin                                                    82334000
               append'msg (msg'address);     <<"LDEV/ADDRESS=">>        82336000
               append'address (parms'tempi'1, parms'tempd'1);           82338000
               append ", " endappend;                                   82340000
               append'msg (msg'sectors);     <<"#SECTORS=">>            82342000
               append'num (parms'tempi'2);   <<#sectors>>               82344000
               append ", " endappend;                                   82346000
               append'msg (msg'error);       <<"ERROR=">>               82348000
                     <<iob...word1...>>                                 82350000
               append'octal (parms'tempd'2'1);                          82352000
               append1 ("/");                                           82354000
                     <<iob...word 2...>>                                82356000
               append'octal (parms'tempd'2'2);                          82358000
               end;                                                     82360000
                                                                        82362000
            <<p'double'1: >>                                            82364000
               begin                                                    82366000
               append'fmti (proctime - start'cpu'time, 15, 10, " ");    82368000
               end;                                                     82370000
                                                                        82372000
            <<p'double'2: >>                                            82374000
               begin                                                    82376000
               append'fmti (timer - start'clock'time, 15, 10, " ");     82378000
               end;                                                     82380000
                                                               <<lb.rs>>82380100
            <<p'errnum: >>                                     <<lb.rs>>82380200
               begin                                           <<lb.rs>>82380300
               append'num (parms'tempd'2'2);                   <<lb.rs>>82380400
               append "/" endappend;                           <<lb.rs>>82380500
               append'num (parms'tempd'2'1);                   <<lb.rs>>82380600
               end;                                            <<lb.rs>>82380700
                                                               <<lb.rs>>82380800
            <<p'fcheck: >>                                              82382000
            begin                                                       82384000
            end;                                                        82386000
                                                                        82388000
            <<p'filecode'range:>>                                       82390000
               begin                                                    82392000
               append'filecode (flfilecode, flfoptions);                82394000
               space (1);                                               82396000
               append'msg (msg'not'in'range);                           82398000
               space (1);                                               82400000
               append'filecode (filecode'low, 0);                       82402000
               append1 ("/");                                           82404000
               append'filecode (filecode'high, 0);                      82406000
               end;                                                     82408000
                                                                        82410000
            <<p'flab'address: >>                                        82412000
               begin                                                    82414000
               append'msg (msg'flab'address'mismatch);                  82416000
               nextline (0);                                            82418000
               append'msg (msg'label'address);                          82420000
               append'address (parms'tempi'1, parms'tempd'1);           82422000
               append ", " endappend;                                   82424000
               append'msg (msg'first'extent);                           82426000
               append'address (parms'tempi'2, parms'tempd'2);           82428000
               end;                                                     82430000
                                                                        82432000
            <<p'flab'checksum: >>                                       82434000
               begin                                                    82436000
               append'msg (msg'flab'checksum);                          82438000
               nextline (0);                                            82440000
               append'msg (msg'checksum'computed);                      82442000
               append'octal (parms'tempi'1);                            82444000
               space (2);                                               82446000
               append'msg (msg'checksum'found);                         82448000
               append'octal (parms'tempi'2);                            82450000
               end;                                                     82452000
                                                                        82454000
            <<p'flab'read:>>                                            82456000
               begin                                                    82458000
               append'msg (msg'label'read'fail);                        82460000
               nextline (0);                                            82462000
               append'msg (msg'address);                                82464000
               append'address (parms'tempi'1, parms'tempd'1);           82466000
               end;                                                     82468000
                                                                        82470000
            <<p'flab'title:>>                                           82472000
               begin                                                    82474000
               append'msg (msg'flab'title);                             82476000
               nextline (0);                                            82478000
               append'msg (msg'found);    <<"FOUND:">>                  82480000
               append flab', (file'part'size) endappend;                82482000
               append1 (".");                                           82484000
               append flab'(8), (file'part'size) endappend;             82486000
               append1 (".");                                           82488000
               append flab'(16), (file'part'size) endappend;            82490000
               end;                                                     82492000
                                                                        82494000
            <<p'flab'write:>>                                           82496000
               begin                                                    82498000
               append'msg (msg'label'write'fail);                       82500000
               nextline (0);                                            82502000
               append'msg (msg'address);                                82504000
               append'address (parms'tempi'1, parms'tempd'1);           82506000
               end;                                                     82508000
                                                                        82510000
            <<p'heading: >>                                             82512000
               begin                                                    82514000
               append'msg (msg'heading1);                               82516000
                                                                        82518000
               if showshortflag then                                    82520000
                  begin                                                 82522000
                  if show'dates'flag then                               82524000
                     begin                                              82526000
                     if short'line then                                 82528000
                        nextline (7);                                   82530000
                     space (2);                                         82532000
                     append'msg (msg'dateheading);                      82534000
                     end;                                               82536000
                  end                                                   82538000
                                                                        82540000
               else           <<not showshortflag...>>                  82542000
                  begin                                                 82544000
                  if short'line then                                    82546000
                     nextline (8);                                      82548000
                  space (3);                                            82550000
                  append'msg (msg'heading2);                            82552000
                  if show'dates'flag then                               82554000
                     begin                                              82556000
                     if medium'line then                                82558000
                        nextline (7);                                   82560000
                     space (2);                                         82562000
                     append'msg (msg'dateheading);                      82564000
                     end;                                               82566000
                  end;                                                  82568000
               end;                                                     82570000
                                                                        82572000
            <<p'indent9:>>                                              82574000
               space (9);                                               82576000
                                                                        82578000
            <<p'info:>>                                                 82580000
               begin                                                    82582000
               append'title (curr'title', fixedv);                      82584000
                                                                        82586000
                     << ldev address >>                                 82588000
                                                                        82590000
               space (2);                                               82592000
               append'address (file'ldev, file'address);                82594000
                                                                        82596000
                     << reel >>                                         82598000
                                                                        82600000
               append'fmti (double(tape'reel), 5, 10, " ");             82602000
                                                                        82604000
                     << sectors >>                                      82606000
                                                                        82608000
                     <<calculate # sectors required by                  82610000
                       file when it is on disk...      >>               82612000
                                                                        82614000
               d:=find'file'size (file'size'maxv, scratch'd);           82616000
               append'fmti (d, 9, 10, " ");                             82618000
                                                                        82620000
               space (1);                                               82622000
                                                                        82624000
                     << code >>                                         82626000
                                                                        82628000
               append'filecode (flfilecode, flfoptions);                82630000
                                                                        82632000
                     <<see if we want other info...>>                   82634000
                                                                        82636000
               if not showshortflag then                                82638000
                  begin                                                 82640000
                                                                        82642000
                  if short'line then                                    82644000
                     nextline (8);                                      82646000
                                                                        82648000
                        << size >>                                      82650000
                                                                        82652000
                  if flfoptions.(13:01) = 1 then   <<ascii>>            82654000
                     begin                                              82656000
                     append'fmti (double(\flrecsize\), 6, 10, " ");     82658000
                     append1 ("B");                                     82660000
                     end                                                82662000
                  else                             <<binary>>           82664000
                     begin                                              82666000
                     append'fmti (double(\flrecsize\/2),                82668000
                                  6, 10, " ");                          82670000
                     append1 ("W");                                     82672000
                     end;                                               82674000
                                                                        82676000
                  space (1);                                            82678000
                                                                        82680000
                        << typ >>                                       82682000
                                                                        82684000
                  append'type (flfoptions);                             82686000
                                                                        82688000
                        << eof >>                                       82690000
                                                                        82692000
                  append'fmti (fleof, 8, 10, " ");                      82694000
                                                                        82696000
                        << limit >>                                     82698000
                                                                        82700000
                  append'fmti (flflim, 9, 10, " ");                     82702000
                                                                        82704000
                        << r/b >>                                       82706000
                                                                        82708000
                  d:=double(find'block'factor (i));                     82710000
                  if i <> 0 then                                        82712000
                     space (4)                                          82714000
                  else                                                  82716000
                     append'fmti (d, 4, 10, " ");                       82718000
                                                                        82720000
                        << #x/mx >>                                     82722000
                                                                        82724000
                        <<count number of in-use extents...>>           82726000
                  dummy:=0;                                             82728000
                  for i:=0 step 1 until flnumexts do                    82730000
                     if flab'd(i + 22) <> 0d then                       82732000
                        dummy:=dummy+1;                                 82734000
                  append'fmti (double(dummy), 3, 10, " ");              82736000
                           <<  "/"  >>                                  82738000
                  append1 ("/");                                        82740000
                           <<maximum number of extents...>>             82742000
                  append'fmti (double(flnumexts+1), 2, 10, "0");        82744000
                                                                        82746000
                  end;                                                  82748000
                                                                        82750000
               if show'dates'flag then                                  82752000
                  begin                                                 82754000
                  if showshortflag then                                 82756000
                     if short'line then                                 82758000
                        nextline (8)                                    82760000
                     else                                               82762000
                  else if medium'line then                              82764000
                     nextline (8);                                      82766000
                                                                        82768000
                        << created >>                                   82770000
                                                                        82772000
                  space (1);                                            82774000
                  append'date (flcreate);                               82776000
                                                                        82778000
                        << accessed >>                                  82780000
                                                                        82782000
                  space (1);                                            82784000
                  append'date (fllastacc);                              82786000
                                                                        82788000
                        << modified >>                                  82790000
                                                                        82792000
                  space (1);                                            82794000
                  append'date (fllastmod);                              82796000
                                                                        82798000
                  end;                                                  82800000
               end;                                                     82802000
                                                                        82804000
            <<p'level:>>                                                82806000
               begin                                                    82808000
                  if parms'tempi'1 = grouplevel then                    82810000
                     begin                                              82812000
                        append'msg(msg'group);                          82814000
                        append " " endappend;                           82816000
                        append res'group',(8) endappend;                82818000
                     end                                                82820000
                  else if parms'tempi'1 = userlevel then                82822000
                     begin                                              82824000
                        append'msg(msg'creator);                        82826000
                        append " " endappend;                           82828000
                        append res'creator',(8) endappend;              82830000
                     end;                                               82832000
                                                                        82834000
                  if parms'tempi'1 <> acctlevel then                    82836000
                     begin                                              82838000
                        append " " endappend;                           82840000
                        append'msg(msg'in);                             82842000
                        append " " endappend;                           82844000
                     end;                                               82846000
                                                                        82848000
                                                                        82850000
                  append'msg(msg'acct);                                 82852000
                  append " " endappend;                                 82854000
                  append res'acct',(8) endappend;                       82856000
               end;                                                     82858000
                                                                        82860000
            <<p'line2:>>                                                82862000
               nextline (0);                                            82864000
                                                                        82866000
            <<p'mnum>>                                         <<06312>>82866100
               begin                                           <<06312>>82866200
               append "(S/R " endappend;                       <<06312>>82866300
               append'num (msgno);                             <<06312>>82866400
               append1 (")");                                  <<06312>>82866500
               end;                                            <<06312>>82866600
            <<p'not'title:>>                                            82868000
               append'title (not'title', fixedv);                       82870000
            <<p'not'purged>>                                            82870100
               begin                                                    82870200
               append'title (curr'title', fixedv);                      82870300
               append'msg (msg'not'purged);                             82870400
               append'fserr (parms'tempi'1);                            82870500
               end;                                                     82870600
                                                                        82872000
            <<p'nsr:>>                                                  82874000
               begin                                                    82876000
               append'title (curr'title', fixedv);                      82878000
               space (1);                                               82880000
               if storing then                                          82882000
                  append'msg (msg'not'stored)                           82884000
               else                                                     82886000
                  append'msg (msg'not'restored);                        82888000
               end;                                                     82890000
                                                                        82892000
            <<p'num:>>                                                  82894000
               begin                                                    82896000
               append'num (parms'tempi'1);                              82898000
               end;                                                     82900000
                                                                        82902000
            <<p'open'fail:>>                                            82904000
               begin                                                    82906000
               append'msg (msg'open'fail);                              82908000
                                                                        82910000
               space (1);                                               82912000
                                                                        82914000
               @p:=parms'tempi'1;                                       82916000
               if (i:=\parms'tempi'2\) > 132 then                       82918000
                  i:=132;                                               82920000
               append p,(i) endappend;                                  82922000
                                                                        82924000
               if fid > 0 then                                          82926000
                  genmsg (io'message'set, error'code,                   82928000
                          %133333, <<p1>>, <<p2>>, <<p3>>,              82930000
                          <<p4>>, <<p5>>, -fid);                        82932000
               end;                                                     82934000
                                                                        82936000
            <<p'pattern>>                                               82936100
               begin                                                    82936200
               append'pattern (look'file'pat);                          82936300
               append1 (".");                                           82936400
               append'pattern (look'group'pat);                         82936500
               append1 (".");                                           82936600
               append'pattern (look'acct'pat);                          82936700
               space (1);                                               82936800
               end;                                                     82936900
            <<p'restore'p:>>                                            82938000
               begin                                                    82940000
               append'msg (msg'will'restore);                           82942000
               space (1);                                               82944000
               append'fmti (files'selected, 6, 10, " ");                82946000
               space (1);                                               82948000
               append'msg (msg'files'on'tape);                          82950000
               space (1);                                               82952000
               append'fmti (files'on'tape+1d, 6, 10, " ");              82954000
               end;                                                     82956000
                                                                        82958000
            <<p'security:>>                                             82960000
               begin                                                    82962000
               append fluserid',(8) endappend;                          82964000
               space (1);                                               82966000
$if x1=on then                <<debugging code>>                        82968000
               if debug'sendmessage then                                82970000
                  begin                                                 82972000
                  append1 ("%");                                        82974000
                  append'fmti (flsecmx, 11, octal, "0");                82976000
                  space (1);                                            82978000
                  end;                                                  82980000
$if                           <<debugging code>>                        82982000
               len:=0;        <<length of security "text">>             82984000
                              <<append'security examines len>>          82986000
               len:=len + append'security ("R", flsecmx1.(02:6));       82988000
               assure'room (18);                                        82990000
               len:=len + append'security ("A", flsecmx1.(08:6));       82992000
               assure'room (18);                                        82994000
               len:=len + append'security ("W",                         82996000
                                            0 cat flsecmx1 (10:14:2)    82998000
                                              cat flsecmx2 (12:00:4));  83000000
               assure'room (18);                                        83002000
               len:=len + append'security ("L", flsecmx2.(04:6));       83004000
               assure'room (18);                                        83006000
               len:=len + append'security ("X", flsecmx2.(10:6));       83008000
               if len > 0 then                                          83010000
                  append1 (")");                                        83012000
                                                                        83014000
               if flsecure = 0 then                                     83016000
                  begin                                                 83018000
                  assure'room (8);                                      83020000
                  space (1);                                            83022000
                  append'msg (msg'released);                            83024000
                  end;                                                  83026000
               end;                                                     83028000
                                                                        83030000
            <<p'summary:>>                                              83032000
               begin                                                    83034000
               if restoring then                                        83036000
                  append'msg (msg'files'restored)                       83038000
               else                                                     83040000
                  append'msg (msg'files'stored);                        83042000
               append'fmti (good'file'count, 11, 10, " ");              83044000
                                                                        83046000
               if failed'file'count > 0d then                           83048000
                  begin                                                 83050000
                  append1 (",");                                        83052000
                  space (6);                                            83054000
                  if restoring then                                     83056000
                     append'msg (msg'failed'restore'files)              83058000
                  else                                                  83060000
                     append'msg (msg'failed'store'files);               83062000
                  append'fmti (failed'file'count, 6, 10, " ");          83064000
                  end;                                                  83066000
                                                                        83068000
               nextline (0);                                            83070000
                                                                        83072000
               if restoring then                                        83074000
                  begin                                                 83076000
                  append'msg (msg'files'not'restored);                  83078000
                  append'fmti (bad'file'count, 7, 10, " ");             83080000
                  end                                                   83082000
               else                                                     83084000
                  begin                                                 83086000
                  append'msg (msg'files'not'stored);                    83088000
                  append'fmti (files'rejected, 7, 10, " ");             83090000
                  end;                                                  83092000
               end;                                                     83094000
                                                                        83096000
            <<p'text:>>                                                 83098000
               begin                                                    83100000
               @p:=parms'tempi'1;                                       83102000
               if (i:=\parms'tempi'2\) > 132 then                       83104000
                  i:=132;                                               83106000
               append p, (i) endappend;                                 83108000
               end;                                                     83110000
                                                                        83112000
            <<p'title:>>                                                83114000
               append'title (curr'title', fixedv);                      83116000
                                                                        83118000
            <<p'unknown:>>                                              83120000
               begin                                                    83122000
               append "Cannot interpret message # " endappend;          83124000
               append'num (msgno);                                      83126000
               end;                                                     83128000
                                                                        83130000
               end;                                                     83132000
            end                                                         83134000
                                                                        83136000
         else if ptype >= 1000 then                                     83138000
            append'msg (ptype)                                          83140000
                                                                        83142000
         else                                                           83144000
            begin                                                       83146000
            append "IN MSG#" endappend;                                 83148000
            append'num (msgno);                                         83150000
            append " UNKNOWN PTYPE#" endappend;                         83152000
            append'num(ptype);                                          83154000
            append " AT INX=" endappend;                                83156000
            append'num(inx);                                            83158000
            end;                                                        83160000
                                                                        83162000
         if ptype <> p'line2 then                                       83164000
            space (1);                                                  83166000
                                                                        83168000
$if x1=on then                <<debugging code>>                        83170000
         if debug'sendmessage then                                      83172000
            begin                                                       83174000
            say "@PTEXT NOW " endsay;                                   83176000
            sayoctal (@ptext);                                          83178000
            send;                                                       83180000
            say "  PTEXT=" endsay;                                      83182000
            say text1',(70) endsay;                                     83184000
            send;                                                       83186000
            end;                                                        83188000
$if                           <<debugging code>>                        83190000
                                                                        83192000
                                                                        83194000
         end;                                                           83196000
                                                                        83198000
      end <<interpret'template sub>>;                                   83200000
   <<-------------------------------->>                                 83202000
   if not pmask.(12:1) or msgno = 0 then return;               <<lb.rs>>83204000
   if not pmask.(13:1) then send'no'crlf := false;             <<lb.rs>>83206000
   if not pmask.(14:1) then tell'to'op := false;               <<lb.rs>>83208000
   put'in'string := pmask.(15:1);                              <<lb.rs>>83208100
                                                                        83210000
         <<..sigh...disable arithmetic traps cuz this                   83212000
           procedure might call genmsg/formsg, which                    83214000
           rather dumbly depends on traps being off instead             83216000
           of turning them off itself...>>                              83218000
                                                                        83220000
   disable'arithmetic'traps;                                            83222000
                                                                        83224000
$if x1=on then                <<debugging code>>                        83226000
   if debugging then                                                    83228000
      begin                                                             83230000
      say "SENDMESSAGE (" endsay; saynum (msgno); say1 (")");           83232000
      send;                                                             83234000
      end;                                                              83236000
$if                           <<debugging code>>                        83238000
                                                                        83240000
         <<assure ourselves that we can talk to $stdlist if             83242000
           this routine is called before syslist has been               83244000
           opened...>>                                                  83246000
                                                                        83248000
   if (syslistnum:=syslist'num) = 0 then                                83250000
      syslistnum:=stdlist'num;                                          83252000
                                                                        83254000
if msgno >= 10000 then                                                  83256000
   begin                                                                83258000
      move text1' := "*** ERROR *** RESTORE # ";                        83260000
      ascii(msgno,10,text1(12) );                                       83262000
      print(text1,-29,0);                                               83264000
      enable'arithmetic'traps;                                          83266000
      return;                                                           83268000
   end;                                                                 83270000
   if msgno >= first'real'msg then                                      83272000
      begin                                                             83274000
$if x1=on then                <<debugging code>>                        83276000
      if debug'sendmessage then                                         83278000
         begin                                                          83280000
         say "REAL MSG!" endsay;                                        83282000
         send;                                                          83284000
         end;                                                           83286000
$if                           <<debugging code>>                        83288000
                                                                        83290000
            <<prevent multiple 'break' messages...>>                    83292000
                                                                        83294000
      if msgno = sr'break'sensed then                                   83296000
         if break'msg'seen then                                         83298000
            begin                                                       83300000
               enable'arithmetic'traps;                                 83302000
               return;                                                  83304000
            end                                                         83306000
         else                                                           83308000
            break'msg'seen:=true;                                       83310000
                                                                        83312000
            <<send the message from the store catalog (if               83314000
              open, otherwise from the system catalog...>>              83316000
      if tell'to'op then                                                83318000
         begin                                                          83320000
            if store'catalog > 0 then                                   83322000
               begin                                                    83324000
                  len := genmessage (store'catalog, sr'message'set,     83326000
                                     msgno, scratch, 132, %011333,      83328000
                                     parms'tempi'1, parms'tempi'2,      83330000
                                     <<parm3>>,<<parm4>>,<<parm5>>);    83332000
                  scratch' (len) := 0;                                  83334000
                  genmsg (-1 <<in string>>, @scratch', %133333,         83336000
                          <<parm1>>,<<parm2>>,<<parm3>>,<<parm4>>,      83338000
                          <<parm5>>, 0 <<operator>>);                   83340000
               end                                                      83342000
            else                                                        83344000
               begin                                                    83346000
                  genmsg (sr'message'set, msgno, %011333,               83348000
                          parms'tempi'1, parms'tempi'2,                 83350000
                          <<parm3>>, <<parm4>>, <<parm5>>,              83352000
                          0 <<operator>> );                             83354000
               end;                                                     83356000
                                                                        83358000
         end                                                            83360000
      else if put'in'string then                               <<lb.rs>>83360100
         begin                                                 <<lb.rs>>83360200
         if store'catalog > 0 then                             <<lb.rs>>83360300
            begin                                              <<lb.rs>>83360400
            len := genmessage (store'catalog, sr'message'set,  <<lb.rs>>83360500
                               msgno, string, 132, %011333,    <<lb.rs>>83360600
                               parms'tempi'1, parms'tempi'2,   <<lb.rs>>83360700
                               <<parm3>>,<<parm4>>,<<parm5>>); <<lb.rs>>83360800
            string (len) := 0;                                 <<lb.rs>>83360900
            end                                                <<lb.rs>>83361000
         else                                                  <<lb.rs>>83361100
            begin                                              <<lb.rs>>83361200
            text1' := 0;                                       <<lb.rs>>83361210
            formsg (text1',sr'message'set, msgno, %011333,     <<lb.rs>>83361300
                    parms'tempi'1, parms'tempi'2,              <<lb.rs>>83361400
                    0, 0, 0,                                   <<lb.rs>>83361500
                    string, 72, len, -1, 0);                   <<lb.rs>>83361600
            string (len) := 0;                                 <<lb.rs>>83361700
            end;                                               <<lb.rs>>83361900
         end                                                   <<lb.rs>>83361920
                                                                        83362000
      else if store'catalog > 0 then                                    83364000
         begin                                                          83366000
                                                                        83368000
         if syslistnum <> 0 then                                        83370000
            genmessage (store'catalog, sr'message'set, msgno,           83372000
                        <<buf>>,  <<bufsize>>, %133333,                 83374000
                        syslistnum);                                    83376000
                                                                        83378000
         if offline'num <> 0 then                                       83380000
            genmessage (store'catalog, sr'message'set, msgno,           83382000
                        <<buf>>, <<bufsize>>, %133333,                  83384000
                        parms'tempi'1, parms'tempi'2,                   83386000
                        <<parm3>>, <<parm4>>, <<parm5>>,                83388000
                        offline'num);                                   83390000
         end                                                            83392000
                                                                        83394000
      else                                                              83396000
         begin                                                          83398000
                                                                        83400000
         if syslistnum <> 0 then                                        83402000
            genmsg (sr'message'set, msgno,                              83404000
                    %011333,                                   <<lb.rs>>83406000
                    parms'tempi'1, parms'tempi'2,                       83408000
                    <<parm3>>, <<parm4>>, <<parm5>>,                    83410000
                    -syslistnum);                                       83412000
                                                                        83414000
         if offline'num <> 0 then                                       83416000
            genmsg (sr'message'set, msgno,                              83418000
                    %011333,                                   <<lb.rs>>83420000
                    parms'tempi'1, parms'tempi'2,                       83422000
                    <<parm3>>, <<parm4>>, <<parm5>>,                    83424000
                    -offline'num);                                      83426000
         end;                                                           83428000
      enable'arithmetic'traps;                                          83430000
      return;                                                           83432000
      end;                                                              83434000
                                                                        83436000
   if not show'flag then                                                83438000
      if msgno = m'stored  or  msgno = m'restored then                  83440000
         begin                                                          83442000
$if x1=on then                <<debugging code>>                        83444000
         if debugging then                                              83446000
            begin                                                       83448000
            say "NOT SHOW'FLAG...DON'T SEND MSG# " endsay;              83450000
            saynum(msgno);                                              83452000
            send;                                                       83454000
            end;                                                        83456000
$if                           <<debugging code>>                        83458000
         enable'arithmetic'traps;                                       83460000
         return;                                                        83462000
         end;                                                           83464000
                                                                        83466000
         <<go thru the following code 1 or 2 times, depending           83468000
           upon: if offline exists and is not the same size             83470000
           as syslist, do code twice (once per file) otherwise          83472000
           do the code only one. >>                                     83474000
                                                                        83476000
   fid:=syslistnum;                                                     83478000
   size'flags:=0;                                                       83480000
   recsize:=syslist'recsize;                                            83482000
   showshortflag:=show'short'flag;   <<changed for offline later>>      83484000
                                                                        83486000
   loops:=1;                                                            83488000
                                                                        83490000
   if offline'num <> 0 then                                             83492000
      loops:=2;                                                         83494000
                                                                        83496000
   while (loops:=loops-1) >= 0 do                                       83498000
      begin                                                             83500000
                                                                        83502000
      initialize'sendmessage;                                           83504000
                                                                        83506000
$if x1=on then                <<debugging code>>                        83508000
      if debug'sendmessage then                                         83510000
         begin                                                          83512000
         say "   LOOPS = " endsay; saynum (loops);                      83514000
         say ", FID=" endsay; saynum (fid);                             83516000
         say ", RECSIZE=" endsay; saynum (recsize);                     83518000
         if short'line then say " SHORT" endsay;                        83520000
         if medium'line then say " MEDIUM" endsay;                      83522000
         if big'line then say " BIG" endsay;                            83524000
         if showshortflag then                                          83526000
            say " (SHOWSHORT)" endsay;                                  83528000
         send;                                                          83530000
         end;                                                           83532000
$if                           <<debugging code>>                        83534000
                                                                        83536000
      find'msg'template;                                                83538000
                                                                        83540000
      interpret'template;                                               83542000
                                                                        83544000
      write'msg (fid);                                                  83546000
                                                                        83548000
      fid:=offline'num;                                                 83550000
      recsize:=offline'recsize;                                         83552000
      size'flags:=0;                                                    83554000
      showshortflag:=false;  <<offline is never short>>                 83556000
                                                                        83558000
      end;                                                              83560000
                                                                        83562000
enable'arithmetic'traps;                                                83564000
   end <<sendmessage proc>>;                                            83566000
$page "TRUE OUTER BLOCK"                                                90000000
$control segment=main                                                   90002000
   if size'of'lpdt'entry <> lpdt'entry'size then               <<lb.rs>>90002100
      quit (1);                                                <<lb.rs>>90002300
                                                                        90004000
if info'length < 0 then                                                 90006000
   info'length := 0;                                                    90008000
                                                                        90010000
outer'block (parm, info'length, info'address);                          90012000
                                                                        90014000
end.                                                                    90016000
