! "Standard" Imp run time support library

%option "-low-nons-nocheck-nodiag-nostack"
%include "nmouse.inc-nolist"

%systemroutine NEWLINES (%integer n)
  n = n-1 %and printsymbol(nl) %while n>0
%end

%systemroutine SPACES (%integer n)
  n = n-1 %and printsymbol(' ') %while n>0
%end

%systemroutine PRINTLINE (%string(255)s)
  printstring(s); printsymbol(nl)
%end

%systemroutine READLINE (%string(*)%name s)
! For symmetry with PRINT LINE, the terminating NL is skipped and
! not included in the string.  Blank lines are not ignored, nor are
! leading and trailing spaces.
%integer sym
%bytename b
  b == length(s); b = 0
  %cycle
    readsymbol(sym); %exitif sym=nl
    b = b+1; b[b] = sym
  %repeat
%end

%systemstring(8)%fn ITOH (%integer n)
! Convert integer to 8-digit hex string
%integer i,k
%string(8)s=""
  %for i = 28,-4,0 %cycle
    k = n>>i&15; k = k+7 %if k>9; s = s.tostring(k+'0')
  %repeat
  %result = s
%end

%systemintegerfn HTOI (%string(255)s)
! Convert hex string to integer
%integer n=0,p=0,k
  %cycle
    p = p+1
    %result = n %if p>length(s)
    k = charno(s,p); %continueif k<=' '
    k = k-'0'
    %if k>9 %start
      k = k-32 %if k>='a'-'0'
      k = k-7 %if k-7>9
    %finish
    %result = n %unless 0<=k<=15
    n = n<<4+k
  %repeat
%end

%systemintegerfn STOI (%string(255)s)
! Convert decimal string to integer
%integer i,k
%integer sign=0, val=0
  i = 0
  %while i < length(s) %cycle
    i = i+1;  k = charno(s,i)
    %continue %if k <= ' '
    %if k = '-' %start
      sign = 1
    %else %if '0' <= k <= '9'
      val = val<<3+val+val+k-'0'
    %else
      %signal 4, 1, k, "Non-numeric character"
    %finish
  %repeat
  %result = val %if sign = 0
  %result = -val
%end

%systemstring(255)%fn ITOS (%integer v,p)
! Convert integer to decimal string
%string(255)s
%bytename l
  %routine printsymbol(%integer x)
    l = l+1; l[l] = x
  %end
  %routine spaces(%integer x)
    x = x-1 %and printsymbol(' ') %while x>0
  %end
  %routine write(%integer n,p)
  %integer q,r
    %if p>0 %start
      p = \p; printsymbol(' ') %and p = p+1 %if n>=0
    %finish
    p = -120 %if p<-120
    q = n//10; r = {rem(n,10)} d1 
    %if q=0 %start
      p = p+1 %if n<0; spaces(-1-p); printsymbol('-') %if n<0
    %else
      p = p+1 %if p<0; write(q,p)
    %finish
    printsymbol(|r|+'0')
  %end
  s = ""; l == length(s)
  write(v,p)
  %result = s
%end

%systemstring(255)%fn RTOS (%real r,%integer n,m)
%constreal pmax = 2147483647.0
%real y,z
%integer i=0,l,count=0,sign=' '
%string(255)result = ""
  sign = '-' %if r < 0
  m = 80 %if m>80
  n = 254-m %if 254-m>255
  y = |r|+0.5/10.0\m;  !modulus, rounded
  %if y > pmax %start
    count = count+1 %and y = y/10.0 %until y < 10.0
  %finish
  z = 1.0
  %cycle
    i = i+1;  z = z*10.0
  %repeat %until z > y
  l = n-i
  result = result." " %and l = l-1 %while l>0
  result = result.tostring(sign) %unless sign = ' ' %and n <= 0
  %cycle
    z = z/10.0
    l = int pt(y/z)
    y = y-l*z
    result = result.tostring(l+'0')
    i = i-1
    %exit %if i+m <= 0
    result = result."." %if i = 0
  %repeat
  result = result."@".itos(count,0) %if count # 0
  %result = result
%end

