begin
! MEXRUN: Run FE02 program under old system
! (called by CLI)
! incorporates V3 diagnostic rountines
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
@380(a5) integer stacklim
@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 preliminaryexcepth,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)
d6 = x; stacklim = 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
length(fscomm) = len
i = charno(fscomm,2)-'0'
fscomm = substring(fscomm,3,len-1)
signal 3,3,i,fscomm
! %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
on 9 start {happens when reading the terminating entry
->end {if the code area is shorter than 11 bytes or
finish {the 11th byte look slike a huge string...
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
end:
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
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-d7/a0-a6,-(sp)
*move.l 64(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-d7/a0-a6
*move.l (sp)+,(sp)
*sub.l #12,(sp)
*rts
fail: *movem.l (sp)+,d0-d7/a0-a6
*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
printstring("Load ".module." fails: ")
write(event_event,0); write(event_sub,1); space; phex(event_extra); space
printstring(event_message); newline
topprog == topprog_next; curprog == topprog
lhb == record(localheap)
release while topprog_heaplevel < lhb_level
finish
if ok>=0 start
*lea event_message,a0
*move.l event_extra,d2
*move.b event_sub,d1
*moveq #16_70,d0
*or.b event_event,d0
signalevent
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+3)&(¬3)
*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
@16_1000 short obsolete
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 # ""
if event_line # 0 start
space; space; print lineno(event_line)
elseif event_r(5) # 0
space; space; print lineno(event_r(5))
elseif obsolete # 0
space; space; print lineno(obsolete)
finish
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 unless membot <= ad < memtop
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) {!}
{}trueif 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)
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*}
*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))
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
externalroutine runprogram(string (255)module)
record (basef)name lhb
integer i,j
event = 0
scratch1 = 0; scratch2 = 0 {for Pascal}
!; ctrlin == nil; ctrlout == nil
returnunless loadmodule(module,1)
j = event_event<<8+event_sub
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 j=1; !^Y
if j#0 and j#1 start
event_line = 0; interpret event
diagnose(event_pc,event_r(15),maingla)
interpret event if event_line#0
finish
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(25000){15000{9900
moddict == credict(2000){1000{880}
finish
fildict == record(16_3fc0)
installmodule("fmac: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
*lea excepth,a0; *move.l a0,preliminary excepth
runprogram("")
preliminary excepth = 0
endofprogram