!  File  MOUSE:IMPLIB

! Library of "standard" Imp routines
! plus heap, dictionary, logical names,
! input/output, object file loader,
! and a simple command processing loop.
! RWT September 1987

%option "-low-nons-nocheck-nodiag"

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

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

%systemroutine READLINE (%string(*)%name s)
! A LINE is a sequence of non-NL characters and may be empty, hence
! blank lines are not skipped, and leading and trailing spaces are
! significant.  The terminating NL is skipped and not included in the
! string, to make it "compatible" with PRINT LINE.
%integer sym
%bytename b
  b == length(s); b = 0
  %cycle
    readsymbol(sym); %exitif sym=nl
    b = b+1; b[b] = sym
  %repeat
%end

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

%systemstring(9)%fn ITOH (%integer n)
%string(9)s=""
%integer i,k
  %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)
%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-7 %if k-7>9
      k = k-32 %if k>15
    %finish
    %result = n %unless 0<=k<=15
    n = n<<4+k
  %repeat
%end

%systemintegerfn STOI (%string(255)s)
%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)
%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; *move.l d1,r
    %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 IREAD %alias "READ"
%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 = iread
    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
    %signal 1,3,,"READSTRING: String too big" %if b=255
    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

%systemintegerfn STRINGDIFF (%string(*)%name a,b)
{result is <=> zero iff a<=>b, but upper/lower case treated equivalent}
!%bytename p,q
!%integer n,m
!%byte pp,qq
!  p == length(a); q == length(b); m = p-q
!  %if m<=0 %then n = p %else n = q
!  %cycle
!    n = n-1; %result = m %if n<0
!    p == p[1]; q == q[1]; pp = p!32; qq = q!32
!    %result = pp-qq %unless pp-qq=0
!  %repeat
!optimised:
%label l1,end
  *clr.l d0; *move.b (a0)+,d0
  *clr.l d1; *move.b (a1)+,d1; *sub.l d1,d0
  *bgt l1; *move.b -1(a0),d1
l1: *subq.l #1,d1; *bmi end
  *moveq #32,d2; *or.b (a0)+,d2
  *moveq #32,d3; *or.b (a1)+,d3
  *sub.l d3,d2; *beq l1
  *move.l d2,d0
end:
  %result = d0
%end

! Bulk move

%systemroutine SMOVEBLOCK (%integer bytes,from,to)
!"signed" move block
!if bytes>0 then move (from)+ to (to)+ but
!if bytes<0 then from:=from-bytes, to:=to-bytes, move -(from) to -(to)
%label f1,f2,f3,f4,f5,f6,f7,b0,b1,b2,b3,b4,b5,b6,b7,end
  *move.l d1,a0
  *move.l d2,a1
  *eor d1,d2
  *tst.l d0
  *bmi b0;       !copy backwards ->
  *beq end;      !copy nothing ->
  *btst #0,d2;   !if (from!!to)&1#0 then
  *bne f5;       !copy bytewise ->
  *btst #0,d1;   !if from&1=0 then
  *beq f1;       !go for longword loop ->
  *move.b (a0)+,(a1)+; !copy first byte to even up
  *subq.l #1,d0
f1: *moveq #3,d2
  *and d0,d2;    !remainder for byte loop
  *subq.l #4,d0
  *bmi f4;       !bytes<4 ->
  *lsr.l #2,d0;  !longwords-1
  *bra f3
f2: *swap d0;    !longword loop
f3: *move.l (a0)+,(a1)+
  *dbra d0,f3
  *swap d0
  *dbra d0,f2
f4: *move.l d2,d0
f5: *subq.l #1,d0; !bytes-1
  *bmi end
  *bra f7
f6: *swap d0;      !byte loop
f7: *move.b (a0)+,(a1)+
  *dbra d0,f7
  *swap d0
  *dbra d0,f6
  *bra end
b0: *neg.l d0;   !backwards copy
  *add.l d0,a0;  !adjust addresses for -()
  *add.l d0,a1
  *btst #0,d2
  *bne b5
  *move a0,d1;   !!
  *btst #0,d1
  *beq b1
  *move.b -(a0),-(a1)
  *subq.l #1,d0
b1: *moveq #3,d2
  *and d0,d2
  *subq.l #4,d0
  *bmi b4
  *lsr.l #2,d0
  *bra b3
b2: *swap d0
b3: *move.l -(a0),-(a1)
  *dbra d0,b3
  *swap d0
  *dbra d0,b2
b4: *move.l d2,d0
b5: *subq.l #1,d0
  *bmi end
  *bra b7
b6: *swap d0
b7: *move.b -(a0),-(a1)
  *dbra d0,b7
  *swap d0
  *dbra d0,b6
end:
%end

%systemroutine MOVEBLOCK (%integer bytes,from,to)
!in case of overlap copy without propagating
!  %returnif bytes<=0
!  bytes = -bytes %if from<to<from+bytes
!  smoveblock(bytes,from,to)
%label x,y
  *tst.l d0
  *ble y
  *cmp.l d2,d1
  *bge x
  *move.l d1,d3
  *add.l d0,d3
  *cmp.l d3,d2
  *bge x
  *neg.l d0
x:*jsr smoveblock
y:
%end

%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
  *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; *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
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

%recordformat heap cell fm -
  (%byte level %or %integer size, %record(heap cell fm)%name fwd,bck)
%recordformat heap base fm -
  (%byte level %or %integer size, %record(heap cell fm)%name holes,
   %integer front,limit)

%recordformat dict cell fm -
  (%record(dict cell fm)%name parent,left,right,%integer token,%string(255)s)
%recordformat dict fm -
  (%record(dict fm)%name alt,%record(dict cell fm)%name tree)

%recordformat scb fm -
  (%integer p,l,bs,bl,fs,fl,fastpc,gla,soppc,mode,
   %record(scb fm)%name next,%string(255)%name prompt,
   %integer a,b,c,d,%string(255)filename)

%recordformat fe02 object fm -
  (%half flags,extra,%integer type,offset,%string(255)name)
%recordformat fe02 header fm -
  ({%byte type,version) %or}%half tyver,flags,export,import,%integer codesize,
   %half reset,main, %integer ownsize,stack,%half dlim,chlim,spare1,spare2)
%recordformat mar fm -
  (%record(mar fm)%name next, %record(fe02 header fm)%name header,
   %integer gla,%string(255)filename)
%recordformat par fm -
  (%record(par fm)%name next,
   %record(mar fm)%name modules)
%recordformat fe02 indir fm -
  (%integer address %or -
   %half op1, %integer opd1, %half op2, %integer opd2)
%recordformat dyn fm -
  (%record(fe02 object fm)%name object, %record(par fm)%name program)

@0(a5)-
%integer evlink,
%integerarray display(1:7),
%byte eventevent,eventsub,%half eventline,%integer eventextra,
%string(255-32)eventmessage,%integer eventpc,%integerarray eventdisplay(1:7),
%integerarray eventr(0:15),
%integer scratch1, scratch2, exception handler,
%record (par fm)%name topprog,
%record (heap base fm)%name heap, %integer stacklimit,
%record (scb fm)%name curin, curout, %integer instream, outstream,
%record (scb fm)%namearray in,out(0:7), %string(255)cliparam,
%record (dict fm)%name masterdict, extdict, moddict, logdict, fildict, comdict
        
! Heap package

%constinteger sizemask=16_FFFFFC

%systemintegerfn HEAPGET (%integer amount)

! Allocate an AMOUNT-byte chunk on the heap,
! returning its start address in both D0 and A0.