%systemstring(255)%fn RTOF (%real x, %integer n)
%real y,round
%integer count=-99,sign=0
%string(255) result=""
  %if x # 0 %start
    x = -x %and sign = 1 %if x < 0
   !Adjust X so that 1.0 <= rounded(X) < 10.0
    count = 0;  round = 0.5\n
    y = 1.0-round
    %if x < y %start;  !ie rounded(X) < 1.0
      count = count-1 %and x = x*10.0 %until x >= y
    %finish %else %start
      y = 10.0-round
      %while x >= y %cycle;  !ie rounded(X) > 10.0
        count = count+1;  x = x/10.0
      %repeat
    %finish
    x = -x %if sign # 0
  %finish
  result = rtos(x,1,n)
  result = result."@".itos(count,0)
  %result = result
%end

%systemrealfn STOR (%string(255)Input)
%integer Sign = 0, Sym, Pos = 1
%real Value, Exp

   %routine Next
      Pos = Pos + 1
      %if Pos > Length (Input) %start
         Sym = 0
      %else
         Sym = Char No (Input, Pos)
      %finish
   %end

   Sym = Char No (Input, Pos)
   %if Sym = '-' %start
      Sign = 1
      Next
   %finish
   Value = 0
   %if Sym # '.' %start
      %signal 6, 5, Pos %unless '0' <= Sym <= '9'
      %cycle
         Value = Value*10.0 + (Sym - '0')
         Next
      %repeat %until %not '0' <= Sym <= '9'
   %finish
   %if Sym = '.' %start
      Exp = 10.0
      %cycle
         Next
         %exit %unless '0' <= Sym <= '9'
         Value = Value + (Sym - '0')/Exp
         Exp = Exp * 10.0
      %repeat
   %finish
   %if Sym = '@' %start
      Sym = SToI (Sub String (Input, Pos + 1, Length (Input)))
      Value = Value * 10.0\Sym
   %finish
   Value = -Value %if Sign # 0
   %result = Value
%end

%systemrealfn FTOR (%string(255)s)
  %result = stor(s)
%end

%systemintegerfn READINTEGER %alias "READ"
! Read a decimal integer.  The radix may be changed using '_' as customary.
%integer i,k,sign,ten=10,max='9'
  %cycle
    k = next symbol
    %exit %if k > ' '
    skip symbol
  %repeat
  sign = 0
  %if k = '-' %start
    sign = 1
    skip symbol;  k = next symbol
  %finish
  %cycle
    %signal 4,1,k,"READ: Non-numeric character" %unless '0'<=k<=max
    i = k-'0'
    %cycle
      skip symbol
      k = next symbol
      k = k-32 %if k>='a'
      %if k>'9' %start
        %exitif k<'A'
        k = k-7
      %finish
      %exit %unless '0' <= k <= max
      i = i*ten-'0'+k
    %repeat
    %exitunless k='_'-7
    ten = i; max = '0'+ten-1
    skipsymbol; k = nextsymbol
    k = k-32 %if k>='a'
    %if k>'9' %start
      k = -1 %if k<'A'
      k = k-7
    %finish
  %repeat
  i = -i %if sign # 0
  %result = i
%end

%systemrealfn READREAL
%integer sign=0,sym
%real value,exp
  %cycle
    sym = nextsymbol
    %exit %if sym > ' '
    skipsymbol
  %repeat
  %if sym = '-' %start
    sign = 1
    skip symbol;  sym = nextsymbol
  %finish
  value = 0
  %if sym # '.' %start
    %signal 4,1,sym,"READ: Non-numeric character" %unless '0' <= sym <= '9'
    %cycle
      value = value*10.0+(sym-'0')
      skip symbol;  sym = nextsymbol
    %repeat %until %not '0' <= sym <= '9'
  %finish
  %if sym = '.' %start
    exp = 10.0
    %cycle
      skip symbol;  sym = nextsymbol
      %exit %unless '0' <= sym <= '9'
      value = value+(sym-'0')/exp
      exp = exp*10.0
    %repeat
  %finish
  %if sym = '@' %start
    skipsymbol
    sym = readinteger
    value = value*10.0\sym
  %finish
  value = -value %if sign # 0
  %result = value
%end

