! General utility procedures

%include "I:UTIL.INC"
%include "I:FS.INC"
%include "CONFIG.INC"
%include "COMMON"
%include "ERRORS.INC"
%include "SCHEDULE.INC"

%routinespec pdate

%ownrecord(common fm)%name common

%recordformat frig fm(%record(common fm)%name common)
%externalrecord(frig fm) common frig
! These are necessary, because %external %names don't work


! "High-density" hex.  Usually just "normal" hex, except that
! the high order hexit isn't forced to be modulo 16, and the
! sequence goes ...8, 9, :, ;, .... rather than the more
! normal ...8, 9, A, B, ....

%externalstring(1)%fn hdx1(%integer i)
   ! single hexit version
   %result = tostring(i + '0')
%end

%externalstring(2)%fn hdx2(%integer i)
   ! two hexit version
   %result = "" %if i < 0  { Special }
   %result = tostring(i >> 4 + '0') . tostring(i & 15 + '0')
%end

%externalstring(4)%fn hdx4(%integer i)
   ! four hexit version
   %string(7) s
   %integer j, k, n
      s = ""
      %for n = 1, 1, 4 %cycle
         j = i // 16
         k = i - 16 * j
         s = tostring(k + '0') . s
         i = j
      %repeat
      %result = s
%end

%externalintegerfn hdx to i(%string(255) s)
   ! convert from "high-density" hex to binary
   %integer i, x = 0
      %result = 0 %if s = ""
      x = x << 4 + charno(s, i) - '0' %c
         %for i = 1, 1, length(s)
      %result = x
%end


! "Normal" hex

%externalroutine pxb(%integer what)
   ! This one is redundant, as it is pre-defined in
   ! the operating system.
   %integer ch
      ch = (what >> 4) & 15
      %if 0 <= ch <= 9 %then print symbol(ch + '0') %c
                       %else print symbol(ch - 10 + 'A')
      ch = what & 15
      %if 0 <= ch <= 9 %then print symbol(ch + '0') %c
                       %else print symbol(ch - 10 + 'A')
%end

%externalstring(2)%fn itox2(%integer what)
   ! convert binary to a 2-hexit string
   %string(3) s
   %integer ch
      ch = (what >> 4) & 15
      %if 0 <= ch <= 9 %then s = to string(ch + '0') %c
                       %else s = to string(ch - 10 + 'A')
      ch = what & 15
      %if 0 <= ch <= 9 %then s = s . to string(ch + '0') %c
                       %else s = s . to string(ch - 10 + 'A')
      %result = s
%end



! Case conversion

%externalroutine upper case(%string(*)%name s)
   ! convert the parameter to upper case
   %bytename ch
   %integer l
      l = length(s)
      %return %if l = 0
      ch == charno(s, 1)
      %while l > 0 %cycle
         ch = ch - 'a' + 'A' %if 'a' <= ch <= 'z'
         ch == ch[1]
         l = l - 1
      %repeat
%end


! Zap login.  (And also set and quoted passwords).  Ensures that
! passwords don't appear either in the trace buffer or on the
! console.

%externalroutine zap login(%string(*)%name text) 
   { L, Q, P }
   %integer l, ch
      %return %if text = ""
      ch = charno(text, 1)
      ch = ch - 'a' + 'A' %if 'a' <= ch <= 'z'
      %if ch = 'P' %or ch = 'Q' %start
         ! Password or Quote.  Only one parameter.
         length(text) = 2
         text = text . "????"
      %else %if ch = 'L'
         ! Login.  Two parameters.  The first is variable
         ! in length, so we have to hunt for the start of
         ! the second....
         l = length(text)
         l = l - 1 %while l > 0 %and charno(text, l) # ','
         length(text) = l %if l # 0
         text = text . "????"
      %else %if ch = ']'
         %if length(text) > 4 %and charno(text, 3) = '6' %start
            ! Setting system password
            length(text) = 4
            text = text . "????"
         %finish
      %finish
