! NOTE NEW VERSION OF THIS GLOBAL ARRY
!
CONSTSTRING (10)ARRAY LT(0:7)=" !???! "," IMP "," FORTRAN ",
" IMPS "," ASMBLR "," ALGOL(E) ",
" OPTCODE "," PASCAL "
!*
! 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.
SYSTEMROUTINE INDIAG(INTEGER OLDLNB, LANG, PCOUNT,MODE,DIAG,ASIZE, C
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,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
IF FIRST=1 THEN GLOBPTR=0
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)
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 ELSE FLINE=INTEGER(OLDLNB+I)
NEWLINE
IF MODE=1 THEN PRINTSTRING(LT(LANG)) ELSE START
IF FIRST=1 THEN FIRST=0 AND PRINTSTRING("DIAGNOSTICS ")
PRINTSTRING("ENTERED FROM")
FINISH
IF WORD0>>16=0 THENSTART
IF MODE=0 THEN PRINTSTRING(LT(LANG))
PRINTSTRING("ENVIRONMENTAL BLOCK
")
FINISHELSESTART
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 THENSTART
PRINTSTRING("(MODULE ".STRING(ASIZE).")")
FINISH
NEWLINE
IF LANG#ALGOL THEN I=20 ELSE I=16
IF MODE=0 OR DIAG>1 THEN START
PRINT LOCALS(TSTART+I+(WORD3>>26)<<2,"LOCAL")
IF WORD1&X'C0000000'#0 THEN START ;! EXTERNAL(ETC) ROUTINE
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 PRINT LOCALS(INTEGER ADATA,STRING (15)LOC)
!***********************************************************************
!* ADATA POINTS TO THE FIRST ENTRY FOR LOCALS IN THE SYMBOL TABLES*
!***********************************************************************
INTEGER I,NRECS,SADATA
IF LOC="GLOBAL" THEN START
I=0
WHILE I<GLOBPTR CYCLE
IF GLOBAD(I)=ADATA THEN RETURN
I=I+1
REPEAT
IF GLOBPTR<=20 THEN 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 THEN PRINT SCALAR(VARS(I))
REPEAT
IF ASIZE>0 THEN START
CYCLE I=1,1,NRECS
IF VARS(I)_VAL>>28&3#0 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,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)
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)
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
CYCLE I=1,1,ND
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(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,BASEADDR,ELSPERLINE,C
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
ENDOFFILE