!IBM magtape library

%include "Labels.inc"
%include "MTdefs.inc"
%include "EBCDIC.inc"
%include "IBMprocs.inc"

%const %integer true = 0,  false = 1     {Pseodo-Booleans}

!Signals
%const %integer MT err = 13,  { & subevents... }
                No such drive = 1,
                Already claimed = 2,
                Bad Vol = 3,
                Wrong Vol = 4,
                Chan open = 5,
                 Not open = 6,
                      EOF = 7,
                      EOT = 8,
            invalid label = 9,
    Unimplemented feature = 10

   %routine error (%integer code, extra)
      %const %string(31) %array text(1:10) =
         "no such channel",
         "tape in use",
         "tape is not IBM labelled",
         "label does not match tape",
         "channel in use",
         "channel not open",
         "end of file",
         "end of tape",
         "incorrect file labels",
         "unimplemented feature"
      event_message = "unknown error"
      event_message = text(code) %if 0 < code <= 10
      %signal %event MT err, code, extra
   %end

%record %format Buf fm  (%byte %array B(0:2047))
%own %record(buf fm) buffer

%record %format chan fm (                %c
        %integer     Vflags,             {Flags from LOAD MT call}
                     Flags,              {Copied from OPEN MT call}
                     Count,              {Relative file position in tape}
                     Block size,         {bytes}
                     Rec len,
                     Output,             {Bool: chan open for output}
                     Block count,        {Relative block position in file}
                     Open,               {Bool: File open on this channel?}
                     Free,               {Bool: Chan not connected to a vol?}
        %string(17)  File,               {Name of open dataset}
        %byte %array Vol ID(1:6),        {Name of vol. mounted on chan}
        %byte %name  BP,                 {Next free byte in buffer}
        %integer     Used,               {No. of bytes used in buffer on output}
                     Left,               {No. of bytes read from buf on input}
        %record(buffm)%name buffer)      {Ptr. to buffer area}