%end


! Pack / unpack filenames.  Radix-40 used throughout the
! file system, both for filenames and for usernames.

%externalintegerfn pack(%string(255) s, %integername p1, p2)
   %integer l, pos, error = success

   %integerfn pack3
      ! pack one 16-bit portion
      %integer i, j = 0, ch
         %for i = 1, 1, 3 %cycle
            j = 40 * j
            pos = pos + 1
            %if pos <= l %start
               ch = charno(s, pos)
               %if 'A' <= ch <= 'Z' %start
                  ch = ch - 'A' + 1
               %else %if 'a' <= ch <= 'z'
                  ch = ch - 'a' + 1
               %else %if '0' <= ch <= '9'
                  ch = ch - '0' + 28
               %else %if ch = '.'
                  ch = 38
               %else %if ch = '$'
                  ch = 39
               %else %if ch = '_'
                  ch = 27
               %else %if ch = '#'
                  ch = 0
               %else
                  error = param error
                  ch = 0
               %finish
               j = j + ch
            %finish
         %repeat
         %result = j
   %end

      l = length(s)
      %if l = 0 %start
         ! null filename -- special case
         p1 = 0;  p2 = 0
         %result = success
      %finish
      %result = param error %unless l <= 12;  ! too long
      pos = 0
      p1 = pack3 << 16 ! pack3
      p2 = pack3 << 16 ! pack3
      %result = param error %if p1 = 0 %and p2 = 0
      %result = error
%end


%constbytearray pchar(0 : 39) =
   '#', 'A', 'B', 'C',  'D', 'E', 'F', 'G',
   'H', 'I', 'J', 'K',  'L', 'M', 'N', 'O',
   'P', 'Q', 'R', 'S',  'T', 'U', 'V', 'W',
   'X', 'Y', 'Z', '_',  '0', '1', '2', '3',
   '4', '5', '6', '7',  '8', '9', '.', '$'

%constinteger dollars = 16_F9FF

%externalstring(31)%fn unpack(%integer p1, p2)

   %string(3)%fn unpack3(%integer p, z1, z2, z3)
      ! unpack one 16-bit portion
      %bytearray u(1 : 3)
      %string(3) s = ""
      %integer i, q, r, last, it
         %result = "" %if p = 0 %and z1 = 0 %and z2 = 0 %and z3 = 0
         %result = "***" %unless 0 <= p <= dollars
         %for i = 3, -1, 1 %cycle
            q = p // 40
            r = p - 40 * q
            u(i) = r
            p = q
         %repeat
         last = z1 ! z2 ! z3
         %for i = 3, -1, 1 %cycle
            it = u(i)
            s = to string(pchar(it)) . s %if it # 0 %or last # 0
            last = it %if last = 0
         %repeat
         %result = s
   %end

   %integer x1, x2, x3, x4
      %result = "*bad*" %if p1 = -1
      %result = "?zero?" %if p1 = 0 %and p2 = 0
      x1 = p1 >> 16;  x2 = p1 & 16_FFFF
      x3 = p2 >> 16;  x4 = p2 & 16_FFFF
      %result = unpack3(x1, x2, x3, x4) . %c
                unpack3(x2, x3, x4,  0) . %c
                unpack3(x3, x4,  0,  0) . %c
                unpack3(x4,  0,  0,  0)
%end


! Password encryption -- probably secure enough....?

%integerfn ecma crc(%integer ad, len)
   ! Provided by Gordon Brebner
   %integer rem
   %routine include(%byte b)
      %integer i, flag
         %for i = 0, 1, 7 %cycle
            flag = rem
            rem = rem<<1 ! b&1
            rem = rem !! 2_00000100110000010001110110110111 %if flag < 0
            b = b>>1
         %repeat
   %end
      rem = 16_FFFFFFFF
      include(byte integer(ad)) %for ad = ad, 1, ad+len-1
      include(0);  include(0)
      %result = \rem
