C GXREF% EDIT GLOBAL CROSS REFERENCE LISTING. PRODUCES C TWO LISTINGS, DEPENDING ON WHICH ENTRY POINT IS USED C (GXREFB LISTS BY BLOCK) SUBROUTINE GXREF @ INTENDED AS FIRST ENTRY IMPLICIT INTEGER (A-Z) COMMON/ITEM/NAME,BLOCK,W3,ELT,VERS,DEFNAM,ELT2,VERS2 DEFINE FLAG = FLD(15,3,W3) DEFINE SEQ = FLD(0,15,W3) DEFINE RSQ = FLD(18,18,W3) DEFINE MFL = FLD(0,6,BLOCK) @ ZERO FOR MODULE CHECKER DEFINE MID = FLD(6,6,BLOCK) @ SUBTYPE FOR MODULE CHECKING DEFINE MSEQ = FLD(0,18,W3) @ SEQUENCE NUMBER FOR MODULE CHECKING LOGICAL SVZ DEFINE SVZ(I,J) = I/BOOL(2**J) DEFINE MARNO = FLD(18,18,W3) @ ARGUMENT NUMBER FOR MODULE CHECKING DEFINE MTY = FLD(18,3,BLOCK) @ TYPE OF ARGUMENT FOR MODULE CHECKING DEFINE MSID = FLD (21,3,BLOCK) @ DEFINES MODE OF ARGUMENT DEFINE MFMD = FLD(30,3,BLOCK) @ DEFINES MODE OF FNC/SUB/ENT INTEGER FNCNME(2,3)/'SUBROU','TINE','ENTRY ',' ','FUNCTI','ON'/ INTEGER TLT(7) /'Y','I','R','D','C','L','B'/ INTEGER RLT(7) /'Y','V','A','C','AE','EX','FN'/ INTEGER FTYPE(2,7) /'UNREFE','RENCED','INTEGE','R','REAL',' ' *,'DOUBLE',' PREC', 'COMPLE','X','LOGICA','L','BOOLEA','N'/ INTEGER FMODE(2,6) /'LABEL',' ','VARIAB','LE','ARRAY ',' ', * 'FUNCTI','ON','*VARIA','BLE*','*ARRAY','*'/ INTEGER IDTB(7)/O1,O22,O44,O2,O66,O2,O10/ INTEGER BUF(30),WDX,CHX PARAMETER MAXWDX = 21 DATA O1000,O10000/O1000,O10000/ C----- C INITIALIZE C----- ASSIGN 200 TO NEWITM WRITE(6,5000) 'NAME' GO TO 100 C----- C ENTRY POINT FOR BLOCK LIST C----- ENTRY GXREFB ASSIGN 250 TO NEWITM WRITE (6,5000) 'BLOCK' C 100 CONTINUE GENERATE (P,1,1,4) BUF(P) = ' ' OLDN = -1 OLDB = -1 OLDR = -1 WDX = 1 150 CALL GETITM(NAME,$950) RSA = RSQ GO TO NEWITM @ START DOING IT C---- C GET NEW BY-NAME ITEM C---- 200 IF(FLD(0,12,BLOCK).EQ.10) GO TO 610 @ REFERENCE IF(FLD(0,12,BLOCK).EQ.8) GO TO 620 @ DEFINITION IF(NAME.EQ.OLDN.AND.BLOCK.EQ.OLDB.AND.RSA.EQ.OLDR) GO TO 400 STARS = ' ' @ ASSUME NAME UNIQUE IF(NAME.EQ.OLDN) STARS = '**' @ NAME WAS REUSED WRITE(6,6000) (BUF(I),I=1,WDX) IF(BLOCK.NE.0) WRITE(6,5100) STARS,NAME,BLOCK,RSA IF(BLOCK.EQ.0) WRITE(6,5200) STARS,NAME GO TO 300 C----- C GET NEW BY-BLOCK ITEM. C----- 250 IF(FLD(0,12,BLOCK).EQ.10) GO TO 150 @ REFERENCE IF(FLD(0,12,BLOCK).EQ.8) GO TO 150 @ DEFINITION IF(NAME.EQ.OLDN.AND.BLOCK.EQ.OLDB.AND.RSA.EQ.OLDR) GO TO 400 STARS = ' ' IF(BLOCK.EQ.OLDB.AND.RSA.EQ.OLDR) STARS = '**' @ RENAMED STORAGE WRITE(6,6000) (BUF(I),I=1,WDX) IF(BLOCK.NE.0) WRITE(6,5300) STARS,BLOCK,RSA,NAME IF(BLOCK.EQ.0) WRITE(6,5400) STARS,NAME C----- C FINISH CHANGE OF ENTITY C---- 300 OLDN = NAME OLDB=BLOCK OLDR =RSA GO TO 410 @ BYPASS TEST AND FLUSH C NORMAL NEW REFERENCE C---- 400 IF(ELT.EQ.OLDE.AND.VERS.EQ.OLDV) GO TO 450 IF(IZ.EQ.1) WRITE(6,6000) (BUF(I),I=1,WDX) IZ=0 OLDE = ELT OLDV = VERS 410 WDX = 1 @ SET UP FIRST LINE CHX = -6 @ FOR ELEMENT CALL ENAME (ELT) IF(ELT2.NE.' ') CALL ENAME(ELT2) IF(VERS.EQ. ' ') GO TO 420 CALL PC(1R/) CALL ENAME (VERS) IF(VERS2.NE.' ') CALL ENAME(VERS2) 420 CALL PC(1R ) CALL PC(1R ) GO TO 470 @ BY PASS COMMA C---- C EDIT A REFERENCE C---- 450 SVWDX = WDX IF(FLAG.EQ.1) IZ = 1 451 SVCHX = CHX CALL PC(1R,) CALL PC(1R ) 470 IF(FLAG.GT.1) CALL PC(1R*) @ DEFN POINT SB= 27 @ SEQUENCE NUMBER IF(SEQ.GT.O1000) SB = 24 IF(SEQ.GT.O10000) SB=21 DO 480 I=SB,33,3 480 CALL PC(FLD(I,3,SEQ)+1R0) IF(DEFNAM.EQ.0) GO TO 490 CALL PC(1R() @ EDIT DEFINE NAME CALL ENAME(DEFNAM) CALL PC(1R)) 490 IF(WDX-MAXWDX) 150,500,510 500 IF(CHX.LT.30) GO TO 150 510 WDX = SVWDX @ MUST START NEW LINE CHX = SVCHX DO 520 I=1,6 520 CALL PC(1R ) WRITE(6,6000) ( BUF(I),I=1,SVWDX) BUF(1) = ' ' WDX = 1 CHX = 18 GO TO 470 @ REDO IT GUARANTEED NO OVERFLOW 950 WRITE (6,6000)(BUF(I),I=1,WDX) RETURN C 620 CONTINUE @ PROCESS DEFINITION HERE IF(RFLG.NE.0) WRITE(6,6000) (BUF(I),I=1,WDX) @ CLOSE OUT LAST LINE ENDIF IF(NAME.NE.SNAME) WDX = 1 ; CHX = -6 CALL ENAME(FNCNME(1,MFMD)) ; CALL ENAME(FNCNME(2,MFMD)) CALL PC (1R ) ; CALL PC (1R ) CALL ENAME(NAME) ; CALL PC(1R ) ; CALL PC(1R ) CALL ENAME('AT') ; CALL PC(1R ) SB = 27 IF(MSEQ.GT.01000) SB = 24 IF(MSEQ.GT.010000) SB = 21 DO 625 I = SB,33,3 625 CALL PC(FLD(I,3,MSEQ)+1R0) CALL PC (1R ) ; CALL ENAME('IN') ; CALL PC (1R ) CALL ENAME(ELT) ; IF(ELT2.NE.' ') CALL ENAME(ELT2) IF(VERS.NE.' ') CALL PC(1R/) ; CALL ENAME(VERS) IF(VERS2.NE.' ') CALL ENAME(VERS2) ENDIF DO I = 1,6 CALL PC(1R ) ENDLOOP WRITE(6,6000) (BUF(I),I=1,WDX) ENDIF ARNO = MARNO @ SAVE ARGUMENT NUMBER SNAME = NAME @ SAVE NAME STYPE = MTY @ SAVE TYPE OF DEFINITION SMODE = MSID @ SAVE MODE OF DEFINITION IF(ARNO.EQ.0) RFLG = 0 ; ERFL = 0 ; GO TO 150 WDX = 2 @ SET TO COLUMN 6 CHX = -6 BUF(1) = ' ' ; BUF(2) = ' ' CALL ENAME('ARGUM') CALL ENAME('ENT') CALL PC(1R ) CALL PC(1R ) CALL PC(1R ) IF(ARNO.LE.9) CALL PC(MOD(ARNO,10)+1R0) ELSE CALL PC(ARNO/10+1R0) CALL PC(MOD(ARNO,10)+1R0) ENDIF CALL PC(1R ) CALL PC(1R ) CALL PC(1R ) CALL ENAME (FTYPE(1,MTY+1)) ; CALL ENAME (FTYPE(2,MTY+1)) CALL PC(1R/) CALL ENAME (FMODE(1,MSID+1)) ; CALL ENAME(FMODE(2,MSID+1)) RFLG = 0 @ FORCE DEFINITION TO NEW LINE ERFL = 0 @ SHOW DEFINITION OCCURRED WRITE(6,6000) (BUF(I),I=1,WDX) @ CLOSE OUT LAST LINE GO TO 150 @ GET NEXT GROUP 610 CONTINUE @ PROCESS REFERENCE HERE IF(NAME.NE.SNAME) GO TO 630 IF(MARNO.NE.ARNO) GO TO 640 615 IF(RFLG.NE.0) IF(WDX.GT.15) WRITE(6,6000) (BUF(I) ,I=1,WDX) WDX = 3 ; CHX = -6 ELSE CALL PC(1R,) ENDIF ELSE WDX = 3 @ SKIP TO COLUMN 18 CHX = -6 BUF(1) = ' ' ; BUF(2) = ' ' ENDIF SB = 27 IF(MSEQ.GT.01000) SB = 24 IF(MSEQ.GT.010000) SB = 21 DO I = SB,33,3 CALL PC(FLD(I,3,MSEQ)+1R0) ENDLOOP CALL PC(1R() CALL ENAME(ELT) IF(ELT2.NE.' ') CALL ENAME(ELT2) IF(VERS.NE.' ') CALL PC(1R/) ; CALL ENAME(VERS) * ; IF(VERS2.NE.' ') CALL ENAME (VERS2) CALL PC(1R)) IF(ARNO.EQ.0) RFLG = 1 ; GO TO 150 ITF = ' ' @ SET TO ASTERISK IF TYPES DO NOT MATCH IMF = ' ' @ SET TO ASTERISK IF MODES DO NOT MATCH CALL PC(1R ) CALL PC(1R ) IF(MTY.NE.STYPE) ITF = 1R* CALL PC(FLD(0,6,TLT(MTY+1))) @ LETTER DEFINING TYPE CALL PC(1R/) CALL PC(FLD(0,6,RLT(MSID+1))) CALL PC(FLD(6,6,RLT(MSID+1))) @ LETTER DEFINING MODE IF(.NOT.SVZ(IDTB(SMODE),MSID)) IMF = 1R* IF(ERFL.NE.0) IMF = 1R ; ITF = 1R CALL PC(ITF) @ FLAG FOR TYPE MISMATCH CALL PC(ITF) @ FLAG FOR MODE MISMATCH RFLG= 1 @ SHOW AT LEAST ONE DEFINITION PRINTED GO TO 150 @ GET NEXT ITEM 630 CONTINUE IF(RFLG.NE.0) WRITE(6,6000) (BUF(I),I=1,WDX) * ;WDX = 3 ; CHX = -6 WRITE(6,6300) NAME 6300 FORMAT(' REFERENCE TO UNDEFINED FUNCTION ',A6) 635 CONTINUE ARNO = MARNO ; SNAME = NAME RFLG = 0 EFRL = 1 GO TO 615 640 CONTINUE IF(RFLG.NE.0) WRITE(6,6000) (BUF(I),I=1,WDX) * ;WDX = 3 ; CHX = -6 WRITE(6,6400) MARNO 6400 FORMAT(' NO DEFINITION FOR ARGUMENT ',I4) GO TO 635 5000 FORMAT ('1 GLOBAL CROSS-REFERENCE BY ',A6//) 5100 FORMAT ('0',A2,1X,A6,' /',A6,'/ ',O6/) 5200 FORMAT ('0',A2,1X,A6,'(EXTERNAL)'/) 5300 FORMAT ('0',A2,' /',A6,'/ ',O6,' = ',A6/) 5400 FORMAT ('0',A2,' (EXTERNAL) ',A6/) 6000 FORMAT (7X,20A6,A5) C SUBROUTINE PC(C) CHX=CHX+6 IF(CHX.NE.36) GO TO 10 CHX = 0 WDX = WDX +1 BUF(WDX) = ' ' 10 FLD(CHX,6,BUF(WDX)) = C RETURN C SUBROUTINE ENAME (N) DO 10 I=0,30,6 10 IF(FLD(I,6,N).NE.1R ) CALL PC(FLD(I,6,N)) RETURN C END