!Mag tape archiving program

!Format of archive tapes:
!
!   Tape ID  TM  Label fid ... TM fid ... TM fid ... TM fid ... TM EM
!            TM  Label fid ... TM fid ... TM fid ... TM fid ... TM EM
!
!                        .  .  .  .  .  .  .  .  .  .
!
!            TM  Label fid ... TM fid ... TM fid ... TM fid ... TM EM
!            TM  EOT
!
!   TM:      Tape mark.
!   Tape ID: Header, text part anything
!   Label:   Ditto
!   fid:     File identifier - header block, text part is a full file
!            name UNIT_USER:FILE.EXT.  Index part is a file sequence no.
!   EM:      A header block, text part "**end**"
!   EOT:     A header block, text part "**end of tape**"
!
!   A "header block" is 63 bytes: 60 bytes IMP string (text) +
!                                  2 bytes sequence no (binary) +
!                                  2 bytes spare.

%begin
   %include "Sysinc:command.inc"
   %externalstring(15)%spec Console Int
   %const %string(3) version = "1.6"

   !*Machine-code bootstrap tables

   %ownshortintegerarray Bootstrap(1:40) =
      !Loaded by 50-seq (50-seq called from STRAP1).
      !Loads system image on tape (512-byte blocks) -> store @ x'C00' up
      X'C810',X'00F0',
      x'D320',x'0078',x'C830',x'0C00',x'2458',x'9E15',x'9D20',x'C300',x'0010',
      x'2233',x'3403',x'9A10',x'9813',x'CA30',x'01FF',x'3403',x'9A10',x'9813',
      x'DE20',x'8023',x'DE10',x'801E',x'2631',x'9D10',x'2081',x'9E15',x'9D20',
      x'C300',x'0040',x'4330',x'FFCC',x'D1D0',x'0EF4',x'087F',x'C84E',x'0018',
      x'030E',x'F0E1'
   %ownintegerarray xC00 BOOT(0:127) =
      !Standard disc bootstrap (lives at X'C00'). 
      x'C88000C6',x'2501F810',x'FFF00CF4',x'50010000',
      x'58210000',x'23332614',x'2036111C',x'101C5010',
      x'090441F0',x'0C2624D0',x'24C2C860',x'0E00F8B0',
      x'0001FFFF',x'C8A000F0',x'C89000B6',x'DE900CF0',
      x'9DAE2081',x'9D9E94EE',x'C3E08200',x'21122333',
      x'DE900CF0',x'9D8E2347',x'C3E00010',x'2034C3E0',
      x'0040023F',x'9D8E021F',x'2387222B',x'988DDE80',
      x'0CEC4140',x'0CE0988D',x'DE800CED',x'41400CE0',
      x'DEA00CF0',x'34E69AAE',x'98A634EB',x'9AAE98AB',
      x'988D9A9C',x'DE900CF1',x'DEA00CEE',x'9DAE2081',
      x'DEA00CF0',x'9D9E2125',x'C3E00080',x'2234030F',
      x'2148021F',x'D1D00EF4',x'087FC84E',x'0018030E',
      x'C3E00010',x'033F9BA0',x'99AE3400',x'06E00BE6',
      x'26E2C4E0',x'FF000A6E',x'07CC26D1',x'43000C76',
      x'9D9E2221',x'9D8E027F',x'20820304',x'C1C23010',
      x'48C10000',x'FFFFFFFF',x'FFFFFFFF',x'FFFFFFFF',
      x'00000000'(*)

   !Boot tape format:
   !
   !      _________________________________________________________....
   !     |          |                  |                               
   !     |  Boot    |   x'C00' loader  |     System image        TM
   !     |__________|__________________|____________________________...______..
   !        block 0         block 1          blocks 3,4,5,..
   !
   !
   !All this is the "label" part of an archive format tape,
   !which is as normal after the tape mark.


   %constinteger H = x'FFFF'
   %constinteger default password = x'10685B';   !PASS:
   %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 = Command_Modifier

   %record(packfm) F
   %record(packfm) owner
   %record(file fm) dir entry
   %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, create = 0, out unit = 0
   %string(15)%name int
   %integer error, unit no, x
   %own %integer sys disc = 2;   !default
   %constinteger user list = 301
   %byteintegerarray b(0:2047)
   %const %integer max user = 20
   %integer %array user(1:max user)
   %integer users

   %predicate wanted (%integer username)
      %integer j
      %for j = 1, 1, users %cycle
         %true %if user(j) = username
      %repeat
      %false
   %end

   %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
      select output(1)
      close output
      select output(0)
      %stop
   %end
   %routine report(%string(63) text, %integer value)
      selectoutput(0)
      printstring(text)
      write(value, 0) %if value # 0
      newline
      selectoutput(1)
   %end
   %predicate create user(%integer unit, owner)
      %record(parmfm) p
      p_dact = 31
      p_p1 = unit
      p_p2 = owner
      p_p3 = default password
      p_p4 = 0;  p_p5 = 0;  p_p6 = 0
      svc(20, p)
      %if p_p6 = 0 %or p_p6 = -2 %then %true
      %false
   %end
   %routine become(%integer unit, owner)
      %record(parmfm) p
      %unless create user(unit, owner) %start
         printstring("Cannot create user")
         newline
         %return
      %finish
      p_dact = 27
      p_p1 = unit
      p_p2 = owner
      p_p3 = 0
      p_p4 = 0
      p_p5 = 0
      p_p6 = 0
      svc(20, p)
      %if p_p6 # 0 %start
         printstring("Cannot become -- ")
         printstring(string(addr(p_p1)))
         newline
      %finish
   %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(*)%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) %if length(s) # 63
         read sym
      %repeat
      sp = ' '
   %end