%end

%externalintegerfn encrypt(%string(255) pass)
   %result = 0 %if pass = ""
   upper case(pass)
   %result = ecma crc(addr(pass) + 1, length(pass))
%end


! Bulk move of bytes

%externalroutine bulk move(%integer bytes, %bytename from, to)
   ! This routine based on one by RWT
   %if bytes <= 0 %start
      pdate
      printstring("*** Bulk move ");  write(bytes, 0)
      printstring(" bytes ????")
      newline
      %return
   %finish
   ! printstring("Bulk move ");  write(bytes, 0)
   ! printstring(" from ");  phex(addr(from))
   ! printstring(" to ");  phex(addr(to))
   ! newline
   bytes = bytes - 1
   *move.l from, a0
   *move.l to, a1
   *move.l bytes, d0
loop:
   *move.b (a0)+, (a1)+
   *dbra   d0, loop
%end


! Add text to trace buffer.
! The labels circumvent(ed) a compiler problem.

%externalroutine trace(%integer context, inout, %string(255) text)
   %record(trace fm)%name trace
   %integer x
      length(text) = length(text) - 1 %if text # "" %c
         %and charno(text, length(text)) = nl
      length(text) = 55 %if length(text) > 55
      zap login(text) %if inout = trace in
      trace == common_trace_t(common_trace_p)
c1:   x = (common_trace_p + 1) & tbuffs
c2:   common_trace_p = x
c3:   common_trace_q = x
      trace_context = context
      trace_inout   = inout
      trace_text    = text
%end


! Claim and release system buffers.  Buffers are either:
!  (a)   in use;
!  (b)   pushed onto the free list if they are no longer required;
!  (c)   above the high water mark, if they have never been used.

%externalintegerfn claim buffer
   %integer claimed
   %record(buffer fm)%name buffer
      %if common_buffer pool free # 0 %start
         ! Something on the free list
         claimed = common_buffer pool free
         buffer == common_buffer(claimed)
         common_buffer pool free = buffer_link
      %else
         ! Free list exhausted, bring the tide in some more....
         claimed = common_buffer pool used + 1
         %result = -1 %if claimed > buffs;  ! None left -- probably a disaster
         common_buffer pool used = claimed
         buffer == common_buffer(claimed)
      %finish
      buffer = 0;  ! zap it, just in case
      buffer_ether packet = -1
      %result = claimed
%end

%externalroutine release buffer(%integer which)
   %record(buffer fm)%name buffer
      buffer == common_buffer(which)
      buffer_link = common_buffer pool free
      common_buffer pool free = which
%end


! Generate / unpack dates and times.  The algorithms are taken
! from Mouses V9.2, but appear to be the same as used in the
! old filestore......?

%owninteger current date = 0
%owninteger current time = 0
%owninteger current offset
%owninteger next log stamp

%constinteger minutes per day = 24 * 60

%externalroutine time stamp(%shortname date, time)
   %integer now, x, q
      now = CPU time
      x = (now - current offset) // (60 * clock factor)
      %if x > 0 %start
         ! More minutes to add to the current time
         current time = current time + x
         current offset = current offset + (60 * clock factor) * x
         ! Find out if it's tomorrow yet....
         x = current time // minutes per day
         %if x > 0 %start
            ! Wrapped round into tomorrow, or even beyond....
            current date = current date + x
            q = minutes per day * x
            current time = current time - q
            next log stamp = next log stamp - q
         %finish
         %if current time > next log stamp %start
            ! Another console log stamp due.
            kick(stamp flag)
            next log stamp = current time + stamp interval
         %finish
      %finish
      date = current date
      time = current time
%end


! Convert the date into a printable form.
! (This %must surely be a well-known algorithm??)

