<< LINES .001/.009 ARE RESERVED FOR SYSTEMS INTEGRATION>>               00005000
$control map,code,uslinit                                               00010000
<<labseg - module 86>>                                                  00015000
<< hp32002c mpe source c.00.00 >>                                       00020000
$copyright     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1980. ",            & 00025000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00030000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00035000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00040000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00045000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.",& 00050000
$     "LABSEG JANUARY 17, 1983."                               <<06135>>00055000
$control uslinit,code,map                                               00060000
<< labseg - module 86 >>                                       <<02547>>00065000
<< hp32002b mpe source c.00.00 >>                                       00070000
<<" (C) Copyright Hewlett-Packard Company, 1980.                        00075000
  all rights reserved.  no part of this program may                     00080000
  be photocopied, reproduced, or translated to                          00085000
  another program language without the prior written                    00090000
  consent of Hewlett-Packard Company. "   >>                            00095000
                                                                        00100000
$control main=labseg                                                    00105000
$control segment=labseg                                                 00110000
                                                                        00115000
begin                                                                   00120000
                                                               <<03581>>00125000
comment                                                        <<03581>>00130000
                                                               <<03581>>00135000
           fix history since d-mit                             <<03581>>00140000
                                                               <<03581>>00145000
fix #      description of fix                                  <<03581>>00150000
                                                               <<03581>>00155000
                                                               <<03581>>00160000
<<02547>>  new source                                          <<03581>>00165000
                                                               <<03581>>00170000
<<02563>>  support for variable density tape drives.           <<03581>>00175000
           improve error handling for avr of tapes.            <<03581>>00180000
                                                               <<03581>>00185000
<<02575>>  parameter of daddr of cleanldev is now passed       <<03581>>00190000
           by value.                                           <<03581>>00195000
                                                               <<03581>>00200000
<<02616>>  change to pvolid.                                   <<03581>>00205000
                                                               <<03581>>00210000
<<02621>>  1) ensure uvl labels skipped when 1st file on       <<03581>>00215000
              reel is fopen'd                                  <<03581>>00220000
           2) correct sf 86's due to :                         <<03581>>00225000
              a) a reply <pin>,0 to a reelswitch request       <<03581>>00230000
                 during a labeled tape restore.                <<03581>>00235000
              b) mounting 2nd or later reel as 1st reel        <<03581>>00240000
                 during a labeled tape restore.                <<03581>>00245000
                                                               <<03581>>00250000
<<02622>>  1) fix problems with reelswitching when store/      <<03581>>00255000
              restore to/from labeled tape.                    <<03581>>00260000
           2) disallow more than one file opened on a          <<03581>>00265000
              labeled tape concurrently.                       <<03581>>00270000
                                                               <<03581>>00275000
<<02648>>  correct goodreel, add delays for devrec, allow      <<03581>>00280000
           any printing chars in vol label.                    <<03581>>00285000
                                                               <<03581>>00290000
<<02622>>  add error reporting to attachio calls.              <<03581>>00295000
                                                               <<03581>>00300000
<<02673>>  correct system log record, put i/o error messages   <<03581>>00305000
           on console, please return of cce to mean tape is    <<03581>>00310000
           mounted on a tape drive in pvolid, don't wait       <<03581>>00315000
           on a dclose in freedevice for cleantape.            <<03581>>00320000
                                                               <<03581>>00325000
<<02689>>  1) allow writes and wtm to occur after tm.          <<03581>>00330000
           2) clean up after =reply <pin>,0 to reelswitch      <<03581>>00335000
              request in a more timely manner.                 <<03581>>00340000
                                                               <<03581>>00345000
<<02690>>  permit override of hdr2 label file characteristics. <<03581>>00350000
           correct cleanup on process termination.             <<03581>>00355000
           correct some problems with tape positioning on      <<03581>>00360000
           reelswitch.                                         <<03581>>00365000
                                                               <<03581>>00370000
<<02703>>  allow store/restore to return file system error     <<03581>>00375000
           numbers in the event of an error in advancing from  <<03581>>00380000
           one labeled tape to another.                        <<03581>>00385000
                                                               <<03581>>00390000
<<02722>>  1) make avr of tapes more forgiving when i/o errors <<03581>>00395000
              occur.                                           <<03581>>00400000
           2) prevent recognize and avrec from both attempting <<03581>>00405000
              avr on the same tape (sr#22254).                 <<03581>>00410000
           3) prevent i/o's from occuring while holding the    <<03581>>00415000
              tltsir (sr#22907).                               <<03581>>00420000
           4) prevent i/o's during fclose of labeled tape after<<03581>>00425000
              a =reply <pin>,0.                                <<03581>>00430000
                                                               <<03581>>00435000
<<*cub*>>  1) support of labeled serial disc for cub.          <<03581>>00440000
           2) addition of tape trouble codes.                  <<03581>>00445000
           3) addition of fix log.                             <<03581>>00450000
                                                               <<03618>>00455000
(fix number col. 64/72)                                        <<03618>>00460000
                                                               <<03618>>00465000
          allowing reelswitch on labeled serial disc.          <<03618>>00470000
                                                               <<03618>>00475000
          cleantape will deallocate the xds for sdisc on       <<03634>>00480000
          a volume set that is not a tape.                     <<03634>>00485000
                                                               <<03634>>00490000
          return an illegal value to a caller of ffileinfo     <<04612>>00495000
          items (26/33,45)  when a non labeled tape file.      <<04612>>00500000
                                                               <<04612>>00505000
   a problem with the ownership bits for reelswitching         <<04647>>00510000
   labeled serial disc.                                        <<04647>>00515000
                                                               <<04647>>00520000
   fix a problem that the tlt will not be updated before the   <<04698>>00525000
     ownership bits in the lpdt are set, thus allowing avr     <<04698>>00530000
     before reelswitch has set up everything.                  <<04698>>00535000
                                                               <<04698>>00540000
          allow use to write over a label if we have           <<04819>>00545000
          operator permission and we have write access.        <<04819>>00550000
                                                               <<04819>>00555000
          when a reelswitch is occuring and the mounted tape   <<04739>>00560000
          is already labeled and not expired and the operator  <<04739>>00565000
          replys n to the ok to write on unexpired volume,     <<04739>>00570000
          then we will set up the tape drive for another tape  <<04739>>00575000
          instead of returning a fwrite error.                 <<04739>>00580000
                                                               <<04739>>00585000
                                                               <<04740>>00590000
          update the ansi standard version from 1 to 3         <<04740>>00595000
                                                               <<04740>>00600000
          one tape mark will be written (for linus).           <<04736>>00605000
                                                               <<04736>>00610000
     fix a problem with the reelswitch reel number on the      <<04872>>00615000
   fix problem with fixno 4612. tgetinfo also needs to return  <<04873>>00620000
   condition codes for when it's called from oplow (for the    <<04873>>00625000
   measurement interface).                                     <<04873>>00630000
                                                               <<04873>>00635000
     third reel on.                                            <<04872>>00640000
                                                               <<04872>>00645000
           fix up the catalog                                           00650000
                                                             <<gg.32>>  00655000
      fix the calling sequence for ckforlabel so that the    <<gg.32>>  00660000
    expired/unexpired checks will be made.                   <<gg.32>>  00665000
                                                             <<gg.32>>  00670000
  fix a problem with fix 4872.  the condition codes are still           00675000
not getting set correctly.                                              00680000
                                                                        00685000
   parse forms message of fopen call correctly so that default <<06024>>00690000
expiration date (00/00/00) can be specified.                   <<06024>>00695000
                                                               <<06024>>00700000
   1) when reopening a file closed with rewind disposition,    <<06026>>00705000
      will check file expiration date properly.                <<06026>>00710000
   2) checks file expiration date of file being opened, not    <<06026>>00715000
      first file on reel.  also enforces rule that files       <<06026>>00720000
      added must have an exp. date earlier (or the same) than  <<06026>>00725000
      that of the preceding file.                              <<06026>>00730000
   3) a labelled tape being opened for read access can no      <<06026>>00735000
      longer sneakily overwrite the volume label.              <<06026>>00740000
                                                               <<06026>>00745000
   allows ansi "D" labelled tape written by hp (pre d-mit) to  <<06135>>00750000
   be used.  treated as variable length record file.           <<06135>>00755000
                                                               <<06135>>00760000
   mpe5 changes:  this module was converted to use the ldt and <<06333>>00765000
   lpdt include files for mpe4 and 5.  no changes were required<<06333>>00770000
   to go from mpe4 to mpe5.                                    <<06333>>00775000
                                                               <<06424>>00780000
   mpe4 pcb include file changes.                              <<06424>>00785000
                                                               <<06939>>00790000
   made changes to accomodate new tape labels log record       <<06939>>00795000
   format for mpe5.                                            <<06939>>00800000
                                                               <<07113>>00805000
   fix up fix #6026 so that the expiration date checks will    <<07113>>00810000
   be made after a tape file has been fopened and fclosed with <<07113>>00815000
   disposition 2 or 3 (rewind).                                <<07113>>00820000
                                                               <<07338>>00825000
   fix pvolid so that parameters will be aligned properly when <<07338>>00830000
   doing a showdev tape.                                       <<07338>>00835000
                                                               <<07493>>00840000
   add support for the hp7974 and hp7978 variable density tape <<07493>>00845000
   drives (buckhorn and antelope).                             <<07493>>00850000
                                                               <<r7493>>00855000
   fixed reel numbers written on header and trailer labels by  <<r7493>>00860000
   nexttapefile (called by store).                             <<r7493>>00865000
                                                               <<d8615>>00870000
   fixed hp7974/7978 (antelope and buckhorn) default tape      <<d8615>>00875000
   density assignments.                                        <<d8615>>00880000
                                                                        00885000
                                                               <<04647>>00890000
                                                               <<04647>>00895000
                                                               <<04647>>00900000
;                                                              <<04647>>00905000
<< new source, 1981 jan 2. >>                                           00910000
                                                                        00915000
   << definitions for tape label table logical device blocks >>         00920000
                                                                        00925000
equate ltesize =26;                                                     00930000
define                                                                  00935000
 lcb'flags  =ltbuf#,            << state bits >>                        00940000
   lcb'labtyp =lcb'flags.(4:2)#,  << label type >>                      00945000
   lcb'tape   =lcb'flags.(6:1)#,   << tape device >>           <<03581>>00950000
   lcb'lockflg=lcb'flags.(7:1)#,  << lockword flag 1:53,1 >>            00955000
   lcb'b5000  =lcb'flags.(8:1)#,  << burroughs tape >>                  00960000
   lcb'hp     =lcb'flags.(9:1)#,  << hp tape >>                         00965000
 lcb'ldev      =ltbuf(1)#,                                              00970000
 lcb'vcb       =ltbuf(2)#,                                              00975000
 lcb'flag2     =ltbuf(3)#,                                              00980000
   lcb'reel   =lcb'flag2#,        << reel nr.  1:27,4 >>                00985000
 lcb'fseq      =ltbuf(4)#,      << file seq. nr.  1:31,4 >>             00990000
 lcb'cdate     =ltbuf(5)#,      << creation date 1:41,6 >>              00995000
 lcb'exdate    =ltbuf(6)#,      << expiration date 1:47,6 >>            01000000
 lcb'fname     =ltbufb(14)#,    << file name  1:4,17 >>                 01005000
 lcb'vsetid    =ltbufb(40)#,    << volume set id 1:21,6 >>              01010000
 lcb'volid     =ltbufb(46)#;    << volume id 0:4,6 >>                   01015000
                                                                        01020000
define buildlcb =                                                       01025000
   byte array ltbufb(*) = ltbuf#;                                       01030000
                                                                        01035000
   << definitions for tape label table volume control blocks >>         01040000
                                                                        01045000
equate vtesize =26;                                                     01050000
define                                                                  01055000
 vcb'flags  =vtbuf#,            << state bits >>                        01060000
   vcb'ascii  =vcb'flags.(0:1)#,  << ascii f-option >>                  01065000
   vcb'flush  =vcb'flags.(1:1)#,  << =reply 0 done >>                   01070000
   vcb'dr'wait=vcb'flags.(2:1)#,  << devrec wait   >>          <<03618>>01075000
   vcb'posn   =vcb'flags.(3:4)#,  << tape position >>                   01080000
   vcb'write  =vcb'flags.(7:1)#,  << write access >>                    01085000
   vcb'seqtyp =vcb'flags.(8:2)#,  << sequencing type >>                 01090000
   vcb'labtyp =vcb'flags.(10:2)#, << label type >>                      01095000
   vcb'lnkwait=vcb'flags.(12:1)#, << waiting for link >>                01100000
   vcb'mntwait=vcb'flags.(13:1)#, << waiting for mount >>               01105000
   vcb'rswait =vcb'flags.(14:1)#, << wait for reelswitch >>             01110000
   vcb'inuse  =vcb'flags.(15:1)#, << this entry in use >>               01115000
 vcb'ldev      =vtbuf(1)#,                                              01120000
 vcb'pin       =vtbuf(2)#,                                              01125000
 vcb'fnum      =vtbuf(3)#,      << fopen nr. >>                         01130000
 vcb'fseq      =vtbuf(4)#,      << file seq. nr.  1:31,4 >>             01135000
 vcb'flag2     =vtbuf(5)#,                                              01140000
   vcb'stortap=vcb'flag2.(0:1)#,  << store tape >>                      01145000
   vcb'rswdone=vcb'flag2.(1:1)#,  << reelswitch was done >>             01150000
   vcb'writdir=vcb'flag2.(2:1)#,  << next file is directory >>          01155000
   vcb'needvol=vcb'flag2.(3:1)#,    << vol1 write flag >>      <<03581>>01160000
   vcb'density=vcb'flag2.(4:3)#,  << requested density >>      <<03581>>01165000
   vcb'vsetopen=vcb'flag2.(7:1)#, << first open of volset >>   <<03581>>01170000
   vcb'reel   =vcb'flag2.(8:8)#,  << reel nr.  1:27,4 >>                01175000
 vcb'exdate    =vtbuf(6)#,      << expiration date 1:47,6 >>            01180000
 vcb'fname     =vtbufb(14)#,    << file name  1:4,17 >>                 01185000
 vcb'lockwrd   =vtbufb(32)#,    << lockword  2:15,8 >>                  01190000
 vcb'vsetid    =vtbufb(40)#,    << volume set id 1:21,6 >>              01195000
 vcb'volid     =vtbufb(46)#;    << volume id 0:4,6 >>                   01200000
                                                                        01205000
define buildvcb =                                                       01210000
   byte array vtbufb(*) =vtbuf;                                         01215000
   logical inuse = vtbuf#;                                              01220000
                                                                        01225000
<< vcb'posn states describe head position on tape. >>                   01230000
                                                                        01235000
equate                                                                  01240000
   ldpnt = 0,     << vol1 >>                                            01245000
   h1nx  = 1,     << hdr1&2 >>                                          01250000
   ah2   = 3,     << uhlx >>                                            01255000
   ahu   = 4,      << tapemark here >>                                  01260000
   dnx   = 6,     << data >>                                            01265000
   ad    = 7,      << tapemark here >>                                  01270000
   t1nx  = 8,     << eov1&2 >>                                          01275000
   at2   =10,     << utlx >>                                            01280000
   atu   =11;      << tapemark >>                                       01285000
                                                                        01290000
  << tape label structure definitions >>                                01295000
                                                                        01300000
equate lblsize =40;     << words >>                                     01305000
define ansi'version = "3"#;                                    <<04740>>01310000
define                                                                  01315000
      l0volid  =blabel0(4)#,                                            01320000
      l0access =blabel0(10)#,                                           01325000
      l0smark  =blabel0(79)#;                                           01330000
define                                                                  01335000
      l1fname  =btlabel(4)#,                                            01340000
      l1vsetid =btlabel(21)#,                                           01345000
      l1reel   =btlabel(27)#,                                           01350000
      l1fseq   =btlabel(31)#,                                           01355000
      l1cyr    =btlabel(42)#,                                           01360000
      l1cday   =btlabel(44)#,                                           01365000
      l1xyr    =btlabel(48)#,                                           01370000
      l1xday   =btlabel(50)#,                                           01375000
      l1acc    =btlabel(53)#,                                           01380000
      l1nblks  =btlabel(54)#,                                  <<0196>> 01385000
      l1system =btlabel(60)#;                                           01390000
define                                                                  01395000
      l2rfmt   =btlabel(4)#,                                            01400000
      l2bsize  =btlabel(5)#,                                            01405000
      l2rsize  =btlabel(10)#,                                           01410000
      l2bufoff =btlabel(50)#,                                           01415000
      l2lock   =btlabel(15)#,     << hp only >>                         01420000
      l2ftype  =btlabel(36)#,                                           01425000
      l2cctl   =btlabel(37)#,                                           01430000
      l2dsposn =btlabel(16)#,    << ibm only >>                         01435000
      l2blkatt =btlabel(38)#;                                           01440000
                                                                        01445000
define                                                                  01450000
      hpsystem  ="HP MPE 3000 "#,                                       01455000
      fopascii  =fops.(13:1)#,                                          01460000
      fopftype  =fops.(8:2)#,                                           01465000
      fopcctl   =fops.(7:1)#;                                           01470000
                                                                        01475000
   << functions for attachio >>                                         01480000
                                                                        01485000
equate read=0,                                                          01490000
       write=1,                                                <<02563>>01495000
       dclose=4,         << device close >>                    <<02563>>01500000
       read'status=15,   << read status for 7976 >>            <<02563>>01505000
       den'func=16,      << set density for 7976 >>            <<02563>>01510000
                                                               <<02563>>01515000
   << important status returns from attachio >>                <<02563>>01520000
                                                               <<02563>>01525000
      pfail'abort =  %63,  << power fail abort >>              <<02563>>01530000
      runaway'    = %103,  << tape runaway, new tape >>        <<06333>>01535000
      power'up    = %213,  << device powered up >>             <<02563>>01540000
      trans'error =  %14,  << transmission error/track error >><<02563>>01545000
      parity'err  =  %74;  << parity error (series ii/iii) >>  <<02563>>01550000
                                                               <<02563>>01555000
equate tltdst=26;                                                       01560000
equate tltsir=39;                                                       01565000
                                                                        01570000
<< tlt base entry structure definitions >>                              01575000
                                                                        01580000
equate xesize   =1,   << entry size >>                                  01585000
       xltbase  =2,   << bottom of ldev part >>                         01590000
       xvtbase  =3,   << top of ldev - bottom of vol t >>               01595000
       xvttop   =4,   << top of current vol table >>                    01600000
       xvtmax   =5,   << upper limit for vol table >>          <<03581>>01605000
       xvrest   =6;  << begining of the rest of the entry >>   <<03581>>01610000
                                                                        01615000
   integer status=q-1;                                                  01620000
   integer rtnx=q-3;                                                    01625000
   integer s0=s-0;                                                      01630000
   logical ls0=s-0;                                                     01635000
   integer x=x;                                                         01640000
equate ccg=0, ccl=1, cce=2;                                             01645000
equate                                                         <<06424>>01650000
       eofstat = %12,                                                   01655000
       invalid  = 4;                                                    01660000
define cc=status.(6:2)#,                                                01665000
   s0stat=s0.(8:8)#,                                                    01670000
   asmb  =assemble#;                                                    01675000
define enable = assemble(sed 1)#;                                       01680000
define disable = assemble(sed 0)#;                                      01685000
                                                                        01690000
$include inclferr                                              <<06333>>01695000
$include inclpcb5                                              <<06424>>01700000
$set x8=on                                                              01705000
$include incllpdt                                              <<06333>>01710000
define                                                         <<02563>>01715000
$page                                                          <<07339>>01720000
<<----------------------------------------------------------->><<06333>>01725000
<<                                                           >><<06333>>01730000
<<      lpdt density definitions for this module only        >><<06333>>01735000
<<                                                           >><<06333>>01740000
<<----------------------------------------------------------->><<06333>>01745000
      hp7970      =  0#,           << subtype for hp7970 >>    <<02563>>01750000
      hp7976      =  1#,           << subtype for hp7976 >>    <<02563>>01755000
      hp7978      =  2#,           << subtype for hp7978 >>    <<07339>>01760000
      hp7974      =  3#,           << subtype for hp7974 >>    <<07339>>01765000
   tape'device =                                               <<03581>>01770000
      ldevtotype(ldev)=24#,                                    <<03581>>01775000
   not'tape'device =                                           <<07339>>01780000
      (ldevtotype(ldev)<>24)#,                                 <<07339>>01785000
   set'bot'on =                                                <<03581>>01790000
      set'lpdt'bot(ldev,1)#,                                   <<03581>>01795000
   set'bot'off =                                               <<03581>>01800000
      set'lpdt'bot(ldev,0)#,                                   <<03581>>01805000
   variable'density =       <<test for var. dens. tape drive>> <<07339>>01810000
      tape'device land                                         <<07339>>01815000
      ((lpdt'auto'subtype = hp7974) lor                        <<07339>>01820000
       (lpdt'auto'subtype = hp7976) lor                        <<07339>>01825000
       (lpdt'auto'subtype = hp7978))#,                         <<07339>>01830000
   not'variable'density =   << test for non var. density    >> <<07339>>01835000
      not'tape'device lor                                      <<07339>>01840000
      ((lpdt'auto'subtype <> hp7974) land                      <<07339>>01845000
       (lpdt'auto'subtype <> hp7976) land                      <<07339>>01850000
       (lpdt'auto'subtype <> hp7978))#;                        <<07339>>01855000
            <<remember that ldev could be sdisc>>              <<03581>>01860000
$include inclldt5                                              <<06333>>01865000
                                                               <<02563>>01870000
  << tape trouble codes  >>                                    <<03581>>01875000
equate                                                         <<03581>>01880000
  tt5 =5,                                                      <<03581>>01885000
  tt6 =6,                                                      <<03581>>01890000
  tt7 =7,                                                      <<03581>>01895000
  tt9 =9,                                                      <<03581>>01900000
  tt10=10,                                                     <<03581>>01905000
  tt11=11,                                                     <<03618>>01910000
  tt12=12,                                                     <<03618>>01915000
  tt13=13,                                                     <<03618>>01920000
  tt14=14,                                                     <<03618>>01925000
  tt15=15,                                                     <<03581>>01930000
  tt16=16,                                                     <<03581>>01935000
  tt23=23,                                                     <<03581>>01940000
  tt24=24,                                                     <<03581>>01945000
  tt25=25,                                                     <<03581>>01950000
  tt27=27,                                                     <<03581>>01955000
  tt29=29,                                                     <<03581>>01960000
  tt41=41,                                                     <<03581>>01965000
  tt42=42,                                                     <<03581>>01970000
  tt43=43,                                                     <<03581>>01975000
  tt52=52,                                                     <<03581>>01980000
  tt53=53;                                                     <<03581>>01985000
equate monitor = %1077;   << filesys sysglob cell >>           <<02648>>01990000
define disabl'ibm = not absolute(monitor).(12:1)#;             <<02648>>01995000
                                                               <<02648>>02000000
$page " FORWARD AND EXTERNAL DECLARATIONS "                             02005000
logical procedure ckforldev(ldev);                             <<06026>>02010000
   value ldev;                                                 <<06026>>02015000
   integer ldev;                                               <<06026>>02020000
   option forward;                                             <<06026>>02025000
                                                               <<06026>>02030000
logical procedure ckforexdate(ldev,rdwr,lbled);                <<06026>>02035000
   value ldev,rdwr,lbled;                                      <<06026>>02040000
   integer ldev,rdwr; logical lbled;                           <<06026>>02045000
   option forward;                                             <<06026>>02050000
                                                                        02055000
procedure cleanldev(ldev);                                     <<02563>>02060000
   value ldev;                                                 <<02575>>02065000
   integer ldev;                                               <<02563>>02070000
   option forward;                                             <<02563>>02075000
                                                               <<02563>>02080000
