SYSTEMROUTINESPEC MOVE(INTEGER LEN, FROM, TO)
EXTERNALROUTINESPEC DUMP(INTEGER START, FINISH, PRINT START)
EXTERNALSTRINGFNSPEC H TO S(INTEGER I, J)
EXTRINSICINTEGER COM36; !ADDRESS OF A RESTART ENVIROMENT
EXTRINSICINTEGER BOTTOM OF STACK; !ADDRESS ON STACK DIAGS ARE TO BE UNWOUND TO
!*
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) IF FAULT # 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,PCOUNT,0,2,100,FIRST,NEWLNB)
! IMP DIAGS
NEXTRT: !CONTINUE TO UNWIND STACK
IF NEWLNB = 0 THEN -> EXIT
PCOUNT = INTEGER(OLDLNB+8)
OLDLNB = NEWLNB
-> EXIT IF OLDLNB < BOTTOM OF STACK;! FAR ENOUGH
I = INTEGER(OLDLNB+16)
LANGFLAG = INTEGER(I+16)>>24
LANGFLAG = 0 IF LANGFLAG > 7
-> LANGUAGE(LANGFLAG)
LANGUAGE(2): ! FORTRAN
LANGUAGE(7): !PASCAL
PRINT STRING(LT(LANGFLAG)." ??
")
-> NEXT RT
EOUT: ! ERRROR EXIT
PRINT STRING("DIAGS FAIL LOOPING
")
EXIT:
ACTIVE = 0
RETURN IF FAULT = 0 = EVENT
I = COM36; ! ADDRESS OF REGISTER SAVE AREA
!ON ENTRY
STOP IF I = 0; !NO WHERE TO GO TO
*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) *
!***********************************************************************
ROUTINESPEC PRINT LOCALS(INTEGER ADATA, STRING (15) LOC)
ROUTINESPEC PRINT SCALAR(RECORDNAME VAR)
ROUTINESPEC PRINT ARR(RECORDNAME 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
RECORDFORMAT F(INTEGER VAL, STRING (11) VNAME)
OWNINTEGERARRAY GLOBAD(0 : 20)
OWNINTEGER GLOBPTR
STRING (10) STMNT
STRING (20) PROC
STRING (50) NAME
CONSTINTEGER ALGOL = 5; ! LANGUAGE CODE
GLOBPTR = 0 IF FIRST = 1
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
UNTIL PREVBLK = 0 CYCLE
TSTART = TSTART+INTEGER(GLAAD+12)
WORD0 = INTEGER(TSTART)
WORD1 = INTEGER(TSTART+4)
WORD2 = INTEGER(TSTART+8)
WORD3 = INTEGER(TSTART+12)
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 START
PRINT LOCALS(TSTART+I+(WORD3>>26)<<2,"LOCAL")
IF WORD1&X'C0000000' # 0 START ;!GLOBALS?
I = WORD1&X'3FFFF'+INTEGER(GLAAD+12)+I
PRINT LOCALS(I,"GLOBAL")
FINISH
FINISH
IF WORD3 # 0 START
NEWLNB = INTEGER(OLDLNB)
UNLESS DIAG = 1 THEN NEWLINE
RETURN
FINISH
FINISH
PREV BLK = WORD1&X'FFFF'
TSTART = PREV BLK
REPEAT
NEWLNB = 0
NEWLINE; RETURN
ROUTINE QSORT(RECORDARRAYNAME A, INTEGER I, J)
RECORDSPEC A(F)
RECORD D(F)
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, STRING (15) LOC)
!***********************************************************************
!* ADATA POINTS TO THE FIRST ENTRY FOR LOCALS IN THE SYMBOL TABLES*
!***********************************************************************
INTEGER NRECS, SADATA, I
IF LOC = "GLOBAL" START
I = 0
WHILE I < GLOBPTR CYCLE
RETURN IF GLOBAD(I) = ADATA
I = I+1
REPEAT
IF GLOBPTR <= 20 START
GLOBAD(GLOBPTR) = ADATA
GLOBPTR = GLOBPTR+1
FINISH
FINISH
NEWLINE
IF INTEGER(ADATA) < 0 THEN PRINTSTRING("NO ")
PRINTSTRING(LOC." 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
RECORDARRAY VARS(1 : NRECS)(F)
INTEGER I
ADATA = SADATA
CYCLE I = 1,1,NRECS
VARS(I) <- RECORD(ADATA)
ADATA = ADATA+8+BYTEINTEGER(ADATA+4)&(-4)
REPEAT
QSORT(VARS,1,NRECS)
CYCLE I = 1,1,NRECS
IF VARS(I)_VAL>>28&3 = 0 C
THEN PRINT SCALAR(VARS(I))
REPEAT
IF ASIZE > 0 THEN START
CYCLE I = 1,1,NRECS
IF VARS(I)_VAL>>28&3 # 0 C
THEN PRINT ARR(VARS(I),ASIZE)
REPEAT
FINISH
END
END
ROUTINE PRINT SCALAR(RECORDNAME 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 *
!***********************************************************************
RECORDSPEC VAR(F)
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
ND = (DV>>32)&255; ND = ND//3
LB(0) = ND; UB(0) = ND
AD = INTEGER(ADDR(DV)+4)+12*(ND-1)
CYCLE I = 1,1,ND
U = INTEGER(AD+8)//INTEGER(AD+4)-1
LB(I) = INTEGER(AD)
UB(I) = LB(I)+U
AD = AD-12
REPEAT
UB(ND+1) = 0
LB(ND+1) = 0
END
ROUTINE PRINT ARR(RECORDNAME 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*
!***********************************************************************
RECORDSPEC VAR(F)
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
CYCLE I = 1,1,ND
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 (*,")
CYCLE I = 2,1,ND
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
CYCLE I = LBS(1),1,UBS(1)
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,
9,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("X".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 "," "," "," ","OBS ",
"VAL ","CYD ","INCA ","MODD ","PRCL ","J ","JLK ","CALL ",
"ADB ","SBB ","DEBJ ","CPB ","SIG ","MYB ","VMY ","CPIB ",
"LCT ","MPSR ","CPSR ","STCL ","EXIT ","ESEX ","OUT ","ACT ",
"SL ","SLSS ","SLSD ","SLSQ ","ST ","STUH ","STXN ","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 OPS(OPCODE>>1) = " " START
INSL = 16
FLAG = 1
FINISH ELSE START
IF 2 <= OPCODE <= 8 THEN TERTIARY DECODE C
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
PRINT STRING(H TO S(J,8)." ")
CYCLE I = 3,-1,0
J = (INS>>(8*I))&X'FF'
IF 32 <= J <= 95 THEN PRINTSYMBOL(J) C
ELSE PRINT STRING(".")
EXIT IF I = 2 AND INSL = 16
REPEAT
IF INSL = 16 THEN PRINT STRING(" ".H TO S( C
INS>>16,4)) ELSE PRINT STRING(" ".H TO S(INS,8))
RETURN IF FLAG = 1
PRINTSTRING(" ".OPS(OPCODE>>1)." ")
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 C
THEN START
IF (N>>16) > 1 THEN N = -(N! C
X'FFFC0000') AND PRINT STRING("-")
FINISH
PRINTSYMBOL(HX((N>>16)&3))
PRINT STRING(H TO S(N,4))
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))
PRINT STRING(H TO S(N,4))
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"
!*
ROUTINE 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
!*
!*
!*
ENDOFFILE