! Executable file header:-
record format MOB HEADER F(short version,flags,export,import,
integer code,short reset,main,
integer own,stack,
short dlim,charlim,spare1,spare2)
! List of loaded modules:-
record format MODLIST F(record (modlistf)name pre,
record (objf)name file,
record (mobheaderf)name header,
integer gla)
@736(a5){#MODLISTSLOT} record (modlistf)name MODLIST
!!!!!!!!!!!!!!!!!!!!!! Diagnostics !!!!!!!!!!!!!!!!!!!!!!!!!!!!
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 == modlist
cycle
return if m == nil {not found}
h == m_header; i = codestart(h)
exit if i <= pc <= i+h_code
m == m_pre
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_file); truncate(e_name,".MOB")
!%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 storemin <= ad < storelim
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 < storelim 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 disp(i) < frame start
frame = disp(i); level = i
finish
repeat
exit if frame >= sp {sound FRAME value}
return if level = 0 {SP >= LIMIT}
{DISP(LEVEL) < SP}
printstring("*Stack corrupt 1: ")
write(level,1); space; phex(frame)
newline
disp(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
printstring(" Module "); 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
disp(level) = integer(frame) {unlink}
sp = frame+4
repeat
set terminal mode(mode)
end ; !diagnose
system routine MONITOR
{*no vars to perturb SP*}
disp(1) = a6
disp(2) = display(2)
disp(3) = display(3)
disp(4) = display(4)
disp(5) = display(5)
disp(6) = display(6)
disp(7) = display(7)
diagnose(integer(a7),a7,maingla)
end
.........................
.........................
! ****************************** NB ******************************
! Open new block so that the variables of RUN PROGRAM are not accessed
! via SP since the stack is extended by OWN storage for main program
! *** NB all returns must be via Signal to ensure stack restored ***
! ********************************************************************
routine RUN
on event 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15 start
return
finish
stack = prog_header_own
! ******************
A7 = A7-stack-1024 {1024 extra for DIAG}
! ******************
gla = A7
prog_gla = gla!1
initialise(prog_file,gla)
! Enter program
prompt(":")
cliparam = param
stage = 1
option "-noass"
D4 = 0; D7 = 16_80808080
A4 = gla
A0 = addr(cliparam) {in case procedure with %string parm}
A1 = code
maingla = a4; mainentry = a1
*jsr (a1) {enter program/procedure}
stop {if procedure, to restore stack}
end ; !run
run
-> notstarted if stage <= 0
set terminal mode(mode)
terminalmask = 0
close all(event_eventsub)
return if event_eventsub = 0 {normal %stop}
selectinput(0); select output(0)
in(0) == defaultin(0); out(0) == defaultout(0)
closeinput; closeoutput
while testsymbol >= 0 cycle ; repeat
return if event_eventsub = 1 {Event 0,1: ^Y}
newline
vreset
event_line = 0; interpret event
diagnose(event_pc,event_r(15),gla)
interpret event if event_line # 0 {repeat after diag}
end ; !run program