%own %record(chan fm) %array chan table(1:1)

   %routine put (%record(chanfm)%name chan, %integer w)
      %integer j
      %for j = 24, -8, 0 %cycle
         chan_bp = w>>j & x'FF'
         chan_bp == chan_bp ++ 1
      %repeat
      chan_used = chan_used + 4
   %end

   %routine get (%record(chanfm)%name chan, %integer %name w)
      %integer j
      w = 0
      %for j = 1,1,4 %cycle
         w = w<<8 ! chan_bp
         chan_bp == chan_bp ++ 1
      %repeat
      chan_left = chan_left - 4
   %end

   %external %routine MOVE (%integer N, %name from,to)
      %byte %name f == byte integer(addr(from)),
                  t == byte integer(addr(to))
      %integer j
      %for j = 1,1,N %cycle
         t = f
         t == t ++ 1;  f == f ++ 1
      %repeat
   %end

   %external %string(*) %map STRING OF (%integer bytes, %name where)
      %own %byte %array copy(0:63)
      Move (bytes, where, copy(1))
      copy(0) = bytes
      %result == string(addr(copy(0)))
   %end

   %external %routine MOVE STRING (%string(255) s, %name to)
      MOVE (length(s), char no(s,1), to)
   %end

   %external %routine FILL (%name buffer, %integer fill char, bytes)
      %byte %name b == byte integer(addr(buffer))
      %integer j
      %for j = 1,1,bytes %cycle
         b = fill char
         b == b ++ 1
      %repeat
   %end

   %external %string(*) %map FIELD (%integer width, %string(*)%name sn)
      %own %string(80) s
      s = sn
      s = s . " " %while length(s) < width
      length(s) = width %if length(s) > width
      %result == s
   %end

   %external %predicate EQUAL (%integer bytes, %name buf1, buf2)
      %byte %name x == byte integer(addr(buf1)),
                  y == byte integer(addr(buf2))
      %integer j
      %for j = 1,1,bytes %cycle
         %false %if x # y
         x == x ++ 1;  y == y ++ 1
      %repeat
      %true
   %end

   %string(31) %map ItoS (%integer N,places)
      %own %string(31) s
      s = ""
      %cycle
         s = to string('0'+rem(N,10)) . s
         N = N//10
      %repeat %until N = 0
      s = "0".s %while length(s) < places
      %result == s
   %end

   %external %integer %function StoI (%string(31) s)
      %integer sign = 1, val = 0, j
      %byte %name b
      %for j = 1,1,length(s) %cycle
         b == char no(s,j)
         %if b = '-' %start
            sign = -sign
         %else %unless '0' <= b <= '9'
            %signal 10,0,b
         %else
            val = 10*val + (b-'0')
         %finish
      %repeat
      %result = sign*val
   %end

   %external %routine CLAIM MT (%integer N, wait)
      error(no such drive,N) %if N # 1
      %cycle
         Claim tape
         %exit %if tape error = 0
         Select output (0)
         Print string ("*Warning: Tape force-released")
         Newline
         Release tape
      %repeat
   %end

   %external %routine RELEASE MT (%integer which)
      error(no such drive,which) %if which # 1
      error(chan open,which) %if chan table(which)_open = true
      Release tape
   %end

   %routine find (%record(chanfm)%name chan, %integer file no)
      {File no is absolute (1..N).   We navigate there
      {by dead reckoning on the CHAN_COUNT field.
      %record(label) L
      file no = 1 %if file no <= 0
      %while chan_count < file no %cycle
         Read tape (addr(L),80)
         Backspace %and %exit %if TM # 0
         skip forward;  skip forward;  skip forward
         chan_count = chan_count + 1
      %repeat
      %while chan_count > file no %cycle
         skip reverse;  skip reverse;  skip reverse
         Backspace;  backspace
         chan_count = chan_count - 1
      %repeat
   %end

   %external %routine LOAD MT (%integer channel, flags, %string(6) volume)
      %record(chan fm)%name chan
      %record(label) V
      error(no such drive,channel) %if channel # 1
      chan == chan table(channel)
      error(chan open,channel) %unless chan_free = true
      chan_free = false
      chan_Vflags = flags
      chan_count = 1                     {Relative file# within volume}
      chan_buffer == buffer
      chan_open = false                  {No file currently open}
      Rewind
      Read tape (addr(V),80);  to ISO (80,V)
      
      {Check VOL1 label}

      Move string (field(6,volume), chan_Vol ID(1))
      error(bad vol,0) %if V_vol1 # m'VOL1'
      error(wrong vol,0) %unless equal (6,V_serial no(1),chan_volid(1))
      
      Find (chan,999999) %if flags&append # 0

   %end {of LOAD MT}


   %routine set label 1 (%record(chanfm)%name chan, %record(label)%name H)
      Fill (H,' ',80)
      Move string (chan_file, H_file(1))
      Move (6, chan_vol ID(1), H_file serial(1))
      Move string ("0001", H_vol seq(1))
      Move string (ItoS(chan_count,4), H_file seq(1))
      Move string (" 00000", H_created(1))
      Move string (" 00000", H_expires(1))
      H_lock = '0'
      Move string ("000000", H_Blocks(1))
      Fill (H_system(1), 0, 13)
   %end

   %routine set label 2 (%record(chanfm)%name chan, %record(label)%name H)
      Fill (H,' ',80)
      H_format = 'F'                     {Fixed records only as yet}
      Move string (ItoS(chan_block size,5), H_block len(1))
      Move string (ItoS(chan_rec len,5), H_record len(1))
      H_density = '2'                    {800bpi NRZI}
      H_DSP = '0'
      H_Job ID(9) = '/'
      %if chan_flags&variable # 0 %then H_format = 'V' %c
                                  %else H_format = 'F'
      %if chan_flags&unblocked# 0 %then H_attrib = ' ' %c
                                  %else H_attrib = 'B'
   %end

   %external %routine OPEN MT IN  (      %c
             %integer channel,
             %string(17) filename,
             %integer File no,
                      Record length, Block size,
                      Flags)
      %own %string(23) %array HDR1 errors(1:4) =
         "not found",
         "Volume serial no. wrong",
         "File sequence no. wrong",
         "Nonzero block count"
      %own %string(23) %array HDR2 errors(1:6) =
         "Record length mismatch",
         "Block size mismatch",
         "Wrong density code?",
         "Multireel dataset!",
         "Spanned records!",
         "Record format mismatch"

      %routine show errors (%string(31) where, %integer mask,
                            %string(23) %array %name text)
         %integer j, k = 0
         %for j = 1,1,32 %cycle
            %if mask&k # 0 %start
               Print string ("*".where." -- ".text(j))
               Newline
            %finish
            k = k<<1
         %repeat
      %end

      %record(label) L
      %record(chan fm)%name chan
      %integer err {mask},  j
      %byte %array dataset(1:17)
      Move string (field(17,filename), dataset(1))
      block size = record length %if block size < record length
      block size = block size//record length * record length

      error(no such drive,channel) %if channel # 1
      chan == chan table(channel)
      error(chan open,channel) %if chan_open = true

      {Set up channel control block}

      chan_file = filename
      chan_block size = block size
      chan_rec len = record length
      chan_output = false
      chan_block count = 0
      chan_flags = flags
      chan_bp == byte integer(addr(chan_buffer))
      chan_left = 0

      Find (chan,file no)

      {Check file header labels}

      Read tape (addr(L),80)
      Backspace %and error(EOT,channel) %if TM # 0
      To ISO (80,L)
      err = 0
      err = 1      %if  L_label1 # m'HDR1'
      err = err+2  %if  filename#"" %and %not equal(17,dataset(1),L_file(1))
      err = err+4  %if  %not equal(6,L_file serial(1), chan_Vol ID(1))
      err = err+8  %if  %not equal(4,ItoS(chan_count,4), L_file seq(1))
      err = err+16 %if  %not equal(6, ItoS(0,6), L_Blocks(1))
      Show errors ("File HDR1 label", err, HDR1 errors)

      Read tape (addr(L),80)
      To ISO (80,L)
      error(unimplemented feature,0) %if 'V' # L_format # 'F'
      err = 0
      err = 1      %if  Record length # 0 %and
                        Record length # StoI(string of(5,L_record len(1)))
      err = err+2  %if  Blocksize # 0     %and
                        Blocksize # StoI(string of(5,L_Block len(1)))
      err = err+4  %if  L_density#2 %or L_how(1)#' ' %or L_how(2)#' '
      err = err+8  %if  L_DSP # '0'
      err = err+16 %if  L_attrib # 'B'
      j = chan_flags
      j = j&(~variable) %if L_format = 'F'
      j = j!variable %if L_format = 'V'
      err = err+32 %if  j # chan_flags
      chan_flags = j                     {Override}
      Show errors ("File HDR2 label", err, HDR2 errors)

      Skip forward                       {Past any UHL's}
      chan_open = true
   %end

   %external %routine READ MT (%integer channel,
                               %integer %name bytes, %name buffer)
      %record(chan fm) %name chan
      %integer j, BDW
      error(no such drive,channel) %if channel # 1
      chan == chan table(channel)
      error(not open,channel) %unless chan_open = true

      %if chan_left = 0 %or chan_flags&unblocked # 0 %start
         Read tape (addr(chan_buffer), chan_block size+15)
         Backspace %and error(EOF,channel) %if TM # 0
         chan_left = bytes transferred   {Less than whole block read?}
         chan_bp == Byte integer(addr(chan_buffer))
         chan_block count = chan_block count + 1
         %if chan_flags&variable # 0 %start
            Get (chan,BDW)
!           %if BDW>>16 # chan_left+4 %start
!              Print string ("*Length count wrong in block")
!              Write (chan_block count,1)
!              Print string (" of file")
!              Write (chan_count,1)
!              Print symbol (':')
!              Write (BDW>>16,1)
!              Print symbol ('#')
!              Write (chan_left+4,0)
!              Newline
!           %finish
            chan_left = BDW>>16 - 4      {Believe BDW not transfer length}
         %finish
      %finish

      %if chan_flags&variable # 0 %start
         Get (chan,bytes)
         bytes = bytes>>16 - 4
         Move (bytes, chan_bp, buffer)
         chan_bp == chan_bp ++ bytes
         chan_left = chan_left - bytes
      %else
         bytes = chan_rec len %if bytes > chan_rec len
         Move (bytes, chan_bp, buffer)
         chan_bp == chan_bp ++ chan_rec len
         chan_left = chan_left - chan_rec len
      %finish

      To ISO(bytes,buffer) %if chan_Vflags&ISO = 0
   %end

   %external %routine OPEN MT OUT (      %c
             %integer channel,
             %string(17) filename,
             %integer File no,
                      Record length, Block size,
                      Flags)
      %record(label) H
      %record(chan fm) %name chan
      error(no such drive,channel) %if channel # 1
      chan == chan table(channel)
      block size = record length %if block size < record length
      block size = block size//record length * record length   {exact multiple}
      error(chan open,channel) %if chan_open = true

      chan_open = true                   {Set channel control block}
      chan_file = filename
      chan_block size = block size
      chan_rec len = record length
      chan_output = true
      chan_block count = 0
      chan_flags = flags
      chan_bp == byte integer(addr(chan_buffer))
      chan_used = 0

      Find (chan,file no)

      Set label 1 (chan,H)               {Build header labels}
      H_label1 = m'HDR1'
      To EBCDIC (80,H)
      Write tape (addr(H),80)

      Set label 2 (chan,H)
      H_label2 = m'HDR2'
      %if flags&variable # 0 %start
         Put (chan,0)                    {Hole for BDW at start of buffer}
      %finish
      To EBCDIC (80,H)
      Write tape (addr(H),80)

      Tape mark
   %end

   %routine flush out (%record(chan fm)%name chan)
      %integer j = chan_used
      %if j # 0 %start
         %while j < 18 %or j&1 # 0 %cycle
            {**** system doesn't like odd-length transfers ****}
            {**** IBM don't like blocks less than 18 bytes ****}
            chan_bp = 0
            chan_bp == chan_bp ++ 1
            j = j + 1
         %repeat
         %if chan_flags&variable # 0 %start   {Fill BDW hole}
            chan_bp == byte integer(addr(chan_buffer))
            Put (chan,chan_used<<16)
         %finish
         Write tape (addr(chan_buffer), j)
         chan_block count = chan_block count + 1
      %finish
      chan_bp == byte integer(addr(chan_buffer))
      chan_used = 0
      Put (chan,0) %if chan_flags&variable # 0   {Hole for BDW}
   %end

   %external %routine WRITE MT (%integer channel,
                                %integer %name bytes, %name buffer)
      %record(chan fm)%name chan
      %integer blank, j
      error(no such drive,channel) %if channel # 1
      chan == chan table(channel)
      error(not open,channel) %unless chan_open = true
      bytes = chan_rec len %if bytes > chan_rec len
      %if chan_flags&variable = 0 %start
         Flush out(chan) %if chan_used+chan_reclen > chan_block size %or
                             chan_flags&unblocked # 0
         Move (bytes, buffer, chan_bp)
         To EBCDIC (bytes,chan_bp) %if chan_Vflags&ISO = 0
         chan_bp == chan_bp ++ bytes
         chan_used = chan_used + bytes
         blank = ItoE(' ')
         %for j = 1,1, chan_reclen-bytes %cycle   {Pad out fixed record}
            chan_bp = blank
            chan_bp == chan_bp ++ 1
            chan_used = chan_used + 1
         %repeat
      %else                              {variable records}
         bytes = bytes+4                 {RDW included}
         Flush out(chan) %if chan_used+bytes > chan_block size %or
                             (chan_flags&unblocked # 0 %and chan_used > 4)
         Put (chan,bytes<<16)
         bytes = bytes - 4               {lose RDW}
         Move (bytes, buffer, chan_bp)
         To EBCDIC (bytes,chan_bp) %if chan_Vflags&ISO = 0
         chan_bp == chan_bp ++ bytes
         chan_used = chan_used + bytes
      %finish
   %end

   %external %routine CLOSE MT (%integer channel)
      %record(chan fm)%name chan
      %record(label) L
      error(no such drive,channel) %if channel # 1
      chan == chan table(channel)
      %return %unless chan_open = true
      chan_open = false
      %if chan_output = true %start
         Flush out (chan)                {Last (or only) data block ->
         Tape mark

         Set label 1 (chan,L)            {write trailer labels
         L_label1 = m'EOF1'
         Move string (ItoS(chan_block count,6), L_Blocks(1))
         To EBCDIC (80,L)
         Write tape (addr(L),80)

         Set label 2 (chan,L)
         L_label2 = m'EOF2'
         To EBCDIC (80,L)
         Write tape (addr(L),80)

         Tape mark;  tape mark           {**EOT**}
         Backspace                       {Next file will scrub last TM}
      %else
         Skip forward                    {past end of user file}
         Skip forward                    {Past trailer labels}
      %finish

      chan_count = chan_count + 1        {One file processed}
   %end

   %external %routine UNLOAD MT (%integer channel)
      %record(chan fm)%name chan
      error(no such drive,channel) %if channel # 1
      chan == chan table(channel)
      error(chan open,channel) %if chan_open = true
      Rewind
      chan_free = true
   %end

%end %of %file