%begin; ! MEXRUN: Run FE02 program under old system

%option "-low-nodiag-noline-nocheck-nostack"

%recordformat oeventf(%integer event,sub,extra,pc,%string(255)message,
    %integerarray r(0:15))
%recordformat neventf(%byte event,sub,%short line,%integer extra,
                      %string(255-32)message,
                      %integer pc,%integerarray display(1:7),
                      %integerarray r(0:15))
%recordformat mob header f(%short version,flags,export,import,
   %integer code,%short reset,main,%integer own,stack,
   %short dlim,charlim,spare1,spare2)
%recordformat mob entry f(%short flags,ptype,%integer type,
                          disp,%string(255)name)
%recordformat mod list f(%record(modlistf)%name next,
                         %record(mobheaderf)%name header,
                         %integer gla,token)
%recordformat mob list f(%record(moblistf)%name next,
                         %record(mobentryf)%name entry,
                         %record(modlistf)%name module,%integer address)
%recordformat prog list f(%record(proglistf)%name next,
                          %record(modlistf)%name modlist,
                          %record(moblistf)%name extlist,
                          %integer heaplevel)
%recordformat dyn link f (%record(proglistf)%name prog,
                          %record(mobentryf)%name entry)
%recordformat dictf(%integer beg,pos,lim,alt)
%recordformat ehcf(%integer pc,a4,a5,a6,sp)

@16_117c %integerfn defname(%string(255)s,%record(dictf)%name d,%integer size)
@16_1180 %integerfn findentry(%string(255)s,%record(dictf)%name d)
@16_1184 %routine transname(%integer ref,%string(255)%name s)
@16_1190 %routine phex2(%integer x)
@16_1194 %routine phex4(%integer x)
@16_1198 %routine phex(%integer x)

@16_3400 %record(oeventf)oevent
@16_3550 %record(ehcf)ehc
@16_3f80 %record(ehcf)oehc
@16_3f98 %integer mainprogram,gb
@16_3fac %integer cliparamad
@16_3ff0 %integer freebot,freetop,membot,memtop

  @0(a5) %integer evlink
  @4(a5) %integerarray display(1:7)
 @32(a5) %record(neventf)event
@360(a5) %integer scratch1,scratch2
@368(a5) %record(*)%name ctrlin,ctrlout,stdin,stdout,curin,curout
@392(a5) %integer instream,outstream
@400(a5) %record(*)%namearray in(0:7)
@432(a5) %record(*)%namearray out(0:7)
@464(a5) %string(255)cliparam
@720(a5) %integer globalheap,localheap
@728(a5) %record(proglistf)%name topprog,curprog
@736(a5) %record(dictf)%name extdict,moddict,fildict
@748(a5) %record(dictf)%name sysdict,logdict,comdict

@16_10cc %integerfn nextsymbol
@16_10c8 %integerfn readsymbol
@16_10c8 %routine skipsymbol
@16_10c0 %routine printsymbol(%integer a)
@16_10c4 %routine printstring(%string(255)s)
@16_10f0 %routine openinput(%integer stream,%string(255)name)
@16_10f4 %routine openoutput(%integer stream,%string(255)name)
@16_10d8 %routine selin(%integer stream)
@16_10dc %routine selout(%integer stream)
@16_10e0 %routine resetinput
@16_10e4 %routine resetoutput
@16_10e8 %routine closeinput
@16_10ec %routine closeoutput
@16_111c %routine write(%integer i,j)
@16_1188 %routine define event handler

%integer i,ga
%constinteger fb=16_3f00,globsize=2048,globprocs=64

%routine newline
  printsymbol(nl)
%end

%routine space
  printsymbol(' ')
%end

%externalroutine prompt(%string(255)s)
  *jsr 16_10d0
%end

%routine setinput(%integer position)
  %signal 3,4,position,"Set input fails" %unless position=0
  resetinput
%end

%routine setoutput(%integer position)
  %signal 3,4,position,"Set output fails" %unless position=0
  resetoutput
%end

%externalintegerfn makeentry(%string(255)s,%record(dictf)%name d)
  %result = defname(s,d,4)
%end

%externalroutine selectinput(%integer stream)
  instream = stream
  selin(stream)
%end

%externalroutine selectoutput(%integer stream)
  outstream = stream
  selout(stream)
%end

