!Mag tape archiving program

%begin
   %conststring(10) version = "1.4"
   %constinteger H = x'FFFF'
   %recordformat parmfm(%shortinteger dsno, dact, ssno, sact, %c
                        %integer p1, p2, p3, p4, p5, p6)
   %recordformat filefm(%integer name1, name2, %c
                        %shortinteger spine, day)
   %recordformat dirfm(%shortinteger mark, %c
                       %byteinteger access, check, %c
                       %shortinteger chain, %c
                       %byteinteger spare, daccess, %c
                       %record(filefm)%array file(1:42))
   %recordformat packfm(%integer unit, owner, name1, name2)
   %recordformat blockfm(%string(59) text, %shortinteger index, spare)
   %record(blockfm) BL
   %owninteger file number = 0
   %integer exclam;  exclam = comreg(2)

   %record(packfm) F
   %record(packfm) owner
   %ownstring(63) em = "***end***"
   %ownstring(63) eot= "***end of tape***"
   %string(63) unit, username
   %ownstring(63) head text = "***no label***"
   %string(63) word, key
   %owninteger sym = ' ', sp = ' ', used = 0
   %string(15)%name int
   %integer error, unit no, x
   %constinteger user list = 301
   %byteintegerarray b(0:2047)

   %routinespec release tape
   %routinespec rewind

   %routine prepare terminal
      %record(parmfm) P
      p_p1 = 1;  p_p2 = 0;  p_p3 = 0;  svc(29, p); !width=0
      p_p1 = 2;  p_p2 = 0;  p_p3 = 0;  svc(29, p); !page =0
      p_p1 = 100000;  svc(21, p);                  !time =100000
   %end
   %routine stop
      rewind
      release tape
      %stop
   %end
   %routine report(%string(63) text, %integer value)
      selectoutput(0)
      printstring(text)
      write(value, 0) %if value # 0
      newline
      selectoutput(1)
   %end
   %routine pack(%string(31) file, %record(packfm)%name f)
      %record(parmfm) P
      string(addr(p_sact)) = file
      svc(17, p)
      f_unit = p_p1
      f_owner = p_p2
      f_name1 = p_p3
      f_name2 = p_p4
   %end
   %routine unpack(%record(packfm)%name f, %string(31)%name file)
      %record(parmfm) p
      p_p1 = f_unit
      p_p2 = f_owner
      p_p3 = f_name1
      p_p4 = f_name2
      svc(18, p)
      file = string(addr(p_sact))
   %end

   %routine read block(%integer block no, %record(dirfm)%name dir)
      %record(parmfm) p
      p_sact = 1
      p_p1 = block no&H
      p_p2 = addr(dir)
      p_p3 = unit no
      p_p4 = 0
      svc(101, p)
      %if p_p1 # 0 %start
         select output(0)
         printstring("Read block ")
         write(block no, 0)
         printstring(" on unit ");  write(unit no, 0)
         printstring(" fails ");  write(p_p1, 0)
         newline
         stop
      %finish
   %end

   %routine read sym
      readsymbol(sym)
      sym = sym-32 %if 'a' <= sym <= 'z'
   %end
   %routine read(%integername n)
      %integer s
      n = 0
      %cycle
         read sym
         %return %if sym = nl
         %unless '0' <= sym <= '9' %start
            n = -1
            printstring("Invalid file number");  newline
            %return
         %finish
         n = n*10+(sym-'0')
      %repeat
   %end
   %routine read word(%string(63)%name s)
      s = ""
      read sym %while sym = ' '
      %cycle
         %exit %if sym = sp %or sym = nl
         s = s.tostring(sym)
         read sym
      %repeat
      sp = ' '
   %end