procedure store'density(ldev,density,mode);                    <<02563>>02085000
   value ldev,mode;                                            <<02563>>02090000
   integer ldev,mode;                                          <<02563>>02095000
   array density;                                              <<02563>>02100000
   option forward;                                             <<02563>>02105000
                                                               <<02563>>02110000
integer procedure convertdate(date);                           <<0196>> 02115000
    value date;                                                <<0196>> 02120000
    byte pointer date;                                         <<0196>> 02125000
    option external;                                           <<0196>> 02130000
<< converts string of form "MM/DD/YY" to calendar format. >>            02135000
                                                                        02140000
logical procedure getsir(sirnum);                                       02145000
   value sirnum;                                                        02150000
   integer sirnum;                                                      02155000
   option external;                                                     02160000
                                                                        02165000
logical procedure relsir(sirnum,already);                               02170000
   value sirnum,already;                                                02175000
   integer sirnum;                                                      02180000
   logical already;                                                     02185000
   option external;                                                     02190000
                                                                        02195000
logical procedure exchangedb(dstx);                                     02200000
   value dstx;                                                          02205000
   logical dstx;                                                        02210000
   option external;                                                     02215000
                                                                        02220000
procedure suddendeath(crash);                                           02225000
   value crash; integer crash;                                          02230000
   option external;                                                     02235000
                                                                        02240000
double procedure attachio(ldev,qmisc,dstx,addr,func,cnt,p1,p2,flags);   02245000
   value ldev,qmisc,dstx,addr,func,cnt,p1,p2,flags;                     02250000
   integer ldev,qmisc,dstx,addr,func,cnt,p1,p2,flags;                   02255000
   option external;                                                     02260000
                                                                        02265000
procedure report'ioerror(ldev,iostatus);                       <<02673>>02270000
   value ldev,iostatus;                                        <<02673>>02275000
   integer ldev,iostatus;                                      <<02673>>02280000
   option external;                                            <<02673>>02285000
                                                               <<02673>>02290000
integer procedure remritentry(adr);                                     02295000
   value adr;                                                           02300000
   integer adr;                                                         02305000
   option external;                                                     02310000
                                                                        02315000
procedure freedevice(ldev,wait,norew);                                  02320000
   value wait,ldev,norew;                                               02325000
   integer ldev;                                                        02330000
   logical wait,norew;                                                  02335000
   option variable,external;                                            02340000
                                                                        02345000
procedure set'lpdt'bot(ldev,val);                              <<02563>>02350000
   value ldev,val; logical ldev,val;                           <<02563>>02355000
   option external;                                            <<02563>>02360000
                                                               <<02563>>02365000
procedure log14;                                                        02370000
  option external;                                                      02375000
                                                                        02380000
procedure debug;                                                        02385000
   option external;                                                     02390000
                                                                        02395000
procedure delay(t);                                            <<02563>>02400000
   value t; double t;                                          <<02563>>02405000
   option external;                                            <<02563>>02410000
                                                               <<02563>>02415000
integer procedure genmsg(setno,msgno,mask,parm1,parm2,                  02420000
      parm3,parm4,parm5,dest,reply,offset,dst,control);                 02425000
   value   setno,msgno,mask,parm1,parm2,parm3,parm4,parm5,              02430000
           dest,reply,offset,dst,control;                               02435000
   integer setno,msgno,dest,dst;                                        02440000
   logical mask,parm1,parm2,parm3,parm4,parm5,reply,offset,             02445000
      control;                                                          02450000
   option variable,external;                                            02455000
                                                                        02460000
procedure post'acb'error(filenum,theirstatus,error);           <<02703>>02465000
  value filenum,theirstatus,error;                             <<02703>>02470000
  integer filenum,error;                                       <<02703>>02475000
  logical theirstatus;                                         <<02703>>02480000
  option external;                                             <<02703>>02485000
                                                               <<03581>>02490000
integer procedure ldevtotype(ldev);                            <<03581>>02495000
  value ldev; integer ldev; option external;                   <<03581>>02500000
                                                               <<03581>>02505000
procedure fors'xds'dealloc(ldev);                              <<03634>>02510000
  value ldev;                                                  <<03634>>02515000
  integer ldev;                                                <<03634>>02520000
  option external;                                             <<03634>>02525000
                                                               <<03634>>02530000
intrinsic calendar,ctranslate,fgetinfo,fcontrol,printopreply;           02535000
intrinsic ascii;                                               <<02722>>02540000
$page " UTILITIES "                                                     02545000
procedure tapetrouble(crash);                                           02550000
   value crash; integer crash;                                          02555000
   option internal;                                            <<02621>>02560000
                                                                        02565000
   begin                                                                02570000
   suddendeath(86);                                                     02575000
   end;                                                                 02580000
integer procedure setowned(ldev,n);                                     02585000
   value ldev,n;                                                        02590000
   integer ldev,n;                                                      02595000
   option internal;                                            <<02621>>02600000
                                                                        02605000
<< get or set ownership bits in the lpdt entry. >>                      02610000
                                                                        02615000
   begin                                                                02620000
   integer lpdt'index;                                         <<06333>>02625000
                                                                        02630000
   disable;                                                             02635000
   lpdt'index := ldev * size'of'lpdt'entry;                    <<06333>>02640000
   setowned := lpdt'dev'own'state;                             <<06333>>02645000
   if n >= 0 then                                              <<06333>>02650000
      lpdt'dev'own'state := n;     << new value >>             <<06333>>02655000
   enable;                                                              02660000
   end;                                                                 02665000
procedure attio(ldev,func);                                             02670000
value ldev,func; integer ldev,func;                                     02675000
   option internal;                                            <<02621>>02680000
                                                                        02685000
   begin                                                                02690000
   if ldev=0 then tapetrouble(tt5);  << oops! >>               <<03581>>02695000
   tos := attachio(ldev,0,0,0,func,0,0,0,%11);                          02700000
   del;                                                                 02705000
   cc := if s0.(13:3) = 1 then cce else                                 02710000
      if s0.(13:3) = 2 then ccg else ccl;                               02715000
   rtnx := tos;                                                         02720000
   end;                                                                 02725000
procedure logit(vtbuf);                                                 02730000
  array vtbuf;                                                          02735000
   option internal;                                            <<02621>>02740000
                                                                        02745000
<< write log record.  the record is built by shuffling                  02750000
the vcb, so caller must have finished using it.  db is                  02755000
at the stack. >>                                                        02760000
                                                                        02765000
   begin                                                                02770000
   vtbuf(26) := vcb'pin;                                       <<06939>>02775000
   vtbuf(2) := vcb'ldev;                                       <<02673>>02780000
   tos := vcb'fnum;   << get file num. out of the way. >>      <<02673>>02785000
   vtbuf(3) := vcb'fseq;                                       <<02673>>02790000
   vtbuf(4).(0:8) := tos;                                      <<02673>>02795000
   vtbuf(4).(8:8) := vtbuf(0).(8:8);   << seq flags >>                  02800000
                                                                        02805000
   tos := @vtbuf+2;                                                     02810000
   tos := 25;                                                  <<06939>>02815000
   tos := 14;    << log record # >>                                     02820000
   log14;                                                               02825000
   end;       << procedure logit>>                                      02830000
$page " NUMERICAL CONVERSION "                                          02835000
procedure bin2asc(num,fptr,fsize);                                      02840000
value num,fsize;                                                        02845000
double num;                                                             02850000
byte array fptr;                                                        02855000
integer fsize;                                                          02860000
   option internal;                                            <<02621>>02865000
                                                                        02870000
   begin    << convert to ascii, with leading zeroes. >>                02875000
   tos := num;                                                          02880000
   while (fsize := fsize-1) >= 0 do                                     02885000
      begin                                                             02890000
      tos := 10;                                                        02895000
      asmb(ldiv);                                                       02900000
      fptr(fsize) := tos+"0";   << remainder >>                         02905000
      asmb(zero,xch);           << restore double >>                    02910000
      end;                                                              02915000
   end;                                                                 02920000
logical procedure binary'(string,nchars);                               02925000
value nchars;                                                           02930000
byte array string;                                                      02935000
integer nchars;                                                         02940000
   option internal;                                            <<02621>>02945000
                                                                        02950000
<< similar to the intrinsic, but is more forgiving of                   02955000
leading and trailing blanks. >>                                         02960000
                                                                        02965000
   begin                                                                02970000
   integer ix;                                                          02975000
   logical result = binary';                                            02980000
                                                                        02985000
   cc := cce;                                                           02990000
   ix := 0;                                                             02995000
   while ix < nchars and string(ix) = " " do ix := ix+1;                03000000
   while ix < nchars and string(ix) <> " " do                           03005000
      begin                                                             03010000
      if ("0" <= integer(string(ix)) <= "9") then                       03015000
         result := result*10+logical(string(ix)-"0") else               03020000
         cc := ccl;                                                     03025000
      ix := ix+1;                                                       03030000
      end;                                                              03035000
   end;                                                                 03040000
$page " TAPE LABEL TABLE MANAGEMENT "                                   03045000
procedure getxdsw(target,dstn,offset,wc);                               03050000
   value dstn,offset,wc;                                                03055000
   integer dstn,offset,wc;                                              03060000
   array target;                                                        03065000
   option internal;                                            <<02621>>03070000
                                                                        03075000
<< a dress suit for an mfds instruction. >>                             03080000
                                                                        03085000
   begin                                                                03090000
   tos := @target;                                                      03095000
   tos := dstn; tos := offset;                                          03100000
   tos := wc;                                                           03105000
   asmb(mfds 4);                                                        03110000
   end;                                                                 03115000
procedure putxdsw(dstn,offset,source,wc);                               03120000
   value dstn,offset,wc;                                                03125000
   integer dstn,offset,wc;                                              03130000
   array source;                                                        03135000
   option internal;                                            <<02621>>03140000
                                                                        03145000
<< fancy clothes for an mtds instruction. >>                            03150000
                                                                        03155000
   begin                                                                03160000
   tos := dstn; tos := offset;                                          03165000
   tos := @source;                                                      03170000
   tos := wc;                                                           03175000
   asmb(mtds 4);                                                        03180000
   end;                                                                 03185000
$page                                                                   03190000
integer procedure getfnum(fnum,vtbuf);                                  03195000
value fnum; logical fnum;                                               03200000
logical array vtbuf;                                                    03205000
   option internal;                                            <<02621>>03210000
                                                                        03215000
<< search for volume entry to match fnum.  for present version,         03220000
match pin and filenum; eventually this should become acb                03225000
location.  db is at stack. >>                                           03230000
                                                                        03235000
   begin                                                                03240000
   logical i = getfnum;                                                 03245000
   logical oldsir,pin;                                                  03250000
   define  inuse = vtbuf(0)#;                                           03255000
   double vtbounds;                                                     03260000
      logical vtbase = vtbounds;                                        03265000
      logical vttop = vtbounds+1;                                       03270000
                                                                        03275000
   cc := cce;                                                           03280000
   pin := curprc/pcbsize;                                      <<06424>>03285000
   oldsir := getsir(tltsir);                                            03290000
   getxdsw(vtbounds,tltdst,xvtbase,2);                                  03295000
   i := vtbase;                                                         03300000
   while i < vttop do                                                   03305000
      begin                                                             03310000
      tos := @vtbuf;                                                    03315000
      tos := tltdst; tos := i;                                          03320000
      tos := vtesize;                                                   03325000
      asmb(mfds 4);                                                     03330000
      if inuse and (vcb'fnum = fnum) and (vcb'pin = pin) then go out;   03335000
      i := i+vtesize;                                                   03340000
      end;                                                              03345000
   cc := ccl;    << not found. >>                                       03350000
   getfnum := -1;      << rat trap. >>                                  03355000
out:                                                                    03360000
   relsir(tltsir,oldsir);                                               03365000
   end;        << procedure getfnum >>                                  03370000
integer procedure getldev(ldev,ltbuf);                                  03375000
value ldev; logical ldev;                                               03380000
logical array ltbuf;                                                    03385000
   option internal;                                            <<02621>>03390000
                                                                        03395000
<< search vt for entry matching ldev.  db is at stack. >>               03400000
                                                                        03405000
   begin                                                                03410000
   logical i = getldev;                                                 03415000
   integer oldsir;                                                      03420000
   logical lttop;                                                       03425000
                                                                        03430000
   if ldev=0 then tapetrouble(tt6);                            <<03581>>03435000
   cc := cce;                                                           03440000
   oldsir := getsir(tltsir);                                            03445000
   getxdsw(lttop,tltdst,xvtbase,1);                                     03450000
   i := ltesize;                                                        03455000
                                                               <<02563>>03460000
while i < lttop do                                             <<02563>>03465000
   begin                                                       <<02563>>03470000
   tos := @ltbuf;                                                       03475000
   tos := tltdst; tos := i;                                             03480000
   tos := vtesize;                                                      03485000
   asmb(mfds 4);                                                        03490000
   if lcb'ldev = ldev then go out;                                      03495000
   i := i+ltesize;                                                      03500000
   end;                                                        <<02563>>03505000
                                                               <<02563>>03510000
   cc := ccl;    << not found. >>                                       03515000
out:                                                                    03520000
   relsir(tltsir,oldsir);                                               03525000
   end;        << procedure getldev >>                                  03530000
$page                                                                   03535000
procedure postvtent(vtbuf,vtaddr,scode);                                03540000
value scode; logical vtaddr,scode; array vtbuf;                         03545000
   option internal;                                            <<02621>>03550000
                                                                        03555000
<< stores entry into vt. db must be at stack.  vtaddr=0                 03560000
means create a new entry (only in volume section).  >>                  03565000
                                                                        03570000
   begin                                                                03575000
   logical inuse;                                                       03580000
   array vtbounds(0:2) =q;                                              03585000
      logical vtbase = vtbounds;                                        03590000
      logical vttop = vtbounds+1;                                       03595000
      logical vtmax = vtbounds+2;                                       03600000
                                                                        03605000
   getxdsw(vtbounds,tltdst,xvtbase,3);                                  03610000
   if integer(vtaddr) < 0 then tapetrouble(tt6);               <<03581>>03615000
   if vtaddr <> 0 then go stuff;                                        03620000
                                                                        03625000
 << create new entry; find hole for it. >>                              03630000
                                                                        03635000
   vcb'inuse := 1;                                                      03640000
   vtaddr := vtbase;                                                    03645000
loop:                                                                   03650000
   if vtaddr >= vttop then go expand;                                   03655000
   tos := @inuse;                                                       03660000
   tos := tltdst; tos := vtaddr;                                        03665000
   tos := 1;                                                            03670000
   asmb(mfds 4);                                                        03675000
   if not inuse then go stuff;                                          03680000
   vtaddr := vtaddr+vtesize;                                            03685000
   go loop;                                                             03690000
                                                                        03695000
expand:                                                                 03700000
   cc := ccl;                                                           03705000
   vttop := vttop+vtesize;                                              03710000
   if vttop >= vtmax then go byebye;     << burp! >>                    03715000
   putxdsw(tltdst,xvttop,vttop,1);     << update size >>                03720000
stuff:                                                                  03725000
   putxdsw(tltdst,vtaddr,vtbuf,vtesize);   << post new entry. >>        03730000
   cc := cce;                                                           03735000
byebye:                                                                 03740000
   if scode <> -1 then relsir(tltsir,scode);                            03745000
   end;        << procedure postvtent >>                                03750000
$page                                                          <<03618>>03755000
procedure labeled'dev'mounted(ldev);                           <<03618>>03760000
  value ldev;                                                  <<03618>>03765000
  logical ldev;                                                <<03618>>03770000
  option uncallable;                                           <<03618>>03775000
comment                                                        <<03618>>03780000
                                                               <<03618>>03785000
   this procedure allows devrec and pvproc to let reelswitch   <<03618>>03790000
know that the "tape" has been mounted.  it will set the        <<03618>>03795000
devrec wait bit in the vcb of the table.                       <<03618>>03800000
                                                               <<03618>>03805000
will be rewritten when we allow different ldevs for            <<03618>>03810000
reswitches.                                                    <<03618>>03815000
                                                               <<03618>>03820000
;                                                              <<03618>>03825000
begin                                                          <<03618>>03830000
logical vtaddr,ltaddr;                                         <<03618>>03835000
integer scode;                                                 <<03618>>03840000
logical array vtbuf(0:vtesize-1)=q;                            <<03618>>03845000
  buildvcb;                                                    <<03618>>03850000
logical array ltbuf(0:ltesize-1)=q;                            <<03618>>03855000
  buildlcb;                                                    <<03618>>03860000
                                                               <<03618>>03865000
ltaddr := getldev(ldev,ltbuf);                                 <<03618>>03870000
if < then tapetrouble(tt11);                                   <<03618>>03875000
if lcb'vcb > 0    <<  tape device is linked up  >>             <<03618>>03880000
  then begin                                                   <<03618>>03885000
    vtaddr := lcb'vcb;                                         <<03618>>03890000
    getxdsw(vtbuf,tltdst,vtaddr,vtesize);                      <<03618>>03895000
    if ldev <> vcb'ldev then tapetrouble(tt12);                <<03618>>03900000
    vcb'dr'wait := 1;                                          <<03618>>03905000
    scode := getsir(tltsir);                                   <<03618>>03910000
    postvtent(vtbuf,vtaddr,scode);                             <<03618>>03915000
    end;                                                       <<03618>>03920000
end;                                                           <<03618>>03925000
$page                                                          <<03618>>03930000
logical procedure test'for'reelswitch(ldev);                   <<03618>>03935000
value ldev;                                                    <<03618>>03940000
logical ldev;                                                  <<03618>>03945000
option uncallable;                                             <<03618>>03950000
comment                                                        <<03618>>03955000
                                                               <<03618>>03960000
  this procedure will let the caller (pvproc) know if we       <<03618>>03965000
are waiting for a reelswitch.  it will check the               <<03618>>03970000
vcb'rswait bit in the vcb for the volume mounted on the        <<03618>>03975000
ldev.                                                          <<03618>>03980000
                                                               <<03618>>03985000
  returns: true if waiting for a reelswitch,                   <<03618>>03990000
           false if not waiting for a reelswitch.              <<03618>>03995000
                                                               <<03618>>04000000
will be rewritten when we allow different ldevs for            <<03618>>04005000
reelswitches.                                                  <<03618>>04010000
                                                               <<03618>>04015000
;                                                              <<03618>>04020000
begin                                                          <<03618>>04025000
logical vtaddr,ltaddr;                                         <<03618>>04030000
integer scode;                                                 <<03618>>04035000
logical array vtbuf(0:vtesize-1)=q;                            <<03618>>04040000
  buildvcb;                                                    <<03618>>04045000
logical array ltbuf(0:vtesize-1)=q;                            <<03618>>04050000
  buildlcb;                                                    <<03618>>04055000
                                                               <<03618>>04060000
ltaddr := getldev(ldev,ltbuf);                                 <<03618>>04065000
if < then tapetrouble(tt13);                                   <<03618>>04070000
if lcb'vcb > 0       <<  tape device is linked up  >>          <<03618>>04075000
  then begin                                                   <<03618>>04080000
    vtaddr := lcb'vcb;                                         <<03618>>04085000
    getxdsw(vtbuf,tltdst,vtaddr,vtesize);                      <<03618>>04090000
    if ldev <> vcb'ldev then tapetrouble(tt14);                <<03618>>04095000
    test'for'reelswitch := vcb'rswait;                         <<03618>>04100000
    end                                                        <<03618>>04105000
  else test'for'reelswitch := false;                           <<03618>>04110000
end;                                                           <<03618>>04115000
procedure setup'tapes;                                         <<02563>>04120000
option privileged,uncallable;                                           04125000
comment                                                        <<03581>>04130000
                                                               <<03581>>04135000
     re-format tltdst as required.  also, initialize other     <<03581>>04140000
     tape data structures.  runs only once.  gets the table    <<03581>>04145000
     in unformated condition (as follows).                     <<03581>>04150000
                                                               <<03581>>04155000
   word 0 - size of tltdst                                     <<03581>>04160000
   word 1 - n: number of ldevs in table.                       <<03581>>04165000
   word 2 - in (0:14): ldev number, in (14:2): 1 if tape       <<06202>>04170000
     ~    -     otherwise 0.                                   <<03581>>04175000
   word n+2                                                    <<03581>>04180000
                                                               <<03581>>04185000
;                                                              <<03581>>04190000
                                                                        04195000
   begin                                                                04200000
   integer pointer oldldev,newldev;                                     04205000
   integer                                                     <<03581>>04210000
      maxsize,                                                 <<03581>>04215000
      scode,                                                   <<02563>>04220000
      userdb,                                                  <<02563>>04225000
      numldevs,       << number of tape ldevs >>               <<02563>>04230000
      index := 0,     << index for tape'ldevs >>               <<02563>>04235000
      ldev;                                                    <<02563>>04240000
   equate                                                               04245000
      oldldevbase = 2,                                         <<03581>>04250000
      newldevbase = ltesize+1;                                          04255000
   integer oldnumldevw = db+1;                                 <<03581>>04260000
   integer maxsizew = db;                                      <<03581>>04265000
<< the next declaration must be the last one in the >>         <<02563>>04270000
<< procedure.  a dynamic direct array will be built >>         <<02563>>04275000
<< on top of stack with an adds instruction. >>                <<02563>>04280000
   integer array tape'ldevs(*) = q;                            <<02563>>04285000
                                                               <<02563>>04290000
   define                                                      <<03581>>04295000
     dev=(0:14)#,                                              <<06202>>04300000
     tape=(14:2)#;                                             <<06202>>04305000
                                                               <<03581>>04310000
                                                                        04315000
   scode := getsir(tltsir);                                    <<02563>>04320000
   userdb := exchangedb(tltdst);                               <<02563>>04325000
                                                               <<02563>>04330000
<< get stack space for tape'ldevs array >>                     <<02563>>04335000
                                                               <<02563>>04340000
   numldevs := oldnumldevw;                                    <<03581>>04345000
   maxsize := maxsizew;                                        <<03581>>04350000
   tos := numldevs;                                            <<02563>>04355000
   asmb( adds 0 );                                             <<02563>>04360000
                                                               <<02563>>04365000
<< move ldev numbers into local array. >>                      <<02563>>04370000
                                                               <<02563>>04375000
   @oldldev := oldldevbase;                                    <<02563>>04380000
                                                               <<02563>>04385000
   while numldevs > 0  do                                      <<02563>>04390000
      begin                                                    <<02563>>04395000
                                                               <<02563>>04400000
      tape'ldevs(index) := oldldev;                            <<03581>>04405000
                                                               <<02563>>04410000
      @oldldev := @oldldev + 1;                                <<03581>>04415000
      numldevs := numldevs - 1;                                <<02563>>04420000
      index := index + 1;                                      <<02563>>04425000
      end;                                                     <<02563>>04430000
                                                               <<02563>>04435000
<< restructure table into new format. >>                       <<02563>>04440000
                                                               <<02563>>04445000
   @newldev := newldevbase;                                    <<02563>>04450000
   numldevs := index;                                          <<02563>>04455000
   index := 0;                                                 <<02563>>04460000
                                                               <<02563>>04465000
   while numldevs > 0  do                                      <<02563>>04470000
      begin                                                    <<02563>>04475000
      << zero out tlt entry >>                                 <<02563>>04480000
      newldev(-1) := 0;                                        <<02563>>04485000
      move newldev(0) := newldev(-1),(ltesize-1);              <<02563>>04490000
                                                               <<02563>>04495000
      newldev := tape'ldevs(index).dev;                        <<03581>>04500000
                                                               <<02563>>04505000
      newldev(-1).(6:1) := tape'ldevs(index).tape;             <<03581>>04510000
                                                               <<03581>>04515000
      @newldev := @newldev + ltesize;                          <<02563>>04520000
      numldevs := numldevs - 1;                                <<02563>>04525000
      index := index + 1;                                      <<02563>>04530000
      end;                                                     <<02563>>04535000
                                                               <<02563>>04540000
