! BASE module.
! Imp run time support interface to MOUSE kernel
! Aug 1986

%option "-low-nons-nocheck-nostack-nodiag"
%include "moose:mouse.inc"
%begin

%systemintegerfn set sr (%integer new sr)
  *trap #0
%end

%systemintegerfn or to sr (%integer bits)
  *trap #1
%end

%systemrecord(state fm)%map scheduling state(%integer priority)
%register(a1)%record(process fm)%name curproc
%register(a0)%record(state fm)%name state
  *trap #2
  *exg a0,a1
  %if priority<0 %start
    state == curproc_state
  %else
    priority = priority&7
    state == state[priority]
  %finish
  %result == state
%end

%systemintegerfn cpu type
  *trap #2
%end

%systemrecord(process fm)%map current process
  *trap #2
%end

%systemintegerfn real time
  %result = current process_ref time
%end

%systemintegerfn cpu time
  %result = current process_cpu time
%end

%systemroutine enqueue (%record(*)%name item,%record(queue fm)%name q)
! Add ITEM to the end of queue Q.
  *trap #8
%end

%systemrecord(*)%map dequeue (%record(queue fm)%name q)
! Remove item from front of queue Q.
  *trap #9
  %result == nil %if a0=a1
  %result ==record(a0)
%end

%systemroutine requeue (%record(*)%name item,%record(queue fm)%name q)
! Add ITEM to the front of queue Q.
  *trap #10
%end

%systemrecord(*)%map unqueue (%record(queue fm)%name q)
! Remove item from end of queue Q.
  *trap #11
  %result == nil %if a0=a1
  %result ==record(a0)
%end

%systemrecord(queue fm)%map inqueue(%record(*)%name item,left,right)
! Add ITEM into middle of queue between LEFT and RIGHT.
! Result is queue into which inserted.
  *trap #12
%end

%systemrecord(queue fm)%map exqueue(%record(*)%name item)
! Remove ITEM from queue.  Result is queue it was in.
  *trap #13
%end

%systemroutine signal semaphore (%record(semaphore fm)%name s)
   *trap #6
%end

%systemroutine semaphore wait (%record(semaphore fm)%name s)
  *trap #7
%end

%systemintegerfn test semaphore(%record(semaphore fm)%name s)
  *trap #14
%end

%systemroutine send message -
   (%record(*)%name m, %record(mailbox fm)%name box,reply)
 @#m %record(message fm)%name message
  message_reply == reply
  enqueue(message,box_queue)
  signal semaphore(box_semaphore)
%end

%systemrecord(*{message fm})%map receive message -
   (%record(mailbox fm)%name box)
  semaphore wait(box_semaphore)
  %result == dequeue(box_queue)
%end

! Utilities to initialise kernel objects

%systemroutine setup queue(%record(queue fm)%name q)
  q_forward == q; q_backward == q; q_header == nil
  q_size = sizeof(q); q_tag = 'QQ'
%end

%systemroutine setup semaphore(%record(semaphore fm)%name s)
  setup queue(s_queue)
  s_queue_size = sizeof(s)
  s_queue_tag = 'SE'
  s_count = 0; s_assoc == nil
%end

%systemroutine setup message(%record(*)%name m,%integer size)
@#m %record(message fm)%name message
%integer i
  setup queue(message_queue)
  size = sizeof(message) %if size<sizeof(message)
  message_queue_size = size
  message_queue_tag = 'ME'
  message_reply == nil
%end

%systemroutine setup mailbox -
    (%record(mailbox fm)%name b,%record(semaphore fm)%name s)
  setup queue(b_queue)
  b_queue_size = sizeof(b)
  b_queue_tag = 'MB'
  b_semaphore == s
%end

%systemroutine setup interrupt handler -
    (%record(interrupt handler fm)%name i,%integer pc)
  setup queue(i_queue)
  i_queue_size = sizeof(i)
  i_queue_tag = 'IH'
  i_a4 = a4; i_pc = pc
%end

%systemroutine setup process(%record(process fm)%name p)
  setup queue(p_queue)
  p_queue_tag = 'PR'; p_queue_size = sizeof(p)
%end

! Process creation etc

%systemroutine set priority(%record(process fm)%name process,%integer priority)
%record(state fm)%name s
%integer sr
  s == scheduling state(priority)
  sr = ortosr(16_700)
  process == currentprocess %if process==nil
  process_state == s
  process_target == s_target      {dubious?}
  process_quota = s_quota
  process_hysteresis = s_quota
  process_target_interrupter = 255
  sr = setsr(sr)
%end

{}%routine {frig} make global(%record(*)%name x)
{}  byte(addr(x)-4) = 1
{}%end

%integerfnspec internal make entry(%string(255)s,%record(dict fm)%name d)

%systemrecord(process fm)%map create process -
  (%integer size,pc,priority,%record(queue fm)%name queue)
{NB priority 0:min, 7:max, -1:same as caller}
%record(poa fm)%name poa
%record(par fm)%name par
@0(a5) %record(poa fm)cur poa
%record(process fm)%name pcb,cur
%integer start

  %routine push(%integer x)
    pcb_ssp = pcb_ssp-4; integer(pcb_ssp) = x
  %end

  %record(dict fm)%map link(%record(dict fm)%name old)
  %record(dict fm)%name d
    %result == nil %if old==nil
    d == new(d); d = 0; d_alt == old
{}  make global(d)
    %result == d
  %end

  %Routine Tackon (%Record(dictfm)%Name dict, %String(3) s)
   %integer a
!   putstring("Setting up ");putstring(s);putsym(32);
!   putlong(addr(dict));putsym(32)

   a = internal make entry (s, poa_masterdict)
!   putlong (a);putsym(10)
   integer(a) = addr(dict)
  %End
           
  cur == current process
  pcb == new(pcb)
  poa == new(poa)
  start = heapget(size)
  pcb = 0
  setup process(pcb)
  pcb_xvt = cur_xvt
  pcb_tvt = cur_tvt
  pcb_membot = start
  pcb_memtop = start+size
  pcb_poa == poa
  pcb_ssp = addr(pcb[1])