!Tape operations

   %routine claim tape
      %record(parmfm) p
      %cycle; !till succeeds
         p_dact = 1;  svc(105, p)
         %exit %if p_p6 = 0
         report("Tape already claimed - force released", 0)
         release tape
      %repeat
   %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 system
      %record(block fm) BL
      %integer j, old;  old = unit no
      %byte %integer %array B(0:511)
      dump header
      print string ("<- $BOOT.SYS#");  newline
      file number = file number + 1
      BL_index = file number;  BL_text = "$BOOT.SYS#"
      write tape (addr(BL),63)
      unit no = sys disc
      %for j = 1,1,255 %cycle;         !dump image from fixed sys area on disc
         read block (j,record(addr(B(0))))
         write tape (addr(B(0)),512)
      %repeat
      tape mark
      terminate
      unit no = old
   %end
   %routine dump bootstrap
      %byte %integer %array B(0:511)
      %integer j,k
      write tape (addr(bootstrap(1)),40*2);  !loaded by 50-seq
      write tape (addr(xC00 Boot(0)),512);   !not in system image
      open input (3,"BOOT:MAGTAPE.SYS")
      select input (3)
      %for j = 1,1,255 %cycle;               !copy tape sys from SLOAD file
         read symbol (B(k)) %for k = 0,1,511
         write tape (addr(B(0)),512)
      %repeat
      close input
      select input (1)
   %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(*)%name header, %record(packfm)%name ff)
      %record(parm fm) P
      %integer k, limit
      %string(63) new file
      %record(packfm) f
      %on 9 %start
         Printstring("Cannot create ".NewFile)
         Newline
         %return
      %finish
      Pack (header, f)
      %return %if ff_unit # 0 %and ff_unit # f_unit
      %return %if ff_owner > 0 %and ff_owner # f_owner
      %return %if ff_owner < 0 %and %not wanted(f_owner)
      %if ff_name1 # 0 %or ff_name2 # 0 %start
         %return %if ff_name1 # f_name1 %or ff_name2 # f_name2
      %finish
      %return %if header = "$BOOT.SYS#"
      f_unit = out unit %if out unit # 0
      P_p1 = f_unit
      P_p2 = f_owner
      P_p3 = f_name1
      P_p4 = f_name2
      Unpack (f, new file)
      Print string ("-> ".new file)
      New line
      %if create # 0 %then become(f_unit, f_owner) %c
                     %else P_p1 = 0 %and P_p2 = 0;   !in current directory
      f_unit = 0;  f_owner = 0
      unpack(f, new file)
      open output(2, new file)
      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)
      P_dact = 46;               !clear 'used' bit
      SVC (20,P)
   %end
   %routine restore user files(%string(63) which, %integer x, cre)
      %record(blockfm) BL
      %record(packfm) f
      %if which = "" %or x # 0 %start
         f = 0
         f_owner = x %if x < 0
      %else
         pack(which, f)
      %finish
      create = cre
      %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
      create = 0
      int = ""
      rewind
   %end
   %routine analyse tape(%record(packfm)%name f)
      %record(blockfm) BL
      %string(63) label
      %record(packfm) ff
      %integer k
      rewind
      skip forward;  backspace;  backspace
      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

   %routine set output unit
      %record(pack fm) f
      %string(63) s
      Out unit = 0;                !default is unit files were dumped from
      Read word (s)
      %if s = "TO" %start
         Read word (s)
         Pack (s."_:", f)
         Out unit = f_unit;        !**used by READ FILE**
      %finish
   %end

int == Console Int
unit no = 0
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
%cycle
   prompt ("Archive:")
   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 %if word = "FILE"
         Dump header
         Read word (word)
         Pack (word, owner)
         dir entry_name1 = owner_name1;  dir entry_name2 = owner_name2
         Dump file (dir entry)
         Terminate
      %else %if word = ".SYSTEM"
         dump system
      %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, 0) %if x > 0
      %else
         read word(key)
         %if key = "UNIT" %start
            Read word (word)
            Set output unit
            Restore user files (word."_:", 0, 1)
            create = 0;  out unit = 0
         %else %if key = "USER"
            Read word (word)
            Set output unit
            Restore user files (word.":", 0, 1)
         %else %if key = "USERS"
            users = 0
            Set output unit
            Prompt ("User:")
            %cycle
               Read sym %while sym <= ' '
               Read word (key)
               %exit %if char no(key,1) = '.'
               key = key.":"
               Pack (key, f)
               %if f_owner < 0 %start
                  Print string ("Invalid username")
                  newline
                  %continue
               %finish
               users = users + 1
               user(users) = f_owner
            %repeat
            Restore user files ("", -1, 1)
         %else %if key = "FILE"
            Read word (word)
            out unit = 0
            restore user files(word, 0, 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)
      rewind
      tape mark
      skip reverse
      dump bootstrap %if word = ".BOOT"
      word = word . " - dated " . date . " at " . time
      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