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