!Tape operations

   %routine claim tape
      %record(parmfm) p
      p_dact = 1;  svc(105, p)
      report("Tape already claimed - force released", 0) %if p_p6 # 0
   %end
   %routine release tape
      %record(parmfm) p
      p_dact = 2;  svc(105, p)
   %end
   %routine function(%integer n)
      %record(parmfm) p
      p_dact = 10;  p_p1 = n;  svc(105, p)
      error = p_p6
   %end
  %routine clear
      function(1)
      report("Clear fails ", error) %if error # 0
   %end
   %routine tape mark
      function(2)
      report("Tape mark fails ", error) %if error # 0
   %end
   %routine rewind
      function(3)
   %end
   %routine skip forward
      function(4)
      report("Skip forward fails ", error) %if error # 0
   %end
   %routine skip reverse
      function(5)
      report("Skip reverse fails ", error) %if error # 0
   %end
   %routine backspace
      function(6)
      report("Backspace fails ", error) %if error # 0
   %end
   %routine read tape(%integer buffer, size)
      %record(parmfm) p
      p_dact = 8;  p_p2 = buffer;  p_p4 = size
      svc(105, p)
      error = p_p6
   %end
   %routine writetape(%integer buffer, size)
      %record(parmfm) p
      p_dact = 9;  p_p2 = buffer;  p_p4 = size
      svc(105, p)
      error = p_p6
   %end

   %integerfn find unit no(%integer packed unit)
      %record(parmfm) p
      %result = 0 %if packed unit = 0
      p_dact = 45;  p_p1 = packed unit;  svc(20, p)
      %if p_p6 # 0 %start
         report(string(addr(p_p1)), p_p6)
         %result = 0
      %finish
      %result = p_p1
   %end
   %routine terminate
      %record(blockfm) bl
      bl_text = eot
      bl_index = file number
      write tape(addr(em), 63)
      tape mark
      write tape(addr(BL), 63)
   %end
   %routine skip to end
      %record(blockfm) BL
      function(5);      !skipr
      %cycle
         skip forward
         read tape(addr(bl), 63)
         %exit %if bl_text = eot
      %repeat
      file number = bl_index
      backspace
   %end
   %routine dump header
      %string(63) h
      skip to end
      h = head text." on ".date." at ".time
      write tape(addr(h), 63)
      printstring("Adding label - ");  printstring(h);  newline
   %end

   %routine dump file(%record(filefm)%name file)
      %record(blockfm) BL
      %integer p, s, index, bp
      %byteintegerarray buf(1:512)
      %record(parmfm) fp, ap
      %record(packfm) f
      %return %if file_name2 = 0
      f_unit = owner_unit;  f_owner = owner_owner
      f_name1 = file_name1;  f_name2 = file_name2
      unpack(f, bl_text)
      fp_p1 = f_unit
      fp_p2 = f_owner
      fp_p3 = f_name1
      fp_p4 = f_name2
      ap = fp;                     !save for later
      fp_dact = 4
      svc(20, fp)
      index = fp_p5
      %if fp_p6 # 0 %start
         report("Cannot open ".BL_text." -- ".string(addr(fp_p1)), 0)
         %return
      %finish
      %if used # 0 %and fp_p4&x'C000' = 0 %start
         fp_dact = 11;  fp_p5 = index;  svc(20, fp)
         %return
      %finish
      printstring("<- ".BL_text);  newline
      b(0) = 255
      file number = file number+1;  bl_index = file number
      write tape(addr(BL), 63)
      p = 0;  bp = 512
      %cycle
         %if bp = 512 %start
            bp = 0
            fp_dact = 7;  fp_p4 = addr(buf(1));  fp_p5 = index
            svc(20, fp)
            %exit %if fp_p6 < 0
         %finish
         bp = bp+1;  p = p+1;  b(p) = buf(bp)
         %if p = 2047 %start
            p = 0
            write tape(addr(b(0)), 2048)
            %exit %if int # ""
         %finish
      %repeat
      int = ""
      %while p < 2047 %cycle
         p = p+1;  b(p) = 4
      %repeat
      b(0) = 0
      write tape(addr(b(0)), 2048)
      tape mark
      fp_dact = 11; fp_p5 = index;  svc(20, fp)
      printstring("Close fails -- ".string(addr(fp_p1))) %if fp_p6 # 0
      %if used # 0 %start
         ap_dact = 46;  svc(20, ap);         !remove usage bits
      %finish
   %end
   %routine dump user(%record(filefm)%name file)
      %integer j
      %record(dirfm) spine
      %return %if file_name2 = 0
      owner_owner = file_name1
      unpack(owner, user name)
      printstring("Dumping ".username);  newline
      read block(file_spine, spine)
      %for j = 1, 1, 42 %cycle
         dump file(spine_file(j))
         %exit %if int # ""
      %repeat
      int = ""
   %end
   %routine dump user files(%record(packfm)%name f)
      %integer j
      %record(dirfm) users
      owner_unit = f_unit;  owner_name1 = 0;  owner_name2 = 0
      unit no = find unit no(f_unit)
      %return %if unit no = 0
      read block(user list, users)
      dump header
      %for j = 1, 1, 42 %cycle
         %exit %if int # ""
         %if f_owner = users_file(j)_name1 %or f_owner = 0 %start
            dump user(users_file(j))
         %finish
      %repeat
      terminate
      int = ""
   %end
