COMPRT
* /--- FILE TYPE = E
* /--- BLOCK START 00 000 81/10/30 15.12
PROGRAM COMPRT(INPUT=1002,TAPE2,OUTPUT=1002,
X TAPE1=INPUT,TAPE4=OUTPUT)
*
* THIS PROGRAM PRINTS A CROSS-REFERENCE LISTING OF
* THE COMMON SYMBOL TABLE FOR THE PLATO SYSTEM.
*
* WRITTEN BY DOUG BROWN
* CONVERTED TO NOS BY TIM HALVORSEN
*
*
* CALL PROGRAM WITH FOLLOWING CARD --
*
* LGO,SOURCE,BINARY.
*
* WHERE *SOURCE* IS THE OUTPUT FILE FROM THE
* COMPILATION OF THE COMMON STUFF. *BINARY*
* IS THE BINARY OF THE SYSTEM TO CROSS REFERENCE.
*
IMPLICIT INTEGER(A-Z)
LOGICAL ERROR
COMMON /PRINT/ SUBHEAD(13),PLINES,DATIME(2),
X LASTLET,MESSAGE(3),BLKLTH
*
* THESE TABLES SHOULD HAVE THE FOLLOWING SIZES --
*
* BUFFER -- BUFLTH
* LINKS -- NLINKS
* COMMONS,CINFO,LCT -- NCOMS
* TEXTS -- TEXTL
* CGUNK -- TCOML
*
DIMENSION BUFFER(8000)
DIMENSION LINKS(8000)
DIMENSION COMMONS(40),CINFO(40),LCT(40)
DIMENSION TEXTS(600)
DIMENSION CGUNK(8000)
*
* THE FOLLOWING DECLARATIONS ARE FIXED SIZE --
*
DIMENSION QREF(6,14)
DIMENSION PSH(3)
DIMENSION QLINKS(2),QBUFF(2),QCOM(2)
DIMENSION QGUNK(2),QTEXT(2)
DIMENSION NAMER(7),ADDRR(6),BLOCKR(7)
*
* THESE ARE THE PARAMETERS TO FUSS WITH --
* BE SURE TO CHANGE THE DIMENSIONS OF THE ABOVE
* ARRAYS THAT ALSO REFERENCE A PARAMETER.
*
* --NOTE-- NLINKS AND TCOML CANNOT EXCEED 16000 UNLESS
* THE TABLE FORMATS ARE CHANGED. MWW 80/6/9.
*
DATA (NLINKS=8000),(BUFLTH=8000),(NCOMS=40)
DATA (LOADFWA=111B),(TEXTL=600),(TCOML=8000)
DATA (BLKLTH=320)
*
* COMPILER PARAMETERS
*
DATA (COLNAME=11),(COLADDR=22),(COLBLOK=33)
*
* THESE ARE MASKS; DONT FUSS WITH THEM --
*
DATA (L9= 7777 7777 7777 7777 7700 B)
DATA (L8= 7777 7777 7777 7777 0000 B)
DATA (L7= 7777 7777 7777 7700 0000 B)
DATA (L6= 7777 7777 7777 0000 0000 B)
DATA (L5= 7777 7777 7700 0000 0000 B)
DATA (L4= 7777 7777 0000 0000 0000 B)
DATA (L3= 7777 7700 0000 0000 0000 B)
DATA (L2= 7777 0000 0000 0000 0000 B)
DATA (L1= 7700 0000 0000 0000 0000 B)
DATA (R9= 0077 7777 7777 7777 7777 B)
DATA (R8= 0000 7777 7777 7777 7777 B)
DATA (R7= 0000 0077 7777 7777 7777 B)
DATA (R6= 0000 0000 7777 7777 7777 B)
DATA (R5= 0000 0000 0077 7777 7777 B)
DATA (R4= 0000 0000 0000 7777 7777 B)
DATA (R3= 0000 0000 0000 0077 7777 B)
DATA (R2= 0000 0000 0000 0000 7777 B)
DATA (R1= 0000 0000 0000 0000 0077 B)
DATA (HISIGN= 4000 0000 0000 0000 0000 B)
DATA (LOSIGN= 0000 0000 0040 0000 0000 B)
*
* /--- BLOCK FORMATS 00 000 80/06/10 03.08
*
* TAPE USAGE
* 1=FIXED INPUT - COMPILER OUTPUT WITH COMMON NAMES
* 2=FIXED INPUT - BINARY
* 4=OUTPUT
*
*
* THIS IS THE TABLE STRUCTURE -
*
* LINKS(X)=42/PROGRAM,4/N.REFS,14/NEXT.LINK
* NLI IS LENGTH (LAST USED INDEX)
* NLINKS IS MAXIMUM LENGTH
*
* COMMONS(ALPHA)=42/NAME,18/PTR
* CINFO(PTR)=6/0,18/A.ADDR,18/LTH,18/FWA
* NCO IS LENGTH
* LCT(CHRON)=SAME AS CINFO
* LCTLTH IS LENGTH
* NCOMS IS MAXIMUM LENGTH OF ALL
*
* TEXTS(WHATEVER)=10/0,5/WC,18/B.ADDR,9/LR,18/L
* NTXT IS LENGTH
* TEXTL IS MAXIMUM LENGTH
*
* ECS RESIDENT -- USES WORDS 0 THROUGH (TCOML-1)
* CGUNK(FWA+VALUE)=24/0,18/FIRST,18/LAST
* (PASS 2 = 42/NAME,18/FIRST)
* CGL IS LENGTH
* TCOML IS MAXIMUM LENGTH
* CGUNK(FWA+BL) IS AOR (VALUE .GE. BL)
* CGUNK(FWA+BL+1) IS GOK (NOT DONE BY TEXT)
*
* /--- BLOCK INITIAL 00 000 80/06/13 10.01
*
* GET THE PROPER AMOUNT OF ECS (USED BY GETNAME
* FOR SWAPPING AREA FOR THE *COMMONS* TABLE)
*
CALL GETECX(BLKLTH+NCOMS)
*
* THIS IS FOR THE PAGE HEADERS
*
CALL DATE(DATIME(2))
CALL TIME(DATIME(1))
CALL NEWPAGE
*
* THESE ARE FOR THE GENERAL ERROR CHECKS
* AND BOMB-OFF MESSAGES.
*
QLINKS(1)=NLINKS
QLINKS(2)=10HNLINKS
QBUFF(1)=BUFLTH
QBUFF(2)=10HBUFLTH
QCOM(1)=NCOMS
QCOM(2)=10HNCOMS
QGUNK(1)=TCOML
QGUNK(2)=10HTCOML
QTEXT(1)=TEXTL
QTEXT(2)=10HTEXTL
*
* NOW TO INITIALIZE THE TABLES
*
DO 10 I=1,TCOML
* CALL WRITEC(0,I-1,1)
CGUNK(I)=0
10 CONTINUE
CGL=0
PSH(1)=0
PSH(2)=45
PSH(3)=30
NLI=0
MAXBUF=0
MAXTXT=0
NCO=0
*
* START LOADING AT *NWA*
*
NWA=LOADFWA
*
* (0,0) LOAD ADDRESS
*
OVERA=0
REWIND 1
REWIND 2
* /--- BLOCK LINKING 00 000 76/12/15 14.29
*
* NOW SEARCH THROUGH THE BINARY
*
300 MESSAGE(1)=10H LINKING
MESSAGE(3)=0
*
* READ A RECORD FROM THE BINARY
*
310 BUFFER IN(2,1)(BUFFER(1),BUFFER(BUFLTH))
IF(UNIT(2))330,500,500
330 NN=LENGTH(2)
CALL CHECK(NN,QBUFF)
MAXBUF=MAX0(NN,MAXBUF)
IF((BUFFER(1).AND.L7).NE.7LOVERLAY)GOTO 337
IF(NWA.EQ.LOADFWA) GOTO 310
IF(OVERA.EQ.0)OVERA=NWA+1
NWA=OVERA
GOTO 310
* BUFFER POINTER
337 PT=1
PIDL=LCTLTH=NTXT=0
* CODE NUMBER
340 CN=SHIFT(BUFFER(PT),6).AND.77B
* WORD COUNT
WC=SHIFT(BUFFER(PT),24).AND.7777B
* RELOCATION
LR=SHIFT(BUFFER(PT),-18).AND.777B
* LOAD ADDRESS
LLL=BUFFER(PT).AND.777777B
*
* DETERMINE IF TABLE WITH INFO THAT WE WANT
*
* TEXT
IF(CN.EQ.40B)GOTO 360
* FILL
IF(CN.EQ.42B)GOTO 370
* PIDL
IF(CN.EQ.34B)GOTO 390
*
* GO ON TO NEXT TABLE
*
350 PT=PT+WC+1
IF(PT.LE.NN)GOTO 340
GOTO 310
*
* -TEXT- TABLE
* USE TO GET WHICH WORD OF COMMON BLOCK REFERENCED
*
360 CALL CHECK(NTXT,QTEXT)
NTXT=NTXT+1
MAXTXT=MAX0(NTXT,MAXTXT)
TEXTS(NTXT)=SHIFT(WC-2,45).OR.SHIFT(PT+2,27)
X .OR.SHIFT(LR,18).OR.LLL
GOTO 350
* /--- BLOCK LINKING 00 000 80/06/10 03.13
*
* -FILL- TABLE
* TELLS REFERENCES TO COMMON
*
370 DO 389 SUBPT=1,WC
WORD=BUFFER(PT+SUBPT)
HW=0
372 IF(WORD.LT.0)GOTO 374
AR=SHIFT(WORD,30).AND.777B
GOTO 385
374 IF(AR.LE.2)GOTO 385
FWA=LCT(AR-2).AND.R3
BL=SHIFT(LCT(AR-2),-18).AND.R3
RLOC=SHIFT(WORD,30).AND.777 777 777 B
PPP=SHIFT(WORD,3).AND.3
DO 375 TT=1,NTXT
TTT=TEXTS(TT).AND.777 777 777 B
IF(RLOC.LT.TTT)GOTO 375
UUU=TTT+(SHIFT(TEXTS(TT),15).AND.37B)
IF(RLOC.GT.UUU)GOTO 375
BADD=SHIFT(TEXTS(TT),33).AND.R3
BADD=BADD+RLOC-TTT
BITSHF=PSH(PPP+1)
CADD=SHIFT(BUFFER(BADD),BITSHF).AND.R3
IF(CADD.GT.BL)CADD=BL
GOTO 376
375 CONTINUE
CADD=BL+1
376 CALL CHECK(NLI,QLINKS)
CADD=CADD+FWA
* CALL READEC(ECGUNK,CADD,1)
ECGUNK=CGUNK(1+CADD)
* IF NOT FIRST LINK
IF(ECGUNK.NE.0)GOTO 378
NLI=NLI+1
ECGUNK=NLI.OR.SHIFT(NLI,18)
* CALL WRITEC(ECGUNK,CADD,1)
CGUNK(1+CADD)=ECGUNK
LINKS(NLI)=IDENT.OR.SHIFT(1,14)
GOTO 385
378 LLAST=ECGUNK.AND.R3
LASTP=LINKS(LLAST).AND.L7
* SENSE NEW PROGRAM
IF(LASTP.NE.IDENT)GOTO 382
NUM=SHIFT(LINKS(LLAST),-14).AND.17B
IF(NUM.LT.15)NUM=NUM+1
LINKS(LLAST)=IDENT.OR.SHIFT(NUM,14)
GOTO 385
382 NLI=NLI+1
LINKS(NLI)=IDENT.OR.SHIFT(1,14)
LINKS(LLAST)=LINKS(LLAST).OR.NLI
ECGUNK=(ECGUNK.AND.L7).OR.NLI
* CALL WRITEC(ECGUNK,CADD,1)
CGUNK(1+CADD)=ECGUNK
385 IF(HW.NE.0)GOTO 389
WORD=SHIFT(WORD,30)
HW=1
GOTO 372
389 CONTINUE
GOTO 350
*
* -PIDL- TABLE
* HAS THE PROGRAM AND COMMON BLOCK LENGTHS
*
390 IDENT=BUFFER(PT+1).AND.L7
PL=BUFFER(PT+1).AND.R3
IF(WC.LT.2)GOTO 397
DO 395 I=2,WC
CNAME=BUFFER(PT+I).AND.L7
BL=BUFFER(PT+I).AND.R3
OLDLTH=NCO
CALL GETNAME(CNAME,COMMONS,NCO,QCOM,RET)
* IF ALREADY THERE, BYPASS FOLLOWING
IF(OLDLTH.EQ.NCO)GOTO 393
CINFO(RET)=SHIFT(BL,18).OR.CGL.OR.SHIFT(NWA,36)
CGL=CGL+BL+2
CALL CHECK(CGL,QGUNK)
NWA=NWA+BL
393 CONTINUE
LCTLTH=LCTLTH+1
LCT(LCTLTH)=CINFO(RET).AND.R6
395 CONTINUE
* SENSE NOT FIRST ONE IN RECORD
397 IF(PIDL.NE.0) GOTO 350
PIDL=1
* THIS PROGRAM ADDRESS
TPA=NWA
* AND UPDATE NEXT-WORD-ADDRESS
NWA=NWA+PL
MESSAGE(2)=IDENT
CALL BDISP(MESSAGE)
GOTO 350
* /--- BLOCK NAMING 00 000 80/06/10 03.16
*
* GET THE NAMES OF THE COMMON VARIABLES
*
500 CONTINUE
MESSAGE(1)=10HGETTING CO
MESSAGE(2)=10HMMON NAMES
CALL BDISP(MESSAGE)
CALL ECHECK(NCO,7HCOMMONS)
*
* MAKE ROOM FOR THE NAMES
*
DO 510 I=1,CGL
* ECA=I-1
* CALL READEC(ECGUNK,ECA,1)
* ECGUNK=SHIFT(ECGUNK,-12)
* CALL WRITEC(ECGUNK,ECA,1)
CGUNK(I)=SHIFT(CGUNK(I),-18)
510 CONTINUE
520 READ(1,5200)D1,NAMER,D2,ADDRR,D3,BLOCKR,D4
5200 FORMAT(R8,7R1,R2,6R1,R5,7R1,R8)
IF(EOF(1))400,522
522 IF(D1.NE.8R )GOTO 520
IF(D2.NE.2R )GOTO 520
IF(D3.NE.5R )GOTO 520
IF(D4.NE.8R )GOTO 520
CALL NAMIT(NAMER,NAME)
IF(NAME.EQ.0) GOTO 520
CALL NAMIT(BLOCKR,BLOCK)
IF(BLOCK.EQ.0)GOTO 520
CALL ATOO(ADDRR,ADDR)
IF(ADDR.LT.0)GOTO 520
CALL BCHOP(BLOCK,COMMONS,NCO,RET)
IF(RET.LT.0)GOTO 520
RET=COMMONS(RET).AND.R3
FWA=CINFO(RET).AND.R3
LTH=SHIFT(CINFO(RET),-18).AND.R3
IF(ADDR.GE.LTH)GOTO 520
ECA=FWA+ADDR
* CALL READEC(ECGUNK,ECA,1)
ECGUNK=CGUNK(1+ECA)
ECGUNK=NAME.OR.(ECGUNK.AND.R3)
* CALL WRITEC(ECGUNK,ECA,1)
CGUNK(1+ECA)=ECGUNK
GOTO 520
* /--- BLOCK PRINTING 00 000 80/06/10 03.47
*
* NOW TO PRINT THE TABLES
*
400 MESSAGE(1)=10H PRINTING
MESSAGE(3)=0
ENCODE(130,4200,SUBHEAD)
4200 FORMAT(6X,*BLOCK RELATIVE ABSOLUTE NAME*
X 6X,*PROGRAMS WITH REFERENCES*
X *(NUMBER OF REFERENCES)*)
DO 490 PT=1,NCO
HI=COMMONS(PT).AND.L7
PTR=COMMONS(PT).AND.R3
MESSAGE(2)=HI
CALL BDISP(MESSAGE)
CALL CSLASH(HI)
FWA=CINFO(PTR).AND.R3
LTH=SHIFT(CINFO(PTR),-18).AND.R3
ABS=SHIFT(CINFO(PTR),-36).AND.R3
IF(LTH.EQ.0) GOTO 490
QZONK=LTH+2
DO 489 FAKPT=1,QZONK
SUBPT=FAKPT-1
J=SUBPT
CALL OTOA(J,HJ)
K=ABS+J
CALL OTOA(K,HK)
ECA=FWA+SUBPT
* CALL READEC(ECGUNK,ECA,1)
ECGUNK=CGUNK(1+ECA)
HL=ECGUNK.AND.L7
NL=ECGUNK.AND.R3
* IGNORE IF NO REFERENCES
IF(NL.EQ.0)GOTO 489
* SENSE IF REGULAR OR NOT
IF(SUBPT.LT.LTH)GOTO 440
IF(SUBPT.EQ.LTH)HL=5H*AOR*
IF(SUBPT.EQ.(LTH+1))HL=5H*GOK*
440 CALL CLEAN(HL)
*
* GET LINKS AND NUMBER OF REFS AND PRINT THEM
*
LP=0
450 LP=LP+1
NAME=LINKS(NL).AND.L7
NUMBER=SHIFT(LINKS(NL),-14).AND.17B
IF(NUMBER.EQ.15)NUMBER=63
CALL PACK(NAME,NUMBER,QREF(LP,1))
NL=LINKS(NL).AND.37777B
* TEST IF OUTPUT LINE FULL
IF(LP.EQ.6)GOTO 460
* SEE IF ANY MORE REFERENCES
IF(NL.NE.0)GOTO 450
460 CALL NEXTLN
PRINT 4600,HI,HJ,HK,HL,((QREF(M,N),N=1,14),M=1,LP)
4600 FORMAT(6X,4A10,84R1)
HI=1H
IF(NL.EQ.0)GOTO 489
* THE FOLLOWING IS FOR CONTINUED LINES
HJ=HK=HL=1H
GOTO 440
489 CONTINUE
490 CONTINUE
*
* ALL DONE - PRINT TABLE LENGTH INFO
*
PRINT 4900,NLI,NLINKS,NCO,NCOMS,MAXTXT,TEXTL,
X CGL,TCOML,MAXBUF,BUFLTH
4900 FORMAT(/////* REFERENCES *I5*/*I5
X *, COMMON BLOCKS *I5*/*I5
X *, TEXT TABLES *I5*/*I5 /
X *, COMMON WORDS *I5*/*I5
X *, MAXIMUM RECORD SIZE *I5*/*I5)
STOP
END
* /--- BLOCK ROUTINES 00 000 76/12/15 14.07
SUBROUTINE ATOO(IN,OUT)
*
* ALPHA TO OCTAL CONVERSION ROUTINE
*
IMPLICIT INTEGER(A-Z)
DIMENSION IN(6)
OUT=0
DO 10 I=1,6
TEMP=IN(I)
IF(TEMP.EQ.1R )GOTO 10
IF(TEMP.GT.1R7)GOTO 99
IF(TEMP.LT.1R0)GOTO 99
OUT=SHIFT(OUT,3).OR.(TEMP-1R0)
10 CONTINUE
RETURN
99 OUT=-1
END
SUBROUTINE NAMIT(IN,OUT)
*
* CONVERT AN NAME IN THE FORM OF AN ARRAY (ONE CHARACTER
* PER ENTRY) TO A SINGLE WORD, LEFT-JUSTIFIED.
*
IMPLICIT INTEGER(A-Z)
DIMENSION IN(7)
OUT=0
BITSHF=54
DO 10 I=1,7
TEMP=IN(I)
IF(TEMP.EQ.1R )RETURN
OUT=OUT.OR.SHIFT(TEMP,BITSHF)
BITSHF=BITSHF-6
10 CONTINUE
NAME=0
RETURN
END