!
!The currently available disc utility commands are:
!
!     DISC(TEST) disc/,listing
!           Check the integrity of logical disc unit 'disc'.  A listing
!           of the names and sizes {FILENAME (blocks,extents)} of all
!           files on that disc are sent to output stream 2 ('listing')
!           'Disc' is either the logical name of a loaded disc unit,
!           (e.g. "SYS7","EXTN") or the unit number of the drive the
!           logical disc is mounted on, preceded by a '#'.  E.g. '#1'
!           (the first cartridge disc, device address X'C6').
!           'Listing' may be any valid output stream destination, a
!           queue, (LP:, PP:) a file (FRED.LST, $1) or a device (T:).
!
!     DISC(COMPRESS) disc1/disc2,listing
!           The logical contents of 'disc1' are copied onto 'disc2',
!           being compressed into a minimally fragmented form in the
!           process.  A 'listing' of the output disc may be produced
!           if required.   Examples:
!              DISC(COMPRESS) SYS7/#5
!              DISC(COMPRESS) #1/JIM,LP:newJIM.lst
!
!     DISC(COPYUSERS) disc1/disc2,listing
!     DISC(COPYUSER)  disc2/disc2,listing
!        These two are synonymous, and perform the same function as
!        COMPRESS, on a selected group of users from 'disc1'.  When
!        the program starts, you will be prompted "Copy:", to which
!        you should reply with a list of usernames from 'disc1', seperated
!        by commas or newlines, and terminated by the dummy name ".END".
!        E.g.  DISC(COPYUSER) FRED/JIM
!              Copy: XXX, YYY
!              Copy: A, BB
!              Copy:.end
!        (This will copy users FRED_XXX, FRED_YYY, FRED_A and FRED_BB
!        onto disc JIM.  ***JIM WILL BE OTHERWISE EMPTY AFTER THIS
!        OPERATION***, i.e. any existing users on JIM will be overwritten).
!
!     DISC(TIDY) disc
!        The free list on 'disc' is reconstructed.  As many 'lost blocks'
!        as possible are reclaimed and put on the new free list.
!
!     DISC(COPY) disc1/disc2
!        This operation is a mindless track-by-track image dump of disc1
!        onto 'disc2'.  No compression is performed.  Note that if an
!        attempt is made to copy a disc onto a different physical type
!        of unit, block zero in the dumped disc will indicate the old
!        type of drive, this should be avoided.  COPY is mainly to
!        enable the operator make copies of discs not recorded in MOUSES
!        format.  (Any disc may be copied since no interpretation is placed
!        on the data on the disc: the number of blocks to be copied is
!        prompted for at the operator's console).
!
!     DISC(INITIALISE) /disc
!        The operator supplies various bits of information to be recorded
!        on block zero of 'disc' to identify it in the future. (Volume
!        serial number, disc name and description etc).  The directory
!        structure of the 'disc' is then wiped clean, leaving no users
!        with no files on the disc.
!        All 'blank' discs when received by an installation must be
!        initialised before the system will LOAD them.
!
!     DISC(WIPE) /disc
!        As for initialise, except that the contents of block zero remain
!        unaltered.  Used to clean out a corrupted disc.
!
!     DISC(ZERO) /disc
!        Allows the operator to alter the contents of block zero.
!        (In order to resurrect dead discs).  Pointers in block zero
!        (to free list etc) are simply set to their preferred values
!        while keeping fingers firmly crossed...
!
!     DISC(KILL) /disc
!        Block zero of the 'disc' is overwritten with an invalid pattern.
!        All data on the disc is destroyed.  The disc can no longer be LOADed
!        by the system.  (It must be re-INITIALISEd first).
!\
!
!New MOUSES disc utility program.        A. Culloch,  July 1980.
%const %string(31) version = "V2.02"
!2.02: Bug fix in COPY SYSTEM.  30-JUN-81 (ADC)

%include "sysinc:command.inc"

%const %string(31) program source = "crash:DISC"

%external %routine %spec doing (%string(12) activity)
!User may interrogate current value of ACTIVITY by
!using the system's '^G' facility.

!System message format
%include "SYSINC:PARMFM.INC"

!File system disc block formats

%record %format extent  (%short length,  {# of contiguous blocks in extent}
                         %short base)    {disc addr of first block}
%record %format spine   (%short extents, {# of extents in file}
                         %byte  access permissions,
                                check,   {should always be '?'}
                         %integer blocks,{# of blocks in file}
                         %record(extent) %array extent (1:126))

%record %format file    (%integer name1, name2,   {packed filename}
                         %short spine block,      {disc addr of file's spine}
                         %short day)              {date last written}
%const %integer dollar hash = x'C000 0000'        {&NAME1#0 => temp file}
%record %format directory(%short files,  {# of files in directory}
                         %byte  access rights,    {user access}
                         %byte  check,            {always '?'}
                         %short unused,
                         %byte  spare,
                         %byte  access permissions,{directory access}
                         %record(file) %array file (1:42))

%record %format user    (%integer name, password,
                         %short   dir block,      {disc addr of user dir}
                         %short   spare)
%record %format userlist(%short   users, spare1,  {# of users on unit}
                         %integer spare2,
                         %record(user) %array user (1:42))

!Block zero on every logical disc

%record %format zero fm (%integer vol id,         {m'VOLN'}
                         %string(7) disc id,      {"SVOL"}
                         %integer   free list,    {free blocks spine}
                                    user list,    {user catalog}
                                    defective list,{bad blocks list}
                         %integer   system area,  {start of system image}
                                    system size,  {N contiguous blocks}
                         %string(11)initialisation date,
                         %integer   tracks,       {physical disc info}
                                    blocks per cylinder,
                                    heads,
                         %integer   initialised,  {=0 => Disc WIPED O.K.}
                         %integer   copied,
                         %integer   checksum,     {sum(blockzero)-1 = 0}
                         %string(187) description,{of logical disc contents}
                         %integer marked,   {V2.00+: Disc INITIALISED O.K.}
                         %byte %array spare (1:252))

%record %format block   (%record(spine) S %or
                         %record(directory) D %or
                         %record(user list) U %or
                         %record(zero fm) Z)   {bad blocks list and free
                                               {list are just perverted
                                               {spine blocks

!System constants

%const %integer disc read = 101          {read from absolute disc address}
%const %integer disc write = 102         {write absolute disc block}
%const %integer read segment = 106       {read N contiguous blocks at abs disc ad}
%const %integer write segment = 107      {write N contiguous blocks}
%const %integer disc status = 108
%const %integer pack filename = 17
%const %integer unpack filename = 18
%const %integer to director = 20
%const %integer unit name = 40
%const %integer find disc = 45           {map packed disc-id => unit#}

%begin
   !Events trapped in program
   %const %integer input ended = 9       {end of file}
   %const %integer total failure = 11    {signalled by GET space routine}

   {I/O stream names}
   %const %integer console = 0, listing = 2, help text = 3

   %record %format disc (%integer unit no,     {unit# disc is mounted on}
                         %integer unit,        {packed unit-name}
                         %integer blocks,      {size of logical disc}
                         %integer FP,          {first free block pointer}
                         %integer prot,        {non-zero => write-prot disc}
                         %integer errors,      {# of errors found on disc}
                         %record(zero fm) zero,{copy of block zero}
                         %integer %array bitmap (0:2047))

   %record(disc) in, out                 {disc descriptors}

   %const %integer H = 16_FFFF           {halfword mask}
   %const %integer non zero = 1
   %const %integer sys size = 256        {size of system image on disc}
   %const %integer default free list=300 {preferred value}
   %const %string(31) corrupt = " corrupt pointer to ",
                      nocheck = " invalid check byte in " {error messages}
   %const %integer commands = 13
   %const %string(15) %array command word (1:commands) =
      "TEST",                            {perform integrity checks on disc}
      "COMPRESS",                        {copy & compress logical disc unit}
      "INITIALISE",                      {let operator set up disc block zero}
      "WIPE",                            {clear directory structure on disc}
      "KILL",                            {write bad block zero onto disc}
      "ZERO",                            {alter selected fields in block 0}
      "COPY",                            {brainless copy of N blocks}
      "HELP",                            {copy the start of the source to TTY}
      "COPYUSER",                        {compress selected users from a disc}
      "COPYUSERS",                       {synonymous with COPYUSER}
      "TIDY",                            {recreate free list on disc}
      "RENAME",                          {alter logical name of a disc}
      "LIST"                             {just user listing}
   %const %integer single block = 1      {mnemonic}
   %integer errors = 0                   {see ERROR logging routine}
   %integer testing = 0                  {#0 => "TEST" parameter given}
   %integer splatting = 0                {#0 to inhibit block-0 validation
                                         {in the SET DISC routine}
   %integer copy user {flag} = 0         {#0 => only copy selected users}
   %integer wanted users = 0             {number of the chosen few}
   %integer exclam = COMMAND_modifier
   %integer %array wanted user (1:42)    {Their packed names}

   %routine clear out
      errors = 0
      testing = 0
      splatting = 0
      copy user = 0
      wanted users = 0
   %end

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


   !Utility routines

   %integer %fn stoi (%string(15) s)
      %byte %name b
      %integer j = 0, k, sign = 1
      %result = 0 %if s = ""
      sign = -sign %if s -> ("-") . s
      %for k = 1,1,length(s) %cycle
         b == char no (s,k)
         %result = -1 %unless '0' <= b <= '9'
         j = 10*j + (b-'0')
      %repeat
      %result = sign*j
   %end

   %string(15) %fn itos (%integer j)
      %string(15) s = ""
      %integer n = | j |
      %cycle
         s = to string (rem(n,10)+'0') . s
         n = n // 10
      %repeat %until n = 0
      s = "-" . s %if j < 0
      %result = s
   %end

   %routine normalise (%string(*)%name s)   {Kill ' 's & force upper case}
      %string(63) t
      %byte %name b
      %integer j
      s = s . t %while s -> s . (" ") . t
      %for j = 1,1,length(s) %cycle
         b == char no (s,j)
         b = b - 'a' + 'A' %if 'a' <= b <= 'z'
      %repeat
   %end

   %routine scan (%string(*)%name s)
      %on %event input ended %start
         s = s . ",.END";  %return
      %finish
      s <- ""
      skip symbol %while next symbol <= ' '
      %while next symbol >= ' ' %cycle
         s <- s . to string (next symbol)
         skip symbol
      %repeat
      normalise (s)
   %end

   %routine set bit (%integer %array %name bitmap, %integer index)
      %integer j = index>>5, k = index&31
      bitmap(j) = bitmap(j) ! 1<<k
   %end

   %routine clear bit (%integer %array %name bitmap, %integer index)
      %integer j = index>>5, k = index&31
      bitmap(j) = bitmap(j) & (\(1<<k))
   %end

   %predicate bit set (%integer %array %name bitmap, %integer index)
      %integer j = index>>5, k = index&31
      %true %if bitmap(j) & 1<<k # 0
      %false
   %end

   %routine report (%string(63) message)
      print string (message);  newline
   %end

   !Allocate buffer space for multiblock disc transfers
   %integer buf len = (FREE SPACE {on stack} - 8000 {safety})//512 {blocks}
   %record(block) %array buf (1:buf len)
   
   %routine error (%string(63) message)
      report ("*" . message);  errors = errors + 1
   %end

   %predicate valid block (%record(disc)%name D, %integer block no)
      block no = block no & H
      %false %unless 0 <= block no <= D_blocks %and
                     (%not bit set (D_bitmap,block no))
      set bit (D_bitmap, block no)
      %true
   %end

   %predicate valid extent (%record(disc)%name D, %record(extent)%name x)
      %integer base, length, j
      base = x_base&H
      length = x_length&H
      %false %unless length > 0 %and 0 <= base < D_blocks %and
                     base + length <= D_blocks
      %for j = base, 1, base + length - 1 %cycle
         %false %if bit set (D_bitmap,j) {overlaps blocks on other files?}
         set bit (D_bitmap,j)
      %repeat
      %true
   %end

   %integer %fn checkword (%record(zero fm)%name Z)
      !Calc check word for block zero
      %integer j, k = 0
      k = k + integer(j) %for j = addr(Z), 4, addr(Z) + 512 - 4
      %result = 1 - k
   %end

   %byte %fn checksum (%record(*)%name spine)
      %integer j, k
      k = 0;  k = k + byte integer(j) %for j = addr(spine),1,addr(spine) + 511
      %result = (-k) & 16_FF
   %end

   %routine read block (%record(disc)%name D, %integer block no,
                        %record(*)%name buffer)
      %record(parm fm) P
      P_p1 = block no&H;  P_p2 = addr(buffer);  P_p3 = D_unit no;  P_p4 = 0
      SVC (disc read,P)
      %if P_p1 # 0 %start
         report ("Disc read error " . itos(P_p1) . " from unit #" . %c
                 itos(D_unit no) . " at block #" . itos(block no))
      %finish
   %end

   %routine write block (%record(disc)%name D, %integer block no,
                         %record(*)%name buffer)
      %record(parm fm) P
      %return %if D_unit no = 0 {null}
      P_p1 = block no&H;  P_p2 = addr(buffer);  P_p3 = D_unit no;  P_p4 = 0
      SVC (disc write,P)
      %if P_p1 # 0 %start
         report (D_zero_disc id . " protected") %and %stop %if D_prot # 0
         report ("Disc write error " . itos(P_p1) . " to unit #" . %c
                 itos(D_unit no) . " at block #" . itos(block no))
         %stop
      %finish
   %end

   %routine list (%record(disc)%name D)
      !Uses CLEAR BIT rather than splatting D_BITMAP
      !before traversing the disc so that the operation
      !is transparent as far as the bitmap is concerned
      %record(parm fm) P
      %record(spine) spine block
      %record(user list) users
      %integer j, k, files, user count, blocks, total, free
      %string(63) s
      %record(user)%name u
      %record(directory) dir
      %record(file)%name f
      doing ("Disc listing")
      select output (listing)
      report ("Dump of " . D_zero_disc id)
      clear bit (D_bitmap,D_zero_user list)
      %return %unless valid block (D,D_zero_user list)
      read block (D,D_zero_user list,users)
      user count = 0;  total = 0
      %for j = 1,1,42 %cycle
         u == users_user(j)
         %if u_name # 0 %start
            user count = user count + 1
            newline
            P = 0;  P_p2 = u_name;  SVC (unpack filename,P)
            report (P_filename)
            clear bit (D_bitmap,u_dir block) %if 0 <= u_dir block < D_blocks
            %return %unless valid block (D,u_dir block)
            read block (D,u_dir block,dir)
            files = 0;  blocks = 0
            %for k = 1,1,42 %cycle
               f == dir_file(k)
               %if f_name2 # 0 %start
                  newline %if rem(files,3) = 0
                  files = files + 1
                  P = 0;  P_p3 = f_name1;  P_p4 = f_name2
                  SVC (unpack filename,P)
                  P_filename = " " . P_filename %while length(P_filename) < 15
                  print string (P_filename)
                  %if 0 <= f_spine block < D_blocks %start
                     clear bit (D_bitmap,f_spine block)
                  %finish
                  %if %not valid block (D,f_spine block) %start
                     error (P_filename . " corrupt")
                     s = "*CORRUPT*"
                  %else
                     read block (D,f_spine block,spine block)
                     blocks = blocks + spine block_blocks&H
                     s = " (" . itos (spine block_blocks&H) . "," . %c
                                itos (spine block_extents). ")"
                  %finish
                  s = s . " " %while length(s) < 10
                  print string (s)
               %finish
            %repeat
            blocks = blocks + files      {remember spines themselves}
            newline
            write (files,8);  print string (" file")
            print symbol ('s') %if files # 1;  print symbol (',')
            write (blocks,1); print string (" block")
            print symbol ('s') %if blocks # 1
            newline
            total = total + blocks
         %finish
      %repeat
      total = total + user count         {directory blocks}      %c
                    + single block       {block zero}            %c
                    + 3 * single block   {free,user,defective}
      total = total + D_zero_system size
      newlines (3);  spaces (3)
      print string (D_zero_disc id . ": ");  write (user count,0)
      print string (" users")
      newline
      write (total,8);  print string (" blocks in use");  newline
      free = D_blocks - total {used blocks}
      write (free,8);   print string (" free blocks (")
      free = 100*free//D_blocks {%}
      free = 0 %if free < 0
      write (free,0);   print string ("%)");  newline
      select output (console)            {again}
   %end

   %routine tidy (%record(disc)%name D)
      !Creates a new free list on D holding all blocks
      !not claimed so far (BITMAP entries not SET).
      %record(extent) e, swap
      %integer j, k, flag, lost = 0
      %record(spine) new free list = 0
      %return %if D_unit no <= 0
      %record(extent)%name this, that, victim
      doing ("free list")
      k = 0;  k = k + 1 %while \D_bitmap(k) = 0   {find a clear bit}
      j = 32*k
      %while j < D_blocks %cycle
         %if %not bit set (D_bitmap,j) %start   {start of a free extent}
            e_base <- j;  e_length = 0
            %cycle
               e_length <- e_length&H + 1
               j = j + 1
            %repeat %until j >= D_blocks %or bit set (D_bitmap,j)
            !now put this extent in NEW FREE LIST
            %if new free list_extents < 126 %start
               new free list_extents = new free list_extents + 1
               new free list_extent(new free list_extents) = e
            %else
               !Free list full -- throw away smallest
               !existing extent (the VICTIM) if it's smaller than 'E'.
               victim == new free list_extent(1)   {perhaps}
               %for k = 1,1,126 %cycle
                  this == new free list_extent(k)
                  victim == this %if this_length&H < victim_length&H
               %repeat
               %if e_length&H <= victim_length&H %start   {VICTIM is spared}
                  lost = lost + e_length&H
               %else
                  report ("reject")
                  lost = lost + victim_length&H
                  victim = e
               %finish
            %finish
         %finish
         j = j + 1
      %repeat
      !Sort new free list by ascending base address
      %if new free list_extents = 0 %start
         error(d_zero_disc id.": empty free list?")
      %else
         %cycle
            flag = 0
            this == new free list_extent(1)
            %for j = 2,1,new free list_extents %cycle
               that == new free list_extent(j)
               %if this_base&H > that_base&H %start
                  swap = this;  this = that;  that = swap
                  flag = non zero
               %finish
               this == that
            %repeat
         %repeat %until flag = 0
      %finish
      new free list_check = 0
      !DIRECTOR uses FREE_EXTENTS really as a
      !lost blocks counter, which we must initialise.
      new free list_extents = lost
      new free list_check = checksum (new free list)
      write block (D, D_zero_free list, new free list)
   %end

   %routine validate free list (%record(disc)%name D)
      %record(spine) free
      %record(extent)%name e
      %integer j, free blocks = 0, last
      !This routine checks that no blocks allegedly
      !on the free list are in fact part of the
      !directory structure of the disc. (In which
      !case their bits in the bitmap will be SET).
      doing ("freelist chk")
      read block (D, D_zero_free list, free)
      report (D_zero_disc id . ": ". itos(free_extents) . " lost blocks") %c
         %if free_extents # 0            {DIRECTOR counts lost blocks there}
      %if checksum (free) # 0 %start
         error (D_zero_disc id . ": " . no check . "free list")
         %return
      %finish
      last = 0
      %for j = 1,1,126 %cycle
         e == free_extent(j)
         %if e_base = 0 %start
            %cycle
               %if e_base # 0 %or e_length # 0 %start
                  error(d_zero_disc id.": incomplete free list")
                  %return
               %finish
               %exit %if j = 126
               j = j+1
               e == free_extent(j)
            %repeat
            %exit
         %finish
         %if e_base&H <= last %start
            error (D_zero_disc id . ": free list out of order")
         %finish
         last <- (e_base + e_length)&H
         %if valid extent (D,e) %start
            free blocks = free blocks + e_length&H
         %else
            error (D_zero_disc id . ": corrupt free list")
         %finish
      %repeat
      report ("free blocks: " . itos(free blocks))
   %end

   %routine get (%record(disc)%name D,
                 %record(extent)%name free, %integer max size)
      !A contiguous extent of up to MAX SIZE blocks
      !is claimed from the OUTPUT disc, and an extent
      !descriptor for it returned in FREE.
      free = 0 %and %return %if D_unit no <= 0 {NULL disc}
      %cycle                          {find a single free block on OUTPUT}
         %if D_FP >= D_blocks %start
            error ("Output disc too small")
            %signal total failure     {trapped in SQUEEZE: forces a return}
         %finish
         %exit %if %not bit set (D_bitmap,D_FP)
         D_FP = D_FP + 1
      %repeat
      free_base <- D_FP;  free_length = 0
      %cycle
         %exit %if D_FP >= D_blocks %or
                   bit set (D_bitmap,D_FP) {block in use} %or
                   free_length&H >= max size  {got all we wanted}
         set bit (D_bitmap, D_FP)
         free_length <- free_length&H + 1
         D_FP = D_FP + 1
      %repeat
   %end

   %routine %spec set disc (%record(disc)%name D, %string(25) id)

   %routine wipe (%record(disc)%name D)
      report ("***WIPING " . D_zero_disc id)
      %record(parm fm) P                 {D.I.Y. disc I/O - dont abort on errs}
      %integer j, k, block, left, N
      %record(spine) bad = 0             {new defective blocks list}
      %record(spine) user                {new (empty) user list}
      %record(zero fm)%name Z == D_zero
      %record(extent) free
      %record(extent)%name this

      %on %event total failure %start    {GET failed to claim system area}
         report ("No space for system area")
         -> NO SYS
      %finish

      %if Z_marked # -1 %start           {disc not properly initialised}
         report ("Unit #" . itos(D_unit no) . " not initialised")
         %stop
      %finish

      !Create defective list

      doing ("badblock chk")
      report ("blocks: ".itos(D_blocks))
      D_bitmap(j) = 0 %for j = 0, 1, 2047   {splat the bitmap}
      set bit (D_bitmap,0)               {don't scribble on block zero!}
      block = 0
      %cycle
         left = D_blocks&H - block       {# of blocks left to test}
         %exit %unless left > 0
         N = buf len;  N = left %if N > left   {test in N-block chunks}
         P_p1 = block;  P_p2 = addr(buf(1))
         P_p3 = D_unit no;  P_p4 = N
         SVC (read segment,P)
         %if P_p1 # 0 %start             {I/O err => 1 or more bad blocks}
            %for j = block, 1, block + N - 1 %cycle
               P_p1 = j                  {test individual blocks in chunk}
               P_p2 = addr(buf(1))
               P_p3 = D_unit no;  P_p4 = 0
               SVC (disc read,P)
               %if P_p1 # 0 %start       {block #J is duff}
                  set bit (D_bitmap,j)
                  bad_extents = bad_extents + 1   {use one extent for each}
                  %if bad_extents > 126 %start
                     report ("Too many bad blocks!")
                     %stop
                  %finish
                  this == bad_extent (bad_extents)
                  this_base = j;  this_length = single block
                  %if j = 0 %start
                     error ("Block zero is defective!!")
                     %stop
                  %finish
               %finish
            %repeat
         %finish
         block = block + N
      %repeat
      report ("Bad blocks: " . itos(bad_extents)) %if bad_extents # 0

      !Allocate system area

      D_FP = 0
      %if Z_system area # 0 # Z_system size %start
         %cycle
            get (D,free,sys size)
            %exit %if free_length&H = sys size
            !chunk not big enough - forget it
            clear bit (D_bitmap,j) %for j = free_base&H, 1,
                                            free_base&H + free_length&H - 1
         %repeat
         Z_system area = free_base&H
         Z_system size = free_length&H
      %finish

NO SYS:
      !Allocate free, user, defective blocks
      !(normally 300,301 and 302)

      D_FP = default free list
      %if %not valid block (D,Z_free list) %start
         get (D,free,single block)
         Z_free list = free_base&H
      %finish
      %if %not valid block (D,Z_user list) %start
         get (D,free,single block)
         Z_user list = free_base&H
      %finish
      user = 0;  write block (D,Z_user list,user)
      %if %not valid block (D,Z_defective list) %start
         get (D,free,single block)
         Z_defective list = free_base&H
      %finish
      bad_check = 0;  bad_check = checksum (bad)
      write block (D,Z_defective list,bad)
      bad = 0;                           !use BAD as free list now
      bad_check = checksum (bad)
      write block (D,Z_free list,bad)
      D_FP = 0                           {put things back}

      tidy (D)                           {create new free list}
      Z_initialisation date = DATE
      Z_initialised = 0                  {DONE}
      Z_checksum = 0;  Z_checksum = checkword (Z)
      write block (D,0,Z)
   %end

   %routine read page (%record(disc)%name D,
                       %integer disc addr, blocks, buf start)
      %record(parm fm) P
      P_p1 = disc addr&H; P_p2 = addr(buf(buf start)); P_p3 = D_unit no
      P_p4 = blocks&H;  SVC (read segment,P)
      %if P_p1 # 0 %start
         report ("Read page fails on unit #" . itos(D_unit no) . %c
                 ", status: " . itos(P_p1))
      %finish
   %end

   %routine write page (%record(disc)%name D,
                        %integer disc addr, blocks, buf start)
      %record(parm fm) P
      %return %if D_unit no = 0
      P_p1 = disc addr&H;  P_p2 = addr(buf(buf start));  P_p3 = D_unit no
      P_p4 = blocks&H;  SVC (write segment,P)
      %if P_p1 # 0 %start
         report (D_zero_disc id . " protected") %and
            %stop %if D_prot # 0
         report ("Write page fails on unit #" . itos(D_unit no) . %c
                 ", status: " . itos(P_p1))
         %stop
      %finish
   %end

   %routine merge (%record(userlist)%name new, %record(disc)%name D)
      !Create a new userlist from the old one on 'D'
      !and the NEW one passed to us.  Return merged
      !list in NEW.
      %record(userlist) old
      %integer j,k
      %record(user)%name u, slot
      %return %if D_unit no <= 0
      read block (D,D_zero_user list,old)
      j = 1
      %for k = 1,1,42 %cycle
         u == new_user(k)
         %if u_name # 0 %start
            %while j <= 42 %cycle
               slot == old_user(j)
               j = j + 1
               %if slot_name = 0 %start
                  slot = u
                  %exit
               %finish
            %repeat
         %finish
      %repeat
      new = old
   %end

   %routine squeeze (%record(disc)%name input, output)
      !The logical contents of the INPUT disc are
      !copied to the OUTPUT disc.  As the files are
      !being written sequentially, the output disc
      !will be minimally fragmented after the operation,
      !with all free space in one or two extents.

      %routine copy system
         %integer done
         %return %if input_zero_system size <= 0 %or
                    output_zero_system size <= 0
         doing ("Copy system")
         %if input_zero_system size > output_zero_system size %start
            report ("Not enough space for system area on " . %c
                    output_zero_disc id)
            %return
         %finish
         %integer j, k
         %integer pages = input_zero_system size // buf len,
                  odd blocks = rem (input_zero_system size,buf len)
         %for j = input_zero_system area, buf len,
                  input_zero_system area + (pages-1)*buf len %cycle
            read page (input, j, buf len, 1)
            writepage(output, j, buf len, 1)
         %repeat
         done = input_zero_system area + pages*buf len;   !block
         %for j = done, 1, done + odd blocks - 1 %cycle
            read block (input, j, buf(1))
            writeblock(output, j, buf(1))
         %repeat
         report ("System area: " . itos(input_zero_system size))
      %end

      %integer %fn squeezed file (%integer {packed} user {name},
                                  %record(file)%name F)
         !Result is disc addr in OUTPUT disc of new spine
         !block for the copied file.
         %integer bufp = 1, free buf = buf len, base
         %integer last, left, xfer len, j, extents
         %record(spine) old spine, new spine;  new spine = 0
         %integer {flag} empty spine = non zero
         %record(extent)%name e
         %record(extent) free
         %record(parm fm) P = 0;  P_p1 = input_unit;  P_p2 = user
                                  P_p3 = F_name1;     P_p4 = F_name2

         %routine output buf
            !The contents of BUF, from block 1 to BUFP is
            !written to the OUTPUT disc in as many extents
            !as required.  Each new extent is added to the
            !NEW SPINE block being created.
            %own %record(extent)%name last extent
            %record(extent) free
            %integer p = 1
            bufp = bufp - 1              {index of next free block->#of blocks}
            %while p <= bufp %cycle      {more to write}
               get (output, free, {extent of size up to # of blocks left}
                          bufp - p + 1)
               write page (output, free_base, free_length, {buf start} P)
               %if empty spine # 0 %or {not contiguous with last ext}
               free_base&H # last extent_base&H + last extent_length&H %start
                  empty spine = 0
                  new spine_extents = new spine_extents + 1
                  %if new spine_extents > 126 %start
                     error ("Spine block full!!")
                     %stop
                  %finish
                  last extent == new spine_extent(new spine_extents)
                  last extent = free
               %else                     {merge with LAST EXTENT}
                  last extent_length = (last extent_length + free_length)&H
               %finish
               p = p + free_length
            %repeat
            free buf = buf len           {buffer empty now}
            bufp = 1
         %end

         read block (input, F_spine block, old spine)
         %unless 0 <= old spine_extents <= 126 %start
            SVC (unpack filename,P)
            error (P_filename . itos(old spine_extents) . " extents?")
            old spine_extents = 126
         %finish
         %if old spine_check # '?' %start
            SVC (unpack filename,P)
            error (P_filename . no check . "spine block")
         %finish
         extents = 0
         %for j = 1,1,old spine_extents %cycle
            e == old spine_extent(j)
            %if e_length # 0 %start
               extents = extents + 1
               %if %not valid extent (input,e) %start
                  P = 0;  P_p1 = input_unit;  P_p2 = user
                  SVC (unpack filename,P)
                  error (P_filename . corrupt . "extent")
                  %if %not (0 <= e_base&H < input_blocks %and
                            0 <=(e_base+e_length)&H < input_blocks) %or
                     e_length&H > 200 {arbitrary} %start
                     !all is lost
                     report ("(Not copied)")
                     %continue
                  %finish
                  !copy poss. duff extent
               %finish
               new spine_blocks <- (new spine_blocks + e_length)&H
               %if testing = 0 %start    {actually copy the file?}
                  base = e_base&H;  last = (e_base + e_length)&H
                  left = e_length&H      {# of blocks yet to be transferred}
                  %cycle
                     output buf %if free buf <= 0
                     xfer len = left     {Try to read in all the other blocks}
                     xfer len = free buf %if xfer len > free buf
                     read page (input, base, xfer len, bufp)
                     bufp = bufp + xfer len;  left = left - xfer len
                     free buf = free buf - xfer len{less space left in buffer}
                     base = base + xfer len    {next disc addr}
                  %repeat %until base >= last  {read in whole extent?}
               %finish
            %finish
         %repeat
         output buf                      {flush}
         P = 0; P_p1 = input_unit; P_p2 = user; P_p3 = F_name1; P_p4 = F_name2
         %if new spine_blocks # old spine_blocks %start
            SVC (unpack filename,P)
            error (P_filename . " block count wrong in spine")
         %else %if extents # old spine_extents
            SVC (unpack filename,P)
            error (P_filename . " zero length extent in spine?")
         %finish
         %result = 0 %if new spine_extents = 0
         get (output, free, single block)
         new spine_check = '?'
         new spine_access permissions = old spine_access permissions
         write block (output, free_base, new spine)
         %result = free_base
      %end

      %integer %fn squeezed user (%integer {packed} name {of user},
                                  {disc addr of user's} dir block)
         !Result is disc addr (on OUTPUT) of copied directory.
         %record(directory) D, new dir
         %record(spine) S
         %record(parm fm) P = 0;  P_p1 = input_unit;  P_p2 = name
         %record(extent) free
         %record(file)%name F
         %integer j

         read block (input, dir block, D);  new dir = D
         %unless 0 <= D_files <= 42 %start
            SVC (unpack filename,P)
            error (P_filename . itos(D_files) . " files?")
            D_files = 42
         %finish
         new dir_files = 0
         %for j = 1,1,42 %cycle
            F == new dir_file(j)
            %if f_name2 # 0 %and f_name1&dollar hash = 0 %start
               %if %not valid block (input,F_spine block) %start
                  P = 0;  P_p1 = input_unit;  P_p2 = name
                  P_p3 = f_name1;  P_p4 = f_name2
                  SVC (unpack filename,P)
                  error (P_filename . corrupt . "spine block")
                  %if %not (0 <= f_spine block < input_blocks) %start
                     report ("(Not copied)")
                     F = 0
                     %continue
                  %finish;   !might be OK
                  read block (input,f_spine block,S)
                  %if S_check # '?' %start
                     report ("(Not copied)")
                     F = 0
                     %continue
                  %finish;   !plausible
               %finish
               !spine OK
               f_spine block <- squeezed file (name,f) &H
               %if f_spine block # 0 %start;   !exists
                  new dir_files = new dir_files + 1
               %finish %else f = 0
            %finish %else f = 0
         %repeat
         get (output, free, single block)
         write block (output, free_base, new dir)
         %result = free_base
      %end

      !SQUEEZE input => output disc

      %record(user list) catalog         {users on input disc}
      %record(user list) new cat
      %record(user)%name U
      %record(parm fm) P
      %string(63) s
      %integer j

      %on %event total failure %start    {Detected in GET space routine}
         %return                         {ERROR was called in GET,
      %finish                            {so main program will produce the
                                         {FAULTY OUTPUT DISC message}
      wipe (output) %if output_errors # 0
      read block (input, input_zero_user list, catalog)
      %unless 0 <= catalog_users <= 42 %start
         error (input_zero_disc id . ": " . itos(catalog_users) . %c
                " users?")
      %finish
      copy system
      new cat = catalog;  new cat_users = 0
      %for j = 1,1,42 %cycle
         U == new cat_user(j)
         %if U_name # 0 %start
            P = 0;  P_p1 = input_unit;  P_p2 = U_name
            SVC (unpack filename,P)
            s <- P_filename
            %if %not valid block (input,U_dir block) %start
               error (P_filename . corrupt . "directory")
               !no hope
               U = 0
               %continue
            %finish
            %if copy user = 0 {do everyone} %or wanted(U_name) %start
               doing (s)
               %if exclam # 0 %start
                  %if testing # 0 %then report ("testing " . s) %c
                                  %else report ("copying " . s)
               %finish
               new cat_users = new cat_users + 1
               U_dir block <- squeezed user (U_name,U_dir block)&H
            %finish %else U = 0
         %finish
      %repeat

      merge (new cat,output) %if copy user # 0;   !combine with old catalog
      write block (output, output_zero_user list, new cat)
      tidy (output) %if output_unit no > 0
   %end {of SQUEEZE}


   %routine validate block zero (%record(disc)%name D)
      %record(zero fm)%name Z == D_zero
      %record(spine) bad blocks
      %record(extent) temp
      %integer j,k
      %if exclam = '?' %start            {print interpreted block zero}
         report ("Unit " . Z_disc id . ", " . Z_description)
         report ("Free list at " . itos(Z_free list))
         report ("User list at " . itos(Z_user list))
         report ("Bad blocks list at " . itos(Z_defective list))
         report ("System area at " . itos(Z_system area))
         report ("System size: " . itos(Z_system size))
         report ("Tracks: " . itos(Z_tracks))
         report ("Blocks per cylinder: " . itos(Z_blocks per cylinder))
         report ("Heads: " . itos(Z_heads))
      %finish
      k = checkword(Z)
      error("Block zero checksum fault ".itos(k)) %if k # 0
      %if %not valid block (D,Z_free list) %start
         error (Z_disc id . corrupt . "free list")
         Z_free list = default free list {& hope for the best}
      %finish
      %if %not valid block (D,Z_user list) %start
         error (Z_disc id . corrupt . "user list")
         Z_user list = default free list + 1
      %finish
      %if %not valid block (D,Z_defective list) %start
         error (Z_disc id . corrupt . "bad blocks list")
         Z_defective list = default free list + 2
      %finish
      %if Z_system size # 0 %start    {unit holds a system image}
         temp_base = Z_system area
         temp_length = Z_system size
         %if %not valid extent (D,temp) %start
            error (Z_disc id . corrupt . "system area")
            Z_system area = 1;  Z_system size = sys size
         %finish
      %finish
      %if Z_tracks <= 0 %or Z_blocks per cylinder <= 0 %or Z_heads <= 0 %start
         error ("-ve no. of tracks, sectors, heads?")
         D_blocks = x'FFFF'              {max poss disc addr}
      %finish
      %if errors = 0 %then read block (D, Z_defective list, bad blocks) %c
                     %else bad blocks = 0
      %if 0 <= bad blocks_extents <= 126 %start
         %if checksum (bad blocks) # 0 %start
            error (Z_disc id . ": defective list checksum error")
         %else
            %for j = 1,1,bad blocks_extents %cycle
               %if bad blocks_extent(j)_length # 0 %and
                  (%not valid extent(D,bad blocks_extent(j))) %start
                  error (Z_disc id . ": Defective list" . %c
                         corrupt . "an extent")
               %finish
            %repeat
         %finish
      %else
         error (Z_disc id . ": " . %c
                itos (bad blocks_extents) . " bad blocks?")
      %finish
   %end

   %routine set disc (%record(disc)%name D, %string(25) id)
      %string(63) S
      %record(parm fm) P = 0
      %integer j, old errors = errors
      D = 0
      %return %if id = ""
      %if id -> ("#") . id %start        {unit# given numerically}
         j = stoi (id);  id = "#" . id
      %else
         P_filename = id . "_:"
         SVC (pack filename,P)
         j = -1
         P_dact = find disc                 {packed disc name => unit#}
         SVC (to director,P)
         j = P_p1 %if P_p6 = 0
      %finish
      error ("Invalid disc name " . id) %and %stop %if j < 0
      D_unit no = j
      P_p3 = D_unit no
      SVC (disc status,P)
      error ("Unit #" . itos(D_unit no) . " offline") %and %stop %if P_p6&3 # 0
      D_prot = P_p6 & 4
      read block (D,0,D_zero)
      D_blocks <- D_zero_tracks * D_zero_blocks per cylinder
      set bit (D_bitmap,0)
      length(D_zero_disc id) = 4 %if length(D_zero_disc id) > 4;!!!!!!!!!!!!!
      s <- D_zero_disc id
      s <- s . "_:"
      P_filename <- s
      SVC (pack filename,P)
      D_unit = P_p1
      P_dact = unit name;  P_p1 = D_unit no
      SVC (to director,P)
      D_prot = non zero %if P_p6 = 0 %and P_p2 # 0   {prot in director?}
      %return %if splatting # 0
      validate block zero (D)
      D_errors = errors - old errors
   %end


   !field number mnemonics on block zero

   %const %integer vol id = 1
   %const %integer disc id = 2
   %const %integer sys area = 3
   %const %integer make = 4
   %const %integer descr = 5
   %const %integer fields = 5

   %routine set zero (%record(disc)%name D, %integer mask, to do)
      !Alter fields indicated by mask in disc block zero from data
      !supplied by operator at the console.
      !No. of fields TO DO passed as a parameter.
      %string(63) atom
      %const %integer parms = 5          {fields in block zero}
      %const %string(15) %array parm id (1:parms) =
         "Phy. disc name:",
         "Log. disc name:",
         "System area? ",
         "Disc type:",
         "Description:"
      %const %integer {disc} types = 5, last type = types
      %const %string(9) %array type id (1:types) =
         "DIABLO",                       {5MB cartridge disc}
         "TELEFILE",                     {300MB fixed disc unit}
         "MSM80",                        {Perkin-Elmer 67MB disc}
         "CALCOMP",                      {Calcomp 67M disc}
         "UNKNOWN"                       {track size/cyls etc explicit}
      !*** UNKNOWN must be last type ***
      %const %integer %array tracks (1:types) = 400,100,815//3,815//3,0(*)
      %const %integer %array blocks per cylinder (1:types) = 2*12,19*32,5*26,5*26,
                                                             0(*)
      %const %integer %array heads (1:types) = 2,19,5,5,0(*)
      %integer j,k,m
      %switch F (1:parms)
      %record(zero fm)%name Z == D_zero
      %record(parm fm) P = 0

      Z_marked = -1;  Z_system area = -1;  Z_system size = -1
      Z_initialisation date = DATE
      %while to do > 0 %cycle            {fields left to fill}
         j = 1
         %while j <= parms %cycle
            %if mask & 1<<j # 0 %start
               prompt (parm id(j))
               scan (atom) %if j # descr
               -> F(j)

               F(vol id):
                  %if length(atom) > 4 %start
                     report ("Volume-id too long")
                     %continue
                  %finish
                  Z_vol id = 0
                  atom = atom . " " %while length(atom) < 4
                  Z_vol id = Z_vol id<<8 ! char no (atom,k) %for k = 1,1,4
                  mask = mask & (\(1<<j))
                  to do = to do - 1
                  %continue
               F(disc id):
                  P_filename = atom . "_:";  SVC (pack filename,P)
                  report ("Illegal disc name") %and
                     %continue %if P_p6 # 0
                  Z_disc id = atom
                  mask = mask & (\(1<<j))
                  to do = to do - 1
                  %continue
               F(sys area):
                  %if atom = "NO" %start
                     {Sytem area deleted next time disc is COMPRESSed}
                     Z_system area = 0
                     Z_system size = 0
                  %finish
                  mask = mask & (\(1<<j));  to do = to do - 1
                  %continue
               F(descr):
                  Z_description = ""
                  %while next symbol # NL %cycle
                     Z_description <- Z_description . to string(next symbol)
                     skip symbol
                  %repeat
                  skip symbol {NL}
                  mask = mask & (\(1<<j))
                  to do = to do - 1
                  %continue
               F(make):
                  %cycle
                     %for k = 1,1,types %cycle
                        %if type id (k) = atom %start
                           Z_tracks = tracks(k)
                           Z_blocks per cylinder = blocks per cylinder(k)
                           Z_heads = heads(k)
                           mask = mask & (\(1<<j))
                           to do = to do - 1
                           %if k = last type {"UNKNOWN"} %start
                              prompt ("Tracks:");  scan (atom)
                              Z_tracks = stoi (atom)
                              prompt ("Blocks per cylinder:");  scan (atom)
                              Z_blocks per cylinder = stoi (atom)
                              prompt ("Heads:");  scan (atom)
                              Z_heads = stoi (atom)
                           %finish
                           %exit
                        %finish
                        %if k = last type %start   {ATOM matches no type}
                           report ("Valid types are:")
                           report (type id(m)) %for m = 1,1,types
                           report ("UNKNOWN to spec disc parms by hand")
                           scan (atom)
                        %finish
                     %repeat
                  %repeat %until mask & 1<<j = 0
            %finish
            j = j + 1
         %repeat
      %repeat
      D_zero_checksum = 0
      D_zero_checksum = checkword (D_zero)
      write block (D,0,D_zero)
   %end

   %routine make sure (%record(disc)%name D)
      %string(15) reply
      %return %if D_errors # 0           {nothing worth keeping}
      report ("**Are you sure you want to overwrite " . D_zero_disc id . "?")
      prompt ("Yes/no? ")
      scan   (reply)
      %stop %unless reply = "YES"
   %end

   %routine set map (%record(disc)%name D)
      !D bitmap set with all blocks protected
      !except those on its free list
      %record(spine) free
      %record(extent)%name e
      %integer j,k
      %const %integer all bits = \0
      D_bitmap(j) = all bits %for j = 0,1,2047   {protect all}
      read block (D,D_zero_free list,free)
      %for j = 1,1,126 %cycle
         e == free_extent(j)
         %if e_length # 0 %start
            clear bit (D_bitmap,k) %for k = e_base&H, 1, %c
                                            e_base&H + e_length&H - 1
         %finish
      %repeat
   %end


                     !###############################
                     !#                             #
                     !#   M A I N   P R O G R A M   #
                     !#                             #
                     !###############################


   %const %integer all = \0              {all bits set}
   %const %string(1) null = ""
   %const %string(31) no disc = ": no such disc"
   %integer keep = 0
   %string(*)%name parm == COMMAND_parameter  {command line parameter}
   normalise (Parm)
   report ("DISC " . parm . " " . version)
   report (itos(buf len) . " buffers claimed") %if exclam = '?'
   %string(*)%name listing file == COMMAND_out2,
                   in1          == COMMAND_in1,   {1st input stream-id}
                   out1         == COMMAND_out2
   %integer pages, odd blocks
   open output (listing,listing file) %if listing file # null
   select input (console);  select output (console)
   %integer j, ctype = 0
   %string(80) line
   %record(parm fm) P
   %switch C (1:commands)

   %routine check (%string(*)%name s, %string(31) mess)
      %return %if s # null
      prompt (mess);  scan (s)
   %end

   %routine check in (%string(*)%name s) {check file was specd for stream}
      check (s, "Input disc? ")
   %end

   %routine check out (%string(*)%name s)
      check (s, "Output disc? ")
   %end

   %if parm = "KEEP" %start
      keep = 1
again:prompt("Param: ");  read(parm)
      normalise(parm)
   %finish
   clear out
   keep = 0 %and ->stop %if parm = "STOP" %or PARM = "QUIT"
   %for j = 1,1,commands %cycle
      %if parm = command word(j) %start
         Ctype = j
         %exit
      %finish
   %repeat
   report (parm . "?") %and %stop %if Ctype <= 0
   -> C (Ctype)

C(1): !TEST
      testing = non zero
      check in (in1);  set disc (in,in1);  set disc (out,null)
      squeeze (in,out)
      validate free list (in)
      list (in) %if listing file # null
      -> STOP

C(9): !COPYUSER
C(10):!COPYUSERS
      copy user = non zero;  wanted users = 0
      prompt ("Copy: ")
      %cycle
         scan (line);  line = line . ","
         %while line -> parm . (",") . line %and parm # ".END" %cycle
            %continue %if parm = ""
            P_filename = parm . ":";  SVC (pack filename,P)
            %if P_p2 < 0 %start
               report ("Illegal name: " . parm)
            %else
               wanted users = wanted users + 1
               wanted user(wanted users) = P_p2
            %finish
         %repeat
      %repeat %until parm = ".END"
      !drop thru..

C(2): !COMPRESS
      check in (in1);  check out (out1)
      set disc (out,out1)
      make sure (out) %if copy user = 0
      set map (out) %if ctype = 9 %or ctype = 10
      set disc (in,in1)
      error ("Input = output?") %if in_unit no = out_unit no
      squeeze (in,out)
      validate free list (in)
      %if errors # 0 %start
         error ("***FAULTY INPUT DISC***")
         %stop %if exclam # '!'          {explictly ignore errors with '!'}
         errors = 0
      %finish
      report ("Testing output disc")
      testing = non zero
      set disc (in,null)
      set disc (out,out1)   {clears bitmap in OUT}
      squeeze (out,in)
      validate free list (out)
      report ("***FAULTY OUPUT DISC PRODUCED***") %and %stop %if errors # 0
      list (out) %if listing file # null
      -> STOP

C(3): !initialise
      splatting = non zero
      check out (out1);  set disc (out,out1)
      make sure (out)
      out_zero_free list = -1            {these blocks are allocated by WIPE}
      out_zero_user list = -1
      out_zero_defective list = -1
      out_zero_initialised = -1          {only after wiping}
      set zero (out,all,fields)

C(4): !WIPE
      check out (out1);  set disc (out,out1)
      make sure (out) %if ctype = 4
      wipe (out)
      -> stop

C(5): !KILL
      check out (out1);  set disc (out,out1)
      make sure (out)
      out_zero = 0;  out_zero_initialised = non zero   {now wont LOAD ok}
      out_zero_checksum = checkword(out_zero) + 1      {checksum wrong too!}
      write block (out,0,out_zero)
      -> STOP

C(6): !ZERO
      splatting = non zero
      check out (out1);  set disc (out,out1)
      make sure (out)
      set zero (out, all, fields)
      !set preferred pointers
      out_zero_free list     = default free list
      out_zero_user list     = default free list + 1
      out_zero_defective list= default free list + 2
      %if out_zero_system area # 0 %start
         out_zero_system area = 1
         out_zero_system size = sys size
      %finish
PUT ZERO:
      out_zero_checksum = 0;  out_zero_checksum = check word (out_zero)
      write block(out,0,out_zero)
      -> STOP

C(7): !COPY
      splatting = non zero               {suppress block zero checking}
      check out (out1);  set disc (out,out1)
      check in  (in1);   set disc (in,in1)
      make sure (out)
      set zero (out, 1<<make, 1);        !!cant scribble on IN!!
      j = out_zero_tracks * out_zero_blocks per cylinder
      pages = j // buf len;  odd blocks = rem (j,buf len)
      %for j = 0, buf len, (pages - 1) * buf len %cycle
         read page  (in, j, buf len, 1)
         write page (out,j, buf len, 1)
      %repeat
      %for j = pages*buf len, 1, pages*buf len + odd blocks - 1 %cycle
         read block  (in,  j, buf(1))
         write block (out, j, buf(1))
      %repeat
      -> STOP

C(8): !HELP
      open input (help text, program source)
      select input (help text)
      skip symbol                        {first '!'}
      %cycle
         read symbol (j)
         %exit %if j = '\'               {terminating character}
         print symbol (j)
         skip symbol %if j = NL          {past '!'}
      %repeat
      newline
      close input;  -> STOP

C(11):!TIDY
      check in (in1);  set disc (in,in1)
      set disc (out,null)
      -> STOP %if errors # 0
      testing = non zero
      squeeze (in,out)                   {check input disc for errors}
      %if errors # 0 %start
         report("***Faulty input disc")
         errors = 0 %if exclam # 0
      %finish
      tidy(in) %if errors = 0
      -> STOP

C(12):!RENAME
      check in (in1);  set disc (in,in1)
      check out (out1)
      length(out1) = 4 %if length(out1) > 4;  in_zero_disc id = out1
      report (in1 . " renamed " . in_zero_disc id)
      -> PUT ZERO

C(13):!LIST
      check in (in1);  set disc (in,in1)
      list (in)
      -> STOP

STOP:
   doing ("")
   %if errors = 0 %then parm = "No" %else parm = itos (errors)
   parm = parm . " error";  parm = parm . "s" %if errors # 1
   report (parm)
   ->again %if keep # 0

%end %of %program