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