%systemstring(255)%fn READSTRING
! Read a sequence of non-control characters (characters > ' '),
! skipping any leading control characters.  But if a leading quote
! (single or double) is found, proceed in the obvious way.
%string(255)s
%integer term=-1,sym
%bytename b
  b == length(s); b = 0
  readsymbol(sym) %until sym>' '
  term = sym %and readsymbol(sym) %if sym='"' %or sym=''''
  %cycle
    %if sym=term %start
      %exitunless nextsymbol=term
      skipsymbol
    %finish
    b = b+1; b[b] = sym
    sym = nextsymbol; %exitif term<0 %and sym<=' '
    skipsymbol
  %repeat
  %result = s
%end

%systemroutine WRITE (%integer n,p)
  printstring(itos(n,p))
%end

%systemroutine PRINT (%real x, %integer n,m)
  printstring(rtos(x,n,m))
%end

%systemroutine PRINTFL (%real x, %integer n)
  printstring(rtof(x,n))
%end

%systemroutine PHEX1 (%integer x)
  x = x&15; x = x+7 %if x>9; printsymbol(x+'0')
%end

%systemroutine PHEX2 (%integer x)
  phex1(x>>4); phex1(x)
%end

%systemroutine PHEX4 (%integer x)
  phex2(x>>8); phex2(x)
%end

%systemroutine PHEX (%integer x)
  phex4(x>>16); phex4(x)
%end

%systemintegerfn RHEX
%integer n=0,s
  %onevent 4 %start
    %signal 4,1,s,"RHEX: Non-numeric character"
  %finish
  %cycle
    s = nextsymbol; %exitif s>' '
    skipsymbol
  %repeat
  s = s&95 %if s>='a'
  %signal 4 %unless '0'<=s<='9' %or 'A'<=s<='F'
  %while '0'<=s<='9' %or 'A'<=s<='F' %cycle
    s = s-'0'; s = s-7 %if s>9
    n = n<<4+s; skipsymbol; s = nextsymbol
    s = s&95 %if s>='a'
  %repeat
  %result = n
%end

! String manipulation

%systemroutine TOUPPER (%string(*)%name s)
%bytename b
%integer i
  b == length(s); i = b
  %while i>0 %cycle
    i = i-1; b == b[1]
    b = b&95 %if 'a'<=b<='z'
  %repeat
%end

%systemroutine TOLOWER (%string(*)%name s)
%bytename b
%integer i
  b == length(s); i = b
  %while i>0 %cycle
    i = i-1; b == b[1]
    b = b!32 %if 'A'<=b<='Z'
  %repeat
%end

%systemroutine TOMIXED (%string(*)%name s)
%bytename b
%integer i,j=0
  b == length(s); i = b
  %while i>0 %cycle
    i = i-1; b == b[1]
    %if 'A'<=b&95<='Z' %then b = b&95!j %and j = 32 %else j = 0
  %repeat
%end

%systempredicate RESOLVES (%string(*)%name var,match,fore,aft)
!!Resolve the string specified by VAR into FORE and AFT split by MATCH
!![FORE and/or AFT absent is conventionally represented by an address
!! of zero]
%integer i
%option "-noline" {not to perturb pred result (compiler neglects to retest)}
  %integerfn resol(%string(*)%name var,match)
  !Return index position of first occurrence of MATCH within VAR
  %label yes,no
    *clr.l d0
    *clr.w d1
    *move.b (a1)+,d1  {length(match)
    *beq yes          {match="" ->
    *clr.w d2
    *move.b (a0)+,d2  {length(var)
    *sub.b d1,d2
    *bcs no           {length(match)>length(var) ->  {*bug: was bmi
    *subq.w #1,d1
loop1:
    *lea 0(a0,d0),a2
    *move.l a1,a3
    *move d1,d3
loop2:
    *cmpm.b (a2)+,(a3)+
    *dbne d3,loop2 {*bug?was dbeq
    *beq yes
    *addq.w #1,d0
    *dbra d2,loop1
no: *moveq #-1,d0
yes:*addq.l #1,d0
  !** (to be) re-coded for efficiency **
!  %integer i=0,j,l
!    l = length(match)
!    %cycle
!      %result = 0 %if i > length(var)-l
!      i = i+1
!      j = 0
!      %cycle
!        %result = i %if j = l
!        j = j+1
!      %repeat %until charno(var,i+j-1) # charno(match,j)
!    %repeat
  %end

  %routine assign(%string(*)%name dest, %integer from,to)
  !! **NB use of TOSTRING is compiled in-line **
  !! **OK when DEST is also source **
    dest = ""
    %while from <= to %cycle
      dest = dest.tostring(charno(var,from));  from = from+1
    %repeat
  %end

  %routine do aft
    assign(aft,i+length(match),length(var)) %unless aft==nil
  %end

  i = resol(var,match)
  %false %if i = 0
  %if fore ## nil %start
    %if fore ## var %start
      assign(fore,1,i-1)
      do aft
    %finish %else %start
      do aft
      length(var) = i-1
    %finish
  %finish %else do aft
  %true
%end

! Bulk move

%systemroutine MOVE (%integer bytes,%name from,to)
%label finished,bytewise,trylong
  *move.l a0,d1; *move.l a1,d2
  *sub.l d1,d2; *and.w #1,d2; *bne bytewise  {buffers misaligned ->
  *move.l d0,d2; *ble finished               {non-positive amount =>
  *and.w #1,d1; *beq trylong                 {buffers word-aligned ->
  *move.b (a0)+,(a1)+; *subq.l #1,d0         {align them
trylong:
  *lsr.l #2,d2; *beq bytewise                {less than 4 bytes to go ->
  *subq.l #1,d2; *swap d2
longouter: *swap d2
longinner: *move.l (a0)+,(a1)+; *dbra d2,longinner
  *swap d2; *dbra d2,longouter
  *and.l #3,d0                               {copy remaining 0:3 bytes
bytewise: *subq.l #1,d0; *bmi finished; *swap d0
byteouter: *swap d0
byteinner: *move.b (a0)+,(a1)+; *dbra d0,byteinner
  *swap d0; *dbra d0,byteouter
finished:
%end

%systemroutinespec file op (%integer c,%string(*)%name f,%name x)
%systemrecord(fcb fm)%mapspec fcb open(%integer c,%string(*)%name f,%name x)
%systemroutinespec fcb close(%record(fcb fm)%name x)
%systemroutinespec fcb abort(%record(fcb fm)%name x)

%systemintegerfn FCB size (%record(fcb fm)%name x)
! Returns the size of the file (input or output).
  %result = 0 %if x==nil
  %result = x_fl-x_fs
%end

%systemintegerfn FCB pos (%record(fcb fm)%name x)
! Returns the current position in the file (input or output).
  %result = 0 %if x==nil
  %result = x_p-x_fs
%end

%externalroutine LOGOUT (%string(255)fs)
  standardise filename(fs)
  file op(foplogout,fs,nil)
%end

%externalroutine LOGIN (%string(255)fsu,p)
  standardise filename(fsu)
  file op(foplogin,fsu,p)
%end

%externalroutine QUOTE (%string(255)fs,p)
  standardise filename(fs)
  file op(fopquote,fs,p)
%end

%externalroutine PASSWORD (%string(255)fs,p)
  standardise filename(fs)
  file op(foppass,fs,p)
%end
  
%externalrecord(fcb fm)%map FILE OPEN INPUT (%string(255)f)
  standardise filename(f)
  %result == fcb open(fopopeni,f,nil)
%end

%externalrecord(fcb fm)%map FILE OPEN OUTPUT (%string(255)f)
  standardise filename(f)
  %result == fcb open(fopopeno,f,nil)
%end

%externalrecord(fcb fm)%map FILE OPEN MODIFY (%string(255)f)
  standardise filename(f)
  %result == fcb open(fopopenm,f,nil)
%end

%externalrecord(fcb fm)%map FILE OPEN APPEND (%string(255)f)
  standardise filename(f)
  %result == fcb open(fopopena,f,nil)
%end

%externalroutine OPENINPUT (%integer s,%string(255)f)
%record(fcb fm)%name fcb
  selectinput(s)
  fcb == file open input(f)
  fcb_next == poa_in(s)
  poa_in(s) == fcb
  poa_curin == fcb
%end

%externalroutine OPENOUTPUT (%integer s,%string(255)f)
%record(fcb fm)%name fcb
  selectoutput(s)
  fcb == file open output(f)
  fcb_next == poa_out(s)
  poa_out(s) == fcb
  poa_curout == fcb
%end

%externalroutine OPENMODIFY (%integer s,%string(255)f)
%record(fcb fm)%name fcb
  selectoutput(s)
  fcb == file open modify(f)
  fcb_next == poa_out(s)
  poa_out(s) == fcb
  poa_curout == fcb
%end

%externalroutine OPENAPPEND (%integer s,%string(255)f)
%record(fcb fm)%name fcb
  selectoutput(s)
  fcb == file open append(f)
  fcb_next == poa_out(s)
  poa_out(s) == fcb
  poa_curout == fcb
%end

%externalroutine CREDIR (%string(255)f)
  standardise filename(f)
  file op(fopcredir,f,nil)
%end

%externalroutine DELETE (%string(255)f)
  standardise filename(f)
  file op(fopdelete,f,nil)
%end

%externalroutine NINFO (%string(255)f,%string(*)%name info)
  standardise filename(f)
  file op(fopinfo,f,info)
%end

%externalroutine RENAME (%string(255)old,new)
  standardise filename(old)
  standardise filename(new)
  file op(foprename,old,new)
%end

%externalroutine COPY (%string(255)from,to)
  standardise filename(from)
  standardise filename(to)
  file op(fopcopy,from,to)
%end

%externalroutine PERMIT (%string(255)f,p)
  standardise filename(f)
  file op(foppermit,f,p)
%end

%externalroutine CHANGE DATE (%string(255)f,d)
  standardise filename(f)
  file op(fopstamp,f,d)
%end

%externalstring(255)%fn GET DATE AND TIME (%string(255)fs)
%string(255)d
  standardise filename(fs)
  file op(foptime,fs,d)
  %result = d
%end

%externalstring(255)%fn DATETIME
  %result = get date and time(".")
%end

%externalstring(255)%fn DATE
%string(255)dt = datetime
%bytename b == length(dt)
  b = b-1 %while b>0 %and b[b]#' '
  b = b-1 %while b>0 %and b[b]=' '
  %result = dt
%end

%externalstring(255)%fn TIME
%string(255)dt = datetime
%bytename b == length(dt)
%integer p = b
  p = p-1 %while p>0 %and b[p]#' '
  dt = substring(dt,p+1,b)
  %result = dt
%end

%systemintegerfn INSTREAM
  %result = poa_instream
%end

%systemintegerfn OUTSTREAM
  %result = poa_outstream
%end

%externalintegerfn INPUT FILE POSITION
  %result = fcb pos(poa_curin)
%end

%externalintegerfn OUTPUT FILE POSITION
  %result = fcb pos(poa_curout)
%end

%externalintegerfn INPUT FILE SIZE
  %result = fcb size(poa_curin)
%end

%externalintegerfn OUTPUT FILE SIZE
  %result = fcb size(poa_curout)
%end

%systemroutine PROMPT (%string(255)s)
  %returnif poa_curin==nil
  %returnif poa_curin_prompt==nil
  poa_curin_prompt = s
%end

%systemstring(255)%fn INFILENAME
  %result = ":N" %if poa_curin==nil
  %result = poa_curin_filename
%end

%systemstring(255)%fn OUTFILENAME
  %result = ":N" %if poa_curout==nil
  %result = poa_curout_filename
%end

%externalintegerfn filesize(%string(255)f)
%record(fcb fm)%name cb == file open input(f)
%integer n = fcb size(cb)
  fcb close(cb)
  %result = n
%end

%externalpredicate exists(%string(255)f)
  %on 3 %start
    %false
  %finish
  fcb close(file open input(f))
  %true
%end

%record(*)%map lock(%record(*)%name r)
  %result == nil %if r==nil
  %result == record(addr(r)!16_80000000)
%end

%record(*)%map unlock(%record(*)%name r)
  %result == nil %if r==nil
  %result == record(addr(r)&16_7fffffff)
%end

%predicate locked(%record(fcb fm)%name cb)
  %trueif cb==nil
  %trueif addr(cb_next)<0
  %false
%end

%systemroutine lock all streams
%integer i
%record(fcb fm)%name cb
  %for i = 0,1,7 %cycle
    cb == poa_in(i)
    cb_next == lock(cb_next) %unless cb==nil
  %repeat
  %for i = 0,1,7 %cycle
    cb == poa_out(i)
    cb_next == lock(cb_next) %unless cb==nil
  %repeat
%end

%systemroutine unlock all streams
%integer i
%record(fcb fm)%name cb
  %for i = 0,1,7 %cycle
    cb == poa_in(i)
    cb_next == lock(cb_next) %unless cb==nil
  %repeat
  %for i = 0,1,7 %cycle
    cb == poa_out(i)
    cb_next == lock(cb_next) %unless cb==nil
  %repeat
%end

%externalroutine close all streams
%integer i
%record(fcb fm)%name cb
  poa_curin == nil
  %for i = 0,1,7 %cycle
    %cycle
      cb == poa_in(i); %exitif locked(cb); poa_in(i) == cb_next
      fcbclose(cb)
    %repeat
  %repeat
  selectinput(0)
  %for i = 7,-1,0 %cycle
    %cycle
      cb == poa_out(i); %exitif locked(cb); poa_out(i) == cb_next
      %if event_event!event_sub=0 %then fcbclose(cb) %else fcbabort(cb)
    %repeat
  %repeat
  selectoutput(0)
%end