<< make base entry. >>                                                  04545000
                                                                        04550000
   @newldev := @newldev-1;                                              04555000
   @oldldev := 0;                                                       04560000
   oldldev(0) := 1;      << initialized >>                              04565000
   oldldev(xesize) := ltesize;                                          04570000
   oldldev(xltbase) := ltesize;                                         04575000
   oldldev(xvtbase) := @newldev;                                        04580000
   oldldev(xvttop) := @newldev;                                         04585000
   oldldev(xvtmax) := maxsize;                                          04590000
   oldldev(xvrest) := 0;                                       <<03581>>04595000
   move oldldev(xvrest+1) := oldldev(xvrest),(19);             <<03581>>04600000
                                                                        04605000
   relsir(tltsir,scode);                                                04610000
   exchangedb(userdb);                                                  04615000
                                                               <<02563>>04620000
<< initialize tape density data structures.  >>                <<02563>>04625000
<< zero density fields, and turn on bot bit. >>                <<02563>>04630000
                                                               <<02563>>04635000
   while (index := index - 1) >= 0  do                         <<02563>>04640000
      begin                                                    <<02563>>04645000
      ldev := tape'ldevs(index);                               <<02563>>04650000
      store'density(ldev,scode,2);   << scode is a dummy >>    <<02563>>04655000
      if tape'device then set'bot'on;                          <<03581>>04660000
      end;                                                     <<02563>>04665000
                                                               <<02563>>04670000
   end;         << procedure setup'tapes >>                    <<02563>>04675000
$page " SEGMENT INTERNAL DENSITY MANAGEMENT UTILITIES "        <<02563>>04680000
integer procedure get'density(ldev);                           <<02563>>04685000
   value ldev; logical ldev;                                   <<02563>>04690000
   option internal;                                            <<02563>>04695000
                                                               <<02563>>04700000
comment                                                        <<02563>>04705000
                                                               <<02563>>04710000
   this procedure returns the density of the tape on ldev in   <<02563>>04715000
its internal representation.  its sole purpose is to hide the  <<02563>>04720000
density data structure from other procedures.                  <<02563>>04725000
                                                               <<02563>>04730000
;       << end of comment >>                                   <<02563>>04735000
                                                               <<02563>>04740000
begin                                                          <<02563>>04745000
integer ldt'index;                                             <<06333>>04750000
logical array ldt(0:size'of'ldt'entry-1);                      <<06333>>04755000
                                                               <<02563>>04760000
   ldt'index := 0;                                             <<06333>>04765000
   getxdsw(ldt, ldt'dst, ldev * size'of'ldt'entry,             <<06333>>04770000
           size'of'ldt'entry);                                 <<06333>>04775000
   get'density := ldt'actual'tape'dens;                        <<06333>>04780000
end;                                                           <<02563>>04785000
                                                               <<02563>>04790000
logical procedure wrong'density(vtbuf);                        <<02563>>04795000
   integer array vtbuf;                                        <<02563>>04800000
   option internal;                                            <<02563>>04805000
                                                               <<02563>>04810000
comment                                                        <<02563>>04815000
                                                               <<02563>>04820000
   this procedure returns true when the user has made a        <<02563>>04825000
specific density request (i.e. not default) and the tape       <<02563>>04830000
associated with the request is of a different density.         <<02563>>04835000
                                                               <<02563>>04840000
;    << end of comment >>                                      <<02563>>04845000
                                                               <<02563>>04850000
begin                                                          <<02563>>04855000
   if vcb'density <> ldt'no'density and                        <<06333>>04860000
     get'density(vcb'ldev) <> vcb'density  then                <<02563>>04865000
      wrong'density := true;                                   <<02563>>04870000
end;                                                           <<02563>>04875000
                                                               <<02563>>04880000
logical procedure set'density(ldev,density);                   <<02662>>04885000
   value ldev,density;                                         <<02563>>04890000
   logical ldev;                                               <<02563>>04895000
   integer density;                                            <<02563>>04900000
   option internal;                                            <<02563>>04905000
                                                               <<02563>>04910000
comment                                                        <<02563>>04915000
                                                               <<02563>>04920000
   this procedure sets the density of a multiple density       <<02563>>04925000
mag tape drive.  it is very similar to write'density in        <<02563>>04930000
module fileio.  however, there are certain differences:        <<02563>>04935000
   1)  the bot bit is handled differently for labelled         <<02563>>04940000
       and unlabelled tapes,                                   <<02563>>04945000
   2)  the requested density is kept in different places       <<02563>>04950000
       for labelled and unlabelled tapes,                      <<02563>>04955000
   3)  db will always be at the stack,                         <<02563>>04960000
   4)  for now, tape errors are generally ignored in labseg,   <<02563>>04965000
   5)  the ldt need not be locked since only one process at    <<02563>>04970000
       a time can access a labelled tape.                      <<02563>>04975000
returns true if an error occurs.                               <<02662>>04980000
;      << end of comment >>                                    <<02563>>04985000
                                                               <<02563>>04990000