%externalstring(15)%fn unpack date(%short date)
   %owninteger last unpacked = -1
   %ownbytearray s(0 : 8)
   %integer d, m, y
      %if date # last unpacked %start
         last unpacked = date
         d = (date + 21000) << 2 - 1
         y = d // 1461 + 1
         d = rem(d, 1461)
         d = ((d + 4) >> 2) * 5 - 3
         m = d // 153 - 9
         %if m <= 0 %start
            m = m + 12;  y = y - 1
         %finish
         d = (rem(d, 153) + 5) // 5
         s(0) = 8
         s(1) = d // 10 + '0'
         s(2) = rem(d, 10) + '0'
         s(3) = '/'
         s(4) = m // 10 + '0'
         s(5) = rem(m, 10) + '0'
         s(6) = '/'
         s(7) = y // 10 + '0'
         s(8) = rem(y, 10) + '0'
      %finish
      %result = string(addr(s(0)))
%end


! This one is easy -- just converts minutes to hours and minutes.

%externalstring(7)%fn unpack time(%short time)
   %bytearray b(0 : 5)
   %integer h, m
      h = time // 60
      m = rem(time, 60)
      b(0) = 5
      b(1) = h // 10 + '0'
      b(2) = rem(h, 10) + '0'
      b(3) = '.'
      b(4) = m // 10 + '0'
      b(5) = rem(m, 10) + '0'
      %result = string(addr(b(0)))
%end


! Again, a well-known algorithm.....?

%externalintegerfn pack date(%string(255) date)
   %integer y, m
      m = charno(date, 4) * 10 + charno(date, 5) - '0' * 11
      y = charno(date, 7) * 10 + charno(date, 8) - '0' * 11
      m = m - 3
      m = m + 12 %and y = y - 1 %if m < 0
      %result = (charno(date, 1) ! 16) * 10 + charno(date, 2) - '0' * 11 %c
                + (y * 1461) >> 2     %c
                + (m * 153 + 2) // 5  %c
                - 21000
%end


! Hours and minutes -> minutes

%externalintegerfn pack time(%string(255) time)
   %integer h, m
      h = charno(time, 1) * 10 + charno(time, 2) - 11 * '0'
      m = charno(time, 4) * 10 + charno(time, 5) - 11 * '0'
      %result = -1 %unless 0 <= h <= 23 %and 0 <= m <= 59
      %result = h * 60 + m
%end


! Same as <pack date>, but takes a different input format.

%conststring(3)%array months(1 : 12) =
      "JAN", "FEB", "MAR", "APR",
      "MAY", "JUN", "JUL", "AUG",
      "SEP", "OCT", "NOV", "DEC"

%integerfn pack VAX date(%string(255) date)
   %integer y, m, n
   %string(3) nn
      %result = 0 %if length(date) # 11
      m = 13
      n = charno(date, 1)
      nn = sub string(date, 4, 6)
      %cycle
         m = m - 1;  %result = 0 %if m = 0
         %exit %if months(m) = nn
      %repeat
      y = charno(date, 10) * 10 + charno(date, 11) - '0' * 11
      m = m - 3
      m = m + 12 %and y = y - 1 %if m < 0
      n = (n ! 16) * 10 + charno(date, 2) - '0' * 11 %c
          + (y * 1461) >> 2 %c
          + (m * 153 + 2) // 5 %c
          - 21000
      %result = n
%end

%externalstring(15)%fn unpack VAX date(%short date)
   %ownbytearray s(0 : 11)
   %integer d, m, y
      d = (date + 21000) << 2 - 1
      y = d // 1461 + 1
      d = rem(d, 1461)
      d = ((d + 4) >> 2) * 5 - 3
      m = d // 153 - 9
      %if m <= 0 %start
         m = m + 12;  y = y - 1
      %finish
      d = (rem(d, 153) + 5) // 5
      s(0) = 11
      s(1) = d // 10 + '0'
      s(2) = rem(d, 10) + '0'
      string(addr(s(3))) = months(m)
      s(3) = '-'
      s(7) = '-'
      s(8) = '1'
      s(9) = '9'
      s(10) = y // 10 + '0'
      s(11) = rem(y, 10) + '0'
      %result = string(addr(s(0)))