! Heap space is allocated in multiples of 4 bytes, heap chunks
! are always 4-byte aligned.  Every heap chunk carries a 4 byte
! overhead (used to store the chunk's size and mark-level).
! Chunks are subject to a minimum size (including the 4 byte
! overhead) of 12 bytes, in order to accomodate the forward
! and backward pointers for the list of free holes.
! They are also subject to a maximum size of 2\\24-4 bytes
! because 8 bits of the overhead word are used for the mark level.

%integer pos=0,need
%record(heap cell fm)%name prev,hole
  need = (amount+7)&\3;    !round up and add 4
  need = 12 %if need<12;   !impose minimum
  prev == nil
  hole == heap_holes;      !search hole list for first fit
  %while hole##nil %cycle
    pos = addr(hole)
    %signal 5,10,pos,"HEAPGET: Hole list corrupt"-
      %if hole_level#0 %or hole_bck##prev
    %if hole_size-need>=0 %start;     !big enough
      %if hole_size-need>=12 %start;  !big enough to split, use end
        hole_size = hole_size-need
        pos = pos+hole_size
      %else;                          !(near) exact fit, use whole
        %if prev==nil %then heap_holes == hole_fwd -
        %else prev_fwd == hole_fwd
        hole_fwd_bck == hole_bck %unless hole_fwd==nil
        need = hole_size
      %finish
      ->result
    %finish
    prev == hole
    hole == hole_fwd
  %repeat
! No suitable holes found.  Grab off front.
  pos = heap_limit
  pos = a7-256 %if pos=0
  %signal 2,1,amount,"HEAPGET: Not enough space" -
    %if need>sizemask %or heap_front+need>=pos
  pos = heap_front
  heap_front = pos+need
  stacklimit = heap_front+256 %if heap_limit=0
result:
  hole == record(pos)
  hole_size = need; hole_level = heap_level
%constinteger unassigning=1
$IF unassigning#0
      d0 = need
      a0 = pos+d0
      d0 = d0>>2-2
      *swap d0
oloop:*swap d0
iloop:*move.l d7,-(a0)
      *dbra d0,iloop
      *swap d0
      *dbra d0,oloop
$FINISH
  pos = pos+4
  a0 = pos
  %result = pos
%end

%systemroutine HEAPPUT (%integer pos)

! Return the heap chunk starting at POS to the list of holes.
! Move back the heap front if appropriate.
! If the chunk in question was already disposed, do nothing,
! likewise if it does not lie within the bounds of our heap,
! as it might belong to a more global heap (parent process).

%integer holeend
%record(heap cell fm)%name hole

  %routine corrupt(%integer code,%string(255)m)
    m = "HEAPPUT: ".m
    %signal 5,code,pos,m
  %end

  %returnunless pos&3=0 %and addr(heap)<pos<heap_front
  hole == record(pos-4)
  %return %if hole_level=0
  corrupt(10,"Chunk level corrupt") %if hole_level>heap_level#1
  hole_level = 0
  corrupt(11,"Chunk size corrupt") %if hole_size&3#0 %or hole_size<12
  holeend = pos-4+hole_size
  corrupt(12,"Chunk extends beyond heap front") %if holeend>heap_front
  %if holeend=heap_front %start
    heap_front = heap_front-hole_size
    stacklimit = heap_front+256 %if heap_limit=0
  %else
    hole_fwd == heap_holes
    heap_holes == hole
    hole_bck == nil
    hole_fwd_bck == hole %unless hole_fwd==nil
  %finish
%end

%systemroutine MARK

! Mark the heap for subsequent automatic disposal using RELEASE

  %signal 2,1,255,"MARK: Heap level exceeds 255" %if heap_level=255
  heap_level = heap_level+1
%end

%systemroutine RELEASE

! Automatically dispose all chunks allocated since last MARK

%record(heap cell fm)%name hole,neighbour
%integer p1,p2

  %routine corrupt(%integer n,p,%string(255)m)
    m = "RELEASE: ".m
    %signal 5,n,p,m
  %end

  %returnif heap_level=1
  heap_holes == nil;      !Hole list will be rebuilt
  p1 = addr(heap[1])
  %cycle;                 !Scan the whole heap
    %exitif p1=heap_front
    corrupt(13,p1,"Off end") %if p1>heap_front
    hole == record(p1)
    corrupt(14,p1,"Chunk level corrupt") %if hole_level>heap_level
    hole_level = 0 %if hole_level=heap_level; !Auto-dispose
    %if hole_level=0 %start; !Found a hole
      %cycle;                !Try to absorb neighbours
        p2 = p1+hole_size
        %if p2=heap_front %start
          heap_front = p1
          %exit
        %finish
        corrupt(15,p2,"Chunk extends beyond heap front") %if p2>heap_front
        neighbour == record(p2)
        corrupt(16,p2,"Chunk level corrupt") %if neighbour_level>heap_level
        neighbour_level = 0 %if neighbour_level=heap_level
        %if neighbour_level#0 %start; !add chunk to list
          hole_fwd == heap_holes
          hole_fwd_bck == hole %unless hole_fwd==nil
          hole_bck == nil
          heap_holes == hole
          p1 = neighbour_size&sizemask+p2
          %exit
        %finish
        hole_size = hole_size+neighbour_size&sizemask; !merge with neighbour
      %repeat
    %else
      p1 = hole_size&sizemask+p1
    %finish
  %repeat
  heap_level = heap_level-1
  stacklimit = heap_front+256 %if heap_limit=0
%end

%systemroutine DISPOSE (%name x)
  heapput(addr(x))
%end

%systemintegerfn HEAP LEVEL
  %result = heap_level
%end

%systembytemap HEAP LEVEL OF (%name x)
  *lea -4(a0),a0
%end

%systempredicate IS GLOBAL(%name x)
  %trueif heap level of(x)=1
  %false
%end

%systemroutine MAKE GLOBAL (%name x)
  heap level of(x) = 1
%end

%systemstring(*)%map NEWSTRING (%string(255)s)
%string(*)%name t
  %result == nil %if s=""
  t == string(heapget(length(s)+1))
  t = s
  %result == t
%end

%systemintegerfn FREE STORE
  %result = a7-stacklimit
%end

%systemintegerfn TRAPPED FREE STORE
%record(heapcellfm)%name c == heap_holes
%integer space=0
  %cycle
    %result = space %if c==nil
    %result = space %if c_level#0  {corrupt}
    space = space+c_size
    c == c_fwd
  %repeat
%end

! End of heap package

! Dictionary package
! NB the trees are scanned non-recursively

%systemintegerfn MAKE ENTRY (%string(255)s,%record(dict fm)%name d)
! Make an entry for name S in dictionary D and return the
! address of the token field for that entry.
%record(dict cell fm)%name c,n,p==nil
%integer dif
  %result = 0 %if d==nil
  toupper(s)
  n == record(heapget(sizeof(n)-255+length(s)))
  make global(n) %if is global(d)
  n_parent == nil; n_left == nil; n_right == nil; n_token = 0; n_s = s
  %if d_tree==nil %start
    d_tree == n; %result = addr(n_token)
  %finish
  c == d_tree
  %cycle
    %signal 5,,,"MAKE ENTRY: Dictionary corrupt" %unless c_parent==p
    p == c
    dif = stringdiff(s,c_s)
    %if dif<=0 %start
      %if dif=0 %start
        dispose(n); %result = addr(c_token)
      %finish
      %if c_left==nil %start
        c_left == n; n_parent == c; %result = addr(n_token)
      %finish
      c == c_left
    %elseif c_right==nil
      c_right == n; n_parent == c; %result = addr(n_token)
    %finishelse c == c_right
  %repeat
%end

%systemintegerfn FIND ENTRY (%string(255)s,%record(dict fm)%name d)
! Find the entry for name S in dictionary D, returning the
! address of its token field (or 0 if not found).
%record(dict cell fm)%name c
%integer dif
  toupper(s)
  %cycle
    %result = 0 %if d==nil
    c == d_tree
    %cycle
      %exit %if c==nil
      dif = stringdiff(s,c_s)
      %result = addr(c_token) %if dif=0
      %if dif<0 %then c == c_left %else c == c_right
    %repeat
    d == d_alt
  %repeat
%end

%systemroutine DELETE ENTRY (%integer token,%record(dict fm)%name dict)
%record(dict cell fm)%name c,p,q
%integer offset
  %returnif token=0 %or dict==nil
  offset = addr(c_token)-addr(c)
  c == record(token-offset)
  q == c
  %cycle                    {verify DICT contains C}
    p == q_parent
    %if p==nil %start       {no parent: must be root}
      %exitif dict_tree==q  {OK}
      %return               {not OK}
    %finish
    %returnunless p_left==q %or p_right==q {parent found}
    q == p
  %repeat
  %if c_left==nil %start       {set Q to be C's replacement}
    q == c_right
  %elseif c_right==nil
    q == c_left
  %else
    q == c_left
    %if q_right==nil %start     {transfer R son to L son's R son}
      q_right == c_right; c_right_parent == q
    %else                   {find biggest in L subtree}
      q == q_right %until q_right==nil
      q_right == c_right; c_right_parent == q
      q_left == c_left; c_left_parent == q
    %finish
  %finish
  p == c_parent                  {original parent}
  q_parent == p %unless q==nil
  %if p==nil %start
    dict_tree == q
  %elseif c==p_left
    p_left == q
  %else
    p_right == q
  %finish
%end

%systemstring(255)%fn TRANSLATE ENTRY (%integer x)
! Return the name for which an entry was made in some
! dictionary, for which X is the address of the token field.
  %result = string(x+4)
%end

%systemintegerfn FIRST ENTRY (%record(dict fm)%name d)
! Return the token for the leftmost cell in dictionary D.
%record(dict cell fm)%name c
  c == d_tree; %result = 0 %if c==nil
  c == c_left %while c_left##nil
  %result = addr(c_token)
%end

%systemintegerfn NEXT ENTRY (%integer x)
! Assuming that X was produced as a result of FIRST ENTRY or
! NEXT ENTRY, return the token for the next cell in the same
! dictionary, or 0 if X is the token for the rightmost entry.
%record(dict cell fm)%name c,p
  %result = 0 %if x=0
  c == record(x)
  c == record(addr(c)-addr(c_token)+x)
  %if c_right##nil %start
    c == c_right; c == c_left %while c_left##nil
    %result = addr(c_token)
  %finish
  %cycle
    p == c_parent; %result = 0 %if p==nil
    %result = addr(p_token) %if c==p_left
    %signal 5,,,"NEXT ENTRY: Dictionary corrupt" %unless c==p_right
    c == p
  %repeat
%end

%systemrecord(dict fm)%map CREATE DICT (%string(255)s)
! Create a dictionary descriptor, and register it in the
! main dictionary dictionary.
%integer a=0
%record(dict fm)%name d
  %unless s="" %start
    a = findentry(s,masterdict)
    %result == record(integer(a)) %if a#0 %and integer(a)#0
    a = makeentry(s,masterdict)
  %finish
  d == new(d)
  d = 0
  integer(a) = addr(d) %unless a=0
  %result == d
%end

%systemrecord(dict fm)%map FIND DICT (%string(255)s)
%integer a
  %result == masterdict %if s=""
  a = findentry(s,masterdict)
  %result == record(integer(a)) %if a#0
  %result == nil
%end

%systemroutine DEFINE LOGICAL NAME (%string(255)log,equiv)
%integer t
  logdict == create dict("log") %if logdict==nil
  t = findentry(log,logdict)
  %if t#0 %start
    dispose(string(integer(t))) %if integer(t)#0
    delete entry(t,logdict) %andreturnif equiv=""
  %else
    %returnif equiv=""
    t = makeentry(log,logdict)
  %finish
  integer(t) = addr(newstring(equiv))
  make global(string(integer(t))) %if is global(logdict)
%end

%systempredicate TRANSLATED LOGICAL NAME (%string(*)%name log)
%integer t
  %falseif log=""
  %if charno(log,1)='_' %start
    log = substring(log,2,length(log))
    %false
  %finish
  t = findentry(log,logdict)
  %falseif t=0
  log = string(integer(t))
  %true
%end

%systemstring(255)%fn TRANSLATE LOGICAL NAME (%string(255)s)
  toupper(s) %unless translated logical name(s)
  %result = s
%end

%systemroutine DEFINE COMMAND SYMBOL (%string(255)com,equiv)
%integer t
  comdict == create dict("com") %if comdict==nil
  t = findentry(com,comdict)
  %if t#0 %start
    dispose(string(integer(t))) %if integer(t)#0
    delete entry(t,comdict) %andreturnif equiv=""
  %else
    %returnif equiv=""
    t = makeentry(com,comdict)
  %finish
  integer(t) = addr(newstring(equiv))
  make global(string(integer(t))) %if is global(comdict)
%end

%systempredicate TRANSLATED COMMAND SYMBOL (%string(*)%name com)
%integer t
%bytename b == length(com)
  %if b[b]='_' %start
    b = b-1; %false
  %finish
  t = findentry(com,comdict)
  %falseif t=0
  com = string(integer(t)); %true
%end

%systemstring(255)%fn TRANSLATE COMMAND SYMBOL (%string(255)s)
  toupper(s) %unless translated command symbol(s)
  %result = s
%end

! File access

%systemstring(255)%fn CURRENT FILESTORE
%string(255)s = "current_filestore"
%bytename b == length(s)
  s = translate logical name(s)
  b = b+1 %and b[b] = ':' %if b[b]#':'
  %result = s
%end

%systemstring(255)%fn CURRENT USER
%string(255)s = "current_user"
  s = translate logical name(s)
  %result = s
%end

%systemstring(255)%fn CURRENT DIRECTORY
%string(255)s = "current_directory"
%bytename b == length(s)
  s = translate logical name(s)
  b = b+1 %and b[b] = ':' %if ']'#b[b]#':'
  %result = s
%end

%systemroutine STANDARDISE FILENAME (%string(*)%name name)

! NB:
! "The separator" means ':'.
! Defaulting "" to ":N" has been removed to keep AJS happy,
! Defaulting ":" to ":T" has been left in for the present
! Rules:
! Names begining with the separator are deemed already standardised.
! Names which have a leading (or sole) component which is a logical
! name are subject to substitution of that logical name up to a maximum
! iteration limit.
! Once logical name translation fails, a default prefix is applied.
! That prefix is the current directory in the case of one-component
! names, or the current filestore in the case of multi-component names.
! If the name (whether single or multi component) begins with '^', we
! apply a shortened prefix, consisting of the current directory with
! one trailing components removed for every '^' removeable from the
! front of the name.

%string(1)colon=":"
%string(3)coloncolon="::"
%string(255)prefix,fore,aft
%integer lives=9
%bytename p==length(prefix),f==length(fore),n==length(name)

  %routine check for colon colon
! EFTP-compatibility:
! Names beginning with "::" are changed to begin with ":F:",
! Names of the form x::y are turned into :F:x:y.
    %if resolves(name,coloncolon,fore,aft) %start
      %if fore="" %start
        name = ":F:".aft
      %else
        name = ":F:".fore.":".aft
      %finish
    %finish
  %end

  %predicate starts(%integer k)
! True iff NAME starts with character K.
    %falseif n=0; %trueif n[1]=k; %false
  %end

  %routine shorten prefix
! Strip a trailing component off string PREFIX.
! If (vax) it ends in *.x] turn it into *]
! If (vax) it ends in *[x] (no dot in the []), turn it into *[x.-]
! If it ends in *x:y: or *x:y turn it into *x:
  %integer vax
    %if p[p]=']' %start
      vax = p
      %cycle
        vax = vax-1
        %if p[vax]='[' %start
          p[p] ='.'; p[p+1] = '-'; p[p+2] = ']'; vax = p+2
          %exit
        %finish
        %if p[vax]='.' %start
          p[vax] = ']'
          %exit
        %finish
      %repeatuntil vax=0 %or p[vax]=':'
      p = vax
    %else
      p = 1 %if p=0
      p = p-1 %until p=0 %or p[p]=':'
    %finish
  %end

  %routine apply prefix
! NAME = PREFIX.NAME, but make sure one (if needed)
! and no more than one colon gets put inbetween.
    %returnif p=0
    %if ':'#p[p]#']' %start
      p = p+1; p[p] = ':'
    %finish
    name = substring(name,2,n) %if n>1 %and n[1]=':'
    name = prefix.name
  %end

  %signal 3,3,0,"Null file name" %if n=0
  %if n[1]=':' %start
    name = ":T" %if n=1
    %returnunless n[2]=':'
  %finish
  check for colon colon
  prefix = ""
  %while lives>0 %andnot starts(':') %cycle
    lives = lives-1
    %if starts('^') %start
      prefix = currentfilestore.currentdirectory
      %cycle
        name = substring(name,2,n)
        shorten prefix
      %repeatuntilnot starts('^')
      %exit
    %finish
    %if resolves(name,colon,fore,aft) %start
      %if translated logical name(fore) %start
        prefix = fore; name = aft
        apply prefix; prefix = ""
      %elseif fore="."
        prefix = currentfilestore.currentdirectory; name = aft; %exit
      %else
        prefix = currentfilestore; %exit
      %finish
    %elseunless translated logical name(name)
      prefix = currentfilestore.currentdirectory; %exit
    %finish
    check for colon colon
  %repeat
  apply prefix %unless prefix=""
  toupper(name)
  %unless n>1 %and n[1]=':' %start
    name = "Standardise file name fails: ".name
    %signal 3,3,,name
  %finish
%end

%systemroutine SET DIRECTORY(%string(255)s)
%bytename b == length(s)
%integer i,p
  s = translate logical name("default_directory") %if s=""
  b = b+1 %and b[b] = ':' %if ']'#b[b]#':'
{printstring("SetDir ";s)
  standardise filename(s)
{printstring(" / ";s);newline
  p = 0; i = 0
  %cycle
    p = p+1 %until p>=b %or b[p]=':'
    i = i+1
  %repeatuntil i=3
  define logical name("current_filestore",substring(s,1,p))
  define logical name("current_directory",substring(s,p+1,b))
%end

%systemrecord(scb fm)%map NEW SCB (%string(*)%name filename)
%record(scb fm)%name scb
%integername p
%integer n
  scb == record(heapget(sizeof(scb)-255+length(filename)))
  make global(scb)
  p == integer(addr(scb)); n = sizeof(scb)-256
  %cycle
    p = 0; p == p[1]; n = n-4
  %repeatuntil n=0
  scb_filename = filename
  %result == scb
%end

%routine SOP (%record(scb fm)%name cb,%integer code,p1,p2,%name b)
! Perform file operation in context of stream control block.
@0(a0)%record(scb fm)scb
%label no
  *move.l a4,-(sp)
  *move.l scb_soppc,a2
  *cmp #0,a2
  *beq no
  *move.l scb_gla,a4
  *jsr (a2)
no:  *move.l (sp)+,a4
%end

%constinteger -
  sop close   = 0,
  sop abort   = 1,
  sop flush   = 2,
  sop refresh = 3,
  sop write   = 4,
  sop read    = 5

%systemroutine FILE CLOSE (%record(scb fm)%name x)
! Close file normally (input or output)
  %if x_soppc=0 %start
    dispose(x); %return
  %finish
  sop(x,sopclose,0,0,nil)
%end

%systemroutine FILE ABORT (%record(scb fm)%name x)
! Close file abnormally (input or output, but for input it
! does the same as FILE CLOSE).
  %if x_soppc=0 %start
    dispose(x); %return
  %finish
  sop(x,sopabort,0,0,nil)
%end

%systemroutine FILE FLUSH (%record(scb fm)%name x, %integer ch)
! Write contents of file buffer (X_P-X_BS bytes at X_BS) to file
! at position X_BS-X_FS in file.
! Maintain high water mark (set X_FL to X_P if X_P>X_FL).
! If X_P=X_L, advance the buffer through the file (normally by
! leaving X_BS and X_BL alone and subtracting X_BL-X_BS from
! X_FS and X_FL.  Return with X_L=X_BL.
! Normally return with X_P=X_BS, but if CH>=0, in the case of
! non-buffered devices (in which case X_BS=X_BL), write the one
! byte CH to the device, in the case of buffered devices, add CH
! to the buffer (and return with X_P=X_BS+1).
  sop(x,sopflush,ch,0,nil)
%end

%systemroutine FILE REFRESH (%record(scb fm)%name x)
! Fill the file buffer by reading X_BL-X_BS bytes (less if near
! end of file) from such a position in the file that byte X_P-X_FS
! of the file will be in the buffer.  This will usually involve
! updating X_FS and X_FL and X_P (but always return such that
! X_P-X_FS before is the same as X_P-X_FS after, i.e. X_P-X_FS
! denotes the current position in the file, we do not automatically
! return with X_P=X_BS, although this will normally be the case).
! Normally return with X_L=X_BL (unless near the end of file).
  %if x_soppc=0 %start
    %returnif x_p<x_l; %signal 9,,,"End of (connected) file"
  %finish
  sop(x,soprefresh,0,0,nil)
%end

%systemroutine FILE WRITE -
  (%record(scb fm)%name x,%integer position,amount,%name b)
! Ignoring the buffer pointers in the SCB, write AMOUNT bytes to
! the file at POSITION in the file, from user buffer B.
! Use current position indicated in SCB if POSITION<0.
  position = x_p-x_fs %if position<0
  sop(x,sopwrite,position,amount,b)
%end

%systemroutine FILE READ -
  (%record(scb fm)%name x,%integer position,amount,%name b)
! Ignoring the buffer pointers in the SCB, read AMOUNT bytes from
! place POSITION in the file, to user buffer B.
! Use current position indicated in SCB if POSITION<0.
  position = x_p-x_fs %if position<0
  %if x_soppc=0 %start
    %signal 9,,,"End of (connected) File"
  %finish
  sop(x,sopread,position,amount,b)
%end

%systemintegerfn FILE LENGTH (%record(scb fm)%name x)
! Valid both for input and output files.
  %result = x_fl-x_fs
%end

%predicatespec io load (%string(255)s,%integername pc,gla)

%record(scbfm)%map result of FOP (%integer code,%string(*)%name file,%name x)
! Perform direct file system operation not involving SCBs.
%string(255)dev,full
%bytename d
%integer pc,gla,level

  %record(scbfm)%map call it(%integer a,%name b,c)
    *move.l a4,-(sp)
    *move.l gla,a4
    *move.l pc,a2
    *jsr (a2)
    *move.l (sp)+,a4
  %end

  full = file
  standardise filename(full)                         {-> :x:y:z}
  dev = full
  d == length(dev); dev = "fop_".substring(dev,2,d)  {-> fop_x:y:z}
  level = 4
  %cycle
    d = level %if d[level+1]=':'
    level = level+1
  %repeatuntil level>=d                              {-> fop_x}
{printstring("Calling ioload ";dev); newline
  %unless io load(dev,pc,gla) %start
    dev = "Cannot access file ".file
    %signal 3,3,,dev
  %finish
  %result == call it(code,full,x)
%end

%routine fop (%integer code,%string(*)%name file,%name x)
%record(scbfm)%name unused
  unused == result of fop(code,file,x)
%end

%constinteger -
  fop logout  = 0,
  fop login   = 1,
  fop quote   = 2,
  fop pass    = 3,
  fop openi   = 4,
  fop openo   = 5,
  fop openm   = 6,
  fop opena   = 7 {not used},
  fop credir  = 8,
  fop delete  = 9,
  fop info    = 10,
  fop rename  = 11,
  fop copy    = 12,
  fop permit  = 13,
  fop stamp   = 14,
  fop time    = 15,
  fop special = 16,
  fop oldfinfo= 17

%systemroutine FILE LOGOUT (%string(255)fs)
  fop(foplogout,fs,nil)
%end

%systemroutine FILE LOGIN (%string(255)fsu,p)
  fop(foplogin,fsu,p)
%end

%systemroutine FILE QUOTE PASSWORD (%string(255)fs,p)
  fop(fopquote,fs,p)
%end

%systemroutine FILE CHANGE PASSWORD (%string(255)fs,p)
  fop(foppass,fs,p)
%end
  
%predicatespec connected(%string(255)f)
%routinespec connectfile(%string(255)f,%integer m,%integername p,l)

%systemrecord(scb fm)%map FILE OPEN INPUT (%string(255)f)
%record(scbfm)%name x
%integer i
  standardise filename(f)
  %if connected(f) %start
    x == newscb(f)
    connectfile(f,1,x_fs,i)
    x_bs = x_fs; x_p = x_fs
    x_fl = x_bs+i
    x_bl = x_fl; x_l = x_fl
    *lea filerefresh,a0; *move.l a0,i
    x_fastpc = i
    %result == x
  %finish
  %result == result of fop(fopopeni,f,nil)
%end

%systemrecord(scb fm)%map FILE OPEN OUTPUT (%string(255)f)
  %result == result of fop(fopopeno,f,nil)
%end

%systemrecord(scb fm)%map FILE OPEN MODIFY (%string(255)f)
  %result == result of fop(fopopenm,f,nil)
%end

%systemrecord(scb fm)%map FILE OPEN APPEND (%string(255)f)
%record(scbfm)%name x
%integer size,offset,pos
  x == file open modify(f)
  size = x_fl-x_fs              {size of file
  offset = rem(size,x_bl-x_bs)  {amount used in last block
  pos = size-offset             {start of last block
  x_fs = x_fs-pos; x_fl = x_fl-pos  {seek to last block
  x_p = x_fl; x_l = x_bl            {to past last byte
  file refresh(x) %unless x_p=x_bs  {read partial block
  x_p = x_fl; x_l = x_bl
  %result == x
%end

%systemroutine FILE CREATE DIRECTORY (%string(255)f)
  fop(fopcredir,f,nil)
%end

%systemroutine FILE DELETE (%string(255)f)
  fop(fopdelete,f,nil)
%end

%systemroutine FILE INFO (%string(255)f,%string(*)%name info)
  fop(fopinfo,f,info)
%end

%systemroutine FILE RENAME (%string(255)old,new)
  standardise filename(new)
  fop(foprename,old,new)
%end

%systemroutine FILE COPY (%string(255)old,new)
  standardise filename(new)
  fop(fopcopy,old,new)
%end

%systemroutine FILE PERMIT (%string(255)f,p)
  fop(foppermit,f,p)
%end

%systemroutine FILE CHANGE DATE (%string(255)f,d)
  fop(fopstamp,f,d)
%end

%systemroutine FILE GET DATE (%string(255)fs,%string(*)%name d)
! This one asks the file system what time it thinks it is.
  fop(foptime,fs,d)
%end

%recordformat fs fm(%integer send,recmax,rec,%bytename sendbuf,recbuf)

%systemroutine FILE SPECIAL (%string(255)fs,%record(fs fm)%name r)
! This one is intended to cover special cases, such as admin functions.
! It involves sending SEND bytes from SENDBUF and receiving back up to
! RECMAX bytes into RECBUF, noting in REC the actual number of bytes returned.
  fop(fopspecial,fs,r)
%end

%systemroutine FILE OLDFINFO (%string(255)f,%string(*)%name info)
  fop(fopoldfinfo,f,info)
%end

%systemstring(255)%fn DATETIME
%string(255)fs,dt
  fs = "."; dt = ""
  file get date(fs,dt)
  %result = dt
%end

%systemstring(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

%systemstring(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

%routine stream check(%integer s)
  %signal 6,1,s,"Stream number out of range" %unless s&7=s
%end

%systemroutine OPENINPUT (%integer s,%string(255)f)
%record(scb fm)%name scb
  streamcheck(s)
  selectinput(s)  {back-compat}
  scb == file open input(f)
  scb_next == in(s)
  in(s) == scb
  curin == scb %if instream=s
%end

%systemroutine OPENOUTPUT (%integer s,%string(255)f)
%record(scb fm)%name scb
  streamcheck(s)
  selectoutput(s)
  scb == file open output(f)
  scb_next == out(s)
  out(s) == scb
  curout == scb %if outstream=s
%end

%systemroutine OPENMODIFY (%integer s,%string(255)f)
%record(scb fm)%name scb
  streamcheck(s)
  selectoutput(s)
  scb == file open modify(f)
  scb_next == out(s)
  out(s) == scb
  curout == scb %if outstream=s
%end

%systemroutine OPENAPPEND (%integer s,%string(255)f)
%record(scb fm)%name scb
  streamcheck(s)
  selectoutput(s)
  scb == file open append(f)
  scb_next == out(s)
  out(s) == scb
  curout == scb %if outstream=s
%end

%systemintegerfn INPUT FILE POSITION
  %result = 0 %if curin==nil
  %result = curin_p-curin_fs
%end

%systemintegerfn OUTPUT FILE POSITION
  %result = 0 %if curout==nil
  %result = curout_p-curout_fs
%end

%systemintegerfn INPUT FILE LENGTH
  %result = 0 %if curin==nil
  %result = curin_fl-curin_fs
%end

%systemintegerfn OUTPUT FILE LENGTH
  %result = 0 %if curout==nil
  %result = curout_fl-curout_fs
%end

%systemroutine SET INPUT (%integer byte)
  %returnif curin==nil
  curin_p = curin_fs+byte
  curin_l = curin_p %unless curin_bs<=curin_p<=curin_l
%end

%systemroutine SET OUTPUT (%integer byte)
  %returnif curout==nil
  %unless curout_bs <= curout_fs+byte <= curout_bl %start
    file flush(curout,-1)
    curout_p = curout_fs+byte
    curout_l = curout_p
    file refresh(curout)
  %finish
  curout_p = curout_fs+byte
  curout_l = curout_bl
%end

%systemroutine RESET INPUT
  setinput(0)
%end

%systemroutine RESET OUTPUT
  setoutput(0)
%end

%systemintegerfn inst %alias "INSTREAM"
  %result = instream
%end

%systemintegerfn outst %alias "OUTSTREAM"
  %result = outstream
%end

%systemroutine CLOSE INPUT
%record(scbfm)%name cb
  cb == curin
  %returnif cb==nil
  curin == cb_next; %returnif cb==curin
  in(instream) == curin
  sop(cb,sopclose,0,0,nil)
%end

%systemroutine ABORT OUTPUT
%record(scbfm)%name cb
  cb == curout
  %returnif cb==nil
  curout == cb_next; %returnif cb==curout
  out(outstream) == curout
  file flush(cb,-1)
  sop(cb,sopabort,0,0,nil)
%end

%systemroutine CLOSE OUTPUT
%record(scbfm)%name cb
  cb == curout
  %returnif cb==nil
  curout == cb_next; %returnif cb==curout
  out(outstream) == curout
  file flush(cb,-1)
  sop(cb,sopclose,0,0,nil)
%end

%systemroutine PROMPT (%string(255)s)
  %returnif curin==nil
  %returnif curin_prompt==nil
  curin_prompt = s
%end

%systemstring(255)%fn INFILENAME
  %result = ":N" %if curin==nil
  %result = curin_filename
%end

%systemstring(255)%fn OUTFILENAME
  %result = ":N" %if curout==nil
  %result = curout_filename
%end

%systemintegerfn filesize(%string(255)f)
%record(scb fm)%name cb == file open input(f)
%integer n = cb_fl-cb_fs
{selectoutput(0);printstring("file/FS/FL/size ";f); space; phex(cb_fs)
{space;phex(cb_fl);space; phex(n);newline
  file close(cb)
  %result = n
%end

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

%systemroutine CONNECTFILE (%string(255)f,%integer mode,%integername start,size)
! Values for M:
!   0: Read file into writeable store
!   1: Read file into read-only store
! 128: "Bizarre" mode for VECCE & Compilers
! All other values assumed equivalent to 0
%constinteger bizarre=128,readonly=1,readwrite=0
%integer offset=0,extra=0,pos=0,tok
%record(*)%name scb
  offset = start %and extra = start+size %if mode=bizarre
  start = 0; size = 0
  f = ":N" %if f=""; standardise filename(f)
  tok = findentry(f,fildict)
  pos = integer(tok) %unless tok=0
  %if pos#0 %start    {file already connected}
    size = integer(pos); pos = pos+4
    %if mode=readonly %start
      start = pos
    %else
      start = heapget(size+extra)+offset
      moveblock(size,pos,start)
    %finish
    %return
  %finish
  scb == file open input(f)
  size = file length(scb)
  %if tok=0 %start    {not to be remembered}
    start = heapget(size+extra)+offset 
    file read(scb,0,size,byte(start)) %if size>0
    file close(scb)
    %return
  %finish
  pos = heapget(size+4)+4
  file read(scb,0,size,byte(pos))
  file close(scb)
  integer(tok) = pos-4
  make global(record(pos-4))
  integer(pos-4) = size
  %if mode=readonly %start
    start = pos
  %else
    start = heapget(size+extra)+offset
    moveblock(size,pos,start)
  %finish
%end

%systempredicate CONNECTED (%string(255)file)
%integer t
  standardise filename(file)
  t = findentry(file,fildict)
  %falseif t=0; %falseif integer(t)=0; %true
%end

%systemroutine REMEMBER FILE (%string(255)f)
%integer t
  fildict == createdict("fil") %if fildict==nil
  standardise filename(f)
  t = make entry(f,fildict)
%end

%systemroutine FORGET FILE (%string(255)f)
%integer t,p
  %returnif fildict==nil
  standardise filename(f)
  t = find entry(f,fildict)
  %returnif t=0
  p = integer(t)
  delete entry(t,fildict)
  %returnif p=0
  heap level of(record(p)) = heap level
%end

! Loader

%constinteger jmp=16_4EF9, jsr=16_4EB9, pea=16_4879, lea a4=16_49F9

%constinteger extbit=16_4000,procmask=16_3000,
              system=16_1000,external=16_2000,dynamic=16_3000

%systemroutine DOT MOB (%string(*)%name s)

! Stick ".MOB" on the end if it's not already there

%bytename b
  b == length(s)
  toupper(s)
  %if b<4 %or b[b-3]#'.' %or b[b-2]#'M' %or b[b-1]#'O' %or b[b]#'B' %start
    s = s.".MOB"
  %finish
%end

%integerfnspec load module -
  (%record(fe02 header fm)%name h,%record(par fm)%name p,
   %integer gla,%string(255)filename)

%integerfn codestart(%record(fe02 header fm)%name h)
%integer a
  a = addr(h[1])
  %result = a+h_export+h_import
%end

%record(fe02objectfm)%map nextobject(%record(fe02objectfm)%name o)
  %result == record((addr(o[1])-255+length(o_name)+1)&\1)
%end

%predicate load object -
  (%record(fe02 object fm)%name object,
   %record(par fm)%name program,
   %record(fe02 indir fm)%name ref)
%string(255)file
%record(par fm)%name prog
%record(dyn fm)%name dyn
%integer start,size,tag,flags,dif
%label late

  %predicate compatible(%record(fe02 object fm)%name want,have)
  %integer w,h
    w = want_flags&procmask
    w = external %if w=dynamic
    h = have_flags&procmask
    h = external %if h=dynamic
    %unless w=h %start
      %falseunless w=external %and h=system
    %finish
    w = want_type; h = have_type
    %trueif w=h %or w=0 %or h=0
    %false
  %end

  %predicate found(%record(par fm)%name prog)
  %record(marfm)%name m
  %record(fe02headerfm)%name h
  %record(fe02objectfm)%name o
  %integer stream
    m == prog_modules
    %while m##nil %cycle
      h == m_header
      %if h_export#0 %start
        o == record(addr(h[1]))
        %while o_flags#0 %cycle
          dif = stringdiff(object_name,o_name)
          %if dif=0 %start
            %unless compatible(object,o) %start
              event_message = "Mismatch for ".object_name
              stream = outstream; selectoutput(0) %unless stream=0
              printstring(event_message); newline
              selectoutput(stream) %unless stream=0
              %false
            %finish
            flags = o_flags&procmask
            %if flags=system %start
              ref_op1 = jmp; ref_opd1 = codestart(h)+o_offset
            %elseif flags=0
              ref_address = m_gla+o_offset
            %else
              ref_op1 = lea a4; ref_opd1 = m_gla
              ref_op2 = jmp; ref_opd2 = codestart(h)+o_offset
            %finish
            %true
          %finish
          o == nextobject(o)
        %repeat
      %finish
      m == m_next
    %repeat
    %false
  %end

  prog == program
  %cycle
    %trueif found(prog)
    prog == prog_next
  %repeatuntil prog==nil
  %if object_flags&procmask=dynamic %start
    object_flags = object_flags!!(dynamic!!external)
    dyn == new(dyn)
    dyn_object == object
    dyn_program == program
    ref_op1 = pea; ref_opd1 = addr(dyn)
    ref_op2 = jsr; ref_opd2 = addr(late)
    %true
  %finish
{look up in dictionary}
  tag = findentry(object_name,extdict)
  %falseif tag=0
  tag = integer(tag)
  %falseif tag=0
  file = translate entry(tag)
  tag = findentry(file,moddict)
  dot mob (file)
  connectfile(file,1,start,size)
  length(file) = length(file)-4
  %falseif load module(record(start),program,0,file)=0
  %trueif found(program)
  %false  {should not get here}

late:
@0(a7)%integerarray r(0:14),
(%integer xxref %or %record(fe02 indir fm)%name xref),
%record(dyn fm)%name xdyn
  *movem.l d0-d7/a0-a6,-(sp)
  xxref = xxref-12
  %if load object(xdyn_object,xdyn_program,xref) %start
    dispose(xdyn)
    *movem.l (sp)+,d0-d7/a0-a6
    *move.l (sp)+,(sp)
    *rts
  %finish
  event_message = "Could not dynamically load ".xdyn_object_name
  dispose(xdyn)
!!%signal 0,4,,event_message
  r(0) = 16_50; r(1) = 4; r(8) = addr(event_message)
  *movem.l (sp)+,d0-d7/a0-a6
  *lea 8(sp),sp
  *jmp 16_3efa
%end

%systempredicate IO LOAD (%string(255)s,%integername pc,gla)
%record(par fm)%name p
%record(fe02 indir fm)indir
%record(fe02 object fm)object
  p == topprog
  p == p_next %while p_next##nil
  indir = 0
  object = 0
  object_flags = extbit+external
  object_name = s
  %falseunless load object(object,p,indir)
  %if indir_op1=jmp %start
    gla = 0; pc = indir_opd1
    %true
  %finish
  %if indir_op2=jmp %start
    gla = indir_opd1; pc = indir_opd2
    %true
  %finish
  %false
%end

%integerfn LOAD MODULE -
  (%record(fe02 header fm)%name header,
   %record(par fm)%name program,%integer gla,%string(255)filename)
%integer pos,ok,code,dif,stream
%record(fe02 object fm)%name object
%record(mar fm)%name module

  %unless header_tyver=16_fe02 %start
    stream = outstream; selectoutput(0) %unless stream=0
    printstring("Object file header corrupt"); newline
    selectoutput(stream) %unless stream=0
    %result = 0
  %finish
  pos = addr(header)+sizeof(header)
  code = pos+header_export+header_import
  gla = heapget(header_ownsize) %if gla=0 %and header_ownsize#0
  module == new(module)
  module_header == header
  module_gla = gla
  module_filename = filename
  module_next == program_modules
  program_modules == module
  pos = header_reset<<1+code
  *move.l pos,a0
  *move.l gla,a1
  *move.l a4,-(sp)
  *move.l a1,a4
  *jsr (a0)
  *move.l (sp)+,a4
  ok = header_main<<1+code
  %unless header_import=0 %start
    object == record(addr(header[1])+header_export)
    %cycle
      %exitif object_flags=0
      %if object_flags&extbit#0 %start
        %unless load object(object,program,record(object_offset+gla)) %start
          event_message = "Cannot find ".object_name
          stream = outstream; selectoutput(0) %unless stream=0
          printstring(event_message); newline
          selectoutput(stream) %unless stream=0
          ok = 0
        %finish
      %finish
      object == nextobject(object)
    %repeat
  %finish
  %result = ok
%end

%systemroutine INSTALL (%string(255)file)
%record(scb fm)%name cb == nil
%record(fe02 header fm)header
%record(fe02 object fm)%name object
%integer f=0,pos,lim,otag,mtag
  %on 3,9 %start
    heapput(f) %unless f=0
    file close(cb) %unless cb==nil
    printstring(event_message); newline
    %return
  %finish
  dot mob(file)
  %if connected(file) %start
    connectfile(file,1,pos,mtag)
    %signal 9,,sizeof(header)-mtag,"Header too small" %if mtag<sizeof(header)
    header = record(pos)
    %unless header_tyver=16_fe02 %start
      event_message = file." does not start with FE02"
      %signal 3,3,header_tyver,event_message
    %finish
    %returnif header_export=0
    pos = pos+sizeof(header)
  %else
    cb == file open input(file)
    file read(cb,0,sizeof(header),header)
    %unless header_tyver=16_fe02 %start
      event_message = file." does not start with FE02"
      %signal 3,3,header_tyver,event_message
    %finish
    %signal 9,,,"Heade shows no exports" %if header_export=0
    f = heapget(header_export)
    file read(cb,sizeof(header),header_export,byte(f))
    file close(cb); cb == nil
    pos = f
  %finish
  lim = pos+header_export
  mtag = makeentry(file,moddict)
  %while pos<lim %cycle
    object == record(pos); %exitif object_flags&extbit=0
    otag = findentry(object_name,extdict)
    %if otag>0 %start
      %unless integer(otag)=mtag %start
        printstring(file;" supersedes ")
        printstring(translateentry(integer(otag));" for external entry ")
        printstring(object_name)
        newline
      %finish
    %finishelse otag = makeentry(object_name,extdict)
    integer(otag) = mtag
    pos = (pos+sizeof(object)-255+length(object_name)+1)&\1
  %repeat
  heapput(f) %unless f=0
%end

!   Diagnostics

%record(mar fm)%map mainmodule
%record(mar fm)%name m
  m == topprog_modules
  m == m_next %while m_next##nil
  %result == m
%end

%integerfn mainentry
%record(fe02headerfm)%name h
%integer e
  h == mainmodule_header
  e = codestart(h)+h_main<<1
  %result = e
%end

%integerfn maingla
%integer g
  g = mainmodule_gla>>1<<1
  %result = g
%end

%string(255)%fn nameof(%record(fe02 header fm)%name h)
%string(255)s
%record(parfm)%name par
%record(marfm)%name mar
  par == topprog
  %while par##nil %cycle
    mar == par_modules
    %while mar##nil %cycle
      %if mar_header==h %start
        s = mar_filename
        s = s." (main program)" %if h==mainmodule_header
        %result = s
      %finish
      mar == mar_next
    %repeat
    par == par_next
  %repeat
  s = "un-named module"
  s = s." (main program)" %if h==mainmodule_header
  %result = s
%end

%routine PUT CHAR(%integer k,quote)
  %if k < 32 %start
    printsymbol('^');  printsymbol(k+'@')
  %else %if k < 127
    printsymbol(quote);  printsymbol(k);  printsymbol(quote)
  %finish
%end

%routine PUT INT(%integer v,word)
  write(v,0)
  %if v < -1000 %or v > 1000 %start
    printstring(" (")
    %if word # 0 %then phex4(v) %else phex(v)
    printsymbol(')')
  %else %if 32 <= v <= 126
    printstring(" (");  put char(v,'''');  printsymbol(')')
  %finish
%end

%routine PRINT LINENO(%integer l)
  printstring("Line");  write(l&16_3FFF,1)
  printsymbol('&') %if l>>14 # 0
%end

%routine INTERPRET EVENT
%integer i
  printstring("*Event"); write(event_event,1)
  write(event_sub,1) %if event_sub # 0
  space %and space %and put int(event_extra,0) %if event_extra # 16_80808080
  space %and space %and printstring(event_message) %if event_message # ""
  space %and space %and print lineno(event_line) %if event_line # 0
  %if event_event = 0 %start              {low-level error}
    printstring("   PC "); phex(eventpc)
    space %and phex4(half(eventpc+i)) %for i = -4,2,4
    %if event_sub <= 3 %start             {Address/Bus error}
      %for i = 0,1,15 %cycle
        newline %if i&7 = 0
        space;  phex(eventr(i))
      %repeat
    %finish
  %finish
  newline
%end

!constinteger JMP=16_4EF9, JSR=16_4EB9,
%constinteger JMPW=16_4EF8, JSRW=16_4EB8,
              JSRA1=16_4E91, JSRA4=16_4EAC,
              BRA=16_6000, BSR=16_6100

%routine DIAGNOSE(%integer pc,sp,limit)
{Diagnostic cell}
%recordformat DIAGINFO(%short type,link,
                       %half text,(%short val %or %half ep))
{PC identity}
%record%format ENV F(%integer modstart,modlim,gla,dlim,charbase,
                              proclim,id,line,
       %record(diaginfo)%name d0, %string(31) name)
!Flags on TYPE:-
%constinteger NAME=-16_8000, INDIRECT=16_4000, VAR=16_2000, DYN=16_1000
!Categories (MS 4 bits of LINK):-
%constinteger INTY=0, CHARY=1, BOOLY=2, ENUMY=3,
              POINTY=4, REALY=5,
              STRINGY=8, ARRY=9, SETY=10,
              RECY=12, FILEY=13,
              NONORD=12

%record(envf) E,EE
%record(diaginfo)%name DI
%integer I,LEVEL,FRAME,EPC,FIRST,MODE
%constinteger MAXDEPTH=8

%routine PUT STRING(%string(*)%name s, %integer max)
%integer i
  printsymbol('"')
  %for i = 1,1,length(s) %cycle
    %if 32 <= charno(s,i) < 127 %then printsymbol(charno(s,i)) -
    %else printsymbol('_')
    %return %if i = max       {without closing quote}
  %repeat
  printsymbol('"')
%end

%integer%fn LINENO(%integer line,pc,pos)
!Find line number corresponding to relative PC (words)
!  LINE = base line number
!  POS  = starting position in line info table
%integer max,p
  %cycle
    %if byteinteger(pos)&128 = 0 %start      {PC delta}
      max = 127
      %cycle
        pc = pc-byteinteger(pos)
        %result = line %if pc <= 0
        %exit %if byteinteger(pos) # max
        pos = pos+1;  max = 255
      %repeat
      line = line+1
    %else %if byteinteger(pos) # 255         {line delta}
      line = line+(byteinteger(pos)-128)
    %else                                    {absolute line}
      line = byteinteger(pos+1)<<8+byteinteger(pos+2)
      pos = pos+2
    %finish
    pos = pos+1
  %repeat
%end

%routine FIND(%integer pc,%record(envf)%name e)
%record(par fm)%name P
%record(mar fm)%name M
%record(fe02headerfm)%name H
%record(diaginfo)%name DI
%integer I,J
  e_id = -1;  e_line = 0
  %unless e_modlim >= pc >= e_modstart %start
    e = 0; e_id = -1
    p == topprog
    m == p_modules
    %cycle
      %if m==nil %start
        p == p_next; %returnif p==nil
        m == p_modules
      %finish
      h == m_header;  i = codestart(h)
      %exit %if i <= pc <= i+h_codesize
      m == m_next
    %repeat
    e_modstart = i;  e_modlim = e_modstart+h_codesize
    e_gla = m_gla&\1
    e_d0 == record(e_modlim)
    e_dlim = h_dlim
    e_charbase = e_modlim+e_dlim*sizeof(di)
    e_name = nameof(h)
  %finish
  %return %if e_dlim = 0         {no Diag info}
 {Locate procedure containing PC}
 { procedures are ordered by decreasing address}
  pc = (pc-e_modstart)>>1
  i = 0;  j = 65535
  %cycle
    di == e_d0[i]
    %exit %if pc >= di_ep
    j = di_ep
    %return %if di_link <= i {safety} %or di_link >= e_dlim  {not found}
    i = di_link
  %repeat
  e_id = i
  e_proclim = e_modstart+j+j
  e_proclim = e_modlim %if e_proclim > e_modlim
  e_line = lineno(di[1]_ep,pc-di_ep,e_charbase+di[1]_text) %if di[1]_text # 0
%end

%integer%fn CAT(%record(diaginfo)%name TP)
  %result = tp_link>>12&15
%end

%predicate ADOK(%integer ad)
@16_3ff8 %integer membot,memtop
  %trueif 0<=ad<16_4000 %or membot<=ad<memtop
  %false
%end
%predicate OK8(%integer ad)
  %false %if byteinteger(ad) = 16_80
  %true
%end
%predicate OK16(%integer ad)
  %false %if ad&1 # 0 %or shortinteger(ad) = 16_FFFF8080
  %true
%end
%predicate OK32(%integer ad)
  %false %if ad&1 # 0 %or integer(ad) = 16_80808080
  %true
%end

%predicate OK(%record(diaginfo)%name tp,%integer ad)
%integer k
%switch c(0:15)
  %false %unless adok(ad)
again:
  -> c(cat(tp))
c(inty):
  %if |tp_val| = 1 %start
    %true
c(booly):c(enumy):c(chary):
    %true %if ok8(ad);  %false
  %finish
  %if |tp_val| = 2 %start
c(*):
    %true %if ok16(ad);  %false
  %finish
c(realy):
  %true %if ok32(ad);  %false
c(arry):
  tp == e_d0[tp_type&4095] %until cat(tp) # arry
  %false %if cat(tp) > arry
  -> again                    {!}
c(recy):                      {!}
  k = |tp_val|                {!}
  %while k > 0 %cycle         {!}
    %true %if ok8(ad)         {!}
    ad = ad+1;  k = k-1       {!}
  %repeat                     {!}
  %false                      {!}
c(stringy):                   {!}
  %true %if ok8(ad)           {!}
  %true %if ok8(ad+1)
c(sety):c(filey):c(pointy):  {for now: not implemented}
  %false
%end

%record%format IDINFO(%string(*)%name s,%record(idinfo)%name link)

%routine SHOW(%record(diaginfo)%name DI, %record(idinfo)%name PRE,
              %integer AD,DEPTH)
%record(idinfo) id
%record(diaginfo)%name tp

%routine PUT OBJECT(%record(diaginfo)%name TP,%integer AD)
%switch c(0:15)
  -> c(cat(tp))
c(inty):
  %if tp_val = -1 %start               {unsigned byte}
    putint(byteinteger(ad),0)
  %else %if tp_val = 1                 {signed byte}
    putint(miteinteger(ad),0)
  %else %if tp_val = -2                {half}
    putint(halfinteger(ad),1)
  %else %if tp_val = 2                 {short}
    putint(shortinteger(ad),1)
  %else                                {integer}
    putint(integer(ad),0)
  %finish
  %return
c(chary):
  putchar(byteinteger(ad),'"')
  %return
c(booly):
  %if byteinteger(ad) # 0 %then printstring("TRUE") -
  %else printstring("FALSE")
  %return
c(enumy):
  printstring(string(e_charbase+tp[byteinteger(ad)+1]_text))
  %return
c(realy):
  printfl(real(ad),5)
  %return
c(stringy):
  put string(string(ad),50)
  %return
c(recy):
  %while tp_link&4095 # 0 %cycle
    tp == e_d0[tp_link&4095]
    newline
    show(tp,id,ad+tp_val,depth+1)
  %repeat
  %return
c(arry):
  tp == e_d0[tp_type&4095] %until cat(tp) # arry
  put object(tp,ad)
  printstring(", ...")
  %return
c(*):
  printstring("Unknown category:")
  write(cat(tp),1)
%end  {put object}

%routine PRINT IDENT(%record(idinfo)%name id,%integer field)
  field = field-length(id_s)
  %if id_link ## nil -
  %then print ident(id_link,field-1) %and printsymbol('_') -
  %else spaces(field)
  printstring(id_s)
%end

  id_link == pre;  id_s == string(e_charbase+di_text)
  tp == e_d0[di_type&4095]
  print ident(id,24)
  %if di_type&indirect # 0 %start
    %return %unless ok32(ad)
    ad = integer(ad)
  %finish
  %if di_type < 0 %start                  {%name}
    %return %unless ok32(ad)
    printstring(" @")
    ad = integer(ad)
    %if ad = 0 %then printstring("NIL") %else phex(ad)
    %return %unless depth = 1
  %finish
  %if ok(tp,ad) %start
    printstring(" = ")
    put object(tp,ad)
  %finish
%end  {show}

%integer%fn OKSHORT(%integer p)
{Including ROM and local RAM?}
  %result = 0 %unless p&1 = 0 %and adok(p)
  %result = shortinteger(p)
%end

  first = 1
! mode = terminal mode
! set terminal mode(0) %if mode # 0
  newline
  e_modlim = 0
%cycle
  find(pc,e)                                 {Locate PC}
 {Find most recent LINK to locate next stack frame}
  %cycle
    frame = limit;  level = 0
    %for i = 1,1,7 %cycle
      %if eventdisplay(i) < frame %start
        frame = eventdisplay(i);  level = i
      %finish
    %repeat
    %exit %if frame >= sp                    {sound FRAME value}
    %return %if level = 0                    {SP >= LIMIT}
   {event_display(LEVEL) < SP}
    printstring("*Stack corrupt 1: ")
    write(level,1);  space;  phex(frame)
    newline
    eventdisplay(level) = 16_7FFFFFFF
  %repeat
  epc = mainentry
  %if level # 0 %start                   {frame located below LIMIT}
    pc = integer(frame+4)                {return address}
   {Establish entry-point PC}
    %if okshort(pc-4) = bsr %start       {internal call}
      epc = pc-4
      epc = epc+2+okshort(epc+2) %until okshort(epc) # bra
    %else %if okshort(pc-4) = jsra4      {external call}
      find(pc,ee)                        {locate calling module}
      epc = ee_gla+okshort(pc-2)
      epc = epc+6 %if okshort(epc) # jmp {external v system}
      -> err %unless okshort(epc) = jmp
      epc = integer(epc+2)
    %else %if okshort(pc-2) # jsra1      {EXEC call}
err:  printstring("*Stack corrupt 2: ")
      phex4(okshort(pc-4));  newline
      %exit
    %finish
  %finish
  %if e_id < 0 %start                        {PC not located}
    find(epc,e)                              {locate entry-point PC}
    e_line = 0
    %exit %if epc = mainentry %and e_id # 0  {should be zero}
    %if e_id < 0 %start                      {entry-point not located}
      %if e_dlim # 0 %start
        printstring("*Procedure not located for ")
        phex(epc); space; phex(pc); newline
      %finish
    %else
     {Search stack for plausible call}
     {  probably should be tightened to (a) apply to first PC only}
     {   and (b) stop on JSR only}
      %while sp < frame %cycle
        i = integer(sp);  sp = sp+2
        %if epc < i <= e_proclim  {could be PC in this proc} -
        %and (shortinteger(i-4) = bsr -
              %or shortinteger(i-4)&16_FFE0 = jsr&16_FFE0) %start
          find(i,ee)
          e = ee %and %exit %if ee_id >= 0
        %finish
      %repeat
    %finish
  %finish
  event_line = e_line %if first # 0
  %if e_id >= 0 %start
    %if first # 0 %then spaces(11) %else printstring("Called from")
    space %and print lineno(e_line) %if e_line # 0
    di == e_d0[e_id]
    %if di_text # 0 %start
      printstring(" of") %if e_line # 0
      printstring(" Procedure ");  printstring(string(e_charbase+di_text))
!      space; printsymbol('@'); phex(e_modstart+di_ep+di_ep)
    %finish
    printstring(" in") %if e_line # 0 %or di_text # 0
    space; printstring(e_name)
    newline
    first = 0
    pc = epc %and %continue %if e_id # 0 -
    %and (epc-e_modstart)>>1 # di_ep  {FRAME not for this proc} -
    %and sp < frame                {to prevent looping}
    i = e_id+2                     {first cell for proc}
    %while i < e_d0[e_id]_link %cycle
      di == e_d0[i]
      %if di_type&var # 0 %and di_text # 0 %start
        %if di_type&dyn # 0 %start
          show(di,nil,frame+di_val,1) %and newline %if frame+di_val >= sp
        %else
          show(di,nil,e_gla+di_val,1);  newline
        %finish
      %finish
      i = i+1
    %repeat
    newline
  %finish
  %exit %if level = 0
  first = 0
  eventdisplay(level) = integer(frame)         {unlink}
  sp = frame+4
%repeat
!set terminal mode(mode)
%end

%system%routine MONITOR
{*no vars to perturb SP*}
  *movem.l d0-d7/a0-a7,eventr; !Save registers (rather late)
  display(1) = a6
  eventdisplay = display
  eventpc = integer(eventr(15))
  diagnose(integer(a7),a7,maingla)
%end

!%system%routine EXCEPTH
!{*no vars to perturb SP*}
!  *movem.l d0-d7/a0-a7,event_r; !Save registers (rather late)
!  event_display(1) = a6
!  event_display(2) = display(2)
!  event_display(3) = display(3)
!  event_display(4) = display(4)
!  event_display(5) = display(5)
!  event_display(6) = display(6)
!  event_display(7) = display(7)
!  event_r(15) = a7+66
!  event_pc = integer(event_r(15))
!  diagnose(integer(a7+66),a7+66,maingla)
!%end

%systemroutine RUN PROGRAM (%string(255)file)
%integer start,size,i
%record(fe02 header fm)%name header
%record(par fm)%name par
%integer pc,gla,level,result

  %routine run
    %onevent 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 %start
      %return
    %finish
    %signal 0,1,,"Program not runnable" %if header_tyver#16_FE02
    gla = a7-header_ownsize-2048
    *move.l gla,sp
    pc = load module(header,par,gla,file)
    %signal 0,1,,"Program not runnable" %if pc=0
    *move.l sp,a4
    *move.l pc,a1
    *jsr (a1)
    %stop
  %end

  %on 3 %start
    selectinput(0); selectoutput(0)
    topprog == par_next
    release %while heap level>level
    file = "Run program fails: ".event_message
    %signal 3,event_sub,event_extra,file
  %finish

  event = 0
  level = heap level; mark
  par == new(par); par = 0
  par_next == topprog; topprog == par
  dot mob(file)
  connectfile(file,1,start,size)
  length(file) = length(file)-4
  header == record(start)
  run
  result = eventevent<<8!eventsub
  %if 1#result#0 %start
    selectoutput(0)
    event_line = 0; interpret event
    diagnose(eventpc,eventr(15),maingla)
    interpret event %if event_line#0
  %finish
  %for pc = 1,1,7 %cycle
    selectinput(pc); closeinput
    selectoutput(pc)
    %if result=0 %then closeoutput %else abortoutput
  %repeat
  selectinput(0)
  selectoutput(0)
  topprog == par_next
  release %while heap level>level
%end

%begin   {Initialisation block}

@16_3f00-6*59 %routine becomeprocess(%integer x)
%string(255)line
%string(3)match
%string(15)filename = ":boot:00.mob"
%bytename b == length(line)
%bytename msb == charno(filename,7)
%bytename lsb == charno(filename,8)
%integer pos,file,filesize

! Backwards-compatible dictionary stuff (TEMP!):

%recordformat olddictfm(%integer beg,pos,lim,alt)
@16_3fb0 %record(olddictfm)oldcomdict,oldfildict,*,oldsysdict

%integerfn defname(%string(255)name,%record(olddictfm)%name od,%integer size)
%integer stream = outstream, tag
  %if od==oldsysdict %start
    name = "sys_".name
    tag = findentry(name,comdict)
    %if tag=0 %start
      tag = makeentry(name,comdict)
      integer(tag) = heapget(size)
      tag = integer(tag)
      makeglobal(record(tag))
      %while size>0 %cycle
        size = size-1; byte(tag+size) = 0
      %repeat
    %else
      tag = integer(tag)!16_80000000
    %finish
  %elseif od==oldfildict
    tag = addr(newstring(name)); make global(string(tag))
  %elseif od==oldcomdict
    tag = findentry(name,comdict)
    %if tag=0 %then tag = makeentry(name,comdict)-
    %else tag = integer(tag)!16_80000000
  %else
    %signal 5,,addr(od),"DEFNAME fails - unknown dictionary"
  %finish
  %result = tag
%end

%integerfn refname(%string(255)name,%record(olddictfm)%name od)
%integer stream = outstream, tag
  %if od==oldsysdict %start
    name = "sys_".name
    tag = findentry(name,comdict)
    tag = integer(tag) %if tag#0
  %elseif od==oldfildict
    tag = 0
  %elseif od==oldcomdict
    tag = findentry(name,comdict)
  %else
    %signal 5,,addr(od),"REFNAME fails - unknown dictionary"
  %finish
  %result = tag
%end

%routine transname(%integer tag,%string(255)%name n)
%integer stream = outstream, size
  size = integer(tag-4)
  %signal 5,,tag,"TRANSNAME fails - compatibility problem" %unless size>>24=1-
  %and size<<8>>8=(byte(tag)+7)>>2<<2
  n = string(tag)
%end

! end of TEMP

%routine xcode(%integer n {, %routine(*) A0})
  *muls #-6,d0
  *lea 16_3f00,a1
  *move.w #16_4ef9,0(a1,d0.l)
  *move.l a0,2(a1,d0.l)
%end

%routine next file
@16_11fc %integer boot list
  %if file=0 %start
    file = bootlist
    lsb = '0'; msb = '0'
  %else
    file = (file+filesize+7)&-4
    lsb = lsb+1; lsb = '0' %and msb = msb+1 %if lsb>'9'
  %finish
  filesize = integer(file-4)
  file = 0 %if filesize=0
%end

%predicate this file
x:%trueif file<addr(x)<file+filesize
  %false
%end

%routine load file
%integer token
  token = make entry(filename,fildict)
  integer(token) = file-4
  token = make entry(filename,moddict)
  %if half(file)=16_fe02 %and half(file+4)#0 %start
    %if loadmodule(record(file),topprog,0,filename)=0 %start
      printstring("Module ";filename;" not OK"); newline
    %finish
  %finish
%end

! Register new extracodes

  *lea heapget,a0;      xcode(20)
  *lea dispose,a0;      xcode(21)
  *lea openinput,a0;    xcode(26)
  *lea openoutput,a0;   xcode(27)
  *lea setinput,a0;     xcode(30)
  *lea setoutput,a0;    xcode(31)
  *lea closeinput,a0;   xcode(32)
  *lea closeoutput,a0;  xcode(33)

! Register old extracodes

  *lea prompt,a0;       xcode(34)
  *lea write,a0;        xcode(47)
  *lea defname,a0;      xcode(50)
  *lea refname,a0;      xcode(51)
  *lea transname,a0;    xcode(52)

! Set ourselves up as the main process, grabbing all remaining store

  becomeprocess(0)

! Create the dictionaries and load the object files which
! have been read in by the supervisor's bootstrap

  masterdict == createdict(""); makeglobal(masterdict)
  extdict == createdict("ext"); makeglobal(extdict)
  moddict == createdict("mod"); makeglobal(moddict)
  logdict == createdict("log"); makeglobal(logdict)
  fildict == createdict("fil"); makeglobal(fildict)
  comdict == createdict("com"); makeglobal(comdict)

! Load this file first

  file = 0
  nextfile %until file=0 %or thisfile
  topprog == new(topprog); topprog = 0
  loadfile

! Then load the other files

  file = 0
  %cycle
    nextfile; %exitif file=0; load file %unless thisfile
  %repeat

! Open control/report streams to the terminal
! and lock them (prevent them being closed)

  openoutput(0,":t"); selectoutput(0)
  openinput(0,":t"); selectinput(0)
  curin_next == curin
  curout_next == curout

! Finally run those files which the bootstrap missed out

  %cycle
    nextfile; %exitif file=0
    %continueif thisfile
    %continueunless half(file)=16_fe02 %and half(file+6)#0
    runprogram(filename)
  %repeat

! Access the startup command file, skipping the supervisor boot section.

  openinput(0,":boot:00.mob")
  readline(line) %until charno(line,1)='.'

! Now deal with the rest of the startup command file

  %cycle
    %cycle
      readline(line)
      pos = 0               {Discard trailing comments}
      %cycle
        pos = pos+1
        %exitif pos>b
        %if b[pos]='!' %start
          pos =pos-1 %while b[pos-1]=' '
          b = pos-1
          %exit
        %finish
      %repeat
    %repeatuntil line#""

! Logical name definition?

    match = "=="
    %if resolves(line,match,line,cliparam) %start
      definelogicalname(line,cliparam)
      %continue
    %finish

! Command symbol definition?

    match = "="
    %if resolves(line,match,line,cliparam) %start
      define command symbol(line,cliparam)
      %continue
    %finish

! Otherwise run a program.  Split verb from parameter if any.

    match = " "
    cliparam = "" %unless resolves(line,match,line,cliparam)
    runprogram(line)
    %if event_event!event_sub#0 %start
      printstring(line;" failed: ";event_message); newline
      write(event_event,0; event_sub,1);space;phex(event_extra); newline
    %finish
  %repeat

%endofprogram