begin                                                          <<02563>>04995000
logical array ldt(0:size'of'ldt'entry-1);                      <<06333>>05000000
integer                                                        <<02563>>05005000
   lpdt'index,                                                 <<06333>>05010000
   ldt'index,                                                  <<06333>>05015000
   attio'stat,      << holds attachio status return >>         <<02563>>05020000
   p2;              << parameter 2 to attachio >>              <<02563>>05025000
equate                                                         <<02563>>05030000
   successful  = 1, << general status, ok >>                   <<02563>>05035000
   bflags      = 1, << blocked io flags >>                     <<02563>>05040000
   p2'6250     = 0, << p2 value for 6250 bpi >>                <<02563>>05045000
   p2'1600     = 1, << p2 value for 1600 bpi >>                <<07339>>05050000
   p2'800      = 2; << p2 value for 800  bpi >>                <<07339>>05055000
array                                                          <<07339>>05060000
   density'to'p2'parm(0:3)=pb := 0,p2'1600,p2'6250,p2'800;     <<07339>>05065000
                                                               <<02563>>05070000
                                                               <<02563>>05075000
   lpdt'index := ldev * size'of'lpdt'entry;                    <<06333>>05080000
   if (not'variable'density) then return;                      <<07339>>05085000
                                                               <<02563>>05090000
   if density <> ldt'no'density then                           <<07339>>05095000
      p2 := density'to'p2'parm(density)                        <<07339>>05100000
   else if lpdt'auto'subtype = hp7974 then                     <<d8615>>05105000
      p2 := p2'1600    << default for 7974                  >> <<07339>>05110000
   else                                                        <<07339>>05115000
      p2 := p2'6250;   << default for 7976 or 7978          >> <<07339>>05120000
                                                               <<02563>>05125000
<< retry set density if power problems >>                      <<02563>>05130000
                                                               <<02563>>05135000
   do begin                                                    <<02563>>05140000
      tos := attachio(ldev,0,0,0,den'func,0,0,p2,bflags);      <<02563>>05145000
      del;                                                     <<02563>>05150000
      attio'stat := tos.(8:8);                                 <<02563>>05155000
      end                                                      <<02563>>05160000
   until attio'stat <> power'up  and                           <<02563>>05165000
         attio'stat <> pfail'abort;                            <<02563>>05170000
                                                               <<02563>>05175000
   if attio'stat.(13:3) = successful then                      <<02563>>05180000
      begin                                                    <<02563>>05185000
      ldt'index := 0;                                          <<06333>>05190000
      getxdsw(ldt, ldt'dst, ldev * size'of'ldt'entry,          <<06333>>05195000
              size'of'ldt'entry);                              <<06333>>05200000
                                                               <<02563>>05205000
      ldt'actual'tape'dens := density;                         <<06333>>05210000
                                                               <<02563>>05215000
      putxdsw(ldt'dst, ldev * size'of'ldt'entry, ldt,          <<06333>>05220000
              size'of'ldt'entry);                              <<06333>>05225000
      end                                                       <<2563>>05230000
   else set'density := true;    << error >>                     <<2563>>05235000
   end;       << of procedure set'density >>                    <<2563>>05240000
$page " GOODREEL  "                                            <<02563>>05245000
logical procedure goodreel(vtbuf,ltbuf);                       <<02648>>05250000
logical array vtbuf,ltbuf;                                              05255000
option internal;                                                        05260000
                                                                        05265000
<< decides if a mounted volume is suitable to a tape request.  >>       05270000
                                                                        05275000
   begin                                                                05280000
   buildlcb;                                                            05285000
   buildvcb;                                                            05290000
                                                                        05295000
   if vcb'labtyp <> lcb'labtyp then go ng;                              05300000
   if vcb'write and (vcb'seqtyp=1) then    << next >>                   05305000
      if vcb'volid=lcb'volid,(6) then go ok else go ng;                 05310000
   if vcb'vsetid=lcb'vsetid,(6) then go maybe;                          05315000
   if vcb'volid <> lcb'volid,(6) then go ng;                            05320000
maybe:                                                                  05325000
   if (vcb'seqtyp=0) and vcb'fname =lcb'fname,(if lcb'hp then 17 else 8)05330000
      and (lcb'reel <> 1) then go ng;   << name - need reel 1 >>        05335000
   if (vcb'seqtyp=3) then if (lcb'fseq > vcb'fseq) or                   05340000
      (lcb'fseq = vcb'fseq) and (lcb'reel <> 1) then                    05345000
      go ng;       << by file number - need prior reel >>               05350000
ok:                                                                     05355000
   goodreel := true;     << we'll buy it. >>                            05360000
ng:                                                                     05365000
   end;       << procedure goodreel >>                                  05370000
$page " WRITE HEADER AND TRAILER LABELS "                               05375000
logical procedure writlab0(vtbuf);                             <<02662>>05380000
   array vtbuf;                                                         05385000
   option internal;                                            <<02621>>05390000
                                                                        05395000
<< write volume label [vol1] per info in vcb. >>                        05400000
                                                                        05405000
   begin                                                                05410000
   byte array vtbufb(*) = vtbuf;                                        05415000
   array label0(0:lblsize-1) =q;                                        05420000
      double ltype = label0;                                            05425000
      byte array blabel0(*) = label0;                                   05430000
                                                                        05435000
   if set'density(vcb'ldev,vcb'density) then writlab0 := true; <<02662>>05440000
                                                               <<02563>>05445000
   label0 := "  ";                                                      05450000
   move label0(1) := label0,(lblsize-1);                                05455000
   ltype := "VOL1";                                                     05460000
   move l0volid := vcb'volid,(6);                                       05465000
   if vcb'labtyp = 2 then l0smark := ansi'version else         <<04740>>05470000
      begin          << ibm >>                                          05475000
      l0access := "0";                                                  05480000
      ctranslate(2,blabel0,,80);                                        05485000
      end;                                                              05490000
   tos := attachio(vcb'ldev,0,0,@label0,write,lblsize,0,4,1);  <<02662>>05495000
   del;                                                        <<02662>>05500000
   if tos.(13:3) <> 1 then writlab0 := true;   << error >>     <<02662>>05505000
   end;      << procedure writlab0 >>                                   05510000
$page                                                                   05515000
logical procedure writelab(vtbuf,ltype);                       <<02662>>05520000
value ltype;                                                            05525000
array vtbuf;                                                            05530000
logical ltype;                                                          05535000
   option internal;                                            <<02621>>05540000
                                                                        05545000
<< called from reelswitch and checkul to write hdr, eof,                05550000
and eov labels.  ltype specifies:                                       05555000
   0 - hdr                                                              05560000
   1 - eof                                                              05565000
   2 - eov                                                              05570000
db must be at the stack. returns true if error occured. >>     <<02662>>05575000
                                                                        05580000
   begin                                                                05585000
   integer ldev;                                                        05590000
   logical date;                                                        05595000
   integer recsize;                                                     05600000
   integer blksize;                                                     05605000
   double nblks;                                                        05610000
   logical fops;                                                        05615000
   logical array tlabel(0:lblsize-1) =q;                                05620000
      byte array btlabel(*)=tlabel;                                     05625000
      double l1type = tlabel;                                           05630000
      buildvcb;                                                         05635000
   double array ltypecode(0:2) =pb := "HDR1","EOF1","EOV1";             05640000
   array ftypecode(0:3) =pb := "FFVVUUVV";                              05645000
   equate flags=1;                                                      05650000
                                                                        05655000
                                                               <<02689>>05660000
subroutine attios(func);                                       <<02689>>05665000
value func; integer func;                                      <<02689>>05670000
                                                               <<02689>>05675000
   begin                                                       <<02689>>05680000
   if ldev=0 then tapetrouble(tt5);  << oops! >>               <<03581>>05685000
   tos := attachio(ldev,0,0,@tlabel,func,lblsize,0,4,flags);   <<02689>>05690000
   del;                                                        <<02689>>05695000
   if s0.(13:3) <> 1 then writelab := true; << report error! >><<02689>>05700000
   x := tos;                                                   <<02689>>05705000
   end;                                                        <<02689>>05710000
                                                               <<02689>>05715000
                                                               <<02689>>05720000
 << write hdr1 - eof1 - eov1  >>                                        05725000
                                                                        05730000
   tlabel := "  ";                                                      05735000
   move tlabel(1) := tlabel,(39);                                       05740000
   fgetinfo(vcb'fnum,,fops,,recsize,,ldev,,,,,,,nblks,blksize);         05745000
   if ltype <> 0 then attios(6);  << tm ends data >>           <<02689>>05750000
   l1type := ltypecode(ltype);                                          05755000
   move l1fname := vcb'fname,(17);                                      05760000
   bin2asc(double(vcb'reel),l1reel,4);      << put in reel # >>         05765000
   bin2asc(double(vcb'fseq),l1fseq,4);       << put in file seq # >>    05770000
   bin2asc(double(vcb'exdate.(0:7)),l1xyr,2);   << put in exp date >>   05775000
   bin2asc(double(vcb'exdate.(7:9)),l1xday,3);                          05780000
   date := calendar;                                                    05785000
   bin2asc(double(date.(0:7)),l1cyr,2);                                 05790000
   bin2asc(double(date.(7:9)),l1cday,3);                                05795000
   move l1vsetid := vcb'vsetid,(6);                                     05800000
   bin2asc(if ltype=0 then 0d         << hdr1 >>                        05805000
      else if ltype=1 then nblks      << eof1 >>                        05810000
      else nblks+1d,l1nblks,6);       << eov1 >>                        05815000
   move l1system := hpsystem;                                           05820000
   if vcb'labtyp = 2 then                                               05825000
      begin       << ansi label >>                                      05830000
      if vcb'lockwrd <> " " then l1acc := %230;                         05835000
      end                                                               05840000
   else                                                                 05845000
      begin      << ibm >>                                              05850000
      l1acc := "0";                                                     05855000
      ctranslate(2,btlabel,,80);                                        05860000
      end;                                                              05865000
   attios(write);                                              <<02689>>05870000
                                                                        05875000
 << write hdr2 - eof2 - eov2  >>                                        05880000
                                                                        05885000
   tlabel := "  ";                                                      05890000
   move tlabel(1) := tlabel,(39);                                       05895000
   l1type := ltypecode(ltype)+1d;                                       05900000
   l2rfmt := byte(ftypecode(fopftype));                                 05905000
   if blksize < 1 then blksize := -blksize                              05910000
      else blksize := blksize*2;       << make +bytes >>                05915000
   if recsize < 1 then recsize := -recsize                              05920000
      else recsize := recsize*2;                                        05925000
   if logical(recsize) then                                             05930000
      begin    << round up rec size if block fact > 1. >>               05935000
      if blksize <> recsize then                                        05940000
         recsize := recsize+1;                                          05945000
      end;                                                              05950000
   bin2asc(double(blksize),l2bsize,5);                                  05955000
   bin2asc(double(recsize),l2rsize,5);                                  05960000
   if vcb'labtyp = 2 then                                               05965000
      begin       << ansi label, with hp features. >>                   05970000
      move l2lock := vcb'lockwrd,(8);                                   05975000
      l2ftype := byte("B"-vcb'ascii);                                   05980000
      if fopcctl then l2cctl := "C";                                    05985000
      move l2bufoff := "00";                                            05990000
      end                                                               05995000
   else                                                                 06000000
      begin        << ibm label. >>                                     06005000
      l2dsposn := if ltype = 0 then "0" else if ltype = 2 then "1"      06010000
         else "1";     << needs more >>                                 06015000
      l2blkatt := if blksize = recsize then " " else "B";               06020000
      ctranslate(2,btlabel,,80);                                        06025000
      end;                                                              06030000
   attios(write);                                              <<02689>>06035000
   end;      << procedure writelab >>                                   06040000
$page " CHECK1 "                                                        06045000
logical procedure check1(ltbuf);                                        06050000
logical array ltbuf;                                                    06055000
   option internal;                                            <<02621>>06060000
   begin                                                                06065000
                                                                        06070000
<< called from reelswitch, checkul, and position to                     06075000
read and validate hdr1, eof1, and eov1.  returns:                       06080000
         =-1 - eof                                                      06085000
         =0  - hdr1 label                                               06090000
         =1  - eof1 label                                               06095000
         =2  - eov1 label                                               06100000
         =3  - vol1 label  [fcontrol rewind]                            06105000
         =4  - violation or none of the above                           06110000
         =5  - uvl label                                         mp.68  06115000
db must be at the stack.                    >>                          06120000
                                                                        06125000
   logical result=check1;                                               06130000
   logical ldev;                                                        06135000
      buildlcb;                                                         06140000
   logical array label1(0:lblsize-1) =q;                                06145000
      double l1type = label1;                                           06150000
      byte array btlabel(*)=label1;                                     06155000
   equate flags=1;                                                      06160000
                                                                        06165000
 << begin execution >>                                                  06170000
                                                                        06175000
   cc := cce;                                                           06180000
   ldev := lcb'ldev;                                                    06185000
   tos := attachio(ldev,0,0,@label1,read,lblsize,0,0,flags);            06190000
   del;                                                                 06195000
   if s0stat=eofstat then                                               06200000
      begin     << tapemark: end of vol set >>                          06205000
      del;                                                              06210000
      cc := ccg;     << report eof. >>                                  06215000
      result := -1;                                                     06220000
      go outd;                                                          06225000
      end;                                                              06230000
   if tos.(13:3) <> 1 then                                              06235000
      begin                                                             06240000
      cc := ccl;     << report error. >>                                06245000
      result := 2;                                                      06250000
      go outd;                                                          06255000
      end;                                                              06260000
   if lcb'labtyp = 3 then   << ibm >>                                   06265000
      ctranslate(1,btlabel,,80);    << to ascii >>                      06270000
   if l1type="HDR1" then tos := 0                                       06275000
   else if l1type="EOF1" then tos := 1                                  06280000
   else if l1type="EOV1" then tos := 2                                  06285000
   else if l1type="VOL1" then tos := 3                                  06290000
   else if btlabel="UVL" then tos := 5                         <<02621>>06295000
   else tos := 4;                                                       06300000
   result := s0;                                                        06305000
   if tos < 3 then                                                      06310000
      begin       << hdr1/eof1/eov1 >>                                  06315000
      move lcb'fname := l1fname,(17);                                   06320000
      move lcb'vsetid := l1vsetid,(6);                                  06325000
      lcb'hp := if l1system = hpsystem and (lcb'labtyp = 2)    <<02690>>06330000
         then 1 else 0;                                        <<02690>>06335000
      lcb'lockflg := if lcb'hp and (l1acc=%230) then 1 else 0;          06340000
      lcb'cdate := binary'(l1cday,3);                                   06345000
      lcb'cdate.(0:7) := binary'(l1cyr,2);                              06350000
      lcb'exdate := binary'(l1xday,3);                                  06355000
      lcb'exdate.(0:7) := binary'(l1xyr,2);                             06360000
      lcb'fseq := binary'(l1fseq,4);                                    06365000
      lcb'reel := binary'(l1reel,4);                                    06370000
      end;                                                              06375000
outd:                                                                   06380000
   end;      << procedure check1 >>                                     06385000
$page " CREATETLTENT "                                                  06390000
integer procedure createtltent(fmsg,id,fnum,access,density);   <<02563>>06395000
   value fnum,access,density;                                  <<02563>>06400000
   byte array fmsg;                                                     06405000
   array id;                                                            06410000
   integer fnum,access,density;                                <<02563>>06415000
   option uncallable;                                                   06420000
                                                                        06425000
<<  called from fopen to get tape label parameters from the             06430000
forms message or from the file equation, and make a volume              06435000
entry in the tape label table.  if no volume id is specified,           06440000
operator will be asked for a volume id.  if the first open for          06445000
this volume set, a new file entry will be made in the tape label        06450000
table; otherwise the entry is updated.  parameters:                     06455000
   fmsg  - forms msg, e.g. ".VSET01,ANS,12/3/80,NEXT;"                  06460000
   id  - file name and lockword, as supplied to fopen.                  06465000
   fnum - file number (aft index)                                       06470000
   access - access type (aoptions.(12:4))                               06475000
   density - density requested by user (internal form)           mp.60  06480000
                                                                        06485000
returns 0 if ok, otherwise error number.  db at stack. >>               06490000
                                                                        06495000
                                                                        06500000
begin                                                                   06505000
   logical vtaddr;                                                      06510000
   integer scode,ix,ixd;                                                06515000
   integer lgth;                                                        06520000
   logical pinno,labeltype;                                             06525000
   logical vsetop;                                                      06530000
   logical exdate,seqtype,fseq;                                         06535000
   integer result = createtltent;                                       06540000
   double vtbounds;                                                     06545000
      logical vtbase = vtbounds;                                        06550000
      logical vttop = vtbounds+1;                                       06555000
   integer array buffer(0:12);                                          06560000
      byte array bbuf(*) = buffer;                                      06565000
   integer array reply(0:2) =q;                                         06570000
      byte array replyb(*) =reply;                                      06575000
   integer array volsetid(0:5);                                         06580000
      byte array bvsetid(*) = volsetid;                                 06585000
   byte array bfname(0:17);                                             06590000
   logical array vtbuf(0:vtesize-1) =q;                                 06595000
      buildvcb;                                                         06600000
   byte array bid(*) = id;                                              06605000
                                                                        06610000
 << begin execution >>                                                  06615000
                                                                        06620000
   if access = 3 then                                                   06625000
      begin       << append - illegal. >>                               06630000
      result := lbtappend;                                              06635000
      go endz;                                                          06640000
      end;                                                              06645000
   ix := 0;       << index into forms message >>                        06650000
   while fmsg(ix) <> "." do                                             06655000
      begin       << skip anything preceding the "." >>                 06660000
      ix := ix+1;                                                       06665000
      if ix > 49 then go errf;                                          06670000
      end;                                                              06675000
   pinno := curprc/pcbsize;                                    <<06424>>06680000
   labeltype := 2;      << default: ansi >>                             06685000
   exdate := 0;                                                         06690000
   seqtype := 1;        << next >>                                      06695000
   fseq := 0;                                                           06700000
                                                                        06705000
<< get parms from forms message here >>                                 06710000
                                                                        06715000
   move bvsetid := "      ";                                            06720000
   ix := ix+1;          << skip over "." >>                             06725000
   ixd := 0;                                                            06730000
   while ixd < 6 do                                                     06735000
      begin       << get volume set id >>                               06740000
      tos := fmsg(ix);                                                  06745000
      if not(" " <= s0 <= %176) then go errf;                  <<02648>>06750000
      if s0 = ";" or s0 = "," then go elabn;  << end >>        <<02648>>06755000
      bvsetid(ixd) := tos;                                              06760000
      ix := ix+1;                                                       06765000
      ixd := ixd+1;                                                     06770000
      end;                                                              06775000
   tos := 0;                                                   <<02648>>06780000
elabn:                                                                  06785000
   del;                                                        <<02648>>06790000
   if ixd = 0 then                                                      06795000
      begin    << no vol set id; request it >>                          06800000
      move buffer :=                                                    06805000
         "Volume ID for XXXXXXXX";                                      06810000
      move bbuf(14) := bid,(8);    << copy file name >>                 06815000
      lgth := printopreply(buffer,11,0,reply,-6);                       06820000
<< need to validate input. >>                                           06825000
      move bvsetid := replyb,(lgth);                                    06830000
      end;      << request vol set id >>                                06835000
   if fmsg(ix) = ";" then go checkvs;    << default all. >>             06840000
   if fmsg(ix) <> "," then go errf;                            <<02648>>06845000
   ix := ix+1;                                                          06850000
   if fmsg(ix) = "," then go getdate;   << labeltype omitted >>         06855000
   if fmsg(ix) = "ANS" then                                             06860000
      ix := ix+3      << step to next , >>                              06865000
   else                                                                 06870000
      begin      << ibm >>                                              06875000
      if fmsg(ix) <> "IBM" then go errf;                                06880000
      if access <> read then if disabl'ibm then                         06885000
         begin result := lbtibmwrit; go endz end;              <<02648>>06890000
      labeltype := 3;    << type to ibm >>                              06895000
      ix := ix+3;      << step to next , >>                             06900000
      end;                                                              06905000
   if fmsg(ix) = ";" then go checkvs;                                   06910000
   if fmsg(ix) <> "," then                                              06915000
      begin    << error in format >>                                    06920000
errf:                                                                   06925000
      result := lbtsyntax;                                              06930000
      go endz;                                                          06935000
      debug;      << dummy call >>                                      06940000
      end;                                                              06945000
                                                                        06950000
getdate:                                                                06955000
   ix := ix+1;                                                          06960000
   if fmsg(ix) <> "," then                                              06965000
      begin     << get length of date field >>                          06970000
      ixd := 0;                                                         06975000
      while fmsg(ix+ixd) <> "," and fmsg(ix+ixd) <> ";" do              06980000
         begin                                                          06985000
         if ixd > 12 then go errf;                                      06990000
         ixd := ixd+1;                                                  06995000
         end;                                                           07000000
   << ixd = length of date>>                                            07005000
      if fmsg(ix) = "+" then                                            07010000
         begin       << get increment to today's date. >>               07015000
         exdate := calendar;                                            07020000
         tos := binary'(fmsg(ix+1),ixd-1);                              07025000
         if <> then go errf;                                            07030000
         tos := tos+exdate.(7:9);                                       07035000
         tos := double(tos-1);                                          07040000
         tos := 365;                                                    07045000
         asmb(ldiv);                                                    07050000
         exdate.(7:9) := tos+1;    << remainder = days >>               07055000
         exdate.(0:7) := tos+exdate.(0:7);   << quot - yrs >>           07060000
         end                                                            07065000
      else                                                              07070000
         begin        << expect dd/mm/yy >>                             07075000
         if ixd < 5 then go errf;                                       07080000
         if fmsg(ix) = "00/00/00" then go bump;                         07085000
         exdate := convertdate(fmsg(ix));                               07090000
         if <> then go errf;   << invalid date. >>                      07095000
         end;                                                           07100000
bump: ix := ix+ixd;                                                     07105000
      if fmsg(ix) = ";" then go checkvs;                       <<06024>>07110000
      end;    << convert date >>                                        07115000
                                                                        07120000
  << get here to get seq type or # >>                                   07125000
                                                                        07130000
   ix := ix+1;   << step past , >>                                      07135000
   ixd := 0;     << measure length of sequence field >>                 07140000
   while ixd < 4 and fmsg(ix+ixd) <> ";" and                            07145000
      fmsg(ix+ixd) <> "," do ixd := ixd+1;                              07150000
   if ixd=0 or fmsg(ix)= "NEXT" then  << seqtype := 1 >>                07155000
   else if fmsg(ix) = "ADDF" then                                       07160000
      begin                                                             07165000
      if access = read then                                             07170000
         begin           << lose: need write access. >>                 07175000
         result := invop;                                      <<06333>>07180000
         go endz;                                                       07185000
         end;                                                           07190000
      seqtype := 2;                                                     07195000
      end                                                               07200000
   else                                                                 07205000
      begin      << match file sequence nr. >>                          07210000
      seqtype := 3;                                                     07215000
      fseq := binary'(fmsg(ix),ixd);                                    07220000
      if < then go errf;                                                07225000
      if fseq = 0 then seqtype := 0;  << match filename. >>             07230000
      end;                                                              07235000
                                                                        07240000
<< search for volume set entry matching specified volume id.            07245000
if one is found, this is an open of a file on the volume set. >>        07250000
                                                                        07255000
checkvs:                                                                07260000
   vsetop := false;                                                     07265000
   scode := getsir(tltsir);                                             07270000
   getxdsw(vtbounds,tltdst,xvtbase,2);                                  07275000
   vtaddr := vtbase;                                                    07280000
   while vtaddr < vttop do                                              07285000
      begin                                                             07290000
      getxdsw(vtbuf,tltdst,vtaddr,vtesize);                             07295000
      if inuse and (vcb'fnum=0) and                                     07300000
         (vcb'pin=pinno) and (vcb'labtyp=labeltype) and                 07305000
         bvsetid=vcb'vsetid,(6) then go oldvset;                        07310000
      vtaddr := vtaddr+vtesize;                                         07315000
      end;                                                              07320000
                                                                        07325000
<< volume set being opened; need new entry. >>                          07330000
                                                                        07335000
   vtaddr := 0;         << forces new entry >>                          07340000
   vsetop := true;                                                      07345000
   vtbuf := 0;          << zero binary part >>                          07350000
   move vtbuf(1) := vtbuf,(6);                                          07355000
   vtbuf(7) := "  ";    << blank ascii part >>                          07360000
   move vtbuf(8) := vtbuf(7),(18);                                      07365000
   vcb'ldev := 0;                                              <<02648>>07370000
   vcb'vsetopen := 1;   << 1st open of volume set >>           <<02563>>07375000
   move vcb'volid := bvsetid,(6);                                       07380000
   move vcb'vsetid := bvsetid,(6);    << vset id in new ent >>          07385000
   vcb'fseq := fseq;                                                    07390000
   vcb'labtyp := labeltype;                                             07395000
<< density is a volset attribute. set only on 1st open. >>     <<02563>>07400000
   vcb'density := density;                                     <<02563>>07405000
oldvset:                                                                07410000
   move bfname := bid,(8);       << file name >>                        07415000
   bfname(8) := if vcb'labtyp=3 then " " else ".";             <<02662>>07420000
   move bfname(9) := bid(8),(8);   << group name >>                     07425000
   bfname(17) := " ";                                                   07430000
   move vcb'fname := bfname,(18);   << file name >>                     07435000
   move vcb'lockwrd := bid(24),(8);   << lockword >>                    07440000
   vcb'pin := pinno;                                                    07445000
   vcb'fnum := fnum;                                                    07450000
                                                                        07455000
   vcb'exdate := exdate;                                                07460000
   vcb'seqtyp := seqtype;                                               07465000
   if seqtype=3 then vcb'fseq := fseq;                                  07470000
   vcb'reel := 1;     << all files begin with this >>                   07475000
   if vcb'fseq = 0 then vcb'fseq := 1;                                  07480000
   vcb'write := if access > read then 1 else 0;                         07485000
   vcb'lnkwait := 1;     << flag for linklabel >>                       07490000
   postvtent(vtbuf,vtaddr,scode);                                       07495000
   if < then result := lbtoflow;                                        07500000
   if vsetop then logit(vtbuf);    << write log record >>               07505000
endz:                                                                   07510000
   end;     << procedure createtltent >>                                07515000
$page " STORE'DENSITY "                                        <<02563>>07520000
procedure store'density(ldev,density,mode);                    <<02563>>07525000
   value ldev,mode;                                            <<02563>>07530000
   integer ldev,mode;                                          <<02563>>07535000
   array density;                                              <<02563>>07540000
   option privileged,uncallable;                               <<02563>>07545000
                                                               <<02563>>07550000
comment                                                        <<02563>>07555000
                                                               <<02563>>07560000
   this procedure posts density information into the density   <<02563>>07565000
data structure.  the procedure can be called in three modes:   <<02563>>07570000
                                                               <<02563>>07575000
   mode = 0, fopen-type call.  density is defined as           <<d8615>>07580000
   $edit void=2974000                                          <<d8615>>07585000
      an array.  it contains the user requested density        <<d8615>>07590000
      for the tape ldev.  if this is the first call of this    <<02563>>07595000
      type -- that is request'density contains a null value -- <<02563>>07600000
      and the "default" density was requested, then the        <<02563>>07605000
      tape request is set to 6250 bpi for 7976 or 7978 and     <<07339>>07610000
      1600 for 7974.  in all other cases, default density      <<07339>>07615000
      requests are ignored.                                    <<07339>>07620000
      called by:  fopen.                                       <<02563>>07625000
   mode = 1, avr-type call.  generally, the caller has just    <<02563>>07630000
      finished avr on the device ldev.  density contains the   <<02563>>07635000
      results of a "read status" request to the mag tape dri-  <<02563>>07640000
      ver.  this procedure then interprets the status bytes and<<02563>>07645000
      stores the actual tape density into the data structure.  <<02563>>07650000
      called by:  devrec and recognize (in labseg).            <<02563>>07655000
   mode = 2, deallocate-type call.  the density data structure <<02563>>07660000
      is to be reinitialized.  this call is made during the    <<02563>>07665000
      final release of a tape drive by its current owner.      <<02563>>07670000
      density for this call is a dummy.                        <<02563>>07675000
      called by:  deallocate, reelswith, and checkul.          <<02689>>07680000
                                                               <<02563>>07685000
   caller's responsibilities:                                  <<02563>>07690000
   1)  db must be at the stack.                                <<02563>>07695000
   2)  the caller should ensure that ldev is a mag tape drive. <<02563>>07700000
                                                               <<02563>>07705000
;    << end of comment >>                                      <<02563>>07710000
                                                               <<02563>>07715000
begin                                                          <<02563>>07720000
logical array ldt(0:size'of'ldt'entry-1);                      <<06333>>07725000
integer                                                        <<02563>>07730000
   ldt'index,                                                  <<06333>>07735000
   lpdt'index,                                                 <<06333>>07740000
   savesir;                                                    <<02563>>07745000
define                                                         <<02563>>07750000
   stat'6250 = density.(8:1)#,  << status bit for 7974/76/78 >><<d8615>>07755000
   stat'1600 = density(1).(0:1)#, << for 7974/7978          >> <<d8615>>07760000
   stat'800  = density(1).(1:1)#; << for 7974/7978          >> <<d8615>>07765000
                                                               <<02563>>07770000
   << only continue if tape drive is variable density. >>      <<02563>>07775000
   lpdt'index := ldev * size'of'lpdt'entry;                    <<06333>>07780000
   if (not'variable'density) then return;                      <<07339>>07785000
                                                               <<02563>>07790000
   savesir := getsir(ldt'sir);                                 <<06333>>07795000
                                                               <<02563>>07800000
   ldt'index := 0;                                             <<06333>>07805000
   getxdsw(ldt, ldt'dst, ldev * size'of'ldt'entry,             <<06333>>07810000
           size'of'ldt'entry);                                 <<06333>>07815000
                                                               <<02563>>07820000
   case mode of                                                <<02563>>07825000
      begin                                                    <<02563>>07830000
                                                               <<02563>>07835000
      begin  << 0 - fopen mode - density is user requested  >> <<07339>>07840000
      if density <> ldt'no'density then                        <<06333>>07845000
         ldt'rqst'tape'dens := density  << specific request >> <<06333>>07850000
      else                                                     <<02563>>07855000
         << if 1st request, take the default (6250 or 1600) >> <<07339>>07860000
         << else, default is no change.                     >> <<07339>>07865000
         if ldt'rqst'tape'dens = ldt'no'density then           <<06333>>07870000
            if lpdt'auto'subtype = hp7974                      <<07339>>07875000
               then ldt'rqst'tape'dens := ldt'density'1600     <<07339>>07880000
               else ldt'rqst'tape'dens := ldt'density'6250     <<07339>>07885000
      end;   << 0 - fopen mode                              >> <<07339>>07890000
                                                               <<02563>>07895000
      begin  << 1 - avr mode - density array has status.    >> <<07339>>07900000
      if lpdt'auto'subtype = hp7974 then                       <<d8615>>07905000
         if stat'800 then                                      <<d8615>>07910000
            ldt'actual'tape'dens := ldt'density'800            <<d8615>>07915000
         else                                                  <<d8615>>07920000
            ldt'actual'tape'dens := ldt'density'1600           <<d8615>>07925000
      else       << hp7976 or hp7978 >>                        <<d8615>>07930000
         if not stat'6250 then                                 <<d8615>>07935000
            ldt'actual'tape'dens := ldt'density'1600           <<d8615>>07940000
         else                                                  <<d8615>>07945000
            ldt'actual'tape'dens := ldt'density'6250           <<d8615>>07950000
      end;   << 1 - avr mode                                >> <<07339>>07955000
                                                               <<02563>>07960000
      << free mode - density is a dummy.  clear fields. >>     <<02563>>07965000
      begin                                                    <<02563>>07970000
      ldt'rqst'tape'dens := ldt'no'density;                    <<06333>>07975000
      ldt'actual'tape'dens := ldt'no'density;                  <<06333>>07980000
      end;                                                     <<02563>>07985000
                                                               <<02563>>07990000
      end;   << of case >>                                     <<02563>>07995000
                                                               <<02563>>08000000
   << write word back >>                                       <<02563>>08005000
   putxdsw(ldt'dst, ldev * size'of'ldt'entry, ldt,             <<06333>>08010000
           size'of'ldt'entry);                                 <<06333>>08015000
                                                               <<02563>>08020000
   relsir(ldt'sir,savesir);                                    <<06333>>08025000
                                                               <<02563>>08030000
end;     << of store'density >>                                <<02563>>08035000
$page "  CHECK'AVR'STATUS"                                     <<02722>>08040000
integer procedure check'avr'status(ldev,status,ignore);        <<02722>>08045000
   value ldev,status,ignore;                                   <<02722>>08050000
   integer ldev,status;                                        <<02722>>08055000
   logical ignore;                                             <<02722>>08060000
   option privileged,uncallable;                               <<02722>>08065000
                                                               <<02722>>08070000
comment                                                        <<02722>>08075000
                                                               <<02722>>08080000
   this procedure examines the status returned by attachio     <<02722>>08085000
during automatic volume recognition.  if there was an error,   <<02722>>08090000
an appropriate error message is printed and the procedure      <<02722>>08095000
return tells the caller what kind of error occured.            <<02722>>08100000
                                                               <<02722>>08105000
input:                                                         <<02722>>08110000
   ldev   -- the logical device in question.                   <<02722>>08115000
   status -- the last 8 bits of attachio's status return.      <<02722>>08120000
   ignore -- during avr, certain errors which occur as the     <<02722>>08125000
             result of a read should be ignored.  for example, <<02722>>08130000
             a tape parity error indicates a problem with the  <<02722>>08135000
             tape surface.  although the tape cannot be read,  <<02722>>08140000
             it should still be made available to the system   <<02722>>08145000
             as an unlabelled tape.  if ignore is true, the    <<02722>>08150000
             following errors should be ignored:               <<02722>>08155000
                                                               <<02722>>08160000
             runaway'    - %103                                <<06333>>08165000
             trans'error -  %14                                <<02722>>08170000
             timing'err  -  %34                                <<02722>>08175000
             unit'fail   -  %54                                <<02722>>08180000
             parity'err  -  %74                                <<02722>>08185000
                                                               <<02722>>08190000
             for now, all errors are included because it is not<<02722>>08195000
             clear which errors should be considered fatal.    <<02722>>08200000
                                                               <<02722>>08205000
procedure return:                                              <<02722>>08210000
                                                               <<02722>>08215000
   0 -- no error.                                              <<02722>>08220000
   1 -- error indicating power problems.  (no console message) <<02722>>08225000
   2 -- fatal error.                                           <<02722>>08230000
   3 -- ignored error.  (only returned if ignore = true.)      <<02722>>08235000
                                                               <<02722>>08240000
db must be at stack.                                           <<02722>>08245000
                                                               <<02722>>08250000
;   << end of comment >>                                       <<02722>>08255000
                                                               <<02722>>08260000
begin                                                          <<02722>>08265000
   integer                                                     <<02722>>08270000
      result = check'avr'status,   << procedure return >>      <<02722>>08275000
      length;                                                  <<02722>>08280000
   byte array                                                  <<02722>>08285000
      statbuf(0:6);                                            <<02722>>08290000
                                                               <<02722>>08295000
                                                               <<02722>>08300000
   if status.(13:3) = 1 then                                   <<02722>>08305000
      begin                                                    <<02722>>08310000
      result := 0;   << no error >>                            <<02722>>08315000
      return;                                                  <<02722>>08320000
      end;                                                     <<02722>>08325000
                                                               <<02722>>08330000
   if status = pfail'abort or                                  <<02722>>08335000
     status = power'up  then                                   <<02722>>08340000
      begin                                                    <<02722>>08345000
      result := 1;   << power problem >>                       <<02722>>08350000
      return;                                                  <<02722>>08355000
      end;                                                     <<02722>>08360000
                                                               <<02722>>08365000
   if ignore then                                              <<02722>>08370000
      begin                                                    <<02722>>08375000
                                                               <<02722>>08380000
<< eventually, the following if false then clause will >>      <<02722>>08385000
<< determine those status returns which are to be con- >>      <<02722>>08390000
<< sidered fatal even if ignore is true. >>                    <<02722>>08395000
                                                               <<02722>>08400000
      if false then                                            <<02722>>08405000
         ignore := false                                       <<02722>>08410000
      else                                                     <<02722>>08415000
         begin                                                 <<02722>>08420000
   << don't report eof or tape runaway as an error.  they >>   <<03581>>08425000
   << are expected status returns during avr reads. >>         <<03581>>08430000
         if status <> eofstat land status <> runaway' then     <<06333>>08435000
            begin                                              <<02722>>08440000
            length := ascii(status,8,statbuf);                 <<02722>>08445000
            statbuf(6) := 0;   << genmsg terminator >>         <<02722>>08450000
            genmsg(1,ignore'err,%10000,ldev,                   <<02722>>08455000
                                @statbuf(6-length),,,,0);      <<02722>>08460000
            end;                                               <<02722>>08465000
         end;                                                  <<02722>>08470000
                                                               <<02722>>08475000
      end;   << of ignore >>                                   <<02722>>08480000
                                                               <<02722>>08485000
   if ignore then                                              <<02722>>08490000
      result := 3                                              <<02722>>08495000
   else                                                        <<02722>>08500000
      begin   << report fatal i/o error >>                     <<02722>>08505000
      result := 2;                                             <<02722>>08510000
      report'ioerror(ldev,status);                             <<02722>>08515000
      end;                                                     <<02722>>08520000
                                                               <<02722>>08525000
end;   << of check'avr'status >>                               <<02722>>08530000
$page " AVREC "                                                         08535000
logical procedure avrec(ldev,buff,count,cmd);                           08540000
  value ldev,count,cmd;                                                 08545000
  integer ldev,count,cmd;                                               08550000
  array buff;                                                           08555000
  option uncallable;                                                    08560000
                                                                        08565000
<<  devrec reads the first record on a newly mounted tape,              08570000
then calls avrec.  we see if the record is a tape label;                08575000
if so, and if there is a process waiting for this tape, the             08580000
process is re-started by pulling its entry out of the rit.              08585000
avrec can be called twice: once to scan the volume label,               08590000
and then to scan the header label.  db must be at the stack.            08595000
   count - +words.                                                      08600000
   cmd   - 1 if first call, 2 if second.                                08605000
returns true if done; false if second call is needed.  the              08610000
two-call kluge is needed because devrec does unblocked i/o              08615000
and can't be impeded while we do i/o.  tape is rewound at final         08620000
exit.   >>                                                              08625000
                                                                        08630000
begin                                                                   08635000
   logical vtaddr,ltaddr;                                               08640000
   logical result = avrec;                                              08645000
   double vtbounds;                                                     08650000
      logical vtbase = vtbounds;                                        08655000
      logical vttop = vtbounds+1;                                       08660000
   logical array tlabel(0:lblsize-1) =q;                                08665000
      byte array blabel0(*) = tlabel;                                   08670000
      byte array btlabel(*) = tlabel;                                   08675000
      double ltype = tlabel;                                            08680000
   array msg(0:20);                                                     08685000
      byte array msgb(*)=msg;                                  <<1136>> 08690000
   logical array vtbuf(0:vtesize-1) =q;                                 08695000
      buildvcb;                                                         08700000
   logical array ltbuf(0:ltesize-1) =q;                                 08705000
      buildlcb;                                                         08710000
   logical scode;                                                       08715000
   logical exday;                                                       08720000
                                                                        08725000
   tlabel := "  ";                                                      08730000
   move tlabel(1) := tlabel,(lblsize-1);                                08735000
   move tlabel := buff,(count);  << local copy, for no good reason >>   08740000
   scode := getsir(tltsir);                                             08745000
   ltaddr := getldev(ldev,ltbuf);                                       08750000
   if < then tapetrouble(tt7);                                 <<03581>>08755000
   vcb'flags := 0;     << default >>                                    08760000
   vtaddr := lcb'vcb;                                                   08765000
   if <> then                                                           08770000
      begin      << a volume is associated with this drive. >>          08775000
      getxdsw(vtbuf,tltdst,vtaddr,vtesize);                             08780000
      end;                                                              08785000
   if cmd >= 2 then go tryh1;                                           08790000
   lcb'flags := lcb'flags land %1000; << leave tape bit >>     <<03581>>08795000
   ltbuf(2) := 0;      << first call: clear ldev entry >>               08800000
   move ltbuf(3) := ltbuf(2),(4);                                       08805000
   ltbuf(7) := "  ";                                                    08810000
   move ltbuf(8) := ltbuf(7),(18);                                      08815000
   lcb'vcb := vtaddr;      << restore this word >>                      08820000
                                                                        08825000
<< process vol1 label, if present. >>                                   08830000
                                                                        08835000
   if tlabel(0)=%162726 and tlabel(1)=%151761 and count=40 then         08840000
      begin       << ebcdic "VOL1" >>                                   08845000
      lcb'labtyp := 3;      << set to ibm >>                            08850000
      ctranslate(1,tlabel,,80);                                         08855000
      end                                                               08860000
   else if ltype="VOL1" then lcb'labtyp := 2                            08865000
      else go nl;                                                       08870000
   move lcb'volid := l0volid,(6);                                       08875000
   move lcb'vsetid := l0volid,(6);  << default >>                       08880000
   go postlcb;                                                          08885000
                                                                        08890000
<< process hdr1 label. >>                                               08895000
                                                                        08900000
tryh1:                                                                  08905000
   if lcb'labtyp=3 then ctranslate(1,tlabel,,80);                       08910000
   if blabel0 = "UVL" then go postlcb;  << ignore these >>              08915000
   result := true;      << don't read again. >>                         08920000
   if ltype = "HDR1" then                                               08925000
      begin                                                             08930000
      exday := binary'(l1xday,3);         << julian day >>              08935000
      exday.(0:7) := binary'(l1xyr,2);    << year >>                    08940000
      lcb'exdate := exday;                                              08945000
      lcb'reel := binary'(l1reel,4);                                    08950000
      lcb'fseq := binary'(l1fseq,4);                                    08955000
      move lcb'vsetid := l1vsetid,(6);                                  08960000
      move lcb'fname := l1fname,(17);                                   08965000
      lcb'hp := if l1system = hpsystem and (lcb'labtyp = 2)    <<02662>>08970000
         then 1 else 0;                                        <<02662>>08975000
      if btlabel(68) = "B" then lcb'b5000 := 1;                         08980000
      end;                                                              08985000
   attachio(ldev,0,0,0,5,0,0,0,%13);    << rewind >>                    08990000
   if lcb'tape then set'bot'on; <<tape at load point>>         <<03581>>08995000
                                                                        09000000
<< see if anyone wants this particular volume.  if reelswitch,          09005000
we can restart the user waiting on this ldev.  if linklabel,            09010000
we search the volume entries for one matching the volume. >>            09015000
                                                                        09020000
   if vcb'rswait then go restart;                                       09025000
   getxdsw(vtbounds,tltdst,xvtbase,2);                                  09030000
   vtaddr := vtbase;                                                    09035000
   while vtaddr < vttop do                                              09040000
      begin         << linklabel waiting? >>                            09045000
      getxdsw(vtbuf,tltdst,vtaddr,vtesize);                             09050000
      if inuse and (vcb'ldev=0) and vcb'mntwait and                     09055000
          goodreel(vtbuf,ltbuf) then                           <<02648>>09060000
         begin               << match. >>                               09065000
         lcb'vcb := vtaddr;    << link up >>                            09070000
         vcb'ldev := ldev;                                              09075000
restart: postvtent(vtbuf,vtaddr,-1);                                    09080000
         remritentry(vcb'pin);                                          09085000
         go report;                                                     09090000
         end;                                                           09095000
      vtaddr := vtaddr+vtesize;                                         09100000
      end;                                                              09105000
                                                                        09110000
<< no one is waiting for this volume, so just post the ldev             09115000
entry.  >>                                                              09120000
<< 285 vol ! mounted on ldev# \  >>                                     09125000
                                                                        09130000
report:                                                                 09135000
   move msgb := lcb'volid,(6);                                          09140000
   move msgb(6) := " (ANS) of ";                                        09145000
   if lcb'labtyp = 3 then move msgb(6) := " (IBM)";                     09150000
   if lcb'volid <> lcb'vsetid,(6) then                                  09155000
      begin       << not first vol of vset >>                           09160000
      move msgb(16) := lcb'vsetid,(6);                                  09165000
      msgb(22) := 0;                                                    09170000
      end                                                               09175000
   else msgb(12) := 0;   << zero terminator for genmsg >>               09180000
   genmsg(1,285,%01000,@msgb,ldev,,,,0);                                09185000
                                                                        09190000
postlcb:                                                                09195000
   postvtent(ltbuf,ltaddr,scode);                                       09200000
   return;                                                              09205000
                                                                        09210000
<< unlabelled tape: report, rewind, and exit. >>                        09215000
<< 286 vol (unlabelled) mounted on ldev# \ >>                           09220000
                                                                        09225000
nl:                                                                     09230000
   lcb'labtyp := 1;      << unlabelled >>                               09235000
   result := true;                                                      09240000
   postvtent(ltbuf,ltaddr,scode);                                       09245000
   attachio(ldev,0,0,0,5,0,0,0,%13);    << rewind >>                    09250000
   if lcb'tape then set'bot'on; <<tape at load point>>         <<03581>>09255000
   if vcb'rswait then remritentry(vcb'pin);                             09260000
   genmsg(1,286,%10000,ldev,,,,,0);                                     09265000
   end;      << procedure avrec >>                                      09270000
$page " RECOGNIZE "                                                     09275000
procedure recognize(ldev);                                              09280000
value ldev; integer ldev;                                               09285000
   option uncallable;                                          <<03581>>09290000
                                                                        09295000
<< if a tape drive is on-line when the system comes up, there           09300000
will be no interrupt to cause avr, so we call avrec "by hand"           09305000
to see what's up. >>                                                    09310000
                                                                        09315000
   begin                                                                09320000
   integer cmd,count;                                                   09325000
   integer iostatw;                                                     09330000
   integer lpdt'index;                                         <<06333>>09335000
   array tlabel(0:39);                                                  09340000
   integer original'state;                                     <<*7477>>09345000
                                                                        09350000
<< it is possible for devrec and recognize to both be       >> <<02722>>09355000
<< attempting avr on the same tape drive.  the state bits   >> <<02722>>09360000
<< in the lpdt tell whether devrec is working on the drive. >> <<02722>>09365000
<< if the device is unowned, setting the state bits to 3    >> <<02722>>09370000
<< will prevent devrec from working on the same drive.      >> <<02722>>09375000
<< we will remember the original state of the device and    >> <<*7477>>09380000
<< reset the device to this state on exit.                  >> <<*7477>>09385000
                                                               <<02722>>09390000
   disable;                                                    <<02722>>09395000
   original'state := setowned(ldev,-1);  <<save device state>> <<*7477>>09400000
   if (original'state=2) or (original'state=3) then            <<*7477>>09405000
      begin   << some process (devrec?) owns drive. >>         <<02722>>09410000
      enable;                                                  <<02722>>09415000
      cc := ccl;   << indicate a problem >>                    <<02722>>09420000
      return;                                                  <<02722>>09425000
      end;                                                     <<02722>>09430000
                                                               <<02722>>09435000
   setowned(ldev,1);                                           <<*7477>>09440000
   enable;                                                     <<02722>>09445000
                                                               <<02722>>09450000
start:                                                                  09455000
   attio(ldev,5);       << insure rewound for avr >>                    09460000
   iostatw := x.(8:8);   << pick up attachio status >>         <<02722>>09465000
                                                               <<02722>>09470000
   case check'avr'status(ldev,iostatw,false) of                <<02722>>09475000
      begin                                                    <<02722>>09480000
                                                               <<02722>>09485000
      ;              << 0 - ok.  continue >>                   <<02722>>09490000
                                                               <<02722>>09495000
      go start;      << 1 - restart on power problems >>       <<02722>>09500000
                                                               <<02722>>09505000
      go io'error;   << 2 - i/o error.  quit >>                <<02722>>09510000
                                                               <<02722>>09515000
      ;              << 3 - can't happen, ignore = false >>    <<02722>>09520000
                                                               <<02722>>09525000
      end;   << of case statement >>                           <<02722>>09530000
                                                               <<02722>>09535000
   cmd := 0;                                                            09540000
loop:                                                                   09545000
   cmd := cmd+1;                                                        09550000
   tos := attachio(ldev,0,0,@tlabel,read,40,0,0,1);   <<read>>          09555000
   count := tos;                                                        09560000
   iostatw := tos.(8:8);                                                09565000
                                                               <<02563>>09570000
   case check'avr'status(ldev,iostatw,true) of                 <<02722>>09575000
      begin                                                    <<02722>>09580000
                                                               <<02722>>09585000
      ;              << 0 - ok.  continue >>                   <<02722>>09590000
                                                               <<02722>>09595000
      go start;      << 1 - restart on power problems >>       <<02722>>09600000
                                                               <<02722>>09605000
      go io'error;   << 2 - i/o error.  quit >>                <<02722>>09610000
                                                               <<02722>>09615000
      count := 0;    << 3 - ignored error >>                   <<02722>>09620000
                                                               <<02722>>09625000
      end;   << of case statement >>                           <<02722>>09630000
                                                               <<02722>>09635000
   if not avrec(ldev,tlabel,count,cmd)                                  09640000
      then go loop;                                                     09645000
                                                               <<02563>>09650000
   << avrec has taken care of marking the bot bit for all >>   <<02563>>09655000
   << tape drives.  now, if variable density drive, must  >>   <<02563>>09660000
   << determine density of tape on drive.                 >>   <<02563>>09665000
                                                               <<s8834>>09670000
   lpdt'index := ldev * size'of'lpdt'entry;                    <<s8834>>09675000
                                                               <<02563>>09680000
   if (variable'density) then                                  <<02563>>09685000
      begin    << get status of tape drive >>                  <<02563>>09690000
                                                               <<02563>>09695000
      tos := attachio(ldev,0,0,@tlabel,read'status,-5,0,0,1);  <<02563>>09700000
      del;                                                     <<02563>>09705000
      iostatw := tos.(8:8);                                    <<02563>>09710000
                                                               <<02563>>09715000
      case check'avr'status(ldev,iostatw,false) of             <<02722>>09720000
         begin                                                 <<02722>>09725000
                                                               <<02722>>09730000
         ;              << 0 - ok.  continue >>                <<02722>>09735000
                                                               <<02722>>09740000
         go start;      << 1 - restart on power problems >>    <<02722>>09745000
                                                               <<02722>>09750000
         go io'error;   << 2 - i/o error.  quit >>             <<02722>>09755000
                                                               <<02722>>09760000
         ;              << 3 - can't happen, ignore = false >> <<02722>>09765000
                                                               <<02722>>09770000
         end;   << of case statement >>                        <<02722>>09775000
                                                               <<02722>>09780000
      << put density in data structure. >>                     <<02722>>09785000
      store'density(ldev,tlabel,1);                            <<02722>>09790000
                                                               <<02722>>09795000
      end;   << of variable density drive. >>                  <<02722>>09800000
                                                               <<02722>>09805000
   setowned(ldev,original'state); <<reset state of device>>    <<*7477>>09810000
   cc := cce;                                                  <<02722>>09815000
   return;             << only good exit from procedure >>     <<02722>>09820000
                                                               <<02722>>09825000
                                                               <<02722>>09830000
io'error:      << branch to here on i/o error >>               <<02722>>09835000
                                                               <<02722>>09840000
   cleanldev(ldev);      << zero out tlt entry >>              <<02722>>09845000
   attachio(ldev,0,0,0,dclose,0,0,0,%13);                      <<02722>>09850000
   setowned(ldev,original'state);  <<reset state of device>>   <<*7477>>09855000
   cc := ccl;                                                  <<02722>>09860000
                                                               <<02722>>09865000
   end;       << procedure recognize >>                                 09870000
$page  " LINKLABEL "                                                    09875000
integer procedure linklabel(ldevn,access);                              09880000
 value access;                                                          09885000
 integer ldevn,access;                                                  09890000
  option uncallable;                                                    09895000
  comment                                                      <<03581>>09900000
                                                               <<03581>>09905000
     called from askop in allocate to link the file to the     <<03581>>09910000
a mount device in the tape label table.  if the volume is not  <<03581>>09915000
mounted, request is issued and the process awaits a reply or   <<03581>>09920000
for the volume to be mounted.  if the operator replies a       <<03581>>09925000
logical device the c field in word 5 of the vcb is set so      <<03581>>09930000
that the vol1 label will be written later provided that        <<03581>>09935000
device is a tape (or serial disc), the tape is unlabeled or    <<03581>>09940000
expired, and is open for write.  the ldev is returned.         <<03581>>09945000
                                                               <<03581>>09950000
db is at the stack.                                            <<03581>>09955000
                                                               <<03581>>09960000
   access - depends on aoptions.(12:4)                         <<03581>>09965000
    0 - read only                                              <<03581>>09970000
    1 - write only (write,write-save,append)                   <<03581>>09975000
    2 - read-write (read-write or update)                      <<03581>>09980000
                                                               <<03581>>09985000
exit with tape at load point.  fopen will call position to     <<03581>>09990000
get to the required file.                                      <<03581>>09995000
;                                                              <<03581>>10000000
                                                                        10005000
   begin                                                                10010000
   logical vtaddr,ltaddr;                                               10015000
   logical pinno;                                                       10020000
   integer scode,ldev;                                                  10025000
   integer lpdt'index;                                         <<d8615>>10030000
      integer result = linklabel;                                       10035000
   array ltbounds(0:2) =q;                                              10040000
      logical ltbase = ltbounds;                                        10045000
      logical lttop = ltbounds+1;                                       10050000
      logical vtbase = ltbounds+1;                                      10055000
      logical vttop = ltbounds+2;                                       10060000
   integer array buffer(0:20);                                          10065000
      byte array bbuf(*) = buffer;                                      10070000
   integer array reply(0:2) =q;                                         10075000
      byte array replyb(*) =reply+1;   << text of reply >>              10080000
      integer rcnt =reply;        << char count of reply >>             10085000
   logical array vtbuf(0:vtesize-1) =q;                                 10090000
      buildvcb;                                                         10095000
   logical array ltbuf(0:ltesize-1) =q;                                 10100000
      buildlcb;                                                         10105000
   equate rejected=3,                                                   10110000
        okay=2;                                                         10115000
                                                                        10120000
 << find the vcb entry created by createtltent. >>                      10125000
                                                                        10130000
   result := rejected;                                                  10135000
   pinno := curprc/pcbsize;                                    <<06424>>10140000
   scode := getsir(tltsir);                                             10145000
   getxdsw(ltbounds,tltdst,xltbase,3);                                  10150000
   vtaddr := vtbase;                                                    10155000
   while vtaddr < vttop do                                              10160000
      begin                                                             10165000
      getxdsw(vtbuf,tltdst,vtaddr,vtesize);                             10170000
      if inuse and (vcb'pin = pinno) and                                10175000
         vcb'lnkwait then go pinmatch;                                  10180000
      vtaddr := vtaddr+vtesize;                                         10185000
      end;                                                              10190000
   tapetrouble(tt9);    << it should be there. >>              <<03581>>10195000
                                                                        10200000
pinmatch:                                                               10205000
   vcb'lnkwait := 0;                                                    10210000
   if (ldev := vcb'ldev) <> 0 then                             <<02648>>10215000
      begin       << re-open volume of mounted vol set. >>     <<02648>>10220000
      ltaddr := getldev(ldev,ltbuf);                           <<02648>>10225000
      if <> then tapetrouble(tt10);                            <<03581>>10230000
      go wrchk;                                                <<02648>>10235000
      end;                                                     <<02648>>10240000
                                                                        10245000
<< search ldev's to see if the needed volume has been mounted           10250000
and recognized by avr.  even if mounted, it won't yet be linked         10255000
to the volume entry, since we just finished constructing it.   >>       10260000
                                                                        10265000
   ltaddr := ltbase;                                                    10270000
   while ltaddr < lttop do                                              10275000
      begin                                                             10280000
      getxdsw(ltbuf,tltdst,ltaddr,ltesize);                             10285000
      ldev := lcb'ldev;                                                 10290000
      if (lcb'vcb=0) and goodreel(vtbuf,ltbuf) then go wrchk;  <<02648>>10295000
      ltaddr := ltaddr+vtesize;                                         10300000
      end;                                                              10305000
                                                                        10310000
<< volume not mounted; harass opr for it. >>                            10315000
<< 287 mount tape of volumeset ! >>                                     10320000
                                                                        10325000
   vcb'mntwait := 1;        << turn on wait bit >>                      10330000
   postvtent(vtbuf,vtaddr,scode);                                       10335000
   move bbuf := vcb'vsetid,(6);                                         10340000
   move bbuf(6) := " (ANS)";                                            10345000
   if vcb'labtyp=3 then move bbuf(8) := "IBM";                          10350000
   bbuf(12) := 0;    << genmsg terminator >>                            10355000
bugopr:                                                                 10360000
   rcnt := -1;                                                          10365000
   genmsg(1,287,0,@bbuf,,,,,0,%1404,@reply);                   <<07112>>10370000
                                                                        10375000
<< opr can either mount requested volume, which will be                 10380000
picked up by devrec and avrec, or =reply an ldev, which                 10385000
gets us here.  we check the ldev to see if it is an                     10390000
appropriate tape.  >>                                                   10395000
                                                                        10400000
   if reply < 0 then                                                    10405000
      begin      << avr, presumably; see what we got. >>                10410000
      scode := getsir(tltsir);                                          10415000
      getxdsw(vtbuf,tltdst,vtaddr,vtesize);                             10420000
      ldev := vcb'ldev;                                                 10425000
      ltaddr := getldev(ldev,ltbuf);                                    10430000
      if < then tapetrouble(tt10);    << avr screwup >>        <<03581>>10435000
      go wrchk;                                                         10440000
      end;                                                              10445000
                                                                        10450000
<< opr specified an ldev.  see if it is legitimate. >>                  10455000
                                                                        10460000
   ldev := binary'(replyb,rcnt);                                        10465000
   if <> then go bugopr;      << not a number >>                        10470000
   scode := getsir(tltsir);                                             10475000
   if ldev = 0 then go reject;   << opr rejected request. >>            10480000
   ltaddr := getldev(ldev,ltbuf);                                       10485000
   if < or (lcb'vcb <> 0) then go wronglu;   << not tape, or in use. >> 10490000
   if setowned(ldev,-1) <> 0 then go wronglu; << it's owned >> <<06333>>10495000
   if lcb'labtyp = 0 then                                               10500000
      begin                                                             10505000
                                                                        10510000
<<  the tape on the specified drive has not been identified; it         10515000
may have been ready when the system came up.                            10520000
read it and try avr to spot a labeled tape; if the correct tape         10525000
is mounted, it will be linked by avr. >>                                10530000
                                                                        10535000
      relsir(tltsir,scode);                                             10540000
      if lcb'tape then recognize(ldev)                         <<03581>>10545000
                  else cc := ccl;                              <<03581>>10550000
      if < then go bugopr;     << i/o error >>                          10555000
      scode := getsir(tltsir);     << tape is at load point. >>         10560000
      ltaddr := getldev(ldev,ltbuf);                                    10565000
      end;                                                              10570000
   << unlabbeled? >>                                                    10575000
   if (lcb'labtyp=1) and access > read then go wvl;                     10580000
   if lcb'vcb = vtaddr then go wrchk;  << correct tape - linked >>      10585000
   if ckforldev(ldev) then go wrtape;                          <<06026>>10590000
       << if read access, must be the exact tape requested >>  <<06026>>10595000
       << or we'll wipe out vol1 label without permission. >>  <<06026>>10600000
   if access = read then                                       <<08277>>10605000
      begin                                                    <<06026>>10610000
      if goodreel(vtbuf,ltbuf) then go wvl;                    <<06026>>10615000
      end                                                      <<06026>>10620000
   else                                                        <<06026>>10625000
      go wvl;                                                  <<06026>>10630000
                                                               <<06026>>10635000
       << if we have the correct access, let us use it     >>  <<06026>>10640000
       << for now as if it were unlabelled.                >>  <<06026>>10645000
                                                               <<02722>>10650000
<< wrong tape.  clean ldev entry & rewind-unload. >>           <<02722>>10655000
                                                               <<02722>>10660000
wrtape:                                                        <<06026>>10665000
   cleanldev(ldev);                                            <<02722>>10670000
   relsir(tltsir,scode);                                       <<02722>>10675000
   attio(ldev,9);                                              <<02722>>10680000
   go bugopr;                                                  <<02722>>10685000
                                                               <<02722>>10690000
<< something wrong with operator's reply, ask again. >>        <<02722>>10695000
                                                               <<02722>>10700000
wronglu:                                                       <<02722>>10705000
   relsir(tltsir,scode);                                                10710000
   go bugopr;                                                           10715000
                                                                        10720000
<< it's either an unlabelled tape, or we're overwriting a  >>  <<07113>>10725000
<< labelled tape with a new volume id.                     >>  <<07113>>10730000
                                                                        10735000
wvl:                                                                    10740000
   lcb'fseq := 1;                                                       10745000
   lcb'reel := 1;                                                       10750000
   lcb'vcb := vtaddr;                                                   10755000
   vcb'mntwait := 0;                                                    10760000
   vcb'ldev := ldev;                                                    10765000
                                                               <<d8615>>10770000
   << vcb'density is only used for variable density drives. >> <<d8615>>10775000
   << if no specific density request has been made by the   >> <<d8615>>10780000
   << user, set it to the default density of the drive.     >> <<d8615>>10785000
                                                               <<d8615>>10790000
   lpdt'index := ldev * size'of'lpdt'entry;                    <<d8615>>10795000
   if vcb'density = ldt'no'density then                        <<d8615>>10800000
      begin                                                    <<d8615>>10805000
      if (lpdt'auto'subtype = hp7976) or                       <<d8615>>10810000
         (lpdt'auto'subtype = hp7978) then                     <<d8615>>10815000
         vcb'density := ldt'density'6250                       <<d8615>>10820000
      else    << hp7974 or hp7970 (not used) >>                <<d8615>>10825000
         vcb'density := ldt'density'1600;                      <<d8615>>10830000
      end;                                                     <<d8615>>10835000
                                                                        10840000
   if access <> 0 then                                         <<06026>>10845000
      vcb'needvol := 1;   << write a vol1 later >>             <<06026>>10850000
   postvtent(ltbuf,ltaddr,-1);                                          10855000
   postvtent(vtbuf,vtaddr,scode);                                       10860000
   go goodexit;                                                         10865000
                                                                        10870000
<<  a labelled tape of the vol set is mounted and at load point;        10875000
determine if it is suitable.   >>                                       10880000
                                                                        10885000
wrchk:                                                                  10890000
   if access <> read then                                      <<08277>>10895000
      begin     << write access. >>                                     10900000
      relsir(tltsir,scode);                                             10905000
      if ckforldev(ldev) then                                  <<06026>>10910000
         begin           << not ok to write. >>                         10915000
         scode := getsir(tltsir);                                       10920000
         lcb'vcb := 0;          << de-link >>                           10925000
         postvtent(ltbuf,ltaddr,-1);                                    10930000
reject:                                                                 10935000
         vcb'ldev := 0;                                                 10940000
         vcb'flags := 0;      << release volume entry. >>               10945000
         postvtent(vtbuf,vtaddr,scode);                                 10950000
         go nolink;                                                     10955000
         end;                                                           10960000
      scode := getsir(tltsir);                                          10965000
      end;                                                              10970000
   lcb'vcb := vtaddr;                                                   10975000
   vcb'mntwait := 0;                                                    10980000
   vcb'ldev := ldev;                                                    10985000
                                                                        10990000
   postvtent(ltbuf,ltaddr,-1);                                          10995000
   postvtent(vtbuf,vtaddr,scode);                                       11000000
                                                                        11005000
goodexit:                                                               11010000
   ldevn := ldev;                                                       11015000
   result := okay;                                                      11020000
nolink:                                                                 11025000
   end;       << procedure linklabel >>                                 11030000
$page " CLEANLDEV "                                                     11035000
procedure cleanldev(ldev);                                              11040000
  value ldev;                                                  <<02575>>11045000
  integer ldev;                                                         11050000
  option uncallable;                                                    11055000
                                                                        11060000
<< called from fclose and checkul for fclose to purge an ldev entry     11065000
from the tlt.  caller should rewind-unload. db at the stack.  >>        11070000
                                                                        11075000
   begin                                                                11080000
   integer ltaddr,scode;                                                11085000
   logical array ltbuf(0:ltesize-1) =q;                                 11090000
                                                                        11095000
   scode := getsir(tltsir);                                             11100000
   ltaddr := getldev(ldev,ltbuf);                                       11105000
   if < then tapetrouble(tt15);                                <<03581>>11110000
    lcb'flags := lcb'flags land %1000;  << leave tape bit >>   <<03581>>11115000
   ltbuf(2) := 0;                                                       11120000
   move ltbuf(3) := ltbuf(2),(vtesize-3);                               11125000
   postvtent(ltbuf,ltaddr,scode);                                       11130000
   end;   << procedure cleanldev >>                                     11135000
$page " REELSWITCH "                                                    11140000
integer procedure reelswitch(ldev,rdwr);                                11145000
value ldev,rdwr;                                                        11150000
logical ldev;                                                           11155000
integer rdwr;                                                           11160000
  option uncallable;                                                    11165000
                                                                        11170000
<< called from position, iomove, restore, etc. when a tapemark          11175000
or eot marker is encountered in the data area to switch to the          11180000
next reel of a multi-volume file.  if writing, or if reading            11185000
and eov follows, reelswitch calls for the next reel, positions          11190000
it to the data area, and returns true.  if read other than eov,         11195000
positions tape to tapemark at end of data and returns                   11200000
false.  db can be anywhere, typically at the user's buffer.             11205000
   rdwr = 0:  read; next sequential vol of vol set required.            11210000
          1:  write; any tape ok; any vol label is kept.                11215000
          2:  read for position; any vol of vol set ok.                 11220000
                                                                        11225000
returns:  ldev and cce if next reel mounted                             11230000
          ldev and ccg if eof label found                               11235000
          ldev and ccl if operator did =reply 0.   >>                   11240000
                                                                        11245000
<< note: although it is planned to allow subsequent volumes             11250000
on different ldev's, callers can't handle this now, so that             11255000
is not provided for in this code. >>                                    11260000
                                                                        11265000
   begin                                                                11270000
   logical vtaddr,ltaddr,xldev;                                         11275000
   integer scode,userdb;                                                11280000
   logical restor := false;                                    <<0615>> 11285000
   logical write = rdwr;                                                11290000
   integer lpdt'index;                                         <<06333>>11295000
   integer result = reelswitch;                                         11300000
   integer ltype;                                                       11305000
   logical array vtbuf(0:vtesize-1) =q;                                 11310000
      buildvcb;                                                         11315000
   logical array ltbuf(0:ltesize-1) =q;                                 11320000
      buildlcb;                                                         11325000
   integer array buffer(0:30);                                          11330000
      byte array bbuf(*) = buffer;                                      11335000
   integer array reply(0:3) =q;                                         11340000
      byte array replyb(*) =reply+1;                                    11345000
      integer rcnt = reply;                                             11350000
                                                               <<02648>>11355000
subroutine attios(func);                                       <<02648>>11360000
value func; integer func;                                      <<02648>>11365000
                                                               <<02648>>11370000
   begin                                                       <<02648>>11375000
   if ldev=0 then tapetrouble(tt5);    << oops! >>             <<03581>>11380000
   tos := attachio(ldev,0,0,0,func,0,0,4,%11);                 <<02689>>11385000
   del;                                                        <<02648>>11390000
   if s0.(13:3) > 2 then                                       <<02648>>11395000
      begin                                                    <<02673>>11400000
      report'ioerror(ldev,s0.(8:8));   << gripe >>             <<02673>>11405000
      end;                                                     <<02648>>11410000
   x := tos;                                                   <<02648>>11415000
   end;                                                        <<02648>>11420000
                                                               <<02648>>11425000
 << begin execution >>                                                  11430000
                                                                        11435000
   cc := cce;                                                           11440000
   userdb := exchangedb(0);                                             11445000
   ltaddr := getldev(ldev,ltbuf);                                       11450000
   if < then tapetrouble(tt15);                                <<03581>>11455000
   vtaddr := lcb'vcb;                                                   11460000
   getxdsw(vtbuf,tltdst,vtaddr,vtesize);                                11465000
   if ldev <> vcb'ldev then tapetrouble(tt16);                 <<03581>>11470000
   if rdwr < 0 then                                            <<0615>> 11475000
      begin     << called from startvolume in restore >>       <<0615>> 11480000
      rdwr := 2;      << set to read >>                        <<02662>>11485000
      restor := 1;    << genmsg ask for "prior" reel. >>       <<0615>> 11490000
      go unload;                                               <<0615>> 11495000
      end;                                                              11500000
                                                                        11505000
   if write then                                                        11510000
      begin         << write; finish off this reel. >>                  11515000
      writelab(vtbuf,2);        << write tm,eov1&2 >>                   11520000
      attios(6);         << write tm ending labels >>          <<02648>>11525000
      attios(6);         << write tm ending everything >>      <<02648>>11530000
      end                                                               11535000
   else                                                                 11540000
      begin    << read.  if eov1 follows, need next reel. >>            11545000
      ltype := check1(ltbuf);      << ** need err check >>              11550000
      if ltype <> 2 then                                                11555000
         begin      << should be eof1. other cases illegal >>           11560000
         attios(12);   << bsr over what we just read >>        <<02648>>11565000
         attios(12);   << bsr over tape mark >>                <<02648>>11570000
         cc := ccg;        << report eof >>                             11575000
         go done;       << no more; fread will return eof. >>  <<02563>>11580000
         end;                                                           11585000
      end;    << read >>                                                11590000
unload:                                                        <<0615>> 11595000
   attios(9);       << rewind unload >>                        <<02648>>11600000
   scode := getsir(tltsir);                                             11605000
                                                                        11610000
<< the old reel has been disposed of.  figure out which                 11615000
one comes next. >>                                                      11620000
<< 288 mount next volume of set ! on ldev# \ >>                         11625000
<< 289 mount prior volume of set ! on ldev# \ >>                        11630000
                                                                        11635000
   vcb'reel := vcb'reel+1;                                     <<04872>>11640000
   vcb'rswait := 1;                                                     11645000
   vcb'dr'wait := 0;  <<  set to wait on devrec >>             <<04698>>11650000
   postvtent(vtbuf,vtaddr,scode);                                       11655000
   setowned(ldev,0);    << set unowned to enable avr >>        <<04698>>11660000
                                                                        11665000
   move bbuf := vcb'vsetid,(6);                                         11670000
   bbuf(6) := 0;    << genmsg terminator >>                             11675000
bugopr:                                                                 11680000
   rcnt := -1;                                                          11685000
   genmsg(1,288+restor,%01000,@bbuf,ldev,,,,0,%1404,@reply);   <<07112>>11690000
   if rcnt < 0 then go didavr;                                          11695000
   xldev := binary'(replyb,rcnt);                                       11700000
   if <> then go bugopr;                                                11705000
   if xldev = 0 then go flush;    << opr reject. >>                     11710000
   go bugopr;        << other replies invalid. >>                       11715000
                                                                        11720000
<< avr has happened.  see what tape has been mounted. >>                11725000
                                                                        11730000
<< after avrec has woken us up, devrec still modifies some >>  <<02563>>11735000
<< of the tape data structures.  in particular, it sets    >>  <<02563>>11740000
<< the device state to unowned and determines the tape's   >>  <<02563>>11745000
<< density.  we cannot continue until devrec has finished. >>  <<02563>>11750000
<< by waiting on the taperec bit in the lpdt, we can be    >>  <<02563>>11755000
<< sure that avr has finished. >>                              <<02563>>11760000
                                                               <<02563>>11765000
didavr:                                                                 11770000
   getxdsw(vtbuf,tltdst,vtaddr,vtesize);                       <<03618>>11775000
   while not vcb'dr'wait do                                    <<03618>>11780000
     begin                                                     <<03618>>11785000
     delay(100d);       <<  wait for devrec to finish  >>      <<03618>>11790000
     getxdsw(vtbuf,tltdst,vtaddr,vtesize);                     <<03618>>11795000
     end;                                                      <<03618>>11800000
   scode := getsir(tltsir);                                             11805000
   ltaddr := getldev(ldev,ltbuf);                                       11810000
   if < then tapetrouble(tt16);                                <<03581>>11815000
   if write then                                               <<02648>>11820000
      begin                                                    <<02648>>11825000
      if lcb'labtyp=1 then go wvl      << unlabelled >>        <<02648>>11830000
      else if lcb'labtyp=vcb'labtyp then go wrchk;             <<02648>>11835000
      end                                                      <<02648>>11840000
   else                                                        <<02648>>11845000
      begin      << read >>                                    <<02648>>11850000
      if (lcb'labtyp=vcb'labtyp) and lcb'vsetid=vcb'vsetid,(6) <<02648>>11855000
      then begin                                               <<s8980>>11860000
         if (rdwr=2) or (lcb'reel=vcb'reel) and                <<s8980>>11865000
            (lcb'fseq=vcb'fseq) then go readit                 <<s8980>>11870000
         else if (not restor) and (lcb'reel < vcb'reel) then   <<s8980>>11875000
            genmsg (1, 10, %10000, ldev, , , , , 0, 1, @reply);<<s8980>>11880000
      end;                                                     <<s8980>>11885000
      end;                                                     <<02648>>11890000
   relsir(tltsir,scode);                                       <<02722>>11895000
   attios(9);            << wrong tape; unload it. >>          <<02722>>11900000
   go bugopr;                                                           11905000
                                                               <<04739>>11910000
                                                                        11915000
                                                               <<04739>>11920000
flush:                                                         <<04739>>11925000
                                                               <<04739>>11930000
   if not lcb'tape then << so we may do i/o to serial >>       <<04739>>11935000
     setowned(ldev,1);  <<disc, we must set owned, in >>       <<04739>>11940000
                 <<additon we leave it owned until the>>       <<04739>>11945000
                 <<sdisc xds gets cleaned up.         >>       <<04739>>11950000
   scode := getsir(tltsir);                                    <<04739>>11955000
   vcb'flush := 1;                                             <<04739>>11960000
   postvtent(vtbuf,vtaddr,scode);                              <<04739>>11965000
                                                               <<04739>>11970000
   << done with tape drive, clean up data structure. >>        <<04739>>11975000
   cleanldev(ldev);                                            <<04739>>11980000
   if lcb'tape then set'bot'on; <<tape at bot>>                <<04739>>11985000
   store'density(ldev,ldev,2);   << clean density >>           <<04739>>11990000
                                                               <<04739>>11995000
   cc := ccl;                                                  <<04739>>12000000
   setowned(ldev,0);  <<just in case we are owned >>           <<04739>>12005000
   go done;          << report lossage. >>                     <<04739>>12010000
                                                               <<04739>>12015000
<< there is now a blank (unlabelled) tape to write on ldev.             12020000
we'll cook a vol1 label.  >>                                            12025000
<< 290 vol id for volume of set ! on ldev# \? >>                        12030000
                                                                        12035000
wvl:                                                                    12040000
   relsir(tltsir,scode);                                                12045000
   genmsg(1,290,%01000,@bbuf,ldev,,,,0,%3004,@reply);                   12050000
   move vcb'volid := "      ";                                          12055000
<< need to bless the input. >>                                 <<02648>>12060000
   move vcb'volid := replyb,(rcnt);                                     12065000
                                                                        12070000
   lcb'labtyp := vcb'labtyp;                                            12075000
   move lcb'volid := vcb'volid,(6);                                     12080000
   move lcb'vsetid := vcb'vsetid,(6);                                   12085000
   lcb'fseq := vcb'fseq;                                                12090000
   lcb'reel := vcb'reel;                                                12095000
   lcb'exdate := vcb'exdate;                                            12100000
   vcb'posn := if vcb'stortap then ah2 else ad;                         12105000
   vcb'rswdone := 1;                                                    12110000
   vcb'writdir := vcb'stortap;                                          12115000
   vcb'rswait := 0;                                                     12120000
   scode := getsir(tltsir);                                             12125000
   postvtent(vtbuf,vtaddr,-1);                                          12130000
   postvtent(ltbuf,ltaddr,scode);                                       12135000
   setowned(ldev,1);                                           <<02563>>12140000
   writlab0(vtbuf);                                            <<02563>>12145000
   go writing;                                                          12150000
                                                                        12155000
<< reading: correct labeled tape is mounted and at loadpoint. >>        12160000
                                                                        12165000
readit:                                                                 12170000
   vcb'rswait := 0;     << turn off wait for reelswitch >>              12175000
   move vcb'volid := lcb'volid,(6);                                     12180000
   vcb'posn := if restor then ah2 else ad;                              12185000
   if rdwr <> 2 then vcb'rswdone := 1;                         <<02690>>12190000
   postvtent(vtbuf,vtaddr,scode);                                       12195000
   setowned(ldev,1);                                                    12200000
   attios(7);     << fsf over vol1 and hdr lbls >>             <<02648>>12205000
   if restor then                                              <<0615>> 12210000
      begin         << go to user hdr lbl (store label) >>              12215000
      attios(12);   << bsr over tapemark >>                    <<02648>>12220000
      attios(12);   << bsr over last header label >>           <<02648>>12225000
      end;                                                              12230000
   go goodexit;                                                         12235000
                                                                        12240000
<< writing: the correct labeled tape has been mounted and is            12245000
at loadpoint; see if it is writeable.  >>                               12250000
                                                                        12255000
wrchk:                                                                  12260000
   vcb'rswait := 0;     << turn off wait for reelswitch >>              12265000
   move vcb'volid := lcb'volid,(6);                                     12270000
   vcb'posn := if vcb'stortap then ah2 else ad;                         12275000
   vcb'rswdone := 1;                                                    12280000
   vcb'writdir := vcb'stortap;                                          12285000
   postvtent(vtbuf,vtaddr,scode);                                       12290000
   if not lcb'tape then setowned(ldev,0);  << kludge because >><<04647>>12295000
                              << serial disc will be owned   >><<04647>>12300000
   if ckforldev(ldev) or ckforexdate(ldev,1,2) then            <<06026>>12305000
      begin  << wrong tape, set up to mount another tape >>    <<04739>>12310000
      setowned(ldev,1);  << disable avr >>                     <<04739>>12315000
      scode := getsir(tltsir);                                 <<04739>>12320000
      vcb'rswait := 1;   << turn on wait for reelswitch >>     <<04739>>12325000
      vcb'dr'wait := 0;  << set to wait on devrec >>           <<04739>>12330000
      move bbuf := vcb'vsetid,(6);                             <<04739>>12335000
      move bbuf(6) := 0; << genmsg terminator     >>           <<04739>>12340000
      postvtent(vtbuf,vtaddr,scode);                           <<04739>>12345000
      attios(9);   << rewind-unload >>                         <<04739>>12350000
      setowned(ldev,0); << enable avr >>                       <<04739>>12355000
      goto bugopr;                                             <<04739>>12360000
      end;                                                     <<04739>>12365000
   setowned(ldev,1);                                           <<02563>>12370000
                                                               <<02563>>12375000
<< if the new reel is on a variable density drive, then >>     <<02563>>12380000
<< the vol1 label will be rewritten if the tape is not  >>     <<02563>>12385000
<< at the correct density. >>                                  <<02563>>12390000
                                                               <<02563>>12395000
   lpdt'index := ldev * size'of'lpdt'entry;                    <<06333>>12400000
   if (variable'density) and wrong'density(vtbuf) then         <<02563>>12405000
      begin             << need a new vol1 >>                  <<02563>>12410000
      attios(5);    << rewind >>                               <<02648>>12415000
      writlab0(vtbuf);                                         <<02563>>12420000
      end                                                      <<02563>>12425000
   else                                                        <<02563>>12430000
      attios(11);   << fsr over vol1 >>                        <<02648>>12435000
writing:                                                       <<02563>>12440000
   writelab(vtbuf,0);       << write header labels >>                   12445000
   if not vcb'stortap then attios(6);  << tm ends lbls >>      <<02648>>12450000
   logit(vtbuf);          << write log record >>                        12455000
goodexit:                                                               12460000
   if lcb'tape then set'bot'off; <<bot is off for labtape>>    <<03581>>12465000
done:                                                          <<02563>>12470000
   result := ldev;                                                      12475000
   exchangedb(userdb);                                                  12480000
   end;    << procedure reelswitch >>                                   12485000
$page " CHECKUL "                                                       12490000
integer procedure checkul(fnum,code,func);                     <<02690>>12495000
  value fnum,code,func;                                                 12500000
  integer fnum,code,func;                                      <<02690>>12505000
  option uncallable;                                                    12510000
                                                                        12515000
comment                                                        <<02690>>12520000
                                                               <<02690>>12525000
called by file system intrinsics that effect tape motion,      <<02690>>12530000
this procedure keeps track of tape position and handles user            12535000
and system tape labels.  db can be anywhere.  called from:              12540000
 c,f  procedure                                                         12545000
 0,0  fread                                                             12550000
 1,e  fwrite             e = acb'neweof                        <<02690>>12555000
 2,l  freadlabel         l = label number                      <<02690>>12560000
 3,0  fwritelabel                                                       12565000
 4,d  fclose             d = disposition                       <<02690>>12570000
 5,e  fcontrol rwnd      e = acb'neweof                        <<02690>>12575000
 6,f  fspace             f.(14:1) = acb'neweof                 <<02690>>12580000
                         f.(15:1) = 0, bsr                     <<02690>>12585000
                                  = 1, fsr                     <<02690>>12590000
 7,0  fcontrol fsf                                                      12595000
returns error code and ccl if error, else 0 and cce.           <<02690>>12600000
                                                               <<02690>>12605000
;   << end of comment >>                                       <<02690>>12610000
                                                                        12615000
begin                                                                   12620000
   integer vtaddr,ltaddr,scode,userdb;                                  12625000
   integer ldev,posn,ltype;                                             12630000
   integer result=checkul;                                     <<02690>>12635000
   logical lfunc=func;                                         <<02690>>12640000
   logical mustclose := false;                                 <<02690>>12645000
   logical array vtbuf(0:vtesize-1) =q;                                 12650000
   logical array ltbuf(0:ltesize-1) =q;                                 12655000
   array label2(0:3) =q;                                       <<02662>>12660000
      double labeltype=label2;                                 <<02662>>12665000
      byte array btlabel(*) = label2;                          <<02662>>12670000
                                                                        12675000
subroutine errexit(hack);                                               12680000
value hack; integer hack;                                               12685000
   begin                                                                12690000
   result := hack;                                             <<02690>>12695000
   if mustclose then return;   << finish all processing. >>    <<02690>>12700000
   cc := ccl;                                                           12705000
   go out;                                                              12710000
   end;                                                                 12715000
subroutine attios(func);                                                12720000
value func; integer func;                                               12725000
                                                                        12730000
   begin                                                                12735000
   if ldev=0 then tapetrouble(tt5);    << oops! >>             <<03581>>12740000
   tos := attachio(ldev,0,0,0,func,0,0,4,%11);                 <<02689>>12745000
   del;                                                                 12750000
   if s0.(13:3) > 2 then errexit(lbtposerr);                            12755000
   x := tos;                                                            12760000
   end;                                                                 12765000
subroutine fsfdata(skpe2);                                     <<02662>>12770000
   value skpe2; logical skpe2;                                 <<02662>>12775000
   begin       << advance tape to eof2 or first utl. >>        <<02662>>12780000
skip:                                                                   12785000
   attios(7);       << fsf over data >>                                 12790000
   ltype := check1(ltbuf);   << read eof1/eov1 >>                       12795000
   if ltype = 2 then                                                    12800000
      begin        << eov found; need next reel. >>                     12805000
      attios(12);    << bsr over eov1 >>                                12810000
      reelswitch(ldev,0);                                               12815000
      if < then errexit(navaildev);     << never return... >>  <<06333>>12820000
      if > then errexit(lbtposerr);    << not eov1?? >>                 12825000
      getxdsw(vtbuf,tltdst,vtaddr,vtesize);                             12830000
      getxdsw(ltbuf,tltdst,ltaddr,ltesize);                             12835000
      go skip;                                                          12840000
      end;                                                              12845000
   if ltype <> 1 then errexit(lbtfmterr);   << should be eof1. >>       12850000
   if not skpe2 then return;    << done. >>                    <<02662>>12855000
   tos := attachio(ldev,0,0,@label2,read,4,0,0,1);             <<02662>>12860000
   del;                                                        <<02662>>12865000
   tos := tos.(13:3);                                          <<02662>>12870000
   if s0 > 2 then errexit(lbtposerr);                          <<02662>>12875000
   if lcb'labtyp = 3 then ctranslate(1,btlabel,,4);            <<02662>>12880000
   if tos=2 or labeltype <> "EOF2" then attios(12);   << bsr >><<02662>>12885000
   end;      << subroutine fsfdata >>                                   12890000
   if not (0 <= code <= 7) then tapetrouble(tt41);             <<03581>>12895000
                                                               <<02690>>12900000
   cc := cce;   << anticipate no error. >>                     <<02690>>12905000
   userdb := exchangedb(0);     << db to stack >>                       12910000
   vtaddr := getfnum(fnum,vtbuf);                                       12915000
   if < then tapetrouble(tt42);                                <<03581>>12920000
   posn := vcb'posn;                                                    12925000
   ldev := vcb'ldev;                                                    12930000
   if vcb'flush and code <> 4 then                                      12935000
      begin       << device unavailable (=reply 0) >>                   12940000
      errexit(navaildev);                                      <<06333>>12945000
      end;                                                              12950000
   ltaddr := getldev(ldev,ltbuf);                                       12955000
   if < then tapetrouble(tt43);                                <<03581>>12960000
   case * code of begin                                                 12965000
      begin         << 0: fread >>                                      12970000
      if posn > ad then errexit(invop);                        <<06333>>12975000
      if posn < dnx then                                                12980000
         attios(7);     << fsf over hdr lbls >>                         12985000
      posn := ad;                                                       12990000
      end;                                                              12995000
                                                                        13000000
      begin       << 1: fwrite: complete header labels. >>              13005000
      if posn > ad then errexit(invop);                        <<06333>>13010000
      if posn < ah2 and writelab(vtbuf,0) then                 <<02662>>13015000
         errexit(lbtposerr);          << write hdr1&2 >>       <<02662>>13020000
      if posn < dnx then attios(6);   << wtm ending hdr lbls >>         13025000
      posn := ad;                                                       13030000
      end;     << header labels are now complete. >>                    13035000
                                                                        13040000
      begin      << 2: freadlabel >>                                    13045000
      if posn <= ahu then go out;   << ok to read hdr >>                13050000
      if posn <= ad then fsfdata(1);   << set to user trlr lbls<<02662>>13055000
      posn := atu;                                                      13060000
      end;                                                              13065000
                                                                        13070000
      begin      << 3: fwritelabel >>                                   13075000
      if posn < ah2 then                                                13080000
         begin      << write header labels >>                           13085000
         if writelab(vtbuf,0) then errexit(lbtposerr);         <<02662>>13090000
         posn := ahu;                                                   13095000
         end;                                                           13100000
      if posn = ad then                                                 13105000
         begin         << set to write trlr labels >>                   13110000
         if writelab(vtbuf,1) then errexit(lbtposerr);   << tm,eof1&2 >>13115000
         posn := atu;                                                   13120000
         end;                                                           13125000
      end;                                                              13130000
                                                                        13135000
      begin            << 4: fclose >>                                  13140000
      if func < 0 then mustclose := true;                      <<02690>>13145000
      if vcb'flush then                                        <<02722>>13150000
         begin                                                 <<02722>>13155000
         result := navaildev; << tape drive is already free. >><<06333>>13160000
         go cvol;                                              <<02722>>13165000
         end;                                                  <<02722>>13170000
      if vcb'write then                                         <<2622>>13175000
         begin          << write access >>                      <<2622>>13180000
         if posn > h1nx then                                    <<2622>>13185000
            begin       << header labels written >>             <<2622>>13190000
            if posn < dnx then attios(6);  << wtm ending hdrs >><<2648>>13195000
            if posn < t1nx and writelab(vtbuf,1) then          <<02662>>13200000
               errexit(lbtposerr);   << write tm,eof1&2 >>     <<02662>>13205000
            attios(6);       << wtm ending trlr lbls >>                 13210000
            attios(6);       << wtm for eov >>                          13215000
            if func < 2 then go vsetcl;                                 13220000
            attios(12);       << bsr over eov tm >>                     13225000
            if func = 2 then                                            13230000
               begin          << rewind file >>                         13235000
               attios(12);     << bsr over new tm >>                    13240000
               attios(8);      << bsf over trlr lbls >>                 13245000
               attios(8);      << bsf over data. (*** need reelsw) >>   13250000
               attios(8);      << bsf over hdr lbls >>                  13255000
               attios(11);     << fsr over tm or vol1 >>                13260000
               end                                                      13265000
            else vcb'fseq := vcb'fseq+1;    << at next file >>          13270000
            end         << header labels written >>             <<2622>>13275000
         else                                                   <<2622>>13280000
            if func < 2 then go vsetcl;                         <<2622>>13285000
         end            << write access >>                      <<2622>>13290000
      else                                                              13295000
         begin       << read access >>                                  13300000
         if func < 2 then                                               13305000
            begin         << close volume set >>                        13310000
vsetcl:     attios(9);      << rewind-unload >>                         13315000
            cleanldev(ldev);                                   <<02689>>13320000
cvol:       vtbuf := 0;      << cleantlt >>                    <<02689>>13325000
            posn := 0;                                                  13330000
            move vtbuf(1) := vtbuf,(vtesize-1);                         13335000
            go out;                                                     13340000
            end;                                                        13345000
                                                                        13350000
         if func = 2 then                                               13355000
            begin       << rewind file: close vol but not vset. >>      13360000
            if posn >= t1nx then attios(8);  << bsf/trlrs >>            13365000
            if posn >= dnx then                                         13370000
               begin          << backspace over data >>                 13375000
               attios(8);   << loose end: add reelswitch. >>            13380000
               end;                                                     13385000
            attios(8);      << bsf over hdr lbls >>                     13390000
            attios(11);     << fsr over tm >>                           13395000
            end                                                         13400000
         else                                                           13405000
            begin       << advance to next file. >>                     13410000
            if posn < dnx then attios(7);  << fsf hdr lbls >>           13415000
            if posn < t1nx then fsfdata(0);                    <<02662>>13420000
            attios(7);     << fsf over trlr lbls >>                     13425000
            vcb'fseq := vcb'fseq+1;                                     13430000
            end;                                                        13435000
         end;                                                           13440000
      posn := h1nx;                                                     13445000
      vcb'fnum := 0;   << cleantltf: close vol but not vset. >>         13450000
      end;      << exit with tape before hdr1. >>                       13455000
                                                                        13460000
      begin         << 5: rewind - write eof & trlr labels >>           13465000
      if vcb'stortap and posn = ad then go out;    << done. >>          13470000
      if vcb'write then                                                 13475000
         begin             << write access >>                           13480000
         if posn <= h1nx then go out;  << no i/o. >>                    13485000
         if posn < dnx then                                             13490000
            attios(6);     << wtm: end of hdr labels >>                 13495000
         if posn < t1nx and writelab(vtbuf,1) then             <<02662>>13500000
            errexit(lbtposerr);      << write tm,eof1&2 >>     <<02662>>13505000
         attios(6);     << wtm: end of trlr labels >>                   13510000
         attios(6);     << wtm: end of vol set >>                       13515000
         attios(8);     << bsf over eov tm >>                           13520000
         attios(8);     << bsf over end of trlr labels >>               13525000
         posn := atu;                                                   13530000
         end;         << write access >>                                13535000
      if posn > ad then                                                 13540000
         attios(8);    << bsf over trlr labels >>                       13545000
      if posn >= dnx then                                               13550000
         begin                                                          13555000
         attios(8);    << bsf over data (*** need reelswitch) >>        13560000
         end;                                                           13565000
      attios(8);    << bsf over header labels >>                        13570000
      if check1(ltbuf) = 3  << vol1 >> then                             13575000
         attios(11);    << fsr over hdr1 >>                             13580000
      tos := attachio(ldev,0,0,@label2,read,4,0,0,1);          <<02662>>13585000
      del;                                                     <<02662>>13590000
      tos := tos.(13:3);                                       <<02662>>13595000
      if s0 > 2 then errexit(lbtposerr);                       <<02662>>13600000
      if lcb'labtyp = 3 then ctranslate(1,btlabel,,4);         <<02662>>13605000
      if tos=2 or labeltype <> "HDR2" then attios(12);   << bsr >>      13610000
      posn := ahu;                                                      13615000
      end;                                                              13620000
                                                                        13625000
      begin         << 6: fspace >>                                     13630000
      if posn > ad then errexit(invop);                        <<06333>>13635000
      if posn < dnx then     << in header label area >>                 13640000
       if not lfunc then errexit(invop)  <<bsr in hdr lbls>>   <<06333>>13645000
         else begin                                                     13650000
         attios(7);     << fsf over hdr labels >>                       13655000
         posn := dnx;                                                   13660000
         end;                                                           13665000
      if lfunc.(14:1) then                                     <<02690>>13670000
         begin    << backspace after write: tm needed. >>               13675000
         if writelab(vtbuf,1) then errexit(lbtposerr);  << tm,eof1&2 >> 13680000
         attios(6);    << wtm ending trlr labels >>                     13685000
         attios(6);    << wtm ending reel >>                            13690000
         attios(8);    << bsf over tm >>                                13695000
         attios(8);    << bsf over tm >>                                13700000
         attios(8);    << bsf over labels to end of data >>             13705000
         end;        << write trailer labels >>                         13710000
      posn := ad;                                                       13715000
      end;                                                              13720000
                                                                        13725000
      begin       << 7: fcontrol 7 - fsf - go to utl's >>               13730000
      if posn > ad then                                                 13735000
         attios(8)      << bsf over trlr labels >>                      13740000
      else if posn < dnx then                                           13745000
         attios(7);     << fsf over header lbls >>                      13750000
      fsfdata(1);       << fsf over data >>                    <<02662>>13755000
      posn := at2;                                                      13760000
      end;                                                              13765000
   end;     << case >>                                                  13770000
                                                                        13775000
out:                                                                    13780000
   scode := getsir(tltsir);                                             13785000
   vcb'posn := posn;                                                    13790000
   postvtent(vtbuf,vtaddr,scode);                                       13795000
   exchangedb(userdb);                                                  13800000
   end;     << procedure checkul>>                                      13805000
$page " POSITION "                                                      13810000
integer procedure position(ldev,fnum,blkfact,rsiz,fops,aopactype);      13815000
   value ldev,fnum,aopactype;                                           13820000
   integer fnum,blkfact,rsiz;                                           13825000
   logical ldev,fops,aopactype;                                         13830000
  option uncallable;                                                    13835000
                                                                        13840000
comment                                                        <<03581>>13845000
                                                               <<03581>>13850000
   called from fopen to get to the beginning of the specified  <<03581>>13855000
file.  tape is assumed to be at load point or at a hdr1 label. <<03581>>13860000
file expiration date is checked after positioning tape to the  <<06026>>13865000
specific file.  if adding a file at end of reel, its expiration<<06026>>13870000
date must be no later than that of the file preceding it.      <<06026>>13875000
if reading, exits with tape after hdr2 label, if writing,      <<03581>>13880000
positioned to write hdr1 after writing vol1 label if c         <<03581>>13885000
flag in word 5 of vcb is set.  returns error code, 0 if ok;    <<03581>>13890000
                                                                        13895000
   begin                                                                13900000
   logical vtaddr,ltaddr,scode;                                         13905000
   integer recsize;                                                     13910000
   integer blksize;                                                     13915000
   integer ltype;                                                       13920000
   integer lpdt'index;                                         <<06333>>13925000
   logical                                                     <<02563>>13930000
      firstfile,      << denotes first file on reel >>         <<02563>>13935000
      count,          << for kludgy fseq position >>           <<02563>>13940000
   lastexdate,        << exp date of previous file on reel >>  <<06026>>13945000
      adding;         << adding file to end of vset >>         <<02563>>13950000
   logical array tlabel(0:lblsize-1) =q;                                13955000
      byte array btlabel(*)=tlabel;                                     13960000
      double ltbuftype = tlabel;                                        13965000
   logical array vtbuf(0:vtesize-1) =q;                                 13970000
      buildvcb;                                                         13975000
   logical array ltbuf(0:ltesize-1) =q;                                 13980000
      buildlcb;                                                         13985000
equate flags = 1;                                                       13990000
                                                                        13995000
<< error subroutine >>                                                  14000000
                                                                        14005000
subroutine errexit(errcode);                                            14010000
value errcode; integer errcode;                                         14015000
   begin                                                                14020000
   scode := getsir(tltsir);                                             14025000
   vtbuf := 0;     << cleantlt - close vol & volset >>                  14030000
   move vtbuf(1) := vtbuf,(vtesize-1);                                  14035000
   lcb'flags := lcb'flags land %1000; << leave tape bit >>     <<03581>>14040000
   ltbuf(2) := 0;                                                       14045000
   move ltbuf(3) := ltbuf(2),(vtesize-3);                               14050000
   position := errcode;   << report error >>                            14055000
   go poserr;                                                           14060000
   end;                                                                 14065000
subroutine attios(func);                                                14070000
value func; integer func;                                               14075000
                                                                        14080000
   begin                                                                14085000
   if ldev=0 then tapetrouble(tt5);  << oops! >>               <<03581>>14090000
   tos := attachio(ldev,0,0,0,func,0,0,4,%11);                 <<02689>>14095000
   del;                                                                 14100000
   if s0.(13:3) > 2 then errexit(lbtposerr);                            14105000
   x := tos;                                                            14110000
   end;                                                                 14115000
 << forward space 1 file from hdr2 to next hdr2. >>                     14120000
                                                                        14125000
subroutine fsfile;                                                      14130000
   begin                                                                14135000
   firstfile := false;                                                  14140000
   attios(7);     << fsf over header lbls >>                            14145000
skip:                                                                   14150000
   attios(7);     << fsf over data >>                                   14155000
   ltype := check1(ltbuf);   << read eof1/eov1 >>                       14160000
   if < then errexit(lbtposerr);                                        14165000
   if ltype = 2 then                                                    14170000
      begin        << eov found; need next reel. >>                     14175000
      attios(12);    << bsr over eov1 >>                                14180000
      reelswitch(ldev,2);                                               14185000
      if < then errexit(navaildev);     << never return... >>  <<06333>>14190000
      if > then errexit(lbtposerr);    << not eov1?? >>                 14195000
      getxdsw(vtbuf,tltdst,vtaddr,vtesize);                             14200000
      getxdsw(ltbuf,tltdst,ltaddr,ltesize);                             14205000
      go skip;                                                          14210000
      end;                                                              14215000
   if ltype <> 1 then errexit(lbtfmterr);   << should be eof1. >>       14220000
   lastexdate := lcb'exdate;                                   <<06026>>14225000
   attios(7);     << fsf over trlr lbls >>                              14230000
   ltype := check1(ltbuf);     << read tm/hdr1 >>                       14235000
   if < then errexit(lbtposerr);                                        14240000
   if ltype > 0 then errexit(lbtfmterr);  << wasn't >>                  14245000
   if ltype < 0 then lcb'fseq := lcb'fseq+1;                            14250000
   end;          << subroutine fsfile >>                                14255000
<< begin execution >>                                                   14260000
                                                                        14265000
   vtaddr := getfnum(fnum,vtbuf);                                       14270000
   if < then tapetrouble(tt23);                                <<03581>>14275000
   if ldev <> vcb'ldev then tapetrouble(tt24);                 <<03581>>14280000
   ltaddr := getldev(ldev,ltbuf);                                       14285000
   if aopactype <> 0 then                                               14290000
      attios(1);      << check for write ring >>                        14295000
   firstfile := false;                                                  14300000
   adding := false;                                            <<02563>>14305000
   lcb'fseq := vcb'fseq;   << default >>                                14310000
   if vcb'needvol then                                         <<03581>>14315000
      begin                                                    <<03581>>14320000
      << check expiration date to see if vol1 label can      >><<06026>>14325000
      << be overwritten.                                     >><<06026>>14330000
      if ckforexdate(ldev,1,1) then errexit(lbtunexp);         <<06026>>14335000
      writlab0(vtbuf);                                         <<03581>>14340000
      attio(ldev,6);  << write tm in lieu of hdr1 >>           <<03581>>14345000
      attio(ldev,5);  <<rewind>>                               <<03581>>14350000
      end;                                                     <<03581>>14355000
                                                                        14360000
   << if this is a new volume set open, set previous file's  >><<07113>>14365000
   << expiration date to 12/31/99 for comparing with first   >><<07113>>14370000
   << file's, which will then never be later.  else, use the >><<07113>>14375000
   << previous file exp date in lcb'exdate.  this is accu-   >><<07113>>14380000
   << rate if the file was closed with disp=3, but not for   >><<07113>>14385000
   << disp=2, since lcb'exdate refers to the same file we    >><<07113>>14390000
   << are opening.  the check will be more restrictive than  >><<07113>>14395000
   << necessary in this case.  we make up for this partially >><<07113>>14400000
   << by setting lastexdate to 12/31/99 if the first file of >><<07113>>14405000
   << the volume set is being re-opened.                     >><<07113>>14410000
                                                               <<07113>>14415000
   if vcb'vsetopen or (vcb'fseq=1) then                        <<07113>>14420000
      begin                                                    <<07113>>14425000
      lastexdate := 365;                                       <<07113>>14430000
      lastexdate.(0:7) := 99;                                  <<07113>>14435000
      end                                                      <<07113>>14440000
   else                                                        <<07113>>14445000
      lastexdate := lcb'exdate;                                <<07113>>14450000
                                                               <<07113>>14455000
sv:                                                            <<07113>>14460000
   ltype := check1(ltbuf);    << read tm, vol1, or hdr1 >>              14465000
   if < then errexit(lbtposerr);                                        14470000
   if ltype = 3 then                                                    14475000
      begin     << vol1 >>                                              14480000
      firstfile := true;                                                14485000
      go sv;                                                            14490000
      end;                                                              14495000
   if ltype = 5 and firstfile then go sv;    << skip uvl's >>  <<02621>>14500000
   if ltype > 0 then errexit(lbtfmterr);                                14505000
                                                               <<07113>>14510000
   << now at hdr1 label or eot >>                              <<07113>>14515000
                                                               <<07113>>14520000
   case * vcb'seqtyp of begin                                           14525000
      begin       << 0: search for file name >>                         14530000
agin:                                                                   14535000
      if ltype < 0 then errexit(lbteovset);                             14540000
      if vcb'fname = lcb'fname,(if lcb'hp then 17 else 8) then <<06026>>14545000
         begin          << match found >>                      <<06026>>14550000
         if aopactype > 0 then                                 <<06026>>14555000
            begin                                              <<06026>>14560000
            if not firstfile then                              <<06026>>14565000
               << must update lcb entry to file being opened >><<06026>>14570000
               << before calling ckforexdate, since it grabs >><<06026>>14575000
               << the entry out of the tlt.                  >><<06026>>14580000
               begin                                           <<06026>>14585000
                  scode := getsir(tltsir);                     <<06026>>14590000
                  postvtent(ltbuf,ltaddr,scode);               <<06026>>14595000
               end;                                            <<06026>>14600000
            if ckforexdate(ldev,1,2) then errexit(lbtunexp);   <<06026>>14605000
            if vcb'exdate > lastexdate then errexit(laterexp); <<06026>>14610000
            end;                                               <<06026>>14615000
         go fmatch;                                            <<06026>>14620000
         end;                                                  <<06026>>14625000
      fsfile;                                                           14630000
      go agin;                                                          14635000
      end;                                                              14640000
                                                                        14645000
      begin      << 1: next >>                                          14650000
      if aopactype <> read then go addend;                              14655000
      if ltype < 0 then errexit(lbteovset);  << tm found >>             14660000
      go fmatch;                                                        14665000
      end;                                                              14670000
                                                                        14675000
      begin       << 2: add a file to end of volume set >>              14680000
addf:                                                                   14685000
      if ltype < 0 then go addend;   << tm: end of vset. >>             14690000
      fsfile;                                                           14695000
      go addf;                                                          14700000
      end;                                                              14705000
                                                                        14710000
      begin       << 3: specified file seq # >>                         14715000
      count := 0;                                                       14720000
bump:                                                                   14725000
      if ltype < 0 then        << tapemark: end of vol set. >>          14730000
<<       if lcb'fseq = vcb'fseq and aopactype <> read      >>           14735000
         if (count+1 = vcb'fseq) and aopactype <> read                  14740000
           then go addend else errexit(lbteovset);                      14745000
<<    if lcb'fseq = vcb'fseq then go fmatch;    >>                      14750000
      if (count := count+1) >= vcb'fseq then                   <<06026>>14755000
         begin                                                 <<06026>>14760000
         if aopactype > 0 then                                 <<06026>>14765000
            begin                                              <<06026>>14770000
            if not firstfile then                              <<06026>>14775000
               begin                                           <<06026>>14780000
                  scode := getsir(tltsir);                     <<06026>>14785000
                  postvtent(ltbuf,ltaddr,scode);               <<06026>>14790000
               end;                                            <<06026>>14795000
            if ckforexdate(ldev,1,2) then errexit(lbtunexp);   <<06026>>14800000
            if vcb'exdate > lastexdate then errexit(laterexp); <<06026>>14805000
            end;                                               <<06026>>14810000
         go fmatch;                                            <<06026>>14815000
         end;                                                  <<06026>>14820000
      fsfile;                                                           14825000
      go bump;                                                          14830000
      end;                                                              14835000
   end;   << case >>                                                    14840000
                                                                        14845000
addend:               << write new file at end of vset. >>              14850000
   if firstfile then                                                    14855000
      begin      << start file sequencing. >>                           14860000
      lcb'fseq := 1;                                                    14865000
      if vcb'needvol then                                      <<06026>>14870000
        << ckforexdate already called, just clear bit >>       <<06026>>14875000
         vcb'needvol := 0                                      <<06026>>14880000
      else                                                     <<06026>>14885000
         if ckforexdate(ldev,1,2) then errexit(lbtunexp);      <<06026>>14890000
      end                                                      <<06026>>14895000
   else                                                        <<06026>>14900000
      begin                                                    <<06026>>14905000
      if ltype = 0 then << at hdr1, about to overwrite file >> <<07113>>14910000
         begin                                                 <<06026>>14915000
         scode := getsir(tltsir);                              <<06026>>14920000
         postvtent(ltbuf,ltaddr,scode);                        <<06026>>14925000
         if ckforexdate(ldev,1,2) then errexit(lbtunexp);      <<06026>>14930000
         end;                                                  <<06026>>14935000
      if vcb'exdate > lastexdate then errexit(laterexp);       <<06026>>14940000
      end;                                                     <<06026>>14945000
   adding := true;                                             <<02563>>14950000
fmatch:                                                                 14955000
                                                               <<02563>>14960000
   if aopactype <> 0 then                                      <<07113>>14965000
      begin                                                    <<07113>>14970000
      << set remainder of lcb entry >>                         <<07113>>14975000
      lcb'exdate := vcb'exdate;                                <<07113>>14980000
      lcb'labtyp := vcb'labtyp;                                <<07113>>14985000
      move lcb'volid := vcb'volid,(6);                         <<07113>>14990000
      move lcb'vsetid := vcb'volid,(6);                        <<07113>>14995000
      end;                                                     <<07113>>15000000
                                                               <<07113>>15005000
<< if this is the volume set open, then must resolve density >><<02563>>15010000
<< for tapes on variable density drives.  if we're adding a  >><<02563>>15015000
<< file to an empty volume set or accessing the reel in next >><<02563>>15020000
<< mode, then we'll rewrite the vol1 label at the density    >><<02563>>15025000
<< requested by the user.  in all other cases, vcb'density   >><<02563>>15030000
<< must be updated to reflect the real density of the tape.  >><<02563>>15035000
                                                               <<02563>>15040000
   lpdt'index := ldev * size'of'lpdt'entry;                    <<06333>>15045000
   if vcb'vsetopen and (variable'density) then                 <<02563>>15050000
      begin                                                    <<02563>>15055000
      if adding and firstfile and                              <<02563>>15060000
        wrong'density(vtbuf)   then                            <<02563>>15065000
         begin           << rewrite vol1 at new density >>     <<02563>>15070000
         attios(5);      << rewind >>                          <<02563>>15075000
         if writlab0(vtbuf) then errexit(lbtposerr);           <<02662>>15080000
         attios(6);      << terminate vol1 with tm >>          <<02563>>15085000
         end                                                   <<02563>>15090000
      else                                                     <<02563>>15095000
         vcb'density := get'density(ldev);                     <<02563>>15100000
      end;                                                     <<02563>>15105000
                                                               <<02563>>15110000
   if aopactype <> read then                                            15115000
      begin       << write access >>                                    15120000
      attios(12);       << bsr over tm/hdr1 >>                          15125000
      vcb'posn := h1nx;                                        <<02690>>15130000
      end                                                               15135000
   else                                                                 15140000
      begin       << read access; check hdr2 label >>                   15145000
      tlabel := 0;                                             <<02662>>15150000
      tos := attachio(ldev,0,0,@tlabel,read,lblsize,0,0,flags);         15155000
      del;                                                              15160000
      if tos.(13:3) > 2 then errexit(lbtposerr);               <<02648>>15165000
      if lcb'labtyp = 3 then                                            15170000
         ctranslate(1,btlabel,,80);    << from ebcdic >>                15175000
      if ltbuftype = "HDR2" then                                        15180000
         begin        << process hdr2 label. >>                         15185000
                                                               <<02690>>15190000
  <<  if the file is an hp ansi file, always use the  >>       <<02690>>15195000
  <<  hdr2 label to override the fopen foptions.  if  >>       <<02690>>15200000
  <<  the tape is a foreign tape, opening the file    >>       <<02690>>15205000
  <<  as undefined means ignore the hdr2 label format >>       <<02690>>15210000
  <<  field.  otherwise, return fixed for "F" and     >>       <<02690>>15215000
  <<  undefined for "V", "D" and "U". >>                       <<02690>>15220000
                                                               <<02690>>15225000
                                                               <<02690>>15230000
         if lcb'hp then                                        <<06135>>15235000
            begin                                              <<06135>>15240000
            if (l2rfmt = "F") then fopftype := 0               <<06135>>15245000
            else                                               <<06135>>15250000
               if (l2rfmt = "V") or (l2rfmt = "D") then        <<06135>>15255000
                  fopftype := 1                                <<06135>>15260000
               else fopftype := 2;  << undefined >>            <<06135>>15265000
            end                                                <<06135>>15270000
         else     << non-hp tape >>                            <<06135>>15275000
            fopftype :=                                        <<06135>>15280000
               if (fopftype <> 2) and l2rfmt = "F" then 0      <<06135>>15285000
                                                   else 2;     <<06135>>15290000
         recsize := binary'(l2rsize,5);     << bytes >>                 15295000
         blksize := binary'(l2bsize,5);     << bytes >>                 15300000
                                                               <<02690>>15305000
  <<  if the file is not an hp ansi file and is being >>       <<02690>>15310000
  <<  accessed with undefined record format, then use >>       <<02690>>15315000
  <<  the blocksize field for the record size. >>              <<02690>>15320000
                                                               <<02690>>15325000
         if (fopftype = 2) and not lcb'hp then                 <<02690>>15330000
            recsize := blksize;                                <<02690>>15335000
                                                               <<02690>>15340000
         if recsize <> 0 then                                           15345000
            begin                                                       15350000
                                                               <<02690>>15355000
<<   if the label shows carriage control, then we must     >>  <<02690>>15360000
<<   decrement recsize by one since rbsize in fopen will   >>  <<02690>>15365000
<<   add one to recsize for cctl files.                    >>  <<02690>>15370000
                                                               <<02690>>15375000
            if lcb'hp and l2cctl = "C" then                    <<02690>>15380000
               recsize := recsize - 1;                         <<02690>>15385000
                                                               <<02690>>15390000
            if blksize <> 0 then blkfact := blksize/recsize;            15395000
            if lcb'b5000 then recsize := recsize*1;   << patch >>       15400000
            rsiz := -recsize;                                           15405000
            end;                                                        15410000
         if lcb'hp then                                                 15415000
            begin       << process hp features in hdr2 >>               15420000
            if l2ftype = "A" then fopascii := 1;                        15425000
            if l2ftype = "B" then fopascii := 0;                        15430000
            if l2cctl = "C" then fopcctl := 1;                          15435000
            if lcb'lockflg and                                          15440000
               vcb'lockwrd <> l2lock,(8) then errexit(lbtlwerr);        15445000
            end;                                                        15450000
         end         << process hdr2 label >>                           15455000
      else                                                              15460000
         attios(12);     << hdr2 label missing: bsr. >>                 15465000
      vcb'posn := ah2;                                         <<02690>>15470000
      end;     << read >>                                               15475000
   scode := getsir(tltsir);                                             15480000
   if aopactype = read                                         << 8277>>15485000
      then vcb'reel := lcb'reel << set up proper reelswitch >> << 8277>>15490000
      else lcb'reel := 1;       << reset reel set.          >> << 8277>>15495000
   vcb'ascii := fopascii;                                               15500000
   vcb'fseq := lcb'fseq;                                                15505000
   if vcb'vsetopen then                                        <<02563>>15510000
      begin                                                    <<02563>>15515000
      vcb'vsetopen := 0;     << done with vol set open >>      <<02563>>15520000
      if lcb'tape then set'bot'off; <<bot off for labtape>>    <<03581>>15525000
      end;                                                     <<02563>>15530000
poserr:                                                                 15535000
   postvtent(vtbuf,vtaddr,-1);                                          15540000
   postvtent(ltbuf,ltaddr,scode);    << save header lbl info >>         15545000
   end;     << procedure position >>                                    15550000
$page " CKFOREXDATE "                                                   15555000
logical procedure ckforexdate(ldev,access,lbled);              <<06026>>15560000
 value ldev,access,lbled;                                               15565000
 integer ldev,access; logical lbled;                                    15570000
  option uncallable;                                                    15575000
comment                                                        <<04819>>15580000
                                                                        15585000
    called from position, reelswitch, and askop in allocate,   <<06026>>15590000
this procedure determines whether the tape may be written.     <<04819>>15595000
writing is allowed (ckforexdate=false) if the tape is          <<06026>>15600000
unlabelled, or labelled but is permitted by the operator.      <<06026>>15605000
db at the stack.                                               <<04819>>15610000
   access - access mode as in aoptions(12:4), 1 unless call    <<06026>>15615000
              from askop.                                      <<04819>>15620000
   lbled - 2 if the tape is labelled and we don't want to      <<04819>>15625000
           ask the operator for an expired tape (the volids    <<04819>>15630000
           match).                                             <<04819>>15635000
                                                               <<04819>>15640000
           1 if the tape is supposed to be labelled            <<04819>>15645000
                 (per foptions)                                <<04819>>15650000
           0 if unlabelled (askop call only).                  <<04819>>15655000
                                                                        15660000
;                                                              <<04819>>15665000
begin                                                                   15670000
   logical result=ckforexdate;                                 <<06026>>15675000
   integer ltaddr,scode,msg'num;                               <<04819>>15680000
   logical array ltbuf(0:ltesize-1) =q;                                 15685000
      byte array ltbufb(*) = ltbuf;                            <<04819>>15690000
   integer array buffer(0:39);                                          15695000
      byte array bbuf(*) = buffer;                                      15700000
   logical array reply(0:2) =q;                                         15705000
   logical array msg(0:3) = q;                                 <<04819>>15710000
      byte array msgb(*) = msg;                                <<04819>>15715000
                                                                        15720000
 <<  begin execution.  >>                                               15725000
                                                                        15730000
 result := true;      << default: no write. >>                 <<04819>>15735000
   ltaddr := getldev(ldev,ltbuf);                                       15740000
   if < then tapetrouble(tt25);                                <<03581>>15745000
                                                                        15750000
   if lcb'labtyp < 2 then                                      <<06026>>15755000
      result := false                                          <<06026>>15760000
   else       << labelled tape >>                              <<06026>>15765000
      begin                                                    <<04819>>15770000
      if access = 1 and not(lbled=2 land calendar>lcb'exdate)  <<04819>>15775000
        then begin                                             <<04819>>15780000
        << ask if it is ok to write on volume >>               <<04819>>15785000
        move msgb := lcb'volid,(6);                            <<04819>>15790000
        msgb(6) := 0;  << genmsg terminator >>                 <<04819>>15795000
        msg'num := (if calendar > lcb'exdate                   <<04819>>15800000
           then 282 else 291);                                 <<04901>>15805000
        genmsg(1,msg'num,%01000,@msgb,ldev,,,,0,1,@reply);     <<04819>>15810000
   <<291 ok to write on unexpired vol (!) on ldev# \? (y/n)>>  <<04819>>15815000
   <<282 ok to write on expired vol (!) on ldev# \? (y/n)>>    <<04901>>15820000
                                                               <<04819>>15825000
        if reply                                               <<04819>>15830000
          then begin                                           <<04819>>15835000
          lcb'exdate := 0;  << set expired >>                  <<04819>>15840000
          if not lbled                                         <<04819>>15845000
            then lcb'labtyp := 1;                              <<04819>>15850000
          scode := getsir(tltsir);                             <<04819>>15855000
          postvtent(ltbuf,ltaddr,scode);                       <<04819>>15860000
          result := false;                                     <<04819>>15865000
          end;                                                 <<04819>>15870000
        end                                                    <<04819>>15875000
      else result := false;  << ok to write >>                 <<04819>>15880000
      end;    << labelled tape >>                                       15885000
out:    << for i/o errors >>                                   <<04819>>15890000
end;      << procedure ckforexdate >>                          <<06026>>15895000
$page " CKFORLDEV "                                                     15900000
logical procedure ckforldev(ldev);                             <<06026>>15905000
 value ldev;                                                   <<06026>>15910000
 integer ldev;                                                 <<06026>>15915000
 option uncallable;                                            <<06026>>15920000
comment                                                        <<06026>>15925000
                                                               <<06026>>15930000
    called from linklabel, reelswitch, and askop in allocate,  <<06026>>15935000
this procedure determines if the ldev on which the tape is to  <<06026>>15940000
be written is useable.  it's ok if ckforldev=false.            <<06026>>15945000
db is at the stack.                                            <<06026>>15950000
;                                                              <<06026>>15955000
begin                                                          <<06026>>15960000
   logical result=ckforldev;                                   <<06026>>15965000
   integer ltaddr;                                             <<06026>>15970000
   logical array ltbuf(0:ltesize-1) =q;                        <<06026>>15975000
      byte array ltbufb(*) = ltbuf;                            <<06026>>15980000
                                                               <<06026>>15985000
 <<  begin execution.  >>                                      <<06026>>15990000
                                                               <<06026>>15995000
 result := true;      << default: no write. >>                 <<06026>>16000000
 if setowned(ldev,-1) <> 1 then                                <<06938>>16005000
   begin             << ldev is not owned or recognized >>     <<06026>>16010000
   ltaddr := getldev(ldev,ltbuf);                              <<06026>>16015000
   if < then tapetrouble(tt25);                                <<06026>>16020000
   if lcb'labtyp = 0 then      << no tape mounted >>           <<06026>>16025000
      begin                                                    <<06026>>16030000
                                                               <<06026>>16035000
<< on the allocate call, there may be a tape that was          <<06026>>16040000
<< ready when the system came up, so try avr. >>               <<06026>>16045000
                                                               <<06026>>16050000
      if lcb'tape then recognize(ldev)                         <<06026>>16055000
                  else cc := ccl;                              <<06026>>16060000
      if < then go errexit;       << i/o error. >>             <<06026>>16065000
      end;     << tape is again at load point. >>              <<06026>>16070000
   end;                                                        <<06026>>16075000
   result := false;      << ldev is ok >>                      <<06026>>16080000
errexit:                                                       <<06026>>16085000
end;        << procedure ckforldev >>                          <<06026>>16090000
$page " NEXTTAPEFILE "                                                  16095000
integer procedure nexttapefile(fnum);                                   16100000
integer fnum;                                                           16105000
option uncallable;                                                      16110000
                                                                        16115000
<< used by store-restore to advance to the next file on a               16120000
labeled tape.  returns 0, or error code and ccl if error.  >>           16125000
                                                                        16130000
   begin                                                                16135000
   integer vtaddr,ltaddr,scode;                                         16140000
   integer ldev,ltype,loc'acb'stat;                            <<02703>>16145000
   logical array vtbuf(0:vtesize-1) =q;                                 16150000
   logical array ltbuf(0:ltesize-1) =q;                                 16155000
                                                                        16160000
<< error subroutine >>                                                  16165000
                                                                        16170000
subroutine errexit(errcode);                                            16175000
value errcode; integer errcode;                                         16180000
   begin                                                                16185000
   if errcode = lbteovset then cc := ccg;                      <<02648>>16190000
   nexttapefile := errcode;   << report error >>                        16195000
   post'acb'error(fnum,loc'acb'stat,errcode);                  <<02703>>16200000
   go poserr;                                                           16205000
   end;                                                                 16210000
                                                                        16215000
subroutine attios(func);                                       <<02662>>16220000
value func; integer func;                                               16225000
                                                                        16230000
   begin                                                                16235000
   if ldev=0 then tapetrouble(tt5);    << oops! >>             <<03581>>16240000
   tos := attachio(ldev,0,0,0,func,0,0,4,%11);                 <<02689>>16245000
   del;                                                                 16250000
   if s0.(13:3) > 2 then errexit(lbtposerr);                            16255000
   x := tos;                                                            16260000
   end;                                                                 16265000
                                                                        16270000
   cc := ccl;                                                           16275000
   vtaddr := getfnum(fnum,vtbuf);                                       16280000
   if < then tapetrouble(tt52);                                <<03581>>16285000
   if vcb'flush then                                           <<02621>>16290000
      begin          << device unavailable (=reply 0) >>       <<02621>>16295000
      errexit(navaildev);                                      <<06333>>16300000
      end;                                                     <<02621>>16305000
   ldev := vcb'ldev;                                                    16310000
   ltaddr := getldev(ldev,ltbuf);                                       16315000
   if < then tapetrouble(tt53);                                <<03581>>16320000
   if vcb'write then                                                    16325000
      begin        << store: terminate present file. >>                 16330000
      if vcb'posn > h1nx then                                  <<02622>>16335000
         begin                                                 <<02622>>16340000
         if vcb'posn < dnx then attios(6);  << end hdrs >>     <<02662>>16345000
         if writelab(vtbuf,1) then errexit(lbtposerr); << tm,eof1&2 >>  16350000
         attios(6);        << wtm ending trlr lbls >>          <<02662>>16355000
         vcb'fseq := vcb'fseq+1;    << at next file >>         <<02622>>16360000
         end;                                                  <<02622>>16365000
      vcb'posn := h1nx;                                        <<02622>>16370000
      lcb'fseq := vcb'fseq;                                    <<r7493>>16375000
      end                                                               16380000
   else                                                                 16385000
      begin       << restore: advance tape to next file. >>             16390000
      if vcb'posn < dnx then attios(7);   << skip hdr lbls >>  <<02662>>16395000
skip:                                                                   16400000
      attios(7);               << fsf over data >>             <<02662>>16405000
      ltype := check1(ltbuf);   << read eof1/eov1 >>                    16410000
      if ltype = 2 then                                                 16415000
         begin        << eov found; need next reel. >>                  16420000
         attios(12);    << bsr over eov1 >>                    <<02662>>16425000
         reelswitch(ldev,if vcb'posn > dnx then 0 else 2);              16430000
         if < then errexit(navaildev);    << never return... >><<06333>>16435000
         if > then errexit(lbtposerr);    << not eov1?? >>              16440000
         getxdsw(vtbuf,tltdst,vtaddr,vtesize);                          16445000
         getxdsw(ltbuf,tltdst,ltaddr,ltesize);                          16450000
         vcb'rswdone := 1;                                     <<02690>>16455000
         go skip;                                                       16460000
         end;                                                           16465000
      if ltype <> 1 then errexit(lbtfmterr);   << should be eof1. >>    16470000
      attios(7);         << fsf over trlr lbls >>              <<02662>>16475000
      vcb'reel := 1;                                           <<02622>>16480000
      ltype := check1(ltbuf);     << read tm/hdr1 >>                    16485000
      if < then errexit(lbtposerr);                                     16490000
      if ltype > 0 then errexit(lbtfmterr);  << wasn't >>               16495000
      if ltype < 0 then errexit(lbteovset);                             16500000
      attios(11);        << fsr over hdr2 label >>             <<02662>>16505000
      vcb'posn := ah2;                                         <<02690>>16510000
      vcb'fseq := lcb'fseq;                                    <<02622>>16515000
      end;                                                              16520000
   cc := cce;                                                           16525000
   scode := getsir(tltsir);                                             16530000
   postvtent(vtbuf,vtaddr,-1);                                          16535000
   postvtent(ltbuf,ltaddr,scode);    << save header lbl info >>         16540000
   fcontrol(fnum,5,fnum);   << reset block xfer count >>                16545000
poserr:                                                                 16550000
   end;        << procedure nexttapefile >>                             16555000
$page " LDIRECTF "                                                      16560000
logical procedure ldirectf(fnum);                                       16565000
   value fnum; integer fnum;                                            16570000
 option uncallable;                                                     16575000
                                                                        16580000
<< called from fstore in store after writing a file to see              16585000
if a reelswitch occurred somewhere in the middle of the file.           16590000
if so, fstore will write a directory file following the                 16595000
(partial) file just written on the new reel.  db at the stack.  >>      16600000
                                                                        16605000
   begin                                                                16610000
   integer vtaddr,scode;                                                16615000
   logical array vtbuf(0:vtesize-1) =q;                                 16620000
                                                                        16625000
   scode := getsir(tltsir);                                             16630000
   vtaddr := getfnum(fnum,vtbuf);                                       16635000
   if < then tapetrouble(tt27);                                <<03581>>16640000
   ldirectf := vcb'writdir;                                             16645000
   vcb'writdir := 0;                                                    16650000
   postvtent(vtbuf,vtaddr,scode);                                       16655000
   end;     << procedure ldirectf >>                                    16660000
$page " LRELSW "                                                        16665000
logical procedure lrelsw(fnum);                                <<0615>> 16670000
   value fnum; integer fnum;                                            16675000
 option uncallable;                                                     16680000
                                                                        16685000
<< store/restore: check and reset reelswitch done bit. callers:         16690000
  writetape for fstore. if reelswitch, write header label.              16695000
  irestore to set store tape bit.                                       16700000
  readtape of frestore. if reelswitch, skip directory file.             16705000
db at stack.  >>                                                        16710000
                                                                        16715000
   begin                                                                16720000
   integer vtaddr,scode;                                                16725000
   logical array vtbuf(0:vtesize-1) =q;                                 16730000
                                                                        16735000
   scode := getsir(tltsir);                                             16740000
   vtaddr := getfnum(fnum,vtbuf);                                       16745000
   if < then tapetrouble(tt29);                                <<03581>>16750000
   lrelsw := vcb'rswdone;                                               16755000
   vcb'rswdone := 0;                                                    16760000
   vcb'stortap := 1;                                                    16765000
   postvtent(vtbuf,vtaddr,scode);                                       16770000
   end;        << procedure lrelsw >>                                   16775000
$page " PVOLID "                                                        16780000
integer procedure pvolid(ldev,buf);                                     16785000
value ldev; integer ldev;                                               16790000
byte array buf;                                                         16795000
option uncallable;                                                      16800000
                                                                        16805000
<< used by :showdev in opcommand to print volume id >>         <<07338>>16810000
<< and tape density (for variable density drives).  >>         <<02616>>16815000
                                                                        16820000
   begin                                                                16825000
   logical array ltbuf(0:ltesize-1);                                    16830000
      buildlcb;                                                         16835000
   equate                                                      <<02616>>16840000
      labelpos    = 6,   << buffer rel. index for label type >><<02616>>16845000
      densitypos  = 14,  << buffer rel. index for density >>   <<02616>>16850000
      volidlen    = 50,  << total line len. including volid >> <<07338>>16855000
      densitylen  = 56;  << total line len. including dens. >> <<07338>>16860000
   integer                                                     <<02616>>16865000
      lpdt'index,                                              <<06333>>16870000
      density;                                                 <<02616>>16875000
                                                                        16880000
   cc := ccl;                                                  <<02648>>16885000
   getldev(ldev,ltbuf);                                                 16890000
   if < then return;         << not a tape. >>                          16895000
   case lcb'labtyp of                                                   16900000
      begin                                                             16905000
      return;                      << 0 >>                              16910000
      move buf := "(Nolabel)";     << 1 >>                     <<02616>>16915000
                                                               <<02616>>16920000
      begin                        << 2 >>                     <<02616>>16925000
      move buf := lcb'volid,(6);                               <<02616>>16930000
      move buf(labelpos) := "(ANSI)";                          <<02616>>16935000
      end;                                                     <<02616>>16940000
                                                               <<02616>>16945000
      begin                        << 3 >>                     <<02616>>16950000
      move buf := lcb'volid,(6);                               <<02616>>16955000
      move buf(labelpos) := "(IBM)";                           <<02616>>16960000
      end;                                                     <<02616>>16965000
                                                               <<02616>>16970000
      end;                                                              16975000
   pvolid := volidlen;                                         <<02616>>16980000
   cc := cce;   << a tape is mounted on drive. >>              <<02673>>16985000
                                                               <<02616>>16990000
<< if variable density drive, report tape density >>           <<02616>>16995000
                                                               <<02616>>17000000
   lpdt'index := ldev * size'of'lpdt'entry;                    <<06333>>17005000
   if (variable'density) then                                  <<02616>>17010000
      begin                                                    <<02616>>17015000
      density := get'density(ldev);                            <<02616>>17020000
      if density <= ldt'density'800 then                       <<07339>>17025000
         begin                                                 <<02616>>17030000
         case density of                                       <<02616>>17035000
            begin                                              <<02616>>17040000
            return;                          << 0 - null >>    <<02616>>17045000
            move buf(densitypos) := "1600";  << 1 - den'1600 >><<02616>>17050000
            move buf(densitypos) := "6250";  << 2 - den'6250 >><<02616>>17055000
            move buf(densitypos) := "800";   << 3 - den7800  >><<07339>>17060000
            end;                                               <<02616>>17065000
         pvolid := densitylen;                                 <<02616>>17070000
         end;   << of valid density >>                         <<02616>>17075000
      end;   << of variable density drive >>                   <<02616>>17080000
   end;         << procedure pvolid >>                                  17085000
$page " TGETINFO "                                                      17090000
procedure tgetinfo(ldev,fbuf,itemnum);                                  17095000
   value ldev,itemnum; integer ldev,itemnum;                            17100000
   array fbuf;                                                          17105000
   option uncallable;                                                   17110000
                                                                        17115000
<< called from ffileinfo in fileio to report various tape label         17120000
info items to the user. >>                                              17125000
                                                                        17130000
   begin                                                                17135000
   byte array fbufb(*) = fbuf;                                          17140000
   logical legal'call;                                         <<04612>>17145000
   logical array ltbuf(0:ltesize-1) =q;                                 17150000
      buildlcb;                                                         17155000
                                                                        17160000
   legal'call := true;                                         <<04612>>17165000
   getldev(ldev,ltbuf);                                                 17170000
   if < or lcb'labtyp < 2 then    << not labeled tape. >>      <<04612>>17175000
     legal'call := false;                                      <<04612>>17180000
   case itemnum of                                                      17185000
    begin                                                               17190000
      begin       << 00 volume id >>                                    17195000
      if legal'call then                                       <<04612>>17200000
        move fbufb := lcb'volid,(6)                            <<04612>>17205000
      else move fbufb := "      ";                             <<04612>>17210000
      end;                                                              17215000
                                                                        17220000
      begin      << 01 volume set id >>                                 17225000
      if legal'call then                                       <<04612>>17230000
        move fbufb := lcb'vsetid,(6)                           <<04612>>17235000
      else move fbufb := "      ";                             <<04612>>17240000
      end;                                                              17245000
                                                                        17250000
      begin      << 02 expiration date >>                               17255000
      fbuf := if legal'call then lcb'exdate else -1;           <<04612>>17260000
      end;                                                              17265000
                                                                        17270000
      begin      << 03 file seq number >>                               17275000
      fbuf := if legal'call then lcb'fseq else -1;             <<04612>>17280000
      end;                                                              17285000
                                                                        17290000
      begin      << 04 reel number >>                                   17295000
      fbuf := if legal'call then lcb'reel else -1;             <<04612>>17300000
      end;                                                              17305000
                                                                        17310000
      begin      << 05 seq type >>                                      17315000
      fbuf := if legal'call then 0 else -1;  << lcb'seqtyp;  >><<04612>>17320000
      end;                                                              17325000
                                                                        17330000
      begin      << 06 creation date >>                                 17335000
      fbuf := if legal'call then lcb'cdate else -1;            <<04612>>17340000
      end;                                                              17345000
                                                                        17350000
      begin      << 07 label type >>                                    17355000
      fbuf := if legal'call then lcb'labtyp else -1;           <<04612>>17360000
      end;                                                              17365000
                                                                        17370000
      begin      << 08 tape file name >>                                17375000
      if legal'call then                                       <<04612>>17380000
        begin                                                  <<04873>>17385000
        move fbufb := lcb'fname,(17);                          <<04873>>17390000
        end                                                    <<04873>>17395000
      else                                                     <<04873>>17400000
        begin                                                  <<04873>>17405000
        move fbufb := "                 ";                     <<04873>>17410000
        end;                                                   <<04873>>17415000
      end;                                                              17420000
                                                                        17425000
    end;                                                                17430000
    if legal'call then                                                  17435000
      cc := cce                                                         17440000
    else cc := ccl;                                                     17445000
   end;     << procedure tgetinfo >>                                    17450000
$page " CLEANTAPE "                                                     17455000
procedure cleantape(pinno);                                             17460000
value pinno; logical pinno;                                             17465000
option uncallable;                                                      17470000
                                                                        17475000
<< called from morgue at process termination, following call            17480000
to fprocterm.  files which were closed to close volume but              17485000
not volume set will have volume entries remaining in the tlt            17490000
which we remove here.  freedevice is called to return associated        17495000
tape drives to the available pool and rewind them.  >>                  17500000
                                                                        17505000
   begin                                                                17510000
   logical vtaddr;                                                      17515000
   integer ldev,scode;                                                  17520000
   double vtbounds;                                                     17525000
      logical vtbase = vtbounds;                                        17530000
      logical vttop = vtbounds+1;                                       17535000
   logical array vtbuf(0:vtesize-1) =q;                                 17540000
      buildvcb;                                                         17545000
   logical wait := false;                                      <<02673>>17550000
                                                                        17555000
   scode := getsir(tltsir);                                             17560000
   getxdsw(vtbounds,tltdst,xvtbase,2);                                  17565000
   vtaddr := vtbase;                                                    17570000
   while vtaddr < vttop do                                              17575000
      begin      << search volume entries >>                            17580000
      getxdsw(vtbuf,tltdst,vtaddr,vtesize);                             17585000
      if inuse and vcb'pin=pinno then                                   17590000
         begin         << release volume entry. >>                      17595000
         ldev := vcb'ldev;                                              17600000
         if <> then                                                     17605000
            begin      << release ldev. >>                              17610000
            relsir(tltsir,scode);                                       17615000
            freedevice(ldev,wait);                                      17620000
            if not (tape'device)                               <<03634>>17625000
              then fors'xds'dealloc(ldev);                     <<03634>>17630000
            scode := getsir(tltsir);                                    17635000
            cleanldev(ldev);                                            17640000
            end;                                                        17645000
         vtbuf := 0;                                                    17650000
         move vtbuf(1) := vtbuf,(vtesize-1);                            17655000
         postvtent(vtbuf,vtaddr,-1);                                    17660000
         end;                                                           17665000
      vtaddr := vtaddr+vtesize;                                         17670000
      end;                                                              17675000
   relsir(tltsir,scode);                                                17680000
   end;             << procedure cleantape >>                           17685000
$page " OUTER BLOCK "                                                   17690000
$control segment=outerblock                                             17695000
end.                                                                    17700000