! Push register context onto system stack:
! Format word (in case 68010)
! Program counter
! Status register
! Register set part 1 (interrupt) D0-D1/A0-A1/A4/A6
! Register set part 2 (remainder) D2-D7/A2-A5 (A4 as USP)
  push(pc<<16); push(pc>>16)  {a little obscurity never hurt anyone a lot}
  push(a6); push(a4); push(a1); push(a0); push(d1); push(d0)
  push(addr(poa)); push(pcb_memtop); push(a3); push(a2)
  push(d7); push(d6); push(d5); push(d4); push(d3); push(d2)
  poa = 0
  poa_membot = pcb_membot
  poa_memtop = pcb_memtop
  poa_heapbase = pcb_membot
  poa_heap_size = sizeof(poa_heap)
  poa_heap_level = 1
  poa_heap_holes == nil
  poa_heap_front = poa_heapbase+sizeof(poa_heap)
  poa_heap_limit = 0 {pcb_memtop
  poa_heap_end = pcb_memtop
  poa_stacklim = poa_heap_front+256
  par == new(par); par = 0
  poa_topprog == new(par); poa_topprog = 0; poa_topprog_next == par
  poa_masterdict == link(cur poa_masterdict)
  poa_extdict == link(cur poa_extdict); tackon (poa_extdict,"ext")
  poa_moddict == link(cur poa_moddict); tackon (poa_moddict,"mod")
  poa_logdict == link(cur poa_logdict); tackon (poa_logdict,"log")
  poa_fildict == link(cur poa_fildict); tackon (poa_fildict,"fil")
  poa_comdict == link(cur poa_comdict); tackon (poa_comdict,"com")
  set priority(pcb,priority)
  %if queue==nil %start
    enqueue(pcb,pcb_target_queue)
    pcb_target_interrupter = 255
  %else
    enqueue(pcb,queue)
  %finish
  %result == pcb
%end

%systemroutine delete process(%record(process fm)%name pcb)
%record(process fm)%name cur pcb
%record(poa fm)%name poa
%record(queue fm)%name q
%record(semaphore fm)forever
%integer dummy

  %routine dispose(%record(*)%name x)
    *clr.b -4(a0)
  %end

  %routine zap dict(%record(dict fm)%name d)
    %routine zap tree(%record(dict cell fm)%name c)
      %returnif c==nil
      zap tree(c_left)
      zap tree(c_right)
      dispose(c)
    %end
    %returnif d==nil
    zap tree(d_tree)
    dispose(d)
  %end

  dummy = ortosr(16_700)
  cur pcb == current process
  q == exqueue(pcb)
  poa == pcb_poa
  zap dict(poa_masterdict)
  zap dict(poa_extdict)
  zap dict(poa_moddict)
  zap dict(poa_logdict)
  zap dict(poa_fildict)
  zap dict(poa_comdict)
  dispose(poa_heap)
  dispose(poa)
  %if pcb==curpcb %start
    setup semaphore (forever) 
    dispose(pcb)
{}putstring("process stopped"); putsym(nl)
    semaphore wait(forever)
    *stop #3
  %finish
{}putstring("process killed"); putsym(nl)
  dispose(pcb)
%end

!***   End  of  MOUSE  kernel  stuff   ***

!***   Start  of  FE02  stuff   ***

@16_3ff8 %integer membot,memtop

%routine putdec(%integer n)
%integer e=-1000000000,s='-',k
  %if n=0 %start
    putsym('0'); %return
  %finish
  %if n>0 %start
    n = -n; s = 0
  %finish
  e = e//10 %while e<n
  putsym(s) %unless s=0
  %cycle
    k = n//e; n = rem(n,e)
    putsym(k+'0')
    e = e//10
  %repeatuntil e = 0
%end

%routine signal(%integer ef,sub,extra,%string(255)message)
%shortintegername mask
%integer start,end,bit,epc
@32(a5) %record(eventfm)event
  %routine unwind(%integername x)
    x = integer(x) %while x&1=0 %and event_r(15)<x<poa_evlink
  %end
  *movem.l d0-d7/a0-a7,event_r; event_r(15) = addr(ef)+4
  poa_display(1) = a6
  event_display(epc) = poa_display(epc) %for epc = 1,1,7
  epc = integer(event_r(15)); event_pc = epc
  event_event = ef&15
  %if ef&16=0 %then event_sub = 0      %else event_sub = sub
  %if ef&32=0 %then event_extra = 0    %else event_extra = extra
  %if ef&64=0 %then event_message = "" %else event_message = message
  event_line = 0
  bit = 1<<event_event
  %cycle
    %if poa_trap==nil %start
      putstring("*Untrapped event "); putdec(event_event)
      putsym(' '); putdec(event_sub)
      putsym(' '); putlong(event_extra)
      putsym(' '); putstring(event_message); putsym(nl)
      *stop #0
      !set priority(nil, 0)
      !%cycle;  %repeat
    %finish
    mask == shortinteger(poa_trap_pc)
    %if mask&bit#0 %start
      start = addr(mask[1])
      end = addr(mask[-1])+mask[-1]
      %unless start<epc<=end %start
        unwind(poa_display(epc)) %for epc = 1,1,7
        a6 = poa_display(1)
        a7 = poa_evlink
        *movem.l event_r,d0-d7/a0-a5
        *move.l 8(sp),a4
        *move.l 4(sp),-(sp)
        *addq.l #2,(sp)
        *rts
      %finish
    %finish
    poa_trap == poa_trap_next
  %repeat
%end

! Heap package

%integerfn {frig} allocate(%integer size)
%integer pos = poa_heap_front
%record(heapcellfm)%name h
  %result = pos+4 %if size=0
  size = (size+7)&\3
  h == record(pos)
  h_size = size; h_level = 1
  poa_heap_front = pos+size
  poa_stacklim = poa_heap_front+256
  %result = pos+4
%end

%constinteger sizemask = 16_fffffc

%integerfn getheap(%integer amount,level)  {also NEW}
! 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.
! The backward pointer of the first hole on the list is NIL, as
! is the forward pointer of the last hole.
%integer need,limit,pos=0
%record(heap cell fm)%name hole,prev
  %if level=0 %start  {system-wide}
    level = 1 {*for now*}
  %finish
  limit = poa_heap_limit
  limit = a7-256 %if limit=0
  prev == nil
  need = (amount+7)&\3;    !round up and add 4
  need = 12 %if need<12;   !impose minimum
  hole == poa_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_size < 12 %or hole_backward##prev
    %if hole_size-need>=0 %start;     !big enough
      %if hole_size-need>=12 %start;  !big enough to split in two
!Leave hole in list, allocate space at end of it.
        hole_size = hole_size-need
        pos = pos+hole_size
      %else;                          !exact fit or 4 or 8 too big
!Remove hole from list and allocate all of it.
        %if prev==nil %then poa_heap_holes == hole_forward -
        %else prev_forward == hole_forward
        hole_forward_backward == hole_backward %unless hole_forward==nil
        need = hole_size
      %finish
      ->result
    %finish
    prev == hole
    hole == hole_forward
  %repeat
! No suitable holes found.  Grab off front.
  %signal 2,1,amount,"Heap space exhausted" -
    %if need>=16_1000000 %or poa_heap_front+need>=limit
  pos = poa_heap_front
  poa_heap_front = pos+need
  poa_stacklim = pos+need+256
!!d6 = poa_stacklim
result:
  hole == record(pos)
  hole_size = need; hole_level = level
%constinteger unassigning=0
$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 {NB result in both D0 (for heapget) and A0 (for new)}
%end

%systemintegerfn HEAPGET(%integer amount) {also NEW}
  %result = getheap(amount,poa_heap_level)
%end

%systemintegerfn global heap get(%integer amount)
  %result = getheap(amount,1)
%end

%systemintegerfn system heap get(%integer amount)
  %result = getheap(amount,0)
%end

%integerfn heapmode(%record(*)%name x)
! (used by MAKE ENTRY)
%integer a = addr(x)
  %result = 0 %unless poa_membot<a<poa_memtop  {system-wide}
  %result = byte(a-4)            {global (=1) or local (>1)}
%end

%systemroutine HEAPPUT(%integer pos)
! Return the heap chunk starting at POS to the list of holes.
! But if it is at the heap front, just move back the front pointer.
%integer holeend,heapfront
%record(heap cell fm)%name hole,neighbour

  %routine corrupt(%integer code)
    %signal 5,code,pos,"Heapput: heap corrupt"
  %end

  %returnif pos=0
  %unless poa_membot<pos<poa_memtop %start  {system-wide}
    {} put string("Heapput: system-wide ");  put long(pos);  put sym(NL)
    byte(pos-4) = 0; %return  {*for now*}
  %finish
  heapfront = poa_heap_front
  %signal 5,,pos,"Heapput: invalid address"-
    %unless pos&3=0 %and poa_heapbase<pos<heapfront
  hole == record(pos-4)
  corrupt(11) %if hole_size&3#0             {11: size corrupt
  corrupt(12) %if hole_level=0              {12: already disposed
  corrupt(13) %if hole_level>poa_heap_level#1   {13: level corrupt
  hole_level = 0
  holeend = pos-4+hole_size
  corrupt(14) %if holeend>heapfront         {14: chain corrupt
  %if holeend=heapfront %start
done:
    poa_heap_front = heapfront-hole_size
    poa_stacklim = poa_heap_front+256
!!  d6 = poa_stacklim
    %return
  %finish
  hole_forward == poa_heap_holes
  poa_heap_holes == hole
  hole_backward == nil
  hole_forward_backward == hole %unless hole_forward==nil
! %cycle; !See if our neighbour can be absorbed
!   neighbour == record(holeend)
!   corrupt(15) %if neighbour_size&3#0            {15: size corrupt
!   corrupt(16) %if neighbour_level>poa_heap_level#1  {16: level corrupt
!   %returnunless neighbour_level=0
!   holeend = holeend+neighbour_size
!   corrupt(17) %if holeend>heapfront             {17: chain corrupt
!   hole_size = hole_size+neighbour_size
!   neighbour_backward_forward == neighbour_forward
!   neighbour_forward_backward == neighbour_backward %unless neighbour_forward==nil
!   %if holeend=heapfront %start
!     poa_heap_holes == hole_forward
!     hole_forward_backward == nil %unless hole_forward==nil
!     ->done
!   %finish
! %repeat
%end

%systemroutine MARK
! Mark the heap for subsequent automatic disposal using RELEASE
  %signal 2,1,255,"Too many heap markers" %if poa_heap_level=255
  poa_heap_level = poa_heap_level+1
%end

%routinespec phex(%integer x)
%routinespec write(%integer i,j)

%systemroutine RELEASE
! Automatically dispose all chunks allocated since last MARK
%record(heap cell fm)%name hole,neighbour
%integer p1,p2,heapfront
  %routine corrupt(%integer n)
  %integer i,to,j,k
    i = integer(p1)<<8>>8; to = p1+i
{}  open output(0,":t")
{}  selectoutput(0)
{}  printstring("Oh dear: Heap corrupt for "); phex(addr(poa)); newline
{}  printstring("Heapbase  "); phex(poa_heapbase); newline
{}  printstring("Heapfront "); phex(poa_heap_front); newline
{}  printstring("Heaplimit "); phex(poa_heap_limit); newline
{}  printstring("Heaplevel "); write(poa_heap_level,0); newline
{}  printstring("Corruption of type "); write(n,0)
{}  printstring(" at "); phex(p1); space; phex(integer(p1)); newline
{}  printstring("Neighbour "); phex(to); space; phex(integer(to))
    i = p1
    %cycle
      newline; phex(i); space
      %for j = i,1,i+15 %cycle
        k = byte(j); k = '_' %if k<' ' %or k>126
        printsymbol(k)
      %repeat
      space %and phex(integer(j)) %for j = i,4,i+12
      i = i+16
    %repeatuntil i>to+8
    newline
    %signal 5,n,p1,"Release: heap corrupt"
  %end
  %returnif poa_heap_level<=1; !Global operations in progress
  heapfront = poa_heap_front
  poa_heap_holes == nil;       !Hole list will be rebuilt
  p1 = poa_heapbase+sizeof(poa_heap)
  %cycle;                 !Scan the whole heap
    %exitif p1=heapfront
    corrupt(18) %if p1>heapfront
    hole == record(p1)
    corrupt(19) %if hole_level>poa_heap_level
    hole_level = 0 %if hole_level=poa_heap_level; !Auto-dispose
    %if hole_level=0 %start; !Found a hole
      %cycle;                !Try to absorb neighbours
        p2 = p1+hole_size
        %if p2=heapfront %start
          heapfront = p1
          poa_heap_front = p1
          poa_stacklim = p1+256
!!        d6 = poa_stacklim
          %exit
        %finish
        corrupt(20) %if p2>heapfront
        neighbour == record(p2)
        corrupt(21) %if neighbour_level>poa_heap_level
        %if 0#neighbour_level#poa_heap_level %start; !add chunk to list
          hole_forward == poa_heap_holes
          hole_forward_backward == hole %unless hole_forward==nil
          hole_backward == nil
          poa_heap_holes == hole
          p1 = p2+neighbour_size&sizemask
          %exit
        %finish
        hole_size = hole_size+neighbour_size&sizemask; !merge with neighbour
      %repeat
    %else
      p1 = p1+hole_size&sizemask
    %finish
  %repeat
  poa_heap_level = poa_heap_level-1
%end

%systemrecord(*)%map XNEW %alias "new" (%integer size){(%name x)}
  *jsr heapget
%end

%systemroutine DISPOSE(%record(*)%name pos)
  *move.l a0,d0
  *jmp heapput
%end

%systemintegerfn HEAPLEVEL
  %result = poa_heap_level
%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 FREESTORE
  %result = a7-poa_stacklim
%end

%integerfn stringdiff(%string(*)%name a,b)
{result is <=> zero iff a<=>b}
!$ Case-sensitive version
!  %result = 0 %if a=b
!  %result = -1 %if a<b
!  %result = 1
!$ Non-case-sensitive version
!%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

%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

! Dictionary operations
! 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
  toupper(s)
  n == record(getheap(sizeof(n)-255+length(s),heapmode(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,,,"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

%integerfn internal make entry(%string(255)s,%record(dict fm)%name d)
  %result = make entry(s,d)
%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).
! Looks down ALT tree
%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 {parenthood acknowledged?}
    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)
{Warning: Doesn't look down ALT tree - should it ??? - no.}
%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)
{Warning: Doesn't look down ALT tree - should it ??? - no.}
%record(dict cell fm)%name c,p
  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,,,"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,poa_masterdict)
    %result == record(integer(a)) %if a#0 %and integer(a)#0
    a = makeentry(s,poa_masterdict)
  %finish
  d == new(d); d = 0
{}byte(addr(d)-4) = 1
  integer(a) = addr(d) %unless a=0
  %result == d
%end

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

! General IO library

%systemroutine create logical name(%string(255)log,equiv)
%integer t
  t = findentry(log,poa_logdict)
  %if t#0 %start
    heapput(integer(t)) %if integer(t)#0
  %else
    t = makeentry(log,poa_logdict)
  %finish
  integer(t) = addr(newstring(equiv))
%end

%systemroutine delete logical name(%string(255)log)
%integer t
  t = findentry(log,poa_logdict)
  heapput(integer(t)) %if t#0 %and integer(t)#0
  deleteentry(t,poa_logdict)
%end

%systempredicate translate logical name(%string(*)%name log)
%integer t
  t = findentry(log,poa_logdict)
  %falseif t=0
  log = string(integer(t)); %true
%end

%systempredicate split(%string(255)%name s,l,r)
! Equivalent to  S -> L.(":").R
! In the case where S does not contain ":",
! S is copied into R and L are unaffected.
%integer pos=0
  %cycle
    pos = pos+1
    %if pos>length(s) %start
      r = s %unless r==nil
      l = "" %unless l==nil
      %false
    %finish
  %repeatuntil charno(s,pos)=':'
  l = substring(s,1,pos-1) %unless l==nil
  r = substring(s,pos+1,length(s)) %unless r==nil
  %true
%end

%systemroutine standardise filename(%string(*)%name in,out,device)
! Make OUT the standard form of IN, and DEVICE the leading part of OUT.
%string(255)name,rest
%integer added=0,lives
  name = in
  %cycle
    lives = 9
    %cycle
      name = ":n" %if name=""  {This should go}
      name = ":t" %if name=":" {and this}
!     tolower(name)
      %if lives=0 %start
        out = "Logical translation loop: ".in
        %signal 3,3,,out
      %finish
      lives = lives-1
      %if charno(name,1)=':' %start; !canonical
        out = name
        name = substring(name,2,length(name))
        device = name %unless split(name,device,rest)
{putstring(in;"->";out;"|";device);putsym(nl)
        %return
      %finish
      %if split(name,device,rest) %start; !Test for logical prefix
        %exitunless translate logical name(device)
        name = device.":".rest
      %else
        %exitunless translate logical name(name)
      %finish
    %repeat
    %unless added=0 %start
      device = "default"; out = ":"{.device.":"}.name
{putstring(in;"=>";out);putsym(nl)
      %return
    %finish
    added = 1
    name = "default:".name
  %repeat
%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)))
  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

%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

%predicatespec load object -
 (%record(fe02 object fm)%name object,
  %record(par fm)%name program,
  %record(fe02 indir fm)%name ref)

%systemrecord(scb fm)%map open(%integer mode,%string(255)file)
%string(255)full,dev
%integer pc,gla,level
%record(par fm)%name botprog
%record(fe02 indir fm)ref
%record(fe02 object fm)obj

  %record(scb fm)%map open(%integer m,%string(255)s)
    *move.l a4,-(sp)
    *move.l gla,a4
    *move.l pc,a1
    *jsr (a1)
    *move.l (sp)+,a4
  %end

  ref = 0
  obj = 0; obj_flags = extbit+external
  standardise filename(file,full,dev)
  dev = dev."_open"; toupper(dev)
  obj_name = dev
  botprog == poa_topprog
  botprog == botprog_next %while botprog_next##nil
  !putstring("Trying to load ";dev);putsym(nl)
  level = poa_heap_level; poa_heap_level = 1
  %unless loadobject(obj,botprog,ref) %start
    poa_heap_level = level
!    putstring("About to signal about unknown device");putsym(10)
    length(dev) = length(dev)-5
    dev = "Unknown device ".dev
    %signal 3,3,,dev
  %finish
  poa_heap_level = level
  %if ref_op1=jmp %start
    gla = 0; pc = ref_opd1
  %else
    gla = ref_opd1; pc = ref_opd2
  %finish
  !putstring("Open with gla = ");putlong(gla);putstring(", pc = ");
!  putlong(pc);putsym(nl)
  %result == open(mode,full)
%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)
  scb == open(inputmode,f)
  scb_next == poa_in(s)
  poa_in(s) == scb
  poa_curin == scb %if poa_instream=s
%end

%systemroutine openoutput(%integer s,%string(255)f)
%record(scb fm)%name scb
  streamcheck(s)
  scb == open(outputmode,f)
  scb_next == poa_out(s)
  poa_out(s) == scb
  poa_curout == scb %if poa_outstream=s
%end

%systemroutine openappend(%integer s,%string(255)f)
%record(scb fm)%name scb
  streamcheck(s)
  scb == open(appendmode,f)
  scb_next == poa_out(s)
  poa_out(s) == scb
%end

%systemroutine selectinput(%integer s)
  streamcheck(s)
  poa_instream = s
  poa_curin == poa_in(s)
%end

%systemroutine selectoutput(%integer s)
  streamcheck(s)
  poa_outstream = s
  poa_curout == poa_out(s)
%end

%routine service(%record(scb fm)%name cb,%integer number,param)
@0(a0)%record(scb fm)scb
  *move.l a4,-(sp)
  *move.l scb_serpc,a1
  *move.l scb_gla,a4
  *jsr (a1)
  *move.l (sp)+,a4
%end

%systemroutine preconnect(%string(255)f,%integer start,size)
!%string(255)full,dev {Twould be nice}
%record(fcr fm)%name fcr
%integer tok
!  standardise filename(f,full,dev) {Twould be nice}
!  f = full {ditto}
  tok = makeentry(f,poa_fildict)
  fcr == new(fcr); integer(tok) = addr(fcr)
  fcr = 0
  fcr_start = start; fcr_size = size; fcr_count = 1
%end

%systemroutine connectfile(%string(255)f,%integer m,%integername start,size)
%integer tok,extra,offset,temp
!%string(255)full,dev {Twould be nice}
%record(fcr fm)%name fcr
%record(scb fm)%name scb
%constinteger bizarre=128
!  standardise filename(f,full,dev) {Twould be nice}
!  f = full
  %if m<0 %start   {disconnect}
    tok = findentry(f,poa_fildict)
    %returnif tok=0 %or integer(tok)=0
    fcr == record(integer(tok))
    %returnunless fcr_start=start
    fcr_count = fcr_count-1
    %returnunless fcr_count=0
{printstring("disconnect "); phex(start); printstring(f); newline
    heapput(start)
    dispose(fcr)
    deleteentry(tok,poa_fildict)
    %return
  %finish
  %signal 3,3,m,"Unsupported mode for CONNECTFILE" %unless m=0 %or m=bizarre
  extra = 0; offset = 0
  %if m&bizarre#0 %start
    offset = start; extra = start+size
  %else
    tok = findentry (f,poa_fildict)
    tok = makeentry(f,poa_fildict) %if tok=0
    fcr == nil
    fcr == record(integer(tok)) %unless tok=0
    %unless fcr==nil %start
      fcr_count = fcr_count+1
      start = fcr_start
      size = fcr_size
{printstring("reconnect "); phex(start); space
{phex(size); space; printstring(f); newline
      %return
    %finish
  %finish
  scb == open(inputmode,f)
  temp = scb_bs; size = scb_fl-scb_fs
  start = heapget(size+extra+512{catch GDMR ?})+offset 
  scb_bs = start
  scb_bl = start+size
  scb_fs = scb_bs; scb_fl = scb_bl
  scb_p = scb_bs; scb_l = scb_bs
  service(scb,serrefresh,0)
  scb_bs = temp
  service(scb,serclosin,0)
  dispose(scb)
  %if m&bizarre=0 %start
    fcr == new(fcr); fcr = 0
    fcr_start = start; fcr_size = size
    fcr_count = 1
    integer(tok) = addr(fcr)
{%else
{  putstring("Bizarre connect "); putstring(f); putsym(' ')
{  putlong(start-offset); putsym(' '); putlong(start); putsym(' ')
{  putlong(size); putsym(nl)
  %finish
{printstring("connect "); phex(start); space; phex(size); space
{printstring(f); newline
%end

%systemroutine setinput(%integer byte)
  service(poa_curin,sersetin,byte) %unless poa_curin==nil
%end

%systemroutine setoutput(%integer byte)
  service(poa_curout,sersetout,byte) %unless poa_curout==nil
%end

%systemroutine resetinput
  setinput(0)
%end

%systemroutine resetoutput
  setoutput(0)
%end

%systemintegerfn instream
  %result = poa_instream
%end

%systemintegerfn outstream
  %result = poa_outstream
%end

%systemstring(255)%fn cliparam
  %result = poa_cliparam
%end

%systemroutine closeinput
  %returnif poa_curin==nil %or poa_curin_next==poa_curin
  service(poa_curin,serclosin,0)
  poa_in(poa_instream) == poa_curin_next
  dispose(poa_curin)
  poa_curin == poa_in(poa_instream)
%end

%systemroutine closeoutput
  %returnif poa_curout==nil %or poa_curout_next==poa_curout
  service(poa_curout,serclosout,0)
  poa_out(poa_outstream) == poa_curout_next
  dispose(poa_curout)
  poa_curout == poa_out(poa_outstream)
%end

%systemroutine dropoutput
  %returnif poa_curout==nil %or poa_curout_next==poa_curout
  service(poa_curout,serdropout,0)
  poa_out(poa_outstream) == poa_curout_next
  dispose(poa_curout)
  poa_curout == poa_out(poa_outstream)
%end

%systemroutine prompt(%string(255)s)
  %returnif poa_curin==nil
  service(poa_curin,serprompt,addr(s))
%end

%systemintegerfn nextsymbol
%label ok,eof
@0(a0)%record(scb fm)scb
  *move.l poa_curin,d1
  *beq eof
  *move.l d1,a0
  *move.l scb_p,a1
  *cmp.l scb_l,a1
  {*blo}*bcs ok
  *move.l a4,-(sp)
  *movem.l scb_fastpc,a1/a4
  *jsr (a1)
  *move.l (sp)+,a4
  *move.l poa_curin,a0
  *move.l scb_p,a1
ok:
  *moveq #0,d0
  *move.b (a1),d0
  *rts
eof: %signal 9,,poa_instream,"End of file"
%end

%systemintegerfn readsymbol
%label ok,eof
@0(a0)%record(scb fm)scb
  *move.l poa_curin,d0
  *beq eof
  *move.l d0,a0
  *move.l scb_p,a1
  *cmp.l scb_l,a1
  {*blo}*bcs ok
  *move.l a4,-(sp)
  *movem.l scb_fastpc,a1/a4
  *jsr (a1)
  *move.l (sp)+,a4
  *move.l poa_curin,a0
  *move.l scb_p,a1
ok:
  *moveq #0,d0
  *move.b (a1)+,d0
  *move.l a1,scb_p
  *rts
eof: %signal 9,,poa_instream,"End of file"
%end

%systemroutine printsymbol(%integer k)
@0(a0)%record(scb fm)scb
%label ok,rawmaybe,rawyes
  *move.l poa_curout,d1
  *beq rawmaybe
  *move.l d1,a0
  *move.l scb_p,a1
  *cmp.l scb_l,a1
  {*blo}*bcs ok
  *move.l a4,-(sp)
  *movem.l scb_fastpc,a1/a4
  *jsr (a1)
  *move.l (sp)+,a4
  *rts
ok:
  *move.b d0,(a1)+
  *move.l a1,scb_p
  *rts
rawmaybe:
  *move.l poa_outstream,d1
  *beq rawyes
  *rts
rawyes:
  *jmp putsym
%end

%systemroutine printstring(%string(255)s)
%integer i
  printsymbol(charno(s,i)) %for i = 1,1,length(s)
%end

%systemstring(255)%fn infilename
  %result = "" %if poa_curin==nil
  %result = poa_curin_filename
%end

%systemstring(255)%fn outfilename
  %result = "" %if poa_curout==nil
  %result = poa_curout_filename
%end

! Loader

%integerfnspec load file -
  (%string(255)file,%record(par fm)%name program,%integer gla)

%predicate load object -
  (%record(fe02 object fm)%name object,
   %record(par fm)%name program, %record(fe02 indir fm)%name ref)
%record(dyn fm)%name dyn
%record(par fm)%name botprog
%integer 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(leo fm)%name leo)
    %while leo##nil %cycle
{     putstring("Trying object @");putlong(addr(leo));
{      putsym(' ');putstring(leo_object_name);putsym(nl)
      dif = stringdiff(object_name,leo_object_name)
      %if dif<=0 %start
        %if dif=0 %start
          %unless compatible(object,leo_object) %start
            event_message = "Mismatch for ".object_name
           current process_poa_curout == current process_poa_out(0);
           printstring(event_message); newline
           selectoutput(outstream)
            %false
          %finish
          flags = leo_object_flags&procmask
          %if flags=system %start
            ref_op1 = jmp; ref_opd1 = leo_address
          %elseif flags=external
            ref_op1 = lea a4; ref_opd1 = leo_module_gla
            ref_op2 = jmp; ref_opd2 = leo_address
          %elseif flags=0
            ref_address = leo_address
          %finish
{putstring(" done");putsym(nl)
          %true
        %finish
        leo == leo_left
      %else
        leo == leo_right
      %finish
    %repeat
    %false
  %end

  %trueif found(program_objects)             {already loaded}
  botprog == program
  botprog == botprog_next %while botprog_next##nil
  %trueif found(botprog_objects)             {globally loaded}
  %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,poa_extdict); %falseif tag=0
  tag = integer(tag); %falseif tag=0
  %falseif loadfile(translateentry(tag),program,0)=0
  %trueif found(program_objects); %false  {should not get here (sigh!)}

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 loadobject(xdyn_object,xdyn_program,xref) %start
    dispose(xdyn)
    *movem.l (sp)+,d0-d7/a0-a6
    *move.l (sp)+,(sp)
    *rts
  %finish
  event_message = "No external ".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 dynamicload(%string(255)s,%integername pc,gla)
%record(fe02 indir fm)indir
%record(fe02 object fm)object
  indir = 0
  object = 0
  object_flags = extbit+external
  object_name = s
  %falseunless loadobject(object,poa_topprog,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

%systemintegerfn load module -
  (%record(fe02 header fm)%name header,
   %record(par fm)%name program,%integer gla)
%integer ok,pos,code,dif
%record(fe02 object fm)%name object
%record(mar fm)%name module
%record(leo fm)%name leo,x

!putstring("Corrupt header at ") %and putlong(addr(header)) %and putsym(10) %and-
printstring("Corrupt header at ") %and phex(addr(header)) %and newline %and-
  %result = 0 %unless header_tyver=16_fe02
  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_next == program_modules
  program_modules == module
  %unless header_export=0 %start
    %cycle
      object == record(pos)
      %exitif object_flags=0
      %if object_flags&extbit#0 %start
        leo == new(leo)
        leo_left == nil; leo_right == nil
        leo_object == object
        leo_module == module
        %if object_flags&procmask=0 %start
          leo_address = object_offset+gla
        %else
          leo_address = object_offset+code
        %finish
        x == program_objects
        %if program_objects==nil %start
          program_objects == leo
        %else
          %cycle
            dif = stringdiff(object_name,x_object_name)
            %if dif<=0 %start
              %if dif=0 %start
                dispose(leo); %exit
              %finish
              %if x_left==nil %start
                x_left == leo; %exit
              %finish
              x == x_left
            %elseif x_right==nil
              x_right == leo; %exit
            %else
              x == x_right
            %finish
          %repeat
        %finish
      %finish
      pos = (pos+sizeof(object)-255+length(object_name)+1)&\1
      %repeat
  %finish
  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
    pos = addr(header)+sizeof(header)+header_export
    %cycle
      object == record(pos)
      %exitif object_flags=0
      %if object_flags&extbit#0 %start
        %unless loadobject(object,program,record(object_offset+gla)) %start
          event_message = "*No ".object_name
         currentprocess_poa_curout == currentprocess_poa_out(0);
         printstring(event_message); newline
         selectoutput(outstream)
          ok = 0
        %finish
      %finish
      pos = (pos+sizeof(object)-255+length(object_name)+1)&\1
    %repeat
  %finish
!putlong(addr(header));putstring(" loaded ");putlong(ok);putsym(nl)
  %result = ok
%end

%systemintegerfn load file -
  (%string(255)file,%record(par fm)%name program,%integer gla)
%integer start,size,answer
  connectfile(file,0,start,size)
  answer = load module(record(start),program,gla)
{}connectfile(file,-1,start,size)
  %if answer=0 %start
    event_message = "File ".file
    event_message = event_message." not loaded"
{  putstring(event_message); putsym(nl)
   currentprocess_poa_curout == currentprocess_poa_out(0)
   printstring(event_message); newline
   selectoutput(outstream)
  %finish
  %result = answer
%end

%systemroutine install(%record(fe02 header fm)%name header,%string(255)file)
%integer tv,start,size,pos,mtag,otag
%record(fe02 object fm)%name object
%record(dictfm)%name md,ed
%string(255)s
  md == poa_moddict
! md == md_alt %while md_alt##nil
  ed == poa_extdict
! ed == ed_alt %while ed_alt##nil
  s = file; toupper(s)
  file = file.".MOB" %if-
    length(s)<4 %or substring(s,length(s)-3,length(s))#".MOB"
  %if header==nil %start
    connectfile(file,0,start,size)
    header == record(start)
  %finishelse start=0
  tv = header_tyver
  %if tv=16_fe02 %start
    mtag = makeentry(file,md)
    pos = addr(header)+sizeof(header)
    %unless header_export=0 %start
      %cycle
        object == record(pos); %exitif object_flags&extbit=0
        otag = findentry(object_name,ed)
        %if otag>0 %start
          %unless integer(otag)=mtag %start
            printstring(translateentry(mtag);" supersedes ")
            printstring(translateentry(integer(otag));" for external entry ")
            printstring(translateentry(otag))
            newline
          %finish
        %finishelse otag = makeentry(object_name,ed)
        integer(otag) = mtag
        pos = (pos+sizeof(object)-255+length(object_name)+1)&\1
      %repeat
    %finish
  %finish
  connectfile(file,-1,start,size) %unless start=0
  %signal 3,3,,"Corrupt FE02 file" %unless tv=16_fe02
%end

%systemroutine Preload (%String(255) file)
%integer start,size
%record(fe02headerfm)%name header
   connect file (file,0,start,size)
   header == record(start)
   install(header,file)
%End

!   Diagnostics

%integerfn hex(%integer n)
  n = n&15; n = n+7 %if n>9
  %result = n+'0'
%end

%string(31)%fn nameof(%record(fe02 header fm)%name h)
%integer start
%record(dictfm)%name d
%record(fcrfm)%name fcr
%string(31)s
%integer k=0
  %predicate found(%record(dictcellfm)%name c)
    %falseif c==nil %or k>100; k = k+1
    fcr == record(c_token)
    %unless fcr==nil %start
      %if fcr_start=start %start
        %if length(c_s)>31 %then s = substring(c_s,1,31) %else s = c_s
        %true
      %finish
    %finish
    %trueif found(c_left)
    %trueif found(c_right)
    k = k-1; %false
  %end
  start = addr(h)
  d == poa_fildict
  %while d##nil %cycle
    %if found(d_tree) %start
      tolower(s); k = length(s)
      %if k>4 %start
        length(s) = k-4 %if substring(s,k-3,k)=".mob"
      %finish
      %result = s
    %finish
    d == d_alt
  %repeat
  s = " at "
  s = s.tostring(hex(start>>k)) %for k = 28,-4,0
  %result = s
%end

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

%record(mar fm)%map mainmodule
%record(mar fm)%name m
  m == poa_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

%routine spaces(%integer n)
  %cycle
    n = n-1; %returnif n<0
    printsymbol(' ')
  %repeat
%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

{%systemroutine print(%real x, %integer n,m)
!%constreal pmax = 2147483647.0
!%real y,z
!%integer i=0,l,count=0,sign
!  sign = ' '
!  sign = '-' %if x < 0
!  y = |x|+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
!  spaces(n-i)
!  printsymbol(sign) %unless sign = ' ' %and n <= 0
!  %cycle
!    z = z/10.0
!    l = int pt(y/z)
!    y = y-l*z
!    printsymbol(l+'0')
!    i = i-1
!    %exit %if i+m <= 0
!    print symbol('.') %if i = 0
!  %repeat
!  printsymbol('@') %and write(count,0) %if count # 0
{   printstring("****.****")
{%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 phex1(%integer n)
  printsymbol(hex(n))
%end

%routine phex2(%integer n)
  phex1(n>>4); phex1(n)
%end

%routine phex4(%integer n)
  phex2(n>>8); phex2(n)
%end

%routine phex(%integer n)
  phex4(n>>16); phex4(n)
%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(poa_eventpc)
    %if event_sub <= 3 %start             {Address/Bus error}
!     printstring("  Code="); phex4(event_spare>>16)
!     printstring(" IR="); phex4(event_spare)
      %for i = 0,1,15 %cycle
        newline %if i&7 = 0
        space;  phex(poa_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(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
    m == poa_topprog_modules
    %cycle
      %return %if m == nil   {not found}
      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 = m_header_dlim
    e_charbase = e_modlim+e_dlim*sizeof(di)
    e_name = nameof(m_header)
  %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 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 membot <= ad < memtop
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):
  !print(real(ad),0,3)
  printstring("****.****(RWT bug)")
  %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 membot < p < memtop %and p&1 = 0
  %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 poa_eventdisplay(i) < frame %start
        frame = poa_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
    poa_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);  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
  poa_eventdisplay(level) = integer(frame)         {unlink}
  sp = frame+4
%repeat
!set terminal mode(mode)
%end;  !diagnose

%system%routine MONITOR
{*no vars to perturb SP*}
  *movem.l d0-d7/a0-a7,poa_eventr; !Save registers (rather late)
  poa_eventdisplay(1) = a6
  poa_eventdisplay(2) = poa_display(2)
  poa_eventdisplay(3) = poa_display(3)
  poa_eventdisplay(4) = poa_display(4)
  poa_eventdisplay(5) = poa_display(5)
  poa_eventdisplay(6) = poa_display(6)
  poa_eventdisplay(7) = poa_display(7)
  poa_eventpc = integer(poa_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 module(%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 = loadmodule(header,par,gla)
    %signal 0,1,,"Program not runnable" %if pc=0
    *move.l sp,a4
    *move.l pc,a0
    *jsr (a0)
    %stop
  %end

  poa_display(1) = a6
  %for level = 1,1,7 %cycle
    poa_display(level) = 16_7fffffff %if poa_display(level)=0
  %repeat
  a6 = poa_display(1)
  level = poa_heap_level; mark
  par == new(par); par = 0
  par_next == poa_topprog; poa_topprog == par
  event = 0
  run
  result = poa_event<<8!poa_eventsub
  %if 1#result#0 %start
    selectoutput(0)
    event_line = 0; interpret event
    diagnose(poa_eventpc,poa_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 dropoutput
  %repeat
  selectinput(0)
  selectoutput(0)
  poa_topprog == par_next
  release %while poa_heap_level>level
%end

%systemroutine run file(%string(255)file)
%integer start,size,i
  %on 3 %start
    printstring("Runfile: ");printstring(event_message); newline
    %return
  %finish
  connectfile(file,0,start,size)
  run module(record(start))
  connectfile(file,-1,start,size)
%end

%recordformat runup message fm(%record(message fm)message,-
  %record(fe02 header fm)%name header)
%ownrecord(mailboxfm) mail=0
%ownrecord(semaphorefm) msem=0

%Routine Runup Process
   %Record(runup message fm)%name info
   %Record(fe02 header fm)%name header
   %record(semaphore fm)forever
   %on 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 %start
      putstring("Delete process failed");putsym(10)
      putlong(event_event);putsym(32)
      putlong(event_sub);putsym(32)
      putlong(event_extra);putsym(32)
      putstring(event_message);putsym(10);
      setup semaphore(forever)
      semaphore wait (forever)
      *stop #3
   %finish
   info == receive message (mail)
   header == info_header
   send message (info, info_message_reply, nil)
   run module (header)
   putstring("End Run Module");putsym(10)
   delete process (current process)
%End

%Externalroutine  Run Process (%String(255) file,
                               %integer space,priority)

   %Integer start, size
   %Record(processfm)%Name p
   %Record(runup message fm) m = 0
   %Record(messagefm)%Name reply
   %Record(mailboxfm) confirm=0
   %Record(semaphorefm) csem=0
   %label x
   %on 3 %start
      currentprocess_poa_curout == currentprocess_poa_out(0)
      Printstring("Failed to load ".file.". Reason = ".event_message)
      newline; select output (outstream)
      %Return
   %Finish
{putstring("Run process ";file;" module=")
   mark     ;! tidy up heap first
   release
   setup semaphore(csem)
   setup semaphore(msem)
   setup mailbox(confirm,csem)
   setup mailbox(mail,msem)
   connect file (file, 0, start, size)
{putlong(start); putstring(" process=")
   p == Create Process (space, addr(x), priority, nil)
{putlong(addr(p)); putsym(nl)
   setup message(m,sizeof(m))
   m_header == record(start)
   send message (m,mail,confirm)
   reply == receive message (confirm)
   %Return
x:
   runup process
%End

%routine suck in(%string(255)file,%integername start,size)
@16_408 %integerfn suck(%string(255)file,%integer where)
  start = allocate(0)
  putlong(start)
  putsym(' '); putstring(file)
  size = suck(file,start)
  start = allocate(size)
  putsym(nl)
%end

%string(255)%fn custom name
@16_3fa8 %byte ldte
  %integerfn h(%integer x)
    x = x&15; x = x+7 %if x>9; %result = x+'0'
  %end
  %result = "moose:".tostring(h(ldte>>4)).tostring(h(ldte))."boot"
%end

%routine get next custom file entry(%integername pos,%integer lim,
   %string(*)%name s,%integername stack,prio)
! Read the next valid line from the file described by POS and LIM.
! Comments apart, the line contains a filename, optionally
! followed by up to two decimal non-negative numbers.
! Return in S the name, and in STACK and PRIO the numbers.
! Return the null string in S at the end of the file, and return
! -1 for any numbers not present.
! Lines containing no file name are skipped over.
%integer k

  %integerfn next
  %integer k
  ! Return (and skip) next character in the custom file.
  ! Ignore comments (which start with '!' and end with end-of-line).
  ! Return -1 at end of file.
    %result = -1 %if pos>=lim
    k = byteinteger(pos); pos = pos+1
    %result = k %unless k='!'
    %cycle
      %result = -1 %if pos>=lim
      k = byteinteger(pos); pos = pos+1
    %repeatuntil k<' '
    %result = k
  %end

  %integerfn getnum
  ! Return -1 if no number is present, otherwise return the (non-neg) number.
  %integer n=0
    k = next %while k=' '    {skip spaces}
    %result = -1 %if k<'0' %or k>'9'
    %cycle
      n = n*10-'0'+k
      k = next
    %repeatuntil k<'0' %or k>'9'
    %result = n
  %end

  s = ""; stack = -1; prio = -1
  %cycle
    k = next %until k#' '      {prime, and skip initial spaces}
    %while k>' ' %cycle
      s = s.tostring(k)
      k = next
    %repeat
    %exitunless s=""           {non-empty name}
    %returnif k<0              {end of file}
    k = next %while k>=' '     {skip rest of line}
  %repeat
  stack = getnum
  prio = getnum
  k = next %while k>=' '
%end

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

!***   Main  Program   ***

%record(fe02 header fm)%name header
%integer start,size,pos,lim,ffstart,ffsize
%integer stack,prio
%string(255)f

  *move.l a0,header
  putstring("Base module version 24/09/86"); putsym(nl)

! Initialise extracodes

  *lea signal,a0;       xcode(-6)
  *lea heapget,a0;      xcode(-120)
  *lea dispose,a0;      xcode(-126)
  *lea nextsymbol,a0;   xcode(-132)
  *lea readsymbol,a0;   xcode(-138)
  *lea printsymbol,a0;  xcode(-144)
  *lea printstring,a0;  xcode(-150)
  *lea openinput,a0;    xcode(-156)
  *lea openoutput,a0;   xcode(-162)
  *lea selectinput,a0;  xcode(-168)
  *lea selectoutput,a0; xcode(-174)
  *lea setinput,a0;     xcode(-180)
  *lea setoutput,a0;    xcode(-186)
  *lea closeinput,a0;   xcode(-192)
  *lea closeoutput,a0;  xcode(-198)
  *lea connectfile,a0;  xcode(-210)
!!*lea preconnect,a0;   xcode(-204)

! Initialise various things

  poa_membot = membot; poa_memtop = memtop
  poa_heap == record(membot)
  poa_stacklim = poa_heap_front+256
  poa_masterdict == record(membot+sizeof(poa_heap)+4)

! Create and reference most common dictionaries

  poa_extdict == create dict("ext")
{}make global(poa_extdict)
  poa_moddict == create dict("mod")
{}make global(poa_moddict)
  poa_logdict == create dict("log")
{}make global(poa_logdict)
  poa_fildict == create dict("fil")
{}make global(poa_fildict)
  poa_comdict == create dict("com")
{}make global(poa_comdict)

! Pre-load this file

  size = sizeof(header)+header_export+header_import+header_codesize
  f = "moose:base.mob"
  preconnect(f,addr(header),size); install(header,f)

! Read the custom file-file and preload all files specified in it

  suck in(custom name,ffstart,ffsize)
  pos = ffstart; lim = ffstart+ffsize
  %cycle
    get next custom file entry(pos,lim,f,stack,prio)
    %exitif f=""
    suck in(f,start,size)
    preconnect(f,start,size)
    header == record(start)
    install(header,f)
  %repeat
  putlong(allocate(0)); putsym(nl)
  pos = ffstart
  %cycle
    get next custom file entry(pos,lim,f,stack,prio)
    %exitif f=""
    %if stack>0 %start
!     putstring("Process "); putlong(stack); putsym(' ';prio&7+'0';' ')
!     putstring(f); putsym(nl)
      runprocess(f,stack,prio)
    %finish
  %repeat

! Run the last file specified in the filefile

  mark
  poa_topprog == new(poa_topprog)
  poa_topprog = 0
  run module(header) %unless stack>0

! Should not normally get here

! putstring("*Stopped*")
  %cycle
!    *stop #0
  %repeat
%endofprogram