V10/cmd/pfort/SETREF.f
SUBROUTINE SETREF(GREEN,INDIR)
INTEGER CHK1, KBR(1)
INTEGER REF, PREF, PDSA, DSA, PLAT, PNODE, FINDND, SYMLEN
LOGICAL ERR, SYSERR, ABORT, COMPAR, GREEN, INDIR
COMMON /HEAD/ LNODE, PNODE, NODE(500)
COMMON/ SCR1/ LINODE, INODE(500)
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /CREF/ LREF, PREF, REF(100)
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
COMMON /TABL/ NEXT, LABHD, ISYM, IBNEXT
DATA IBR /1/, JBR /3/, KBR(1) /0/
C
C GREEN = T IF ENCOUNTER EXTERNAL ENTITIES AT ALL
C INDIR = T IF ENCOUNTER ANY INDIRECT REFS
C READS IN ALL REFS FOR A PROGRAM UNIT; FINDS MISSING
C SUBPROGRAM REFS AND DISCARDS THEM; CHECKS ASF REFS AND
C DISCARDS THEM; WRITES INDIRECT REFS OUT ON I6 WITHOUT
C PROCESSING; DOES MINIMAL CHECKING OF DIRECT REFS
C CREATING PAR/DESC LINKS AND WRITING GOOD
C REFS OUT ON I6, AFTER DONE WITH REFS, SEARCHES
C FOR EXTERNAL ENTITIES (USAGE 13) TO FIX UP LEVELS
C
IJK = FINDND(DSA(NAME+4),IIJK)
C READ IN A NEW REF; IF HIT END OF REFS RECORD
C END OF REFS ON I6 AND RETURN
10 IF (INREF(I5)) 20, 20, 80
C WRITE END OF REFS
20 WRITE (I6) IBR, JBR, IBR
C CHECK FOR NON DUMMY EXTERNALS IN SYMBOL TABLE WHICH
C C AUSE CHANGES IN LEVEL CALCS
K = ISYM
30 IF (K) 40, 40, 50
150 SYSERR=.TRUE.
CALL ERROR1(33H IN SETREF, TABLE OVERFLOW OF LAT,33)
40 RETURN
50 IF (IGATT1(K,8).NE.13 .OR. IGATT1(K,4).EQ.1) GO TO 70
L = FINDND(DSA(K+4),IL)
IF (L.NE.0) GO TO 60
CALL ERROR2(18H MISSING EXTERNAL , 18, DSA(K+4), 1, 1, 0)
CALL ERROR2(1H1,0,KBR(1),-1, 0, 1)
GO TO 70
C FOUND AN EXTERNAL ENTITY
60 GREEN = .TRUE.
C ENTER ONTO GREEN LINKS LIST AT NODE
N = IJK + SYMLEN + 3
C J IS HEAD OF GREEN LINKS LIST (SEE SETPD)
160 IF(LAT(N+1).LE.0) GOTO 170
N = LAT(N+1)
GOTO 160
170 J = N+1
IF(PLAT+2.GT.LLAT) GOTO 150
LAT(PLAT) = -L
LAT(PLAT+1) = LAT(J)
LAT(J) = -PLAT
PLAT = PLAT+2
IF(-2.EQ.INODE(IL).OR.INODE(IL).GT.INODE(IIJK)) GOTO 70
INODE(IL) = INODE(IIJK) + 1
CALL ASLEV(-IL)
IF (ABORT .OR. SYSERR) GO TO 40
70 K = DSA(K+3)
GO TO 30
C
C REF IS WD1--NUMBER OF ARGS(2 WD ENTRIES)
C WD2--PTR TO PGM UNIT CALLED IN DSA
C WD3--STMT NO OF CALL
C WD4--CODE, 0 FOR SUBR REFS; 1 FOR FCN REFS
C WD5+-ARG ENTRIES (WD1-SYMBOL TABLE INDEX OR 0
C WD2-TYPE/STRUCTURE INFO)
C
80 IF (REF(4).LT.4) GO TO 100
C
C ASF REFERENCE; CHECKED AND THEN DISCARDED
C
K1 = PNODE - 1
DO 90 I=1,K1
IF (NODE(I).GE.0) GO TO 90
IJR = IABS(NODE(I))
L = IJR + SYMLEN + 3
L = LAT(L)
K = REF(2)
C
C IF HAVE ASF REF, FIND ASF BY NAME AND PAR CHECKS
C
IF (COMPAR(DSA(K+4),LAT(IJR)) .AND. LAT(L).EQ.IJK) GO TO 110
90 CONTINUE
L = REF(2) + 4
CALL ERROR2(18H MISSING ASF DEFN , 18, DSA(L), 1, 1, 0)
CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
GO TO 10
C
C WRITE INDIRECT REF OUT ON I6
C
100 K2 = IGATT1(REF(2),4)
IF(K2.EQ.0) GOTO 140
INDIR = .TRUE.
GOTO 130
C CHECK FOR MISSING SUBPROGRAM
140 K1 = REF(2)
IJR = FINDND(DSA(K1+4),IIJR)
IF (IJR.NE.0) GO TO 110
CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(K1+4), 1
* ,1, 0)
CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
GO TO 10
C CHECK DIRECT REFS AND ASF REFS
C 1 MEANS OK 0 MEANS N.G.
110 IF (CHK1(IJK,IJR)) 10, 10, 120
120 IF (REF(4).EQ.4) GO TO 10
C GOOD DIRECT REF; CREATE PAR/DES LINKS
CALL SETPD(IJR, IJK)
IF (SYSERR) GO TO 40
IF (-2.EQ.INODE(IIJR) .OR. INODE(IIJR).GT.INODE(IIJK)) GO TO 130
C FIX UP LEVELS
INODE(IIJR) = INODE(IIJK) + 1
CALL ASLEV(IIJR)
IF (SYSERR .OR. ABORT) GO TO 40
130 WRITE (I6) PREF, IBR, (REF(L),L=1,PREF)
GO TO 10
END