%end


! Initalise everything (during boot).

%externalroutine set VAX date(%string(255) VAX time)
   %string(255) date, time
      VAX time -> date .("  "). time
      current date = pack VAX date(date)
      current time = pack time(time)
      current offset = CPU time
      next log stamp = current time + stamp interval
%end


! Print out the time.  Print the date if it has changed.

%constinteger day fixup = 2

%conststring(11)%array days(0 : 6) =
      "Monday ", "Tuesday ", "Wednesday ",
      "Thursday ", "Friday ",
      "Saturday ", "Sunday "

%externalroutine pdate
   %short date, time
   %ownshort current date = 16_7fff
      time stamp(date, time)
      %if date # current date %start
         newline
         printstring("Today is ")
         printstring(days(rem(date + day fixup, 7)))
         printstring(unpack date(date))
         current date = date
         newline;  newline
      %finish
      printstring(unpack time(time))
      spaces(2)
%end


! Common area stuff.  If %external %names worked we wouldn't
! need all this stuff......

%externalrecord(common fm)%map common area
   %result == common
%end

%externalroutine init common
   common == common frig_common
%end


! System monitoring stuff follows.  Prints out Ether and
! scheduling states.

%externalintegerspec schedule mask
%externalintegerspec schedule cutoff
%externalintegerspec inhibit count
%externalintegerarrayspec ack wait mask(0 : ether TX procs - 1)

%externalroutine show ether status
   %integer i
      printstring("DTX: ");    phex(DTX)
      printstring(", ACK: ");  phex(ACK)
      printstring(", NAK: ");  phex(NAK)
      printstring(", ES: ");   phex2(EthS)
      newline
      printstring("AWait:")
      space %and phex(ack wait mask(i)) %for i = 0, 1, ether TX procs - 1
      newline
%end

%externalroutine show system status
   %record(buffer fm)%name b
   %integername x
      pdate
      printstring("System status.... ")
      phex(schedule mask);  write(schedule cutoff, 1)
      write(inhibit count, 1)
      write(common_disc request, 1)
      printstring(" disc iwait") %if common_disc twait # 0
      newline
      show ether status
      printstring("Ether: ")
      write((common_ether buffer_next to use %c
             - common_ether buffer_next to process) & ether buffers, 0)
      printstring(" /")
      %if common_ether request queue = 0 %start
         printstring(" queue empty")
      %else
         x == common_ether request queue
         %while x # 0 %cycle
            write(x, 1)
            x == common_buffer(x)_link
         %repeat
      %finish
      newline
      printstring("Proc: ")
      %if common_proc request queue = 0 %start
         printstring(" queue empty")
      %else
         x == common_proc request queue
         %while x # 0 %cycle
            write(x, 1)
            x == common_buffer(x)_link
         %repeat
      %finish
      newline
      kick(stamp flag)
%end

%externalroutine show buffer info
   %record(buffer fm)%name b
   %record(port fm)%name p
   %integer i
      pdate
      write(common_buffer pool used, 0)
      printstring(" used of ");  write(buffs, 0)
      %for i = 1, 1, common_buffer pool used %cycle
         b == common_buffer(i)
         %if i & 7 = 1 %start
            newline
            spaces(5)
         %finish
         write(i, 3);  space
         write(b_context, 3)
         %if 0 < b_context <= ports %start
            p == common_port info(b_context)
            %if p_state = 0 %start
               printstring(" *free*")
            %else
               space
               phex2(p_remote)
               print symbol('.')
               phex2(p_port)
               space
            %finish
         %else
            spaces(6)
         %finish
      %repeat
      newline
%end

%end %of %file