%routine read file(%string(63)%name header, %record(packfm)%name ff)
      %integer k, limit
      %string(63) new file
      %record(packfm) f
      pack(header, f)
      %return %if ff_unit # 0 %and ff_unit # f_unit
      %return %if ff_owner # 0 %and ff_owner # f_owner
      %if ff_name1 # 0 %or ff_name2 # 0 %start
         %return %if ff_name1 # f_name1 %or ff_name2 # f_name2
      %finish
      printstring("-> ".header);  newline
      f_unit = 0;  f_owner = 0
      unpack(f, new file)
      open output(2, new file)
      %if comreg(0) # 0 %start
         report("Cannot create ".new file, 0)
         %return
      %finish
      select output(2)
      %cycle
         read tape(addr(b(0)), 2048)
         k = 1
         limit = 2048
         %if b(0) = 0 %start
            limit = limit-1 %while b(limit-1) = 4
         %finish
         %while k # limit %cycle
            printsymbol(b(k))
            k = k+1
         %repeat
         %exit %if b(0) = 0
      %repeat
      close output
      select output(1)
   %end
   %routine restore user files(%string(63) which, %integer x)
      %record(blockfm) BL
      %record(packfm) f
      %if which = "" %or x # 0 %start
         f = 0
      %else
         pack(which, f)
      %finish
      %cycle
         skip forward
         read tape(addr(bl), 63)
         %exit %if bl_text = eot
         printstring("Label: ".bl_text);  newline
         %cycle
            read tape(addr(bl), 63)
            %exit %if bl_text = em %or int # ""
            %if x = 0 %or bl_index&H = x %start
               read file(bl_text, f)
               %return %if x # 0
            %finish
            skip forward
         %repeat
         %exit %if int # ""
      %repeat
      int = ""
      rewind
   %end
%routine analyse tape(%record(packfm)%name f)
   %record(blockfm) BL
   %string(63) label
   %record(packfm) ff
   %integer k
   rewind
   read tape(addr(bl), 63)
   printstring("Tape identifier: ".bl_text);  newlines(2)
   %cycle
      skip forward
      read tape(addr(bl), 63)
      ->err %if error # 0
      %exit %if bl_text = eot
      label = bl_text
      %cycle
         %if int # "" %start
            int = ""
            rewind
            %return
         %finish
         read tape(addr(bl), 63)
         %if error # 0 %start
err:         report("Tape read error ", error)
            %return
         %finish
         %exit %if bl_text = em
         pack(bl_text, ff)
         %if ff_owner >= 0 %start
            %if (f_unit = 0 %or f_unit = ff_unit) %and %c
                (f_owner = 0 %or f_owner = ff_owner) %start
               %if label # "" %start
                  newlines(2);  printstring("Label: ".label)
                  newline
                  k = 0
                  label = ""
               %finish
               newline %and k = 3 %if k <= 0
               k = k-1
               write(bl_index&H, -8);  space
               print string (bl_text);  spaces (30 - length(bl_text)) %if k # 0
            %finish
         %finish
         skip forward
      %repeat
   %repeat
   newline;  printstring("***end of tape***");  newline
%end

int == string(comreg(15))

printstring("Archive version ".version);  newlines(2)

claim tape
prepare terminal
rewind
%if exclam = 0 %start;               !old tape
   read tape(addr(bl), 63)
   printstring("Tape ".bl_text);  newline
   skip forward
%finish
prompt("Archive:")
%cycle
   used = 0
   int = ""
   read word(word)
   %if word = "DUMP" %start
      read word(word)
      %if word = "USER" %start
         read word(word)
         pack(word.":", f)
         dump user files(F)
      %else %if word = "UNIT"
         read word(word)
         pack(word."_x:", f)
         f_owner = 0
         dump user files(f)
      %else
         report("UNIT or USER wanted", 0)
      %finish
   %else %if word = "IDUMP"
      read word(word)
      pack(word."_X:", f)
      f_owner = 0
      used = 1
      dump user files(f)
   %else %if word = "RESTORE"
      rewind
      x = 0
      read sym %while sym = ' '
      %if sym = '#' %start
         read(x)
         restore user files("", x) %if x > 0
      %else
         read word(key)
         read word(word)
         %if key = "UNIT" %start
            restore user files(word."_:", 0)
         %else %if key = "USER"
            restore user files(word.":", 0)
         %else %if key = "FILE"
            restore user files(word, 0)
         %else
            report("UNIT, USER, or FILE wanted", 0)
         %finish
      %finish
   %else %if word = "ANALYSE"
      read word(word)
      f = 0
      pack(word.":", f) %unless word = ""
      analyse tape(f)
   %else %if word = "LABEL"
      sp = 0;  read word(head text)
      length(head text) = 31 %if length(head text) > 31
   %else %if word = "INITIALISE"
      %if exclam = 0 %start
         printstring("Initialise not permitted");  newline
         %continue
      %finish
      rewind
      sp = 0;  read word(word)
      word = word." - Dated ".date." at ".time
      rewind
      tape mark
      skip reverse
      write tape(addr(word), 63)
      tape mark
      BL_text = EOT;  BL_index = 0;  BL_spare = 0
      write tape(addr(BL), 63)
      printstring("Tape identified as ".word);  newline
   %else %if word = "HELP" %or word = "?"
      select output(0)
      printstring("
Analyse
Analyse unit extn
Analyse user fred
Dump unit extn
Dump user sys5_fred
Idump unit
Exit
Help
Initialise tape-id
Label anything
Restore unit extn
Restore user extn_fred
Restore file extn_fred:file1.imp
Restore # filnum
")
      selectoutput(1)
   %else
      stop %if word = "EXIT" %or word = "STOP"
      report("Unknown command ".word, 0) %unless word = ""
   %finish
   read sym %while sym # nl
   sym = ' '
%repeat
%endofprogram