%externalstring(255)%fn translateentry(%integer e)
%string(255)s
  transname(e,s)
  %result = s
%end

%constinteger overhead=4,minsize=8+overhead
%recordformat holef(%byte level %or %integer size,
                    %record(holef)%name next,prev)
%recordformat basef(%integer limit,
                    (%byte level %or %integer rootsize),
                    %record(*)%name link,holes)

%routine sd6(%integer x)
  *move.l d0,d6
%end

%externalintegerfn heapget(%integer request)
%record(basef)%name lhb
%integer need,pos
%record(holef)%name hole
  need = (request+(overhead+3))&\3
  need = minsize %if need<minsize
  %if localheap=0 %start
    localheap = (d6+(3-256))&\3
    lhb == record(localheap)
    lhb = 0; lhb_limit = localheap+sizeof(lhb)
    sd6(lhb_limit+256)
    lhb_rootsize = sizeof(lhb)-4; lhb_level = 1
  %finishelse lhb==record(localheap)
  pos = lhb_limit
  hole == lhb_holes
  %if hole##nil %start
    %cycle
      %if hole_size-need>=0 %start
        pos = addr(hole)
        %if hole_size-need>=minsize %start
          hole_size = hole_size-need
          pos = pos+hole_size
        %else
          %if hole_prev==nil %then lhb_holes == hole_next %c
                             %else hole_prev_next == hole_next
          hole_next_prev == hole_prev %unless hole_next==nil
          need = hole_size
        %finish
result: hole == record(pos); pos = pos+4
        hole_size = need; hole_level = lhb_level
{}      need = pos+need-4
{}      %cycle
{}        need = need-4
{}        integer(need) = d7
{}      %repeatuntil need=pos
        a0 = pos; %result = pos
      %finish
      hole == hole_next
    %repeatuntil hole==nil
  %finish
  %signal 2,1,request,"HEAPGET: Not enough store" %if d6-a7+256+need>=0
  pos = lhb_limit
  lhb_limit = lhb_limit+need
  sd6(lhb_limit+256)
  ->result
%end

%externalroutine heapput(%integer pos)
%record(basef)%name lhb
%integer holeend
%record(holef)%name hole,neighbour
  ->invalid %if pos<=0 %or pos&3#0 %or localheap=0
  lhb == record(localheap)
  hole == record(pos-4)
  ->invalid %if hole_level=0 %or hole_level>lhb_level
  hole_level = 0
  holeend = pos-4+hole_size
  %if holeend=lhb_limit %start
done:
    lhb_limit = lhb_limit-hole_size
    sd6(lhb_limit+256)
    %return
  %finish
  hole_next == lhb_holes; lhb_holes == hole; hole_prev == nil
  hole_next_prev == hole %unless hole_next==nil
  %cycle
    %signal 5,,holeend,"HEAPPUT: heap corrupt" %if holeend>lhb_limit
    neighbour == record(holeend)
    %returnunless neighbour_level=0
    hole_size = hole_size+neighbour_size
    holeend = holeend+neighbour_size
    neighbour_prev_next == neighbour_next
    neighbour_next_prev == neighbour_prev %unless neighbour_next==nil
    %if holeend=lhb_limit %start
      lhb_holes == hole_next
      hole_next_prev == nil %unless hole_next==nil
      ->done
    %finish
  %repeat
invalid: %signal 5,,,"HEAPPUT: Invalid address"
%end

%externalroutine mark
%record(basef)%name lhb
  %returnif localheap=0
  lhb == record(localheap)
  %signal 5,,,"MARK: too many levels" %if lhb_level=255
  lhb_level = lhb_level+1
%end

%externalroutine release
%record(basef)%name lhb
%record(holef)%name hole,neighbour
%integer p1,p2
  %returnif localheap=0
  lhb == record(localheap)
  lhb_holes == nil
  p1 = localheap+sizeof(lhb)
  %cycle
    %exitif p1=lhb_limit
    %if p1>lhb_limit %start
fail: %signal 5,,p1,"RELEASE: Heap corrupt"
    %finish
    hole == record(p1)
    ->fail %if hole_level>lhb_level
    hole_level = 0 %if hole_level=lhb_level
    %if hole_level=0 %start
      %cycle
        p2 = p1+hole_size
        %if p2=lhb_limit %start
          lhb_limit = p1; sd6(p1+256); %exit
        %finish
        ->fail %if p2>lhb_limit
        neighbour == record(p2)
        ->fail %if neighbour_level>lhb_level
        neighbour_level = 0 %if neighbour_level=lhb_level
        %if neighbour_level=0 %start
          hole_size = hole_size+neighbour_size
        %else
          hole_next == lhb_holes
          hole_next_prev == hole %unless hole_next==nil
          hole_prev == nil
          lhb_holes == hole
          p1 = p2+neighbour_size&16_ffffff
          %exit
        %finish
      %repeat
    %else
      p1 = p1+hole_size&16_ffffff
    %finish
  %repeat
  lhb_level = lhb_level-1
  lhb_level = 1 %if lhb_level=0
%end

%externalrecord(*)%map xnew %alias "new" (%integer size){(%name x)}
  *bsr heapget
%end

%externalroutine dispose(%record(*)%name pos)
  *move.l a0,d0
  *bsr heapput
%end

%externalroutine pushheap
%record(basef)%name lhb,olhb
  %returnif localheap=0
  olhb == record(localheap)
  sd6(olhb_limit+256)
  localheap = 0
  heapput(heapget(1))
  lhb == record(localheap)
  lhb_link == olhb
%end

%externalroutine popheap
%record(basef)%name lhb
  %returnif localheap=0
  lhb == record(localheap)
  %if lhb_link==nil %start
    sd6(localheap+256)
    localheap = 0
  %else
    lhb == lhb_link
    localheap = addr(lhb)
    sd6(lhb_limit+256)
  %finish
%end

%routine oldstop
  *movem.l ehc,a3-a7
  ehc = oehc
  *move.l #255,d5
  *clr.l d0
  *jmp 16_1114
%end

%routine signal event;!(%integer eve,sub,ext,%string(255)mes)

%routine unwind(%integername framebase)
%integer min,max
  min = membot; max = memtop-4
  %cycle
    %if framebase=0 %or framebase<min %or framebase>max %start
      framebase = 16_7fffffff
      %return
    %finish
    %returnif framebase>=evlink
    framebase = integer(framebase)
  %repeat
%end

%routine sig
%integer bit,sigpc,i,eventpc,high
  i = event_r(0)
  event_event = i&15
  %if i&16#0 %then event_sub = event_r(1) %else event_sub = 0
  %if i&32#0 %then event_extra = event_r(2) %else event_extra = 0
  %if i&64#0 %then event_message = string(event_r(8)) %else event_message = ""
  event_line = event_r(5)&65535
  length(event_message) = length(event_message)-1 %ifc
    charno(event_message,length(event_message))=nl
!Explore event blocks
!Format on stack is:  | LINK | EVENTPC | OLDMB | OLDAUX |
!                        32      32        32      32
! of code:   | BRA ... | MASK | start of code  (EVENTPC points to MASK)
!               16  16    16
  bit = 1<<event_event;  sigpc = integer(event_r(15))
  %while evlink#0 %and evlink&1=0 %cycle
    eventpc = integer(evlink+4)
    %if shortinteger(eventpc)&bit#0 %start;   !trapped
      high = shortinteger(eventpc-2)+eventpc-2
      %unless eventpc<sigpc<=high %start;     !not within trap code
        unwind(display(i)) %for i = 1,1,7
        bit = event_r(14); unwind(bit)
        *move.l bit,a6
        *move.l evlink,a7
        *move.l  8(a7),a4
        *move.l  4(a7),a0
        *jmp 2(a0)
      %finish
    %finish
    evlink = integer(evlink)
    sigpc = 0
  %repeat
  oevent_event = event_event
  oevent_sub = event_sub
  oevent_extra = event_extra
  oevent_message = event_message
  shortinteger(16_1000) = event_line
  oldstop
%end{sig}

  *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_pc = integer(event_r(15))
  sig
%end{signal}

%constinteger {MODE values for CONNECTFILE} %c
  bizarre=128,
  writemask=8_30,
  nowrite=0,
  writetemp=8_10,
  updatenew=8_20,
  updateoriginal=8_30,
  readmask=6,
  noread=0,
  execonly=2,
  readonly=4,
  readexec=6,
  lockinstore=1

%externalroutine connectfile(%string(255)f,%integer m,%integername s,l)
! F=FILE  M=MODE  S=START  L=LENGTH
! Read in the file FILE to space allocated on the heap.
! MODE is normally 0, but if MODE&bizarre#0, then S+L bytes of extra
! space are allocated to allow for file expansion, and the file is read
! into the allocated area offset S bytes from the beginning.
! In any case the start and length of the file, not the area, are returned
! in START and LENGTH.  To dispose (using HEAPPUT) the space occupied by
! a file connected in bizarre mode, it is necessary for the calling code
! to remember the offset requested, and HEAPPUT(START-OFFSET).
@16_35C4 %short  uno
@16_372C %byte   cylock,fsport
@16_1100 %routine etherwrite(%integer port,%bytename mem,%integer length)
@16_1104 %integerfn etherread(%integer port,%bytename mem,%integer maxlength)
%integer xno=0,fsize=0,fpos=0
%integer i,j,len,blocks,pos,original,limit
%string(255)fscomm
  
  %routine closefile
    %returnif xno=0
    fscomm = "K".tostring(xno+'0').tostring(nl); xno = 0
    etherwrite(fsport,charno(fscomm,1),length(fscomm))
    len = etherread(fsport,charno(fscomm,1),255)
  %end

  %routine lock
    cylock = cylock+1
  %end

  %routine unlock
    %returnif cylock=0
    cylock = cylock-1
    %returnunless cylock=128
    cylock = 1
    closefile
    cylock = 0
    %signal 0,1
  %end

  %routine move(%integer bytes,from,to)
  %label quit
    *move.l d1,a0
    *move.l d2,a1
    *subq.l #1,d0
    *bmi quit
    *swap d0
  looop: *swap d0
  loop: *move.b (a0)+,(a1)+
    *dbra d0,loop
    *swap d0
    *dbra d0,looop
  quit:
  %end

  %predicate allocate(%integer bytes)
    %onevent 2 %start
      %false
    %finish
    pos = heapget(bytes)
    %true
  %end

  %integerfn hdhex(%integername p)
  %integer k,v=0
    %cycle
      p = p+1;  k = byteinteger(p-1)-'0'
      %result = v %if k < 0
      v = v<<4+k
    %repeat
  %end

  m = m!(readexec+writetemp) %if m&(readmask+writemask)=noread+nowrite
  %if m&bizarre=0 %start
    s = 0; l = 0
  %finish
  %unless f="" %start
     j = findentry(f,fildict);         !Look up in dictionary
     %if j>0 %and integer(j)>0 %start; !File already in store
       fpos = integer(j); fsize = integer(j+4)-fpos
       fpos = 0 %if fsize<=0
       %if fpos#0 %and m&(bizarre+writemask)=nowrite %start
         s = fpos; l = fsize;          !Use copy we already have
         %return
       %finish
     %finish
     %if fpos=0 %start;                !File to be read from filestore
      lock
      fscomm = "S".tostring(uno+'0').f.tostring(nl)
      etherwrite(fsport,charno(fscomm,1),length(fscomm))
      len = etherread(fsport,charno(fscomm,1),255)
      %if charno(fscomm,1) = '-' %start; !filestore error message
        unlock
        %signal 3,3,charno(fscomm,2)-'0',substring(fscomm,3,len-1)
      %finish
      i = addr(fscomm)+1
      xno = hdhex(i); blocks = hdhex(i); fsize = hdhex(i)
      fsize = blocks<<9-fsize
     %finish
  %finish
  limit = fsize+s+l+3  {3 for "P0<nl>"}
  %unless allocate(limit) %start
    close file %and unlock %unless xno=0
    %signal 2,1,fsize,"No space to connect ".f
  %finish
  unlock
  pos = pos+s
  move(fsize,fpos,pos) %if xno=0
  s = pos; l = fsize
  %returnif xno=0
  fscomm = "X".tostring(xno+'0')."@".tostring(nl); !16 blocks at a time
  %cycle
    lock
    etherwrite(fsport,charno(fscomm,1),length(fscomm))
    %for j = 1,1,16 %cycle
      i = limit; i = 515 %if i>515
      len = etherread(fsport,byteinteger(pos),i)
%if byteinteger(pos)='-' %start
  unlock
  fscomm = ""; i = pos+2
  %while i<pos+len %and byteinteger(i)>=' ' %cycle
    fscomm = fscomm.tostring(byteinteger(i))
    i = i+1
  %repeat
  %signal 3,3,byteinteger(pos+1),fscomm
%finish
      i = pos
      len = hdhex(i)
      move(len,i,pos); pos = pos+len
      limit = limit-512
      blocks = 0 %andexitunless len=512
    %repeat
    unlock
  %repeatuntil blocks=0
  lock; closefile; unlock
%end

%predicatespec loadmodule(%string(255)s,%integer flag)

%record(moblistf)%map findmob(%string(255)%name s)
%string(255)m
%record(moblistf)%name x
%integer pass=0,token
  %cycle
    x == curprog_extlist
    %while x##nil %cycle
      %exitif x_entry_name=s
      x == x_next
    %repeat
    %result == x %unless x==nil
    %unless pass=0 %start
      selectoutput(0)
      printstring("Cannot find "); printstring(s)
      printstring(" in "); printstring(m); newline
      %result == nil
    %finish
    pass = 1
    token = findentry(s,extdict)
    %if token<=0 %start
      selectoutput(0)
      printstring("Cannot find "); printstring(s); newline
      %result == nil
    %finish
    m = translateentry(integer(token))
    %result == nil %unless loadmodule(m,0)
  %repeat
%end
  
%constinteger extbit=16_4000,procmask=16_3000,
              system=16_1000,external=16_2000,dynamic=16_3000

%routine toupper(%string(*)%name s)
%bytename b
%integer i
  %for i = 1,1,length(s) %cycle
    b == charno(s,i)
    b = b&95 %if 'A'<=b&95<='Z'
  %repeat
%end

%string(255)%fn file(%string(255)module)
%integer i,j=0
%bytename b
  %for i = 1,1,length(module) %cycle
    b == charno(module,i)
    b = b&95 %if 'A'<=b&95<='Z'
    j = j<<8+b
  %repeat
  module = module.".MOB" %unless j='.MOB'
  %result = module
%end

%routine checkheader(%shortinteger version,%string(255)%name s)
  %returnif version=16_fe02
  selectoutput(0)
  printstring("Bad header "); phex4(version); printstring(" in module ".s)
  newline; %stop
%end

%externalroutine installmodule(%string(255)module)
%string(255)s
%integer token,q
%record(mobheaderf)header
%record(mobentryf)entry

  %routine readrecord(%record(*)%name r,%integer size,extra)
  %integer p,k
    p = addr(r)
    %cycle
      %while size>0 %cycle
        size =size-1; readsymbol(k)
        byteinteger(p) = k; p = p+1
      %repeat
      %returnif extra=0
      extra = 0
      size = (k+2)&\1-1
    %repeat
  %end

  toupper(module)
  token = makeentry(module,moddict)
  %returnunless token#0{>0}
  openinput(3,file(module)); selectinput(3)
  readrecord(header,32,0)
  checkheader(header_version,module)
  %if header_export#0 %start
    %cycle
      readrecord(entry,13,1)
      %exitunless entry_flags<0
      toupper(entry_name)
      %unless entry_flags&extbit=0 %start
        q = makeentry(entry_name,extdict)
        integer(q) = token
      %finish
    %repeat
  %finish
  closeinput; selectinput(0)
%end

%externalpredicate satisfy reference(%record(mobentryf)%name entry,%integer gla)
%record(moblistf)%name cell
%record(dynlinkf)%name dyn
%integer p,mode,mismatch=0,severe=0
%label lateload,fail

  %routine match(%integer a,b)
    %returnif a=b
    mismatch = 1
    severe = 1 %if a#0 %and b#0
  %end

  %routine plug(%integer what,where)
    integer(where) = what
  %end

  %if gla=1 %start
    selectoutput(0)
    printstring("Impossible reference to ".entry_name)
    newline; %false
  %finish
  gla = gla&\1
  p = gla+entry_disp
  mode = entry_flags&procmask
  %if mode=dynamic %start
!!  entry_flags = entry_flags!!(dynamic!!external)
!!  mode = external
    dyn == new(dyn); dyn_prog == curprog; dyn_entry == entry
    plug(16_48790000,p);   !Pea #?
    plug(addr(dyn),p+2)
    plug(16_4eb90000,p+6); !Jsr.l #?
    plug(addr(lateload),p+8)
    entry_flags = entry_flags-dynamic+external
    %true
  %finish
  cell == findmob(entry_name)
  %falseif cell == nil
  match(entry_flags!procmask,cell_entry_flags!procmask)
!!match(entry_ptype,cell_entry_ptype)
  severe = mismatch
  match(entry_type,cell_entry_type)
!*%unless mismatch=0 %start
  %unless severe=0 %start
    selectoutput(0)
!*  printsymbol('*') %unless severe=0
    printstring("Mismatch for ".entry_name); newline
    %falseunless severe=0
  %finish
  gla = cell_module_gla
  gla = gla&\1 %unless gla=1
  %if mode=external %start
    plug(16_287c0000,p);   !Move.l #?,A4
    plug(gla,p+2)
    plug(16_4ef90000,p+6); !Jmp.l #?
    plug(cell_address,p+8)
  %elseif mode=system
    plug(16_4ef90000,p)
    plug(cell_address,p+2)
    %unless gla=1 %or cell_entry_flags&procmask=system %start
      selectoutput(0)
      printstring("%system reference to ".entry_name); newline
      %false
    %finish
  %else;               !variable
    plug(cell_address,p)
  %finish
  %true
lateload:
  *movem.l d0-d3/a0-a3,-(sp)
  *move.l 36(sp),a0;     !dyn link
  *move.l (a0),732(a5);  !set curprog
  *move.l 4(a0),a0;      !entry
  *move.l a4,d0;         !gla
  *bsr satisfyreference
  *tst.l d0
  *beq fail
  *movem.l (sp)+,d0-d3/a0-a3
  *move.l (sp)+,(sp)
  *sub.l #12,(sp)
  *rts
fail: *movem.l (sp)+,d0-d3/a0-a3
  *addq.l #8,sp
  %stop
%end

%predicate loadmodule(%string(255)module,%integer runflag)
!runflag=0 => allocate GLA on heap
!runflag#0 => allocate GLA on stack, and run the program
%integer ok=1 {=1:loading,=0:failed,=-1:running}

  %routine reset(%integer pc,gla)
    *move.l a6,-(sp)
    *move.l a4,-(sp)
    *move.l d0,a0
    *move.l d1,a4
    *jsr (a0)
    *move.l (sp)+,a4
    *move.l (sp)+,a6
  %end

  %routine run(%integer pc,gla)
    *move.l d0,a0
    *move.l d1,a4
    *clr.l d5
    *jmp (a0)
  %end

%record(mobheaderf)%name header
%record(mobentryf)%name entry
%record(moblistf)%name cell
%record(modlistf)%name m
%record(proglistf)%name pl
%record(basef)%name lhb
%integer p,l,export,import,code,stack

%predicate main; !so variables not accessed via SP

%integer re,rb,ra,r9,r8,r7,r5,r4,r3,r2,r1,r0

  *movem.l d0-d5/d7/a0-a3/a6,r0
  %onevent 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 %start
    *movem.l 16(sp),d0-d5/d7/a0-a3/a6
    %if runflag#0 %start
      %trueif ok<0
      topprog == topprog_next; curprog == topprog
      lhb == record(localheap)
      release %while topprog_heaplevel < lhb_level
    %finish
    %if ok>=0 {%and event_message#""} %start
      printstring("Load ".module." fails: ")
      write(event_event,0); write(event_sub,1); space; phex(event_extra); space
      printstring(event_message); newline
    %finish
    %false
  %finish

  %if runflag#0 %start
    heapput(heapget(4)); mark
    lhb == record(localheap)
    pl == new(pl); pl_heaplevel = lhb_level
    pl_modlist == nil; pl_extlist == nil
    pl_next == topprog; topprog == pl; curprog == pl
  %finish
  pl == curprog
! Get file into store
  %if module="" %start
    module = "Main Program"; p = mainprogram
  %else
    connectfile(file(module),readexec,p,l)
  %finish
  header == record(p)
  checkheader(header_version,module)
  export = p+sizeof(header)
  import = export+header_export
  code = import+header_import
! Record module locally
  m == new(m); m_header == header; m_token = makeentry(module,moddict)
  m_gla = 1
  %if runflag=0 %start
    %if header_own#0 %start
      m_gla = heapget(header_own)
    %finish
  %else
    stack = header_own
    *sub.l #2048,sp   {extra for diags
    *sub.l stack,sp
    *move.l sp,p
    m_gla = p!1
  %finish
  m_next == pl_modlist; pl_modlist == m
! Promulgate exports locally
  %if header_export#0 %start
    %cycle
      entry == record(export); %exitif entry_flags>=0
      toupper(entry_name)
      %unless entry_flags&extbit=0 %start
        cell == new(cell)
        cell_entry == entry; cell_module == m
        %if entry_flags&procmask=0 %start
          cell_address = entry_disp+m_gla&\1
        %else
          cell_address = entry_disp+code
        %finish
        cell_next == pl_extlist; pl_extlist == cell
      %finish
      export = (export+sizeof(entry)-256+2+length(entry_name))>>1<<1
    %repeat
  %finish
! Call the module reset routine (before imports available)
  p = m_gla; p = p&\1 %unless p=1
{printstring("Resetting ");printstring(module);newline
  reset((header_reset&65535)<<1+code,p)
! Satisfy module's import requirements
  %if header_import#0 %start
    %cycle
      entry == record(import); %exitif entry_flags>=0
      toupper(entry_name)
      %unless entry_flags&extbit=0 %start
        ok = 0 %unless satisfy reference(entry,m_gla)
      %finish
      import = (import+sizeof(entry)-256+2+length(entry_name))>>1<<1
    %repeat
  %finish
  %if ok=0 %start
    printstring(module." not loaded"); newline; %stop
  %finish
  %trueif runflag=0
  ok = -1
  p = m_gla; p = p&\1 %unless p=1
  code = (header_main&65535)<<1+code
  run(code,p)
  %stop

%end{main}; %trueif main; %false
%end{loadmodule}

!   Diagnostics

%string(31)%fn nameof(%integer token)
%integer ls
%string(255)s
  transname(token,s)
  ls = length(s)
  %if ls>4 %start
    ls = ls-4 %if substring(s,ls-3,ls)=".MOB"
  %finish
  ls = 31 %if ls>31
  length(s) = ls
  %result = s
%end

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

%record(modlistf)%map mainmodule
%record(modlistf)%name m
  m == topprog_modlist
  m == m_next %while m_next##nil
  %result == m
%end

%integerfn mainentry
%record(mobheaderf)%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 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
%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(event_pc)
    %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(event_r(i))
      %repeat
    %finish
  %finish
  newline
%end

%constinteger JMP=16_4EF9, JSR=16_4EB9,
              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 usermon&redefmon # 0 %start
!!max=127;p=pos
!!write(line,1)
!!%cycle
!!write(byteinteger(p),1)
!!%exit %if byteinteger(p) # max
!!p = p+1;  max = 255
!!%repeat
!!newline
!!%finish
    %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(modlistf)%name M
%record(mobheaderf)%name H
%record(diaginfo)%name DI
%integer I,J
  e_id = -1;  e_line = 0
  %unless e_modlim >= pc >= e_modstart %start
    m == topprog_modlist
    %cycle
      %return %if m == nil   {not found}
      h == m_header;  i = codestart(h)
      %exit %if i <= pc <= i+h_code
      m == m_next
    %repeat
    e_modstart = i;  e_modlim = e_modstart+h_code
    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_token)
!%if usermon&redefmon # 0 %start
!  i = 0;  di == e_d0[i]
!  %while i < e_dlim %cycle
!    %if di_type!di_link # 0 %start
!      phex4(i)
!      print ident(e_charbase+di_text,20)
!      space;  phex4(di_type)
!      space;  phex4(di_link)
!      space;  phex4(di_val)
!      newline
!    %finish
!    i = i+1;  di == di[1]
!  %repeat
!%finish
  %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
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)           {!}
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)
  %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 0 < 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 event_display(i) < frame %start
        frame = event_display(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
    event_display(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
  event_display(level) = integer(frame)         {unlink}
  sp = frame+4
%repeat
!set terminal mode(mode)
%end;  !diagnose

%system%routine MONITOR
{*no vars to perturb SP*}
  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)
  diagnose(integer(a7),a7,maingla)
%end

%externalroutine runprogram(%string(255)module)
%record(basef)%name lhb
%integer i,j
  event = 0; scratch1 = 0; scratch2 = 0
  %returnunless loadmodule(module,1)
  j = event_event!event_sub!event_extra
  %for i = 1,1,3 %cycle
    selectinput(i); closeinput
    openoutput(i,"") %if j#0
    selectoutput(i); closeoutput
  %repeat
  selectinput(0); selectoutput(0)
  %returnif j=0
  %returnif event_event=0 %and event_sub=1; !^Y
  newline
  event_line = 0; interpret event
  diagnose(event_pc,event_r(15),maingla)
  interpret event %if event_line#0
  topprog == topprog_next; curprog == topprog
  lhb == record(localheap)
  release %while topprog_heaplevel<lhb_level
  %if j#0 %start
    closeoutput; openoutput(0,":"); selectoutput(0)
    closeinput; openinput(0,":"); selectinput(0)
  %finish
%end

%record(dictf)%map credict(%integer c)
%integer p
%record(dictf)%name d
  p = heapget(c*4+16)
  d == record(p)
  p = p+16
  d_beg = p; d_pos = p+4; d_alt = 0
  integer(p) = 0 %and p = p+4 %and c = c-1 %while c>0
  d_lim = p
  %result == d
%end

! Initial entry is to here

oehc = ehc;             !Preserve old event handler
oevent_event = -1;      !Set up new event handler
define event handler
%unless oevent_event=-1 %start;  !{%on * %start}
  *lea oevent,a0;       !Translate to call on SIGNAL EVENT
  *movem.l (a0),d0-d3;  !_event,sub,extra,pc
  *lea 16(a0),a0;       !_message
  *move.w 16_1000,d5;   !_line
  *and.l #15,d0
  *or.b #16_70,d0;      !mark all 3 (sub,extra,message) present
  *clr.l d4;            !Restore environment
  *lea 1,a4
  *move.l gb,a5
  *move.l 312(a0),a6  {lea 1,a6
  *lea oevent_r,sp
  *move.l 60(sp),sp;    !Restore event sp
  *move.l d3,-(sp);     !Push event pc
  *jmp signalevent
%finish
oevent_event = 0
*clr.l d4;              !Set up register environment
*clr.l d5
*lea 1,a4
*move.l gb,a5
*lea 1,a6

%if gb=0 %start; !Environment not yet initialised
! Create and clear the process global area
  ga = -256; *add.l d6,ga; *add.l #globsize,d6
  integer(i+ga) = 0 %for i = 0,4,globsize-4

! Create dummy entry sequences for the global procedures
! such that those not filled in will result in address error
  i = 6*globprocs; gb = ga+i
  *move.l gb,a5
  %cycle
    shortinteger(fb-i) = 16_4ef9; integer(fb-i+2) = i+1
    shortinteger(gb-i) = 16_4ef9; integer(gb-i+2) = fb-i
    i = i-6
  %repeatuntil i=0

! Fill in global entry points corresponding to procedures in this file
  *move.l #fb,a1
  *lea signalevent,a0;  *move.l a0,-4(a1)
  *lea heapget,a0;      *move.l a0,-118(a1)
  *lea dispose,a0;      *move.l a0,-124(a1)
  *lea nextsymbol,a0;   *move.l a0,-130(a1)
  *lea readsymbol,a0;   *move.l a0,-136(a1)
  *lea printsymbol,a0;  *move.l a0,-142(a1)
  *lea printstring,a0;  *move.l a0,-148(a1)
  *lea openinput,a0;    *move.l a0,-154(a1)
  *lea openoutput,a0;   *move.l a0,-160(a1)
  *lea selectinput,a0;  *move.l a0,-166(a1)
  *lea selectoutput,a0; *move.l a0,-172(a1)
  *lea setinput,a0;     *move.l a0,-178(a1)
  *lea setoutput,a0;    *move.l a0,-184(a1)
  *lea closeinput,a0;   *move.l a0,-190(a1)
  *lea closeoutput,a0;  *move.l a0,-196(a1)
  *lea connectfile,a0;  *move.l a0,-208(a1)

! Create various global dictionaries
  %if memtop-membot<=16_80000 %start
    extdict == credict(5500)
    moddict == credict(600)
  %else
    extdict == credict(7000)
    moddict == credict(800)
  %finish
  fildict == record(16_3fc0)

  installmodule("v3:mexrun")
  installmodule("fmac:arith")
  installmodule("fmac:lib")
  %if loadmodule("fmac:arith",0) %start; %finish
  *move.l 256,freebot; *add.l d6,freebot
%finish
localheap = 0
topprog == nil
curprog == nil
cliparam = string(cliparamad)

event = 0
runprogram("")

%endofprogram
