externalroutinespec dump(integer start, finish, print start)
!*
conststring (1) sp = " "
conststring (1) dot = "."
conststring (1) snl = "
"
externalstringfnspec i to s(integer i)
constinteger amdahl = 369, xa = 371
INCLUDE "TARGET"
if TARGET = 2900 start
systemroutinespec move(integer len, from, to)
finish else start
externalroutinespec move(integer len, from, to)
finish
if TARGET = 2900 start { machine specific constants }
conststringname DATE = X'80C0003F'
conststringname TIME = X'80C0004B'
constinteger SEG SHIFT = 18
finish { 2900 }
!
if TARGET = 370 start
constinteger SEG SHIFT = 16
finish
!
if TARGET = XA or TARGET = AMDAHL start
constinteger SEG SHIFT = 20
finish
!
unless TARGET = 2900 start
constinteger com seg = 31
conststringname DATE = COM SEG << SEG SHIFT + X'3B'
conststringname TIME = COM SEG << SEG SHIFT + X'47'
constinteger uinf seg = 239
finish
!*
!
!<TMODEF
recordformat c
TMODEF(byte FLAG0, FLAG1, FLAG2, FLAG3,
{.04} byteinteger PROMPTCHAR, ENDCHAR,
{.06} bytearray BREAKBIT1(0:3) {%or %halfintegerarray BREAKBIT2(0:1))} ,
{.0A} byteinteger PADS, RPTBUF, LINELIMIT, PAGELENG,
{.0E} byteintegerARRAY TABVEC(0:7),
{.16} byteinteger CR, ESC, DEL, CAN,
{.1A} byteinteger FLAGS, INTERNAL STATE, LEADIN1, LEADIN2, XLO, XHI)
{.20}
!<UINFF
recordformat c
DIRINFF (string (6)USER, string (31)JOBDOCFILE,
{.28} integer MARK, FSYS,
{.30} PROCNO, ISUFF, REASON, BATCHID,
{.40} SESS LIMIT, INT COUNT, I2, STARTCNSL,
{.50} AIOSTAT, SCT DATE, SYNC1 DEST, SYNC2 DEST,
{.60} ASYNC DEST, AACCT REC, I3,
{.6C} string (15)JOBNAME,
{.7C} string (31)BASEFILE,
{.9C} integer I4,
{.A0} ITADDR0, ITADDR1, ITADDR2, ITADDR3,
{.B0} ITADDR4, STREAM ID, DIDENT, SCARCITY,
{.C0} PREEMPTAT, string (11)SPOOLRFILE,
{.D0} integer FUNDS, SESSLEN, PRIORITY, DECKS,
{.E0} DRIVES, PART CLOSE,
{.E8} record (TMODEF)TMODES,
{108} integer PSLOT,
{10C} string (63)ITADDR,
{14C} integerarray FCLOSING(0:3), integer CLO FES,
{160} integer OUTPUT LIMIT, I5, I6, I7,
{170} integer OUT, string (15)OUTNAME,
{184} integer HISEG,
{188} string (31)FORK,
{1A8} integer INSTREAM, OUTSTREAM,
{1B0} integer DIRVSN, I8, SCT BLOCK AD,
integer PROTOCOL,
byteinteger ISEPCHL, ISEPCHR, USEPCH, GSEPCH,
string (1)ISEPL, ISEPR, USEP, GSEP,
{ thus a simple filename has the form: }
{ user USEP file }
{ while a complex one has the form: }
{ user ISEPL index ISEPR USEP group GSEP group GSEP file }
integer CLASS, SUBCLASS,
integer UEND)
if TARGET = 2900 start
EXTERNALINTEGERFNSPEC PRIME CONTINGENCY(ROUTINE ON TRAP)
externalintegerfnspec readid(integer addr)
externalstringfnspec derrs(integer i)
externalroutinespec dresume(integer a, b, c)
externalintegerfnspec dsfi(string (6) user, integer i,j,k,l)
externalintegerfnspec dset ic(integer k ins)
finish else start {NON 2900}
EXTERNALINTEGERFNSPEC DPRIME CONTINGENCY(ROUTINE ON TRAP)
externalintegerfnspec dflag(integername flag, stringname txt)
externalintegerfnspec dresume(integerarrayname regs)
externalintegerfnspec d readid(integerarrayname regs)
externalintegerfnspec dasyncinh(integername act)
externalintegerfnspec dsfi(stringname file index,integername fsys,
type, set, stringname s, integerarrayname i)
!%externalintegerfnspec dset ic(%integername k ins)
finish {NON 2900}
externalstring (8) fnspec h to s(integer value, places)
stringfnspec errs(integer flag)
extrinsicinteger com36; !RESTART AREA
extrinsicinteger bottom of stack; !POINT TO WHICH STACK IS UNWOUND DURING DIAGNOSTICS
EXTRINSICSTRING (6) MY NAME
constinteger max instructions = x'FFFFFFF'
!*
!*
!*
if target=2900 start
!
routinespec ncode(integer s, f, a)
routinespec printmess(integer n)
routinespec indiag(integer oldlnb, lang, pcount, mode, diag, c
asize, integername first, newlnb)
routinespec ermess(integer n, inf)
routine trans(integername fault, event, subevent)
!***********************************************************************
!*_______translate fault to event & vice versa *
!***********************************************************************
constbyteintegerarray etof(0 : 45) = c
0,14,22,24,26,28,35,38,40,42,44,0(4),
3,1,5,63,56,53,19,0,23,0,28,0,26,0,
18,50,51,16,15,20,0,7,6,0,32,0,11,0,
25,0,64
constbyteintegerarray ftoe(1 : 32) = c
X'12',0,x'11',0,x'13',x'62',x'61',0,
0(2),x'81',0(3),x'55',x'54',
0,x'51',x'17',x'56',0(4),
x'91',x'41',0,x'31',0,x'b1',0,x'71'
integer k
if fault = 0 then start ; ! event-subevent given
k = etof(event)
if k # 0 then fault = etof(k+subevent)
finish else start
if 1 <= fault <= 32 start
k = ftoe(fault)
event = k>>4; subevent = k&15
finish
finish
end ; ! trans
!*
!*
routine assdump(integer pcount, oldlnb)
integer i
printstring("
pc =")
printstring(htos(pcount,8))
printstring("
lnb =")
printstring(htos(oldlnb,8))
printstring("
Code
")
ncode(pcount-64,pcount+64,pcount-64)
printstring("
GLA
")
i = integer(oldlnb+16)
dump(i,i+128,i)
printstring("
Stack frame
")
dump(oldlnb,oldlnb+256,oldlnb)
end ; ! assdump
!*
!*
!*
conststring (10) array lt(0 : 7) = c
" !???! "," Imp "," Fortran ",
" Imps "," Asmblr "," Algol(E) ",
" Optcode "," Pascal "
!*
!*
systemroutine ndiag (integer pcount, lnb, fault, inf)
!***********************************************************************
!*_______"MASTER DIAGNOSTIC ROUTINE". discovers the language of the *
!*_______failed routine from word 4 of the gla and calls appropriate *
!*_______diagnostic routine. this is repeated till all diagnostics *
!*_______given. *
!*_______pcount = pcounter at failure *
!*_______lnb = local name base at failure *
!*_______fault = failure (0=%monitor requested) *
!*_______inf =any further information *
!***********************************************************************
owninteger active = 0; ! check for loops
integer langflag, i, gla, oldlnb, newlnb, event, subevent, first
switch language(0 : 7)
select output(0); !diags to main log stream
active = active+1
if active > 1 then -> eout
! check the gla for validity in case of failures during a call sequence
inv gla:
if (integer(lnb+12)>>24)&x'FE' # x'B0' start
lnb = integer(lnb)
-> inv gla
finish
gla = integer(lnb+16)
*ldtb_x'18000020'
*lda_gla
*val_(lnb +1)
*jcc_12,<gla ok>
lnb = integer(lnb)
-> inv gla
gla ok:
langflag = integer(gla+16)>>24
langflag = 0 if langflag > 7
subevent = 0; event = fault>>8
if fault >= 256 then subevent = fault&255 and fault = 0
trans(fault,event,subevent)
first = 1
if fault >= 0 then start
print string("
Monitor entered from".lt(langflag)."
")
if fault = 0 and event # 0 start
printstring("
Monitor entered
")
printstring("Event"); write(event,1)
print string("/"); write(subevent,1)
finish else ermess(fault,inf)
newline
finish else event = 0
oldlnb = lnb
-> language(langflag)
language(0):
language(4): ! unknown & assembler
language(6):
!optcode
assdump(pcount,oldlnb)
-> exit; ! no way of tracing back
language(1):
language(3): ! imp & imps
language(5): ! algol 60
indiag(oldlnb,langflag>>2,pcount,0,2,4,first,newlnb)
! imp diags
if newlnb = 0 then -> exit
nextrt: ! continue to unwind stack
pcount = integer(oldlnb+8)
oldlnb = newlnb
-> exit if oldlnb < com36
! far enough
i = integer(oldlnb+16)
langflag = integer(i+16)>>24
langflag = 0 if langflag > 5
-> language(langflag)
language(2): ! fortran
language(7): !pascal
print string(lt(langflag)." ??
")
if newlnb = 0 then -> exit
-> next rt
eout: ! errror exit
printstring("Diags fail looping".snl)
active=0
stop
exit:
active = 0
return if fault = 0 = event
i = com36
stop if i = 0
*lln_i
*exit_0
end ; ! of ndiag
!*
!*
!*
! layout of diagnosic tables
!****** ** ********* ******
! the bound field of plt descriptor stored at (lnb+3 & lnb+4) if
! used to contain a displacement relative to the start of sst of the
! diagnostic tables for the block or routine being executed.
! a zero bound means no diagnostic requested.(nb this may mean a dummy
! first word in the sst).
! the absolute address of the sst for the current code segment will
! always be found in the standard 10 words of the gla/plt
! form of the tables:-
! word 0 = line of rt in source prog <<16 ! line no posn(from lnb)
! word 1 = (12 lang dependent bits)<<20 ! environment
! word 2 = display posn (from lnb)<<16 ! rt type info
! word 3 = zero for blks or string(<=11bytes) being the
! rt name. this will take words 4 and 5 if needed
! word 6 = language dependent info . imp on conditions etc
! the rest is made up of variable entries and the section is terminated by
! a word of x'FFFFFFFF'
! each variable entry consists of the variable word followed by
! the variable name as a string. the word consists of
! bits 2**31 to 2**20 type information (may be language dependent
! bit 2**19 =0 under lnb =1 in gla
! bits 2**18 to 2**0 displacement from lnb(gla) in bytes
! the environment is a pointer (relative to sst) of the next outermost
! block or a pointer to global owns, external or common areas
! a zero means no enclosing block. word1=word3=0 is an
! imp main program and will terminate the diagnostics.
routine indiag(integer oldlnb, lang, pcount, mode, diag, c
asize, integername first, newlnb)
!***********************************************************************
!* the diagnostic routine for imp %and algol(lang=5) *
!* the algol symbol tables are set up as for imp *
!* mode = 0 for jobber&emas2900, =1 for opeh in vmeb&vmek *
!* diag = diagnostic level *
!* 1 = route summary only (asize)=addr module name from opeh *
!* 2 = diagnostics as traditionally performed *
!* asize is no of elements of each array to be printed(diag>1) *
!***********************************************************************
recordformat f(integer val,string (11) vname)
routinespec print locals(integer adata)
routinespec print scalar(record (f)name var)
routinespec print arr(record (f)name var, integer asize)
routinespec print var(integer type, prec, nam, lang, form, c
vaddr)
integer glaad, fline, nam, type, prec, tstart, prev blk, c
word0, word1, word2, word3, i
string (10) stmnt
string (20) proc
string (50) name
constinteger algol = 5; ! language code
if lang # algol then stmnt = " line" c
and proc = " routine/fn/map " c
else stmnt = " statement" and proc = " procedure "
glaad = integer(oldlnb+16); ! addr of gla/plt
tstart = integer(oldlnb+12)&x'FFFFFF'
if tstart = 0 then start
printstring("
".proc."compiled without diagnostics
")
assdump(pcount,oldlnb)
newlnb = integer(oldlnb)
return
finish
cycle
tstart = tstart+integer(glaad+12)
word0 = integer(tstart)
word1 = integer(tstart+4)
word2 = integer(tstart+8)
word3 = integer(tstart+12)
! %if word1&x'C0000000'=x'40000000' %and comreg(25)#0 %c
! %then newlnb=integer(oldlnb) %and %return
! system routine
name = string(tstart+12)
i = word0&x'FFFF'; ! line no disp
if i = 0 then fline = -1 c
else fline = integer(oldlnb+i)
newline
if mode = 1 then printstring(lt(lang)) else start
if first = 1 then first = 0 c
and printstring("Diagnostics ")
printstring("entered from")
finish
if word0>>16 = 0 then start
if mode = 0 then printstring(lt(lang))
printstring("environmental block
")
finish else start
if fline >= 0 and fline # word0>>16 then start
printstring(stmnt)
write(fline,4)
printstring(" of")
finish
if word3 = 0 then printstring(" block") c
else print string(proc.name)
printstring(" starting at".stmnt)
write(word0>>16,2)
if mode = 1 and diag = 1 then start
printstring("(module ".string(asize).")")
finish
newline
if lang # algol then i = 20 else i = 16
if mode = 0 or diag > 1 c
then print locals(tstart+i+(word3>>26)<<2)
if word3 # 0 start
newlnb = integer(oldlnb)
unless diag = 1 then newline
return
finish
finish
prev blk = word1&x'FFFF'
tstart = prev blk
repeatuntil prevblk=0
newlnb = 0
newline; return
routine qsort(record (f)arrayname a, integer i, j)
record (f)d
integer l, u
if i >= j then return
l = i; u = j; d = a(j); -> find
up:
l = l+1
if l = u then -> found
find:
unless a(l)_vname > d_vname then -> up
a(u) = a(l)
down:
u = u-1
if l = u then -> found
unless a(u)_vname < d_vname then -> down
a(l) = a(u); -> up
found:
a(u) = d
qsort(a,i,l-1)
qsort(a,u+1,j)
end
!*
routine prhex(integer i, pl)
print string(h to s(i,pl))
end
!*
routine print locals(integer adata)
!***********************************************************************
!* adata points to the first entry for locals in the symbol tables*
!***********************************************************************
integer nrecs, sadata
newline
if integer(adata) < 0 then printstring("No l") else printstring("L")
printstring("ocal variables
")
nrecs = 0; sadata = adata
while integer(adata) > 0 cycle
nrecs = nrecs+1
adata = adata+8+byte integer(adata+4)&(-4)
repeat
return if nrecs = 0
begin
record (f)array vars(1 : nrecs)
integer i
adata = sadata
for i = 1,1,nrecs cycle
vars(i) <- record(adata)
adata = adata+8+byteinteger(adata+4)&(-4)
repeat
qsort(vars,1,nrecs)
for i = 1,1,nrecs cycle
if vars(i)_val>>28&3 = 0 c
then print scalar(vars(i))
repeat
if asize > 0 then start
for i = 1,1,nrecs cycle
if vars(i)_val>>28&3 # 0 c
then print arr(vars(i),asize)
repeat
finish
end
end
routine print scalar(record (f)name var)
!***********************************************************************
!* output the next variable in the current block. *
!* a variable entry in the tables is:- *
!* flag<<20!vbreg<<18!disp *
!* where:- *
!* vbreg is variable's base register, disp is it's offset *
!* and flags=nam<<6!prec<<3!type *
!***********************************************************************
integer i, k, vaddr
string (11) lname
i = var_val
k = i>>20
type = k&7
prec = k>>4&7
nam = k>>10&1
lname <- var_vname." "
print string(lname."=")
if i&x'40000' = 0 then vaddr = oldlnb else vaddr = glaad
vaddr = vaddr+i&x'3FFFF'
print var(type,prec,nam,lang,0,vaddr)
newline
end
routine print var(integer type, prec, nam, lang, form, c
vaddr)
!***********************************************************************
!* output a variable. fixed format(form#0) take 14 places for *
!* variables up to 32 bits and 21 places thereafter *
!***********************************************************************
integer k, i, j
constinteger unassi = x'81818181'
switch intv, realv(3 : 7)
! use validate address here to check acr levels etc
*ldtb_x'18000010'
*lda_vaddr
*val_(lnb +1)
*jcc_3,<invalid>
if nam # 0 or (type = 5 and form = 0) then start
if integer(vaddr)>>24 = x'E5' then -> esc
vaddr = integer(vaddr+4)
-> not ass if vaddr = unassi
*ldtb_x'18000010'
*lda_vaddr
*val_(lnb +1)
*jcc_3,<invalid>
finish
-> ill ent if prec < 3; ! bits not implemented
if type = 1 then -> intv(prec)
if type = 2 then -> realv(prec)
if type = 3 and prec = 5 then -> bool
if type = 5 then -> str
intv(4): ! 16 bit integer
k = byteinteger(vaddr)<<8!byteinteger(vaddr+1)
-> not ass if k = unassi>>16
write(k,12*form+1)
return
intv(7): ! 128 bit integer
realv(3): ! 8 bit real
realv(4): ! 16 bit real
ill ent: ! should not occurr
printstring("Unknown type of variable")
return
intv(5): ! 32 bit integer
-> not ass if integer(vaddr) = un assi
write(integer(vaddr),1+12*form)
unless lang=algol or form=1 or -255<=integer(vaddr)<=255 start
printstring(" (X'")
prhex(integer(vaddr),8); printstring("')")
finish
return
intv(3): ! 8 bit integer
write(byteinteger(vaddr),1+12*form); return
realv(5): ! 32 bit real
-> not ass if integer(vaddr) = un assi
! print fl(real(vaddr),7)
print string("Real? X".h to s(integer(vaddr),8))
return
intv(6): ! 64 bit integer
-> not ass if un assi = integer(vaddr) = integer(vaddr+4)
printstring("X'")
prhex(integer(vaddr),8); spaces(2)
prhex(integer(vaddr+4),8)
printsymbol('''')
return
realv(6): ! 64 bit real
-> not ass if unassi = integer(vaddr) = integer(vaddr+4)
! print fl(long real(vaddr), 14)
print string("Longreal? X".h to s(integer(vaddr),8).h to s( c
integer(vaddr+4),8))
return
realv(7): ! 128 bit real
-> not ass if unassi = integer(vaddr) = integer(vaddr+4)
! print fl(longreal(vaddr),14)
if form = 0 then start
printstring(" (R'"); prhex(integer(vaddr),8)
prhex(integer(vaddr+4),8)
space; prhex(integer(vaddr+8),8)
prhex(integer(vaddr+12),8)
printstring("')")
finish
return
bool: ! boolean
-> not ass if integer(vaddr) = unassi
if integer(vaddr) = 0 then printstring(" 'FALSE' ") c
else printstring(" 'TRUE' ")
return
str:
i = byteinteger(vaddr)
-> not ass if byte integer(vaddr+1) = unassi&255 = i
k = 1
while k <= i cycle
j = byte integer(vaddr+k)
-> nprint unless 32 <= j <= 126 or j = 10
k = k+1
repeat
printstring("""")
printstring(string(vaddr)); printstring("""")
return
esc: ! escape descriptor
printstring("Escape routine")
-> aign
invalid:
printstring("Invalid addrss")
-> aign
nprint:
print string(" contains unprintable chars")
return
not ass:
printstring(" not assigned")
aign:
if prec >= 6 and form = 1 then spaces(7)
end ; ! print var
integerfn check dups(integer refaddr, vaddr, elsize)
!***********************************************************************
!* check if var the same as printed last time *
!***********************************************************************
elsize = elsize!x'18000000'
*ldtb_elsize; *lda_refaddr
*cyd_0; *lda_vaddr
*cps_l =dr
*jcc_8,<a dup>
result = 0
adup:
result = 1
end
routine dcodedv(longinteger dv,integerarrayname lb,ub)
!***********************************************************************
!* work down a dope vector described by word descriptor dv and *
!* return size,dimenionality and subscript ranges in data *
!***********************************************************************
integer i, nd, ad, u, t
nd = (dv>>32)&255; nd = nd//3
lb(0) = nd; ub(0) = nd
ad = integer(addr(dv)+4)+12*(nd-1)
t = 1
for i = 1,1,nd cycle
u = integer(ad+8)//integer(ad+4)
ub(i) = u
lb(i) = integer(ad)
t = t*(ub(i)-lb(i)+1)
ad = ad-12
repeat
ub(nd+1) = 0
lb(nd+1) = 0
end
routine print arr(record (f)name var, integer asize)
!***********************************************************************
!* print the first asize elements of the array defined by var *
!* arraynames printed also at present. up to compilers to avoid this*
!***********************************************************************
integer i, j, k, type, prec, elsize, nd, vaddr, hdaddr, c
baseaddr, elsperline, m1, refaddr, elsonline, dupseen
longinteger arrd,doped
integerarray lbs, ubs, subs(0 : 13)
i = var_val
k = i>>20
prec = k>>4&7
type = k&7
printstring("
ARRAY ".VAR_VNAME)
if i&x'40000' # 0 then vaddr = glaad else vaddr = oldlnb
hdaddr = vaddr+i&x'3FFFF'
! validate header address and the 2 descriptors
*ldtb_x'18000010'
*lda_hdaddr
*val_(lnb +1)
*jcc_3,<hinv>
arrd = long integer(hdaddr)
doped = long integer(hdaddr+8)
*ld_arrd
*val_(lnb +1)
*jcc_3,<hinv>
*ld_doped
*val_(lnb +1)
*jcc_3,<hinv>
baseaddr = integer(addr(arrd)+4)
dcodedv(doped,lbs,ubs)
nd = lbs(0)
if type # 5 then elsize = 1<<(prec-3) else start
i = integer(addr(doped)+4)
elsize = integer(i+12*(nd-1)+4)
finish
! print out and check arrays bound pair list
print symbol('('); j = 0
for i = 1,1,nd cycle
subs(i) = lbs(i); ! set up subs to first el
write(lbs(i),1)
print symbol(':')
write(ubs(i),1)
print symbol(',') unless i = nd
j = 1 if lbs(i) > ubs(i)
repeat
print symbol(')')
newline
if j # 0 then printstring("bound pairs invalid") and return
! work out how many elements to print on a line
if type = 5 then elsperline = 1 else start
if elsize <= 4 then elsperline = 6 else elsperline = 4
finish
cycle ; ! through all the columns
! print column header except for one dimension arrays
if nd > 1 then start
print string("
Column (*,")
for i = 2,1,nd cycle
write(subs(i),1)
print symbol(',') unless i = nd
repeat
print symbol(')')
finish
! compute the address of first element of the column
k = 0; m1 = 1; i = 1
while i <= nd cycle
k = k+m1*(subs(i)-lbs(i))
m1 = m1*(ubs(i)-lbs(i)+1)
i = i+1
repeat
vaddr = baseaddr+k*elsize
refaddr = 0; ! addr of last actually printed
dupseen = 0; elsonline = 99; ! force first el onto new line
! cycle down the column and print the elements. sequences of repeated
! elements are replaced by "(RPT)". at the start of each line the
! current value of the first subscripted is printed followed by a aparen
for i = lbs(1),1,ubs(1) cycle
if refaddr # 0 then start ; ! chk last printed in this col
k = check dups(refaddr,vaddr,elsize)
if k # 0 then start
print string("(Rpt)") if dupseen = 0
dupseen = dupseen+1
-> skip
finish
finish
! start a new line and print subscript value if needed
if dupseen # 0 or els on line >= els per line start
newline; write(i,3); print string(")")
dupseen = 0; els on line = 0
finish
print var(type,prec,0,lang,1,vaddr)
elsonline = elsonline+1
refaddr = vaddr
skip:
vaddr = vaddr+elsize
asize = asize-1
exit if asize < 0
repeat ; ! until column finished
newline
exit if asize <= 0 or nd = 1
! update second subscript to next column. check for and deal with
! overflow into next or further cloumns
i = 2; subs(1) = lbs(1)
cycle
subs(i) = subs(i)+1
exit unless subs(i) > ubs(i)
subs(i) = lbs(i); ! reset to lower bound
i = i+1
repeat
exit if i > nd; ! all done
repeat ; ! for further clomuns
return
hinv:
printstring(" has invalid header
")
end ; ! of rt print arr
end ; ! of rt idiags
!*
!*
!*
routine ermess(integer n, inf)
!***********************************************************************
!*_______outputs an error message stored in a compressed format *
!***********************************************************************
constbyteintegerarray tr(0 : 13) = c
1,2,3,4,5,6,7,3,
10,9,7,7,8,10
return if n <= 0
if n = 35 then n = 10
if n = 10 then start ; ! deal with interrupt wt
if inf = 32 then n = 9
if inf <= 13 then n = tr(inf)
if inf = 140 then n = 25
if inf = 144 then n = 28
! more helpful message if
!possible
finish
!*
printmess(n)
!*
! (we would get an iocp ref on this next line)
! %if n=26 %then print symbol(next symbol)
!*__________n=6(array bound fault) excluded from following - 19/3/76
if n = 16 or n = 17 or n = 10 start
write(inf,1)
spaces(3)
print string(h to s(inf,8))
finish
newline
end ; ! ermess
!*
!*********************************************
!*___________________________________________*
!*_this routine recodes from hex into new *
!*_range assembly code. *
!*___________________________________________*
!*********************************************
routine ncode(integer start, finish, ca)
routinespec primary decode
routinespec secondary decode
routinespec tertiary decode
routinespec decompile
conststring (5) array ops(0 : 127) = c
" ","JCC ","JAT ","JAF "," "," "," "," ",
"VAL ","CYD ","INCA ","MODD ","DIAG ","J ","JLK ","CALL ",
"ADB ","SBB ","DEBJ ","CPB ","SIG ","MYB ","VMY ","CPIB ",
" ","MPSR ","CPSR "," ","EXIT ","ESEX ","OUT ","ACT ",
"SL ","SLSS ","SLSD ","SLSQ ","ST ","STUH "," ","IDLE ",
"SLD ","SLB ","TDEC ","INCT ","STD ","STB ","STLN ","STSF ",
"L ","LSS ","LSD ","LSQ ","RRTC ","LUH ","RALN ","ASF ",
"LDRL ","LDA ","LDTB ","LDB ","LD ","LB ","LLN ","LXN ",
"TCH ","ANDS ","ORS ","NEQS ","EXPA ","AND ","OR ","NEQ ",
"PK ","INS ","SUPK ","EXP ","COMA ","DDV ","DRDV ","DMDV ",
"SWEQ ","SWNE ","CPS ","TTR ","FLT ","IDV ","IRDV ","IMDV ",
"MVL ","MV ","CHOV ","COM ","FIX ","RDV ","RRDV ","RDVD ",
"UAD ","USB ","URSB ","UCP ","USH ","ROT ","SHS ","SHZ ",
"DAD ","DSB ","DRSB ","DCP ","DSH ","DMY ","DMYD ","CBIN ",
"IAD ","ISB ","IRSB ","ICP ","ISH ","IMY ","IMYD ","CDEC ",
"RAD ","RSB ","RRSB ","RCP ","RSC ","RMY ","RMYD "," "
integer k, kp, kpp, n, opcode, flag, insl, dec, h, q, ins, c
kppp, pc, all
constintegerarray hx(0 : 15) = c
'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'
pc = 0
all = finish-start
newline
while pc < all cycle
flag = 0
h = 0
dec = 0
move(4,start+pc,addr(ins))
opcode = ins>>25<<1
if opcode = 0 or opcode = 254 or opcode = 48 c
or opcode = 54 or opcode = 76 c
or 8 <= opcode <= 14 then start
insl = 16
flag = 1
finish else start
if 2 <= opcode <= 8 then tertiary decode else start
if x'8' <= opcode>>4 <= x'B' c
and opcode&x'F' < 7 then secondary decode c
else primary decode
finish
finish
decompile
pc = pc+insl>>3
newline
repeat
!***********************************************************************
!*_routine to interpret primary format instruction
routine primary decode
dec = 1
k = ins<<7>>30
n = ins<<9>>25
unless k = 3 then start
insl = 16
return
finish
kp = ins<<9>>30
kpp = ins<<11>>29
if kpp < 6 then insl = 32 and n = ins&x'3FFFF' c
else start
unless ins&x'30000' = 0 c
then printstring(" res. field #0
")
insl = 16
finish
end ; ! primary decode
!*
!*
!***********************************************************************
!*_routine to interpret secondary format instructions
routine secondary decode
dec = 2
h = ins<<7>>31
q = ins<<8>>31
n = ins<<9>>25
if q = 1 then insl = 32 else insl = 16
end ; ! secondary decode
!*
!*
!***********************************************************************
!*_routine to interpret tertiary format instructions
routine tertiary decode
dec = 3
kppp = ins<<11>>29
if kppp > 5 then insl = 16 else insl = 32
n = ins&x'3FFFF'
if insl = 16 and ins<<14>>16 # 0 c
then printstring(" 2 LS bits #0
")
end ; ! tertiary decode
!*
!*
!***********************************************************************
!*_routine to interpret current instruction
routine decompile
integer i, j
!*
!*
conststring (12) array pop(0 : 31) = c
"N ","*** ","(LNB+N) ","(XNB+N) ",
"(PC+N) ","(SSN+N) ","TOS ","B ",
"@DR,N ","*** ","@DR,(LNB+N) ","@DR,(XNB+N) ",
"@DR,(PC+N) ","@DR,(SSN+N) ","@DR,TOS ","*** ",
"ISN ","*** ","@(LNB+N) ","@(XNB+N) ",
"@(PC+N) ","@(SSN+N) ","@TOS ","@DR ",
"ISB ","*** ","@(LNB+N),B ","@(XNB+N),B ",
"@(PC+N),B ","@(SSN+N),B ","@(TOS+B) ","@(PR+B) "
conststring (12) array top(0 : 7) = c
"N ","@DR,N ","(LNB+N) ","(XNB+N) ",
"(PC+N) ","(SSN+N) ","@DR ","@DR,B "
j = pc+ca
printsymbol(hx((j>>16)&3))
printsymbol(hx((j>>12)&15))
printsymbol(hx((j>>8)&15))
printsymbol(hx((j>>4)&15))
printsymbol(hx(j&15))
spaces(4)
for i = 3,-1,0 cycle
j = (ins>>(8*i))&x'FF'
if 32 <= j <= 95 then printsymbol(j) c
else print string(dot)
exit if i = 2 and insl = 16
repeat
if insl = 16 then spaces(8) else spaces(2)
if insl = 16 then start
for j = 28,-4,16 cycle
printsymbol(hx((ins>>j)&15))
repeat
finish else print string(h to s(ins,8))
return if flag = 1
space
printstring(ops(opcode>>1))
space
if dec = 1 then start ; ! primary format
if k < 3 then start
if k = 1 then printstring("(LNB+N) X")
if k = 2 then printstring("@(LNB+N) X")
if k = 0 then printstring(" X")
if k = 0 then start
if n>>6 = 1 then n = -(n!x'FFFFFF80') c
and print string("-")
finish
printsymbol(hx((n>>4)&7))
printsymbol(hx(n&15))
finish else start
printstring(pop(kp*8+kpp))
if insl = 32 then start
printstring("X")
if (kp = 0 and kpp = 0) or kpp = 4 then start
if (n>>16) > 1 then n = -(n!x'FFFC0000') c
and print string("-")
finish
printsymbol(hx((n>>16)&3))
for i = 12,-4,0 cycle
printsymbol(hx((n>>i)&15))
repeat
finish
finish
finish
if dec = 2 then start ; ! secondary format
printstring(" X")
printsymbol(hx((ins>>20)&7))
printsymbol(hx((ins>>16)&15))
if insl = 32 then start
! mask
printstring(" X")
printsymbol(hx((ins>>12)&15))
printsymbol(hx((ins>>8)&15))
! literal/filler
printstring(" X")
printsymbol(hx((ins>>4)&15))
printsymbol(hx(ins&15))
printstring(" H=")
write(h,1)
finish
finish
if dec = 3 then start ; ! tertiary format
printstring(top(kppp))
if insl = 32 then start
! m field
printstring(" X")
printsymbol(hx((ins>>21)&15))
printstring(" X")
if kppp = 0 or kppp = 4 then start
if (n>>16) > 1 then n = -(n!x'FFFC0000') c
and print string("-")
finish
printsymbol(hx((n>>16)&3))
for i = 12,-4,0 cycle
printsymbol(hx((n>>i)&15))
repeat
finish
finish
end ; ! decompile
!*
!*
end ; ! ncode
!*
!*
!*_modified 28/06/76 12.15
!*
!*
conststring (21) array b error(1 : 37) = c
"Real overflow",
"Real underflow",
"Integer overflow",
"Decimal overflow",
"Zero divide",
"Array bounds exceeded",
"Capacity exceeded",
"Illegal operation",
"Address error",
"Interrupt of class",
"Unassigned variable",
"Time exceeded",
"Output exceeded",
"Operator termination",
"Illegal exponent",
"Switch label not set",
"Corrupt dope vector",
"Illegal cycle",
"Int pt too large",
"Array inside out",
"No result",
"Param not destination",
"Program too large",
"Stream not defined",
"Input ended",
"Symbol in data",
"IOCP error",
"Sub character in data",
"Stream in use",
"Graph fault",
"Diagnostics fail",
"Resolution fault",
"Invalid margins",
"Symbol not string",
"String insideout",
"Wrong params given",
"Unsatisfied reference"
!*
externalroutine printmess alias "S#PRINTMESS" (integer n)
!*_print message corresponding to fault n on the current output stream
if 1 <= n <= 37 then start
print string("Program error :- ".b error(n)."
")
finish else start
print string("Error no ")
write(n,3)
newline
finish
end
!*
!*
finishelsestart ; ! not target=2900
!
!*
!* NDIAG - TRIMP version - January 1985 - K.Y.
!* Adapted for Executives - Feb 1985 - S.S.
!* Further nurdled - March 1985 - J.H.
!*
!***********************************************************************
!* *
!* Constants *
!* *
!***********************************************************************
const integer readac=1, writeac=3
const integer arraysize=12
const integer stringlen=31
const integer levels limit=31
!***********************************************************************
!* *
!* External specs *
!* *
!***********************************************************************
own integer active
ownintegerarray resregs( 0:43 )
!----------------------------------- strhex -----------------------------------
string fn strhex(integer n)
result = htos(n, 8)
end {strhex}
!***********************************************************************
!* *
!* Internal specs *
!* *
!***********************************************************************
integer fn spec validate gla(integer address)
integer fn spec validate(integer address, access)
routine spec trans(integer name fault, event, subevent)
routine spec ermess(integer n, inf)
routine spec assdump(integer pcount, lnb, flag)
integer fn spec wtfault(integer inf)
routine phex(integer i)
printstring(htos(i, 8))
end ; !of phex
!---------------------------------- NEXTLNB ----------------------------------
integer fn nextlnb(integer lnb)
! Currently works only for IMP. Attempts to work out next LNB. If it cannot
! progress from LNB supplied (either because non-IMP language noted or because
! bottom of stack reached), then the result returned is the same as the parameter
! supplied.
integer i, j, low, language
const integer min=64; ! minimum stack frame
low = lnb
language = byteinteger(integer(lnb+4*13)+16)
if lnb#bottom of stack and (language=1 or language=3) start
for i = 10, -1, 5 cycle
j = integer(lnb+4*i)
if ((lnb=low and j+min<=low) or (lnb-min>=j>low)) and j>=bottom of stack and integer(j+44)=j then low = j
repeat
finish
result = low
end {NEXTLNB}
!----------------------------------- GIVELNB ----------------------------------
routine givelnb(integer name lnb, integer aregs)
! Looks at registers (5-10) pointed to by AREGS (format 16 words 0-15)
! Tries to deduce the LNB value.
integer array gr(0:15)
integer j, reg
integer fn spec check
move(64, aregs, addr(gr(0)))
if gr(10)>>20#gr(11)>>20 or gr(10)=x'83838383' then printstring("LNB not available") and newline
reg = 10
gr(0) = gr(10)
cycle
gr(1) = gr(reg-1)
j = check
exit if j=0 or reg=5
reg = reg-1
repeat
lnb = gr(0)
integer fn check
! If (the following tests) then "finished"
result = 0 if gr(1)>gr(11) or gr(1)<=gr(0) or gr(1)#integer(gr(1)+44)
! else r1->r0 and "return"
gr(0) = gr(1)
result = 1
end {check}
end {givelnb}
!----------------------------------- ONCOND -----------------------------------
routine oncond(integer event, subevent, lnb, gla, id)
!***********************************************************************
!* UNWIND THE IMP STACK LOOKING FOR ON CONDITIONS *
!* There is only one call of ONCOND - it is in NDIAG. *
!***********************************************************************
integer lang, bit, onword, par1, par2
integer sst ptr, dtable, fline, fbline, btype, prev blk
integer newregs, flag
string (11) name
unless 1<=event<=14 then return
bit = 1<<(event+17)
!prevlnb=nextlnb(lnb)
!ststart=ssown_sscomreg(36)
!stseg=ststart>>segshift
!%while lnb>>segshift=stseg %and lnb>=ststart %cycle
cycle
lang = byteinteger(gla+16)
unless lang=1 or lang=3 then return
sstptr = byteinteger(lnb)<<8!byteinteger(lnb+1); ! Short(LNB)
fline = byteinteger(lnb+2)<<8!byteinteger(lnb+3); ! Short(LNB+2)
dtable = integer(gla+20)+sst ptr
if validate(dtable, readac)=0 start
printstring("DTABLE invalid")
newline
return
finish
fbline = byteinteger(dtable)<<8!byteinteger(dtable+1) {Short(DTABLE)}
btype = byteinteger(dtable+12) {name-length, hence blocktype}
if btype>11 start
printstring("Invalid symbol tables") {remove when code checked out]}
newline
return
finish
prev blk = byteinteger(dtable+6)<<8!byteinteger(dtable+7)
name = string(dtable+12) {null if block}
onword = integer((dtable+btype+16)&(-4))
if btype=0 then printstring("Block") else printstring("Routine/fn/map ")
spaces(13-length(name))
printstring(name)
printstring(" starting at line")
write(fbline, 4)
printstring(" ONWORD = "); printstring(htos(onword, 8))
newline
if onword&bit#0 then exit
fline = fbline
sst ptr = prev blk
gla = integer(lnb+4*13)
newregs = nextlnb(lnb)
return if newregs=lnb
lnb = newregs
repeat
! ON CONDITION found.
! If here and SSOWN_RCODE is 103050709 then we have arrived via the
! ENTERONUSERSTACK trap. Since we have found an %on %event trap prepared
! to deal with the contingency then SSOWN_RCODE can be reset to 0
printstring("On event HIT. Dest LNB = X"); phex(lnb)
newline
par1 = event<<8!subevent
par2 = byteinteger(lnb+2)<<8!byteinteger(lnb+3) {the line number}
active = 0
move(8, par1, addr(resregs(0)) )
move(48, lnb, addr(resregs(6)) ) {move GR 4-15 into resregs}
resregs(1) = resregs(17) {GR 15 -> PSW1}
resregs(41) = 0 {CR 15 = 0 => RUN}
flag = dresume(resregs)
stop
end {ONCOND}
!---------------------------- NDIAG ------------------------------------------
external routine ndiag alias "S#NDIAG"(integer pcount, lnb, fault, inf)
! In calls from IMP code generated by the IMP compiler (i.e., not calls
! written in explicitly by the programmer), and in calls from IMP PERM,
! the inf parameter is NOT significant, and the fault parameter is to
! be interpreted as (event<<16)!subevent.
!
! A call with fault=0 means %monitor - i.e., ndiag is NOT to print any
! message describing a fault, but is required only to print the trace and
! values of variables.
!
! In a call with fault=10, the interrupted code may not have been IMP-compiled,
! so the value of the lnb parameter may not be correct (since there is no
! general method for finding the stack frame pointer from the contents of the
! general registers. Thus if fault=10, ndiag must start by determining the
! source language of the interrupted code. If the language is IMP, then ndiag
! should extract the lnb value from the general registers in
! SSOWN_INTINFO_GR(0:10) - algorithm appears as a comment at the head of the
! TRAP code. If the language is not IMP, then NDIAG must pass the problem
! on to the appropriate language-specific diagnostic routine, and must pass
! the general register values to that routine. Thus language-specific
! diagnostic routines should accept a set of register values as a parameter,
! and should not expect to be supplied with a LNB value.
integer langflag, gla, aregs, newreg, j, lnbhere, display above, test
integer i, limit, level, id, subevent, event, contflag, flag
const integer maxlanguage= 10
switch language(0:maxlanguage)
integer array regs(0:24)
string (20) failno
const string (9) array lt(0:maxlanguage)=" !???! "," IMP "," FORTRAN "," IMPS "," ASMBLR ",
" !???! "(2) {5-6}, " PASCAL " {7}, "! SIMULA " {8}, " !???! "(2){9-10}
routine spec indiag(integer gla, lnb, integer name newregs)
! This array and counter is designed to enable us to suppress the repeated
! presentation of the same environmental variables for a given call on NDIAG
const integer maxe=5
integer ecounter
integer array environmentals printed(0:maxe)
! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
! There is an unresolved problem here.
! NDIAG can apparently loop up to 5 times before it fails (SSOWN_ACTIVE)
! and each entry will lay down a new trap. The trap code guarantees 1 free
! slot for the NDIAG trap so if the table was almost full and we looped
! we wouldn't have room. It seems wasteful to reserve 5 slots so we will
! proceed as coded at the moment and see what happens.
! It depends to some extent on whether there are any normal sequences of
! operations which would put NDIAG on the stack more than once.
! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
!
! ** Start of NDIAG trap
!
ecounter = 0
level = 0
ecounter = 0
limit = levels limit
if fault#0 then selectoutput(0)
active = active+1
if active>1 then failno = " looping" and ->eout
! Two situations.
! 1. NDIAG called from run-time system (from PERM or %monitor), to
! diagnose from previous stackframe. In this case the GLA address is
! in the stackframe above that indicated by paramtere LNB (usually
! the stackframe for LNB itself). We work back from LNBHERE.
! 2. NDIAG called by contingency software following interrupt (e.g. address
! error, overflow). In this case the GLA address is found from the
! registers in SSOWN_INTINFO
! We distinguish these two situations from the value of FAULT (not 10 or 10).
if fault#10 start
! Situation 1. NDIAG called from run-time system
test = 0
*st_10,j
lnbhere = j
aregs = lnb
if lnb<lnbhere start
until j=lnb or j=display above {means NEXTLNB is not progressing further} cycle
display above = j
j = nextlnb(j)
repeat
gla = integer(display above+4*13)
test = validate gla(gla)
finish else start
printstring("LNB HERE ="); phex(lnbhere)
newline
test = 0
finish
finish else start
! Situation 2. Call following interrupt
aregs = addr(regs(0))
move(64, addr(resregs(2)), aregs)
gla = regs(13)
test = validate gla(gla)
if test>0 and (byteinteger(gla+16)=3 or byteinteger( c
gla+16)=1 {IMP}) then give lnb(lnb, aregs)
finish
printstring("LNB = "); printstring(htos(lnb, 8))
printstring(" GLA at "); printstring(htos(gla, 8))
newline
if validate(lnb, 1) = 0 start
printstring("Validate LNB fails"); newline
-> quit
finish
langflag = byteinteger(gla+16)
langflag = 0 if langflag>maxlanguage or test<=0
subevent = 0; event = fault>>8
if 400<=fault<=500 then start
ermess(fault, inf)
newline
finish else start
if 50<=fault<=76 {Error reported by Maths. function} then contflag = 2 else if fault=10 {Interrupt} start
! INF has the "weight" or "class", which is the same as
! the PE number for Program Error interrupts. Only
! Program Error interrupts are reported by this route -
! others have nothing to do with the program and are
! handled by other parts of the system - but a few other
! faults which do not involve real interrupts are reported
! as "simulated" interrupts with class numbers which are
! impossible as Program Error numbers, and this code can
! cope with those.
fault = wtfault(inf); ! Convert "class" or "weight" to a "Fault} number", which is also the number for
! the appropriate error message.
contflag = 1
finish
if 7#langflag#8 then start { i.e., not for PASCAL or SIMULA}
! If the FAULT parameter is >= 256, it consists of an
! event number in the top 24 bits and a subevent number
! in the bottom eight bits. We have already extracted
! the event number, so we pick up the subevent number.
! Then we clear FAULT, so that TRANS will convert the
! event and subevent numbers into a 'proper' fault number
! which will yield an appropriate error message.
if fault>=256 then start
subevent = fault&255
fault = 0
finish
trans(fault, event, subevent); ! Ensures that FAULT, EVENT and SUBEVENT are all set
! to define the same occurrence.
oncond(event, subevent, lnb, gla, id)
finish
if fault>=0 then start
if fault=0 and event#0 start
newline
printstring("Monitor entered")
newline
printstring("Event"); write(event, 1)
printsymbol('/'); write(subevent, 1)
finish else start
ermess(fault, inf)
finish
newline
finish else event = 0
finish
newline
printstring("Monitor entered from".lt(langflag)." [Amdahl diagnostics]")
newline
ermess(fault, inf)
newline
newreg = 0
->language(langflag)
language(1):
language(3): ! imp & imps
indiag(gla, lnb, newreg); ! imp diags
level = level+1
if newreg=0 or level>=limit then ->exit
! Continue to unwind stack
gla = integer(lnb+52)
lnb = newreg
langflag = byteinteger(gla+16)
langflag = 0 if langflag>4
->language(langflag)
language(*): ! unknown, fortran & assembler
assdump(pcount, lnb, 1)
return ; ! no way of tracing back
eout: ! error exit
newline
printstring("NDIAG fails ".failno)
newline
exit:
quit:
active = 0
if fault=0=event then return
stop if com36 = 0
move(48, com36+16, addr(resregs(6)) ) {move GR 4-15 into resregs}
resregs(1) = resregs(17) {GR 15 -> PSW1}
resregs(41) = 0 {CR 15 = 0 => RUN}
flag = dresume(resregs)
stop
! End body of NDIAG
!-------------------------------- INDIAG ---------------------------------------
routine indiag(integer gla, lnb, integer name newregs)
! Prints diagnostics for one routine level of an IMP program. Set NEWREGS to
! point to previous stack frame if possible (else zero, to terminate diagnostics)
!
!
! Layout of diagnostic tables
!
! The first half-word of the stack frame contains a displacement relative to
! the start of SST of the diagnostic tables for the block or routine being
! executed. A zero value means no diagnostics requested. (NB This may mean a
! dummy first word in the SST).
! The address of the SST for the current code segment is at GLA+20 bytes (this
! word points to the x'C2C2C2C2' word in the SST-area of the object file).
!
! Form of the diagnostic tables:-
! For each routine/block there is a routine/block record of 20+N bytes, where
! N is the number by which the routine-identifier including length-byte exceeds
! four bytes. (Blocks have a null identifier).
! Following the routine/block record are IMP-variable records, each comprising
! one word of type-information followed by the identifier as an IMP string.
! These variable-records are contiguous and are terminated by a -1 type-information
! word.
! The routine/block record is as follows:
!
! Bytes 0-1 = line of rt/black heading in source prog
! 2-3 = line no posn (from LNB) ??
!
! bytes 4-5 = ??
! 6-7 = pointer (relative to the SST for the module) of the routine/block
! record for the enclosing block (or zero if none)
! Word 2 = display posn (from LNB)<<16 ! rt type info
! Word 3 = zero for blocks or string(<=11bytes) being the rt name.
! This will take words 4 and 5 if needed
! Word 6 = language dependent info . IMP on conditions etc
!
! Each variable entry consists of the variable word followed by
! the variable name as a string. The word consists of
! bits 2**31 to 2**20 type information (may be language dependent
! Bit 2**19 =0 under LNB =1 in GLA
! Bits 2**18 to 2**0 displacement from LNB(GLA) in bytes
!
! The environment (bytes 6-7 of the routine/block) is a pointer (relative to SST)
! of the next outermost block or a pointer to global owns, external or common areas
! A zero means no enclosing block. Word1=word3=0 is an IMP main program or
! global owns for a module of external routines and will terminate the diagnostics.
! 0 2 4 6 8...
! +----+----+----+----+----- - - ---------+
! | FBL| | |PREV| locvars -1 | Inner routine or block
! +----+----+----+----+----- - - ---------+
! |
! +--------------+
! |
! V 2 4 6 8...
! +----+----+----+----+----- - - ---------+
! | FBL| | |PREV| locvars -1 | Outer begin or ext routine
! +----+----+----+----+----- - - ---------+
! |
! +-------------+
! |
! V 2 4 6 8...
! +----+----+----+----+----- - - ---------+
! |zero| | |zero| locvars -1 | Environmental level
! +----+----+----+----+----- - - ---------+
!
! FBL = "from-block line", i.e. starting line-number of this routine/block
!
! PREV = "previous block" i.e. pointer to diag tables for enclosing (textual) block
!
! locvars = Diag tables for variables local to this level.
!
! -1 ends the records for the variables of this level.
routine spec print locals(integer locenv)
routine spec print var(integer type, prec, nam, form, vaddr)
routine spec pscalar(integer adata)
routine spec parr(integer adata, asize)
integer sst ptr, dtable, fline, fbline, btype, prev blk, i, j, old fbline
string (11) name
! The scheme of things here is as follows.
! CYCLE
! Have we done all dynamic levels? EXIT if so.
! (This test and this cycle are in routine IDIAG)
! CYCLE
! (The contents of this cycle comprise routine INDIAG)
! Print diagnostics for current level.
! Look at next textual level and print diagnostics for same if GLOBAL, i.e.
! print values of global owns if any, ELSE select next dynamic level and EXIT.
! REPEAT
! REPEAT
! In the diagnostic tables, FromBlockLINE (FBLINE) and PREVBLK indicate whether
! the current diagtable is for
! Global owns (Environmental block) FBLINE=0 PREVBLK=0
! or outer begin/ext routine/routine/inner begin FBLINE>0 PREVBLK>0
sstptr = byteinteger(lnb)<<8!byteinteger(lnb+1); ! Short(LNB)
fline = byteinteger(lnb+2)<<8!byteinteger(lnb+3); ! Short(LNB+2)
old fbline = 0
cycle
dtable = integer(gla+20)+sst ptr
if validate(dtable, readac)=0 start
printstring("DTABLE invalid")
newline
newregs = 0
exit
finish
fbline = byteinteger(dtable)<<8!byteinteger(dtable+1) {Short(DTABLE)}
btype = byteinteger(dtable+12) {name-length, hence blocktype}
if btype>11 start
printstring("Invalid symbol tables")
newline
newregs = 0
return
finish else start
prev blk = byteinteger(dtable+6)<<8!byteinteger(dtable+7)
name = string(dtable+12) {null if block}
finish
if fbline=0 start
print locals(1) {Environmental block - global owns}
exit {to next dynamic level}
finish else if old fbline#0 start
! Have done one textual level already and this (current) textual level
! is not the Environmental block
exit {to next dynamic level}
finish
printstring("Entered from line")
write(fline, 4)
printstring(" of")
if btype=0 then printstring(" block") else print string(" routine/fn/map ".name)
printstring(" starting at line")
write(fbline, 4)
print locals(0)
! Go to next textual level. If this is the environmental block, then
! we shall print the variables therein, else finished.
old fbline = fbline
sst ptr = prev blk
repeat
newline
newregs = nextlnb(lnb)
newregs = 0 if newregs=lnb
routine print locals(integer locenv)
! Param is zero for locals, one for environmentals
integer num, prtd, j, adata
const integer max=511
integer array pt, x(0:max)
routine spec sort
num = 0; prtd = 0
newlines(2)
adata = (dtable+btype+20)&(-4)
if locenv#0 start
if integer(adata)<0 then return {silent for no environmental variables}
! Have we printed these already?
j = 0
while j<ecounter cycle
if environmentals printed(j)=adata then return {Yes: clear off}
j = j+1
repeat
! Add to array of ADATA's for which diags have been printed, to avoid
! being tedious and printing the same several times.
if ecounter<=maxe start
environmentals printed(ecounter) = adata
ecounter = ecounter+1
finish
printstring("Environmental")
finish else start
if integer(adata)<0 then printstring("No l") else printstring("L")
printstring("ocal")
finish
printstring(" variables")
newlines(2)
while integer(adata)>=0 cycle
! Save the ADATA pointer if we have enough room, else squawk once
if num<=max start
pt(num) = adata
num = num+1
finish else start
if prtd=0 start
printstring("Max loc variables!")
newline
prtd = 1
finish
finish
adata = (adata+8+byte integer(adata+4))&(-4)
repeat
! Finally print out the sorted variable names
sort
for j = 0, 1, num-1 cycle
adata = pt(x(j))
if integer(adata)>>28&3=0 then pscalar(adata)
repeat
if arraysize>0 start
for j = 0, 1, num-1 cycle
adata = pt(x(j))
if integer(adata)>>28&3#0 then parr(adata, arraysize)
repeat
finish
routine sort
! DECLARE INTEGER ARRAY X, BOUNDS 0:NUM-1, IN CALLING ROUTINE
integer i, j, hit, n
for i = 0, 1, num-1 cycle
x(i) = i
repeat
for i = num-2, -1, 0 cycle
hit = 0
for n = 0, 1, i cycle
if string(pt(x(n))+4)>string(pt(x(n+1))+4) start
j = x(n)
x(n) = x(n+1)
x(n+1) = j
hit = 1
finish
repeat
if hit=0 then exit
repeat
end {sort}
end {print locals}
!---------------------------------- PSCALAR ----------------------------------
routine pscalar(integer adata)
!***********************************************************************
!* OUTPUT THE NEXT VARIABLE IN THE CURRENT BLOCK. *
!* A VARIABLE ENTRY IN THE TABLES IS:- *
!* FLAG<<20!VBREG<<18!DISP *
!* WHERE:- *
!* VBREG IS VARIABLE'S BASE REGISTER, DISP IS IT'S OFFSET *
!* AND FLAGS=NAM<<6!PREC<<3!TYPE *
!***********************************************************************
integer i, k, vaddr, type, prec, nam
string (11) lname
i = integer(adata)
k = i>>20
type = k&7
prec = k>>4&7
nam = k>>10&1
lname <- string(adata+4)." "
print string(lname."=")
if i&X'40000'=0 then vaddr = lnb else vaddr = gla
vaddr = vaddr+i&X'3FFFF'
print var(type, prec, nam, 1, vaddr)
newline
end ; ! of PSCALAR
!---------------------------------- PRINTVAR ----------------------------------
routine print var(integer type, prec, nam, form, vaddr)
!***********************************************************************
!* output the next variable in the current block. *
!* a variable entry in the tables is:- *
!* flag<<20!vbreg<<18!disp *
!* where:- *
!* vbreg is variable's base register, disp is it's offset *
!* and flags=nam<<6!prec<<3!type *
!***********************************************************************
integer v
const integer unassi=x'80808080'
string (63) mess
switch intv, realv(3:7)
if nam#0 start
if type=0 or type=5 then vaddr=vaddr+4 {%name or %stringname}
vaddr = integer(vaddr)
->not ass if vaddr=unassi or validate(vaddr, readac)=0
finish
->ill ent if prec<3; ! bits not implemented
if prec>=5 or type=3 then v = integer(vaddr)
if type=1 then ->intv(prec)
if type=2 then ->realv(prec)
if type=3 then ->rec
if type=5 then ->str
intv(4): ! 16 bit integer
v = byteinteger(vaddr)<<8!byteinteger(vaddr+1)
!v=shortinteger(vaddr)
mess = "x'".strhex(v)."' ".i to s(v)
->omess
intv(7): ! 128 bit integer
realv(3): ! 8 bit real
realv(4): ! 16 bit real
ill ent: ! should not occurr
mess = "unknown type of variable"
->omess
intv(5): ! 32 bit integer
->not ass if v=un assi
mess = "x'".strhex(v)."' ".i to s(v)
->omess
intv(3): ! 8 bit integer
write(byteinteger(vaddr), 1)
return
realv(5): ! 32 bit real
->not ass if v=un assi
printstring(htos(integer(vaddr), 8))
{ print fl(real(vaddr), 7)}
return
realv(6): ! 64 bit real
->not ass if unassi=integer(vaddr)=integer(vaddr+4)
printstring(htos(integer(vaddr), 8)." ".htos(integer(vaddr+4), 8))
{ print fl(long real(vaddr), 14)}
return
realv(7): ! 128 bit real
->not ass if unassi=integer(vaddr)=integer(vaddr+4)
{ print fl(longreal(vaddr), 14)}
{ %if form=0 %then %start}
printstring(" (R'"); phex(integer(vaddr))
phex(integer(vaddr+4))
space; phex(integer(vaddr+8))
phex(integer(vaddr+12))
printstring("')")
{ %finish}
return
intv(6): ! 64 bit integer
rec: ! record print 1st 4 words
->not ass if un assi=v
mess = "x'".strhex(v).strhex(integer(vaddr+4))
if prec=7 or type=3 then start
mess = mess." ".strhex(integer(vaddr+8)).strhex(integer(vaddr+12))
finish
mess = mess."'"; ->omess
str: ->not ass if byteinteger(vaddr+1)=unassi&255=byteinteger(vaddr)
->toolong if byteinteger(vaddr)>253
mess <- """".string(vaddr).""""
->omess
invalid:
mess = " invalid address ".strhex(vaddr)
->omess
too long:
mess = " too long "; ! assume short strings
->omess
not ass:
mess = " not assigned"
omess:
printstring(mess)
end {print var}
!------------------------------------ XDP --------------------------------------
integer fn xdp(integer refaddr, vaddr, elsize); ! CHECK DUPS
!***********************************************************************
!* CHECK IF VAR THE SAME AS PRINTED LAST TIME *
!***********************************************************************
integer i
for i = 0, 1, elsize-1 cycle
if byteinteger(refaddr+i)#byteinteger(vaddr+i) then result = 0 {different}
repeat
result = 1 {same}
end ; ! of XDP
!------------------------------------ DDV ------------------------------------
routine ddv(integer dvad, integer array name lb, ub); ! decode dope vector.
!***********************************************************************
!* WORK DOWN A DOPE VECTOR DESCRIBED BY WORD DESCRIPTOR DV AND *
!* RETURN SIZE,DIMENSIONALITY AND SUBSCRIPT RANGES IN DATA *
!***********************************************************************
integer i, nd
nd = integer(dvad)
lb(0) = nd; ub(0) = nd
for i = 1, 1, nd cycle
dvad = dvad+12; ! Points to lb/ub/stride for current dimension
lb(i) = integer(dvad)
ub(i) = integer(dvad+4)
repeat
ub(nd+1) = 0
lb(nd+1) = 0
end ; ! of DDV
!------------------------------------ PARR ------------------------------------
routine parr(integer adata, asize)
!***********************************************************************
!* PRINT THE FIRST ASIZE ELEMENTS OF THE ARRAY DEFINED BY VAR *
!* ARRAYNAMES PRINTED ALSO AT PRESENT. UP TO COMPILERS TO AVOID THIS*
!***********************************************************************
integer i, j, k, type, prec, els, nd, vaddr, hdaddr, afirst, elsp, m1, refaddr, elsl, dupseen, dvad
integer array lbs, ubs, subs(0:13)
i = integer(adata)
k = i>>20
prec = k>>4&7
type = k&7
newlines(2)
printstring("Array ".string(adata+4))
if i&X'40000'#0 then vaddr = gla else vaddr = lnb
hdaddr = vaddr+i&X'FFFFF'
! VALIDATE HEADER AND THE 2 DESCRIPTORS
if validate(hdaddr, readac)=0 then ->hinv
dvad = integer(hdaddr+8)
if validate(dvad, readac)=0 then ->hinv
! Check the dope vector: length is 3 + (3 * No. of dimensions).
! The number of dimensions must be greater than zero and not greater than 12
nd = integer(dvad)
unless 0<nd<=12 then ->hinv
afirst = integer(hdaddr+4)
ddv(dvad, lbs, ubs); ! decode dope vector.
! ELS = ELement Size
if type<3 {integer or real} then els = 1<<(prec-3) else start
! record, string
i = dvad+12; ! points to lb/ub/stride for first dimension
els = integer(i+12*(nd-1)+4)
finish
! Print out and check bound pair list
print symbol('(')
j = 0
for i = 1, 1, nd cycle
subs(i) = lbs(i); ! SET UP SUBS TO FIRST EL
write(lbs(i), 1)
print symbol(':')
write(ubs(i), 1)
print symbol(',') unless i=nd
j = 1 if lbs(i)>ubs(i)
repeat
print symbol(')')
newline
if j#0 then printstring("Bound pairs invalid") and return
! Work out how many elements to print on a line
if type=5 then elsp = 1 else if els<=4 then elsp = 6 else elsp = 4
cycle {through all the columns}
! Print column header except for 1-dimensional arrays
if nd>1 then start
print string("
Column (*,")
for i = 2, 1, nd cycle
write(subs(i), 1)
print symbol(',') unless i=nd
repeat
print symbol(')')
finish
! Compute the address of first element of the column
k = 0; m1 = 1; i = 1
while i<=nd cycle
k = k+m1*(subs(i)-lbs(i))
m1 = m1*(ubs(i)-lbs(i)+1)
i = i+1
repeat
vaddr = afirst+k*els
refaddr = 0; ! ADDR OF LAST ACTUALLY PRINTED
dupseen = 0; elsl = 99; ! FORCE FIRST EL ONTO NEW LINE
! Cycle down the column and print the elements. sequences of repeated
! elements are replaced by "(Rpt)". at the start of each line the
! current value of the first subscript is printed followed by a right parenthesis
for i = lbs(1), 1, ubs(1) cycle
if refaddr#0 then start ; ! CHK LAST PRINTED IN THIS COL
k = xdp(refaddr, vaddr, els); ! CHECK DUPS
if k#0 then start
print string("(RPT)") if dupseen=0
dupseen = dupseen+1
->skip
finish
finish
! Start a new line and print subscript value if needed
if dupseen#0 or elsl>=elsp start
newline; write(i, 3); print string(")")
dupseen = 0; elsl = 0
finish
print var(type, prec, 0, 0, vaddr)
elsl = elsl+1
refaddr = vaddr
skip:
vaddr = vaddr+els
asize = asize-1
exit if asize<0
repeat {UNTIL COLUMN FINISHED}
newline
exit if asize<=0 or nd=1
! Update second subscript to next column check for and deal with overflow
! into next or further cloumns
i = 2; subs(1) = lbs(1)
cycle
subs(i) = subs(i)+1
exit unless subs(i)>ubs(i)
subs(i) = lbs(i); ! RESET TO LOWER BOUND
i = i+1
repeat
exit if i>nd; ! ALL DONE
repeat ; ! FOR FURTHER CLOMUNS
return
hinv:
printstring(" has invalid header
")
end ; ! of PARR
end ; ! of rt idiags
end {ndiag}
!---------------------------------- WTFAULT ----------------------------------
external integer fn wtfault alias "S#WTFAULT"(integer inf)
!***********************************************************************
!* TURNS INTERRUPT WT INTO PROPER FAULT FOR COMMON CASES *
!***********************************************************************
const byte integer array tr(0:13)= 1,2,3,4,5,6,7,3,
9,9,7,7,8,10
integer n
n = 10; ! DEFAULT FOR UNUSUAL CASE
if inf=32 then n = 9; ! VSI MSG=ADDRESS ERROR
if inf=64 then n = 211; ! CPU TIME EXCEEDED
if inf=65 then n = 213; ! TERMINATION REQUESTED
if inf<=13 then n = tr(inf)
if inf=136 then n = 13; ! OUTPUT EXCEEDED
if inf=140 then n = 25; ! INPUT ENDED
result = n
! Equiv m/c code (?)
!%const %integer n= 23
!%const %byte %integer %array v(0:2*n+2)= %c
! 0,1,2,3,4,5,6,7,8,9,10,11,12,13,16,18,19,20,21,32, 64, 65,136,140,
! 1,2,3,4,5,6,7,3,9,9, 7, 7, 8,10,39,40,40,41,39, 9,211,213, 13, 25,10
! %if 0<=inf<256 %then %start
! *ld_v
! *lb_inf
! *swne_ %l =24; ! Should be N+1.
! *lss_(%dr +24); ! Should be N+1.
! *exit_-64
! %finish
! %result=10
! **** End of machine code. ****
end {WTFAULT}
!----------------------------------- ermess -----------------------------------
routine ermess(integer n, inf)
const integer maxn=28
const integer array faults(0:maxn)= c
x'501', {1281}
x'505', {1285}
x'601', {1537}
x'602', {1538}
x'701', {1793}
x'801', {2049}
x'802', {2050}
1,2,3,4,5,6,7,8,9,10,
11,12,13,14,15,16,17,18,19,64,
21,
0
const string (32) array fmess(0:maxn)= c
"invalid cycle ",
"illegal exponent ",
"capacity exceeded ",
"array bound fault ",
"resolution fails ",
"unassigned variable ",
"switch label not set ",
"operation exception ",
"privileged operation excp ",
"execute exception ",
"protection execption ",
"addressing exception ",
"specification exception ",
"data exception ",
"fixed point overflow excp ",
"fixed point divide excp ",
"decimal overflow exception ",
"decimal divide exception ",
"exponent overflow excp ",
"exponent underflow excp ",
"significance exception ",
"floating point divide excp ",
"segment translation exception ",
"page translation exception ",
"translation specification excp ",
"special operation exception ",
"monitor event ",
"no result!!!!",
"unknown fault "
integer i, j
return if n<=0
for i = 0, 1, maxn cycle
j = faults(i)
exit if n=faults(i)
repeat
printstring(fmess(i))
if j=0 then printstring(htos(n, 8)) and write(n, 1)
unless inf=0 then write(inf, 1)
printsymbol(nl)
end ; ! ermess
!-------------------------------- VALIDATE GLA --------------------------------
integer fn validate gla(integer address)
! Result = 1 if OK (standard format)
! 0 if not
! -1 if not, but first five words are accessible (to dump)
if validate(address, readac)=0 then result = 0
if address&7#0 or validate(integer(address+8), writeac)=0 or validate(integer(address+12), readac)=0 or c
byteinteger(address+16)>10 then result = -1
result = 1 {OK}
end {validate gla}
!---------------------------------- validate ----------------------------------
integer fn validate(integer address, access)
! Result 1 if address is OK (to read), zero if not OK
result = 1
end {validate}
!---------------------------------- assdump ----------------------------------
routine assdump(integer pcount, lnb, flag)
integer i
newline
printstring("PC = ".strhex(pcount))
newline
printstring("registers:")
newline
dump(lnb, lnb+96, 0)
newline
printstring("code")
newline
dump(pcount-64, pcount+64, 0)
return if flag=0
newline
printstring("gla")
newline
i = integer(lnb+56)
dump(i, i+128, 0)
end {ASSDUMP}
!------------------------------------ dump ------------------------------------
!----------------------------------- TRANS -----------------------------------
routine trans(integer name fault, event, subevent)
!***********************************************************************
!* TRANSLATE FAULT TO EVENT & VICE VERSA *
!***********************************************************************
const integer maxfaults=76
const byte integer array ftoe(0:maxfaults)= c
0,X'12',0,X'11',0,X'13',X'62',X'61',0(3),
X'81',X'F1',X'F2',X'F3',X'55',X'54',
0,X'51',X'17',X'56',0(2),X'21',0,
X'91',X'41',0,X'31',0,X'B1',0,X'71',
0,X'42',0(3),X'82',0(11),X'52',X'53',X'53',X'16',
X'14'(4),0(8),X'14'(2),0(2),
X'A6',X'A3',X'A1',X'A2',X'A4',X'A5',X'A7'
integer k, j
if fault=0 then start ; ! EVENT-SUBEVENT GIVEN
j = event<<4+subevent
return if j=0; ! %monitor
for k = maxfaults, -1, 1 cycle
if j=ftoe(k) then fault = k and return
repeat
finish else start
if 1<=fault<=maxfaults start
k = ftoe(fault)
event = k>>4; subevent = k&15
finish
finish
end {TRANS}
finish
!*
stringfn errs(integer flag)
integer i; string (63) error
if TARGET = 2900 then result = derrs(flag) else START
i = dflag(flag,error)
result = error
FINISH
end
if TARGET = 2900 start
externalroutine on trap(integer class, sub class)
!**********************************************************************
!* *
!* CALLED WHEN A CONTIGENCY OCCURS. READS THE INTERRUPT DATA AND *
!* CALLS THE DIAGNOSTIC ROUTINE WHICH RETURNS TO A PREVIOUSLY DEFINED*
!* ENVIROMENT. *
!* *
!**********************************************************************
integerarray a(0 : 31)
integer flag, i, caddr
caddr = addr(a(0))
flag = read id(caddr); !READ INTERUPT DATA FROM DIRECTOR
if flag = 0 start ; !INTERRUPT DATA READ OK?
select output(0)
print string("ON TRAP ROUTINE ENTERED CLASS =")
write(class,2)
print string(" SUB CLASS =")
write(subclass,2)
printstring(snl. c
"SSN/LNB PSR PC SSR ". c
" SSN/SF IT IC CTB ".snl)
cycle i = 0,4,28
print string(h to s(integer(caddr+i),8)." ")
repeat
print string(snl. c
" XNB B DR0 DR1 ". c
" A0 A1 A2 A3".snl)
cycle i = 32,4,60
printstring(h to s(integer(caddr+i),8)." ")
repeat
printstring(snl." XTRA1 XTRA2".snl)
cycle i = 64,4,68
print string(h to s(integer(caddr+i),8)." ")
repeat
newline
if class = 64 or class = 66 start ; !TIMER INTERRUPT OR OPERATOR MESSAGE IGNORE
if class = 64 start ; !RUN OUT OF INSTRUCTIONS
flag = dset ic(max instructions);!ASK FOR MORE
print string("SET IC X".h to s(max instructions,8). c
" FAILS ".errs(flag).snl) if flag # 0
finish
dresume(0,0,caddr); !RESUME WHERE WE WERE ON INTERRUPT
finish
if class = 65 start ; !SINGLE CHARACTER INTS
-> exit if sub class = 'A'; !ABORT
if sub class # 'Q' start
print string(myname." INT:".to string(subclass). c
" ?".snl)
dresume(0,0,caddr)
finish
!IGNORE UNLESS INT 'Q'
sub class = 213
class = 0
finish else sub class = 10
dresume(-1,0,0); !ALLOW MORE INTS
ndiag(a(2),a(0),sub class,class)
finish else print string("READ ID FAILS ".errs(flag).snl)
exit:
!TO A KNOWN ENVIROMENT
dresume(-1,0,0); !NOTE EXIT FROM ONTRAP
print string(myname." ABORTED".snl)
i = com36
stop if i = 0
*lln_i
*exit_0
end ; !OF ROUTINE ON TRAP
finish else start {NON 2900}
!
externalroutine on trap
!**********************************************************************
!* called when a contigency occurs. reads the interrupt data and *
!* calls the diagnostic routine which returns to a previously defined*
!* enviroment. *
!**********************************************************************
record (dirinff)name dirinf
integer flag, i, class, sub class
dirinf == record(uinf seg << seg shift)
flag = dread id(resregs); !read interupt data from director
class = dirinf_class; sub class = dirinf_sub class
if flag = 0 start ; !interrupt data read ok?
select output(0)
print string("On trap routine entered class =")
write(class,2)
print string(" sub class =")
write(sub class,2)
printstring(snl)
if class = 65 start ; !SINGLE CHARACTER INTS
-> exit if sub class = 'A'; !ABORT
if sub class # 'Q' start
print string(myname." INT:".to string(subclass)." ?".snl)
FLAG = dresume(resREGS)
stop
finish
!IGNORE UNLESS INT 'Q'
sub class = 213
class = 0
finish else sub class = 10
ndiag(resregs(1),0 {not required},sub class,class)
flag = dresume( resregs)
stop
finish else print string("Read id fails ".errs(flag).snl)
exit :
! go to a known enviroment
print string(myname." aborted".snl)
stop if com36 = 0
move(48, com36+16, addr(resregs(6)) ) {move GR 4-15 into regs}
resregs(1) = resregs(17) {GR 15 -> PSW1}
resregs(41) = 0 {CR 15 = 0 => RUN}
flag = dresume( resregs)
stop
end ; !of routine on trap
finish {NON 2900}
!*
!*
!*
endoffile