V10/cmd/pfort/LOOKUP.f

      INTEGER FUNCTION LOOKUP(K1, LABEL)
C
C     STMT(PSTMT)-STMT(K2-1) TO BE ENTERED IN DSA
C     LABEL IS TRUE IF SYMBOL IS A LABEL.  ROUTINE
C     RETURNS VALUE OF INDEX OF SYMBOL IN DSA, CREATING
C     A NEW ENTRY ID NESESSARY.  IT ENTERS SYMBOL INTO
C     SYMBOL OR LABEL CHAIN AND CREATES A CROSSREFERENCE
C     ENTRY FOR THE CURRENT STATMT NUMBER
C
      INTEGER PSTMT, SYMLEN, DSA, HASH, L(6), LL(6)
      INTEGER BLANK, SYMHD, STMT, OUTUT, BNEXT, Q(70)
      INTEGER PDSA, OUTUT2, OUTUT3, OUTUT4
      LOGICAL LABEL, ERR, P1ERR, OPT, SYSERR, ABORT
      COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
     *    OUTUT4
      COMMON /DETECT/ ERR, SYSERR, ABORT
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /CHASH/ LHASH, HASH(401)
      COMMON /TRANS/ Q
      COMMON /OPTNS/ OPT(5), P1ERR
      DATA BLANK /1H /
      K = K1 - PSTMT
      IF (K.LE.6) GO TO 10
      CALL ERROR1(39H IDENTIFIER TOO LONG, WILL BE TRUNCATED, 39)
      K = 6
   10 KK = K
      DO 20 I=1,K
        II = PSTMT + I - 1
        J = STMT(II) + 1
        LL(I) = Q(J)
   20 CONTINUE
      DO 30 I=1,SYMLEN
        L(I) = BLANK
   30 CONTINUE
      CALL S5PACK(LL, L, K)
C
C     HAVE PACKED SYMBOL;NOW CALCULATE HASH
C     HASH IS(PRODUCT OF FIRST AND THIRD LETTERS PLUS SECOND) MOD 257
C
      IF (KK.LT.3) GO TO 50
      IHASHS = STMT(PSTMT)*STMT(PSTMT+2) + STMT(PSTMT+1)
   40 IHASHS = MOD(IHASHS,LHASH)
      ISAVE = IHASHS
      IHASH = IHASHS + 1
      GO TO 80
   50 IHASHS = STMT(PSTMT)
      GO TO (60, 70), KK
   60 IHASHS = IHASHS*69 + 69
      GO TO 40
   70 IHASHS = IHASHS*69 + STMT(PSTMT+1)
      GO TO 40
   80 IF (HASH(IHASH).EQ.0) GO TO 140
C
C     IF TABLE EMPTY, CREATE ENTRY, SEND BACK INDEX OF FIRST WORD IN DSA
C     ELSE COMPARE SYMBOL TO ID AND RETURN INDEX OF PROPER ENTRY IN HASH
C     TABLE  AFTER RESOLVING COLLISION
C
      DO 90 J=1,SYMLEN
        II = HASH(IHASH) + 3 + J
        IF (L(J).NE.DSA(II)) GO TO 100
   90 CONTINUE
      LOOKUP = HASH(IHASH)
      IF (DSA(LOOKUP+1)) 190, 190, 200
C
C     RESOLVE CONFLICTS BY LINEAR CONGRUENCE
C
  100 IHASHS = MOD(IHASHS+1,LHASH)
      IF (IHASHS.EQ.ISAVE) GO TO 110
      IHASH = IHASHS + 1
      GO TO 80
  110 CALL ERROR1(34H IN LOOKUP, TABLE OVERFLOW OF HASH, 34)
  120 SYSERR = .TRUE.
      RETURN
  130 CALL ERROR1(33H IN LOOKUP, TABLE OVERFLOW OF DSA, 33)
      GO TO 120
C
C     CREATE NEW SYMBOL TABLE ENTRY; ZERO ITS CROSSREF TAIL PTR
C
  140 HASH(IHASH) = NEXT
      IF (NEXT+6+SYMLEN.GE.BNEXT) GO TO 130
      LOOKUP = NEXT
C
C*****DSA
C     1ST WORD..... ATTRIBUTE WORD
C     FIELD 1
C
C     BITS 0-2*TYPE (FOR SYMBOL) 0 DOUBLE PRECISION, 1 REAL, 2 INT,
C      3 COMPLEX,4 LOGICAL, 5 HOLLERITH
C      TYPE (FOR LABEL) 1 EXECUTABLE STMT, 2 NONEXEC. STMT,
C      3 FORMAT STMT
C     BIT 3****EXPLICITLY TYPED 1, IMPLICITLY 0
C     FIELD 2
C     BIT 4****(FOR SYMBOL) IN COMMON 1, NOT IN COMMON 0
C      (FOR LABEL) DEFINED 1, REFERENCED 0
C      (FOR COMMON-NAME) INITIALIZED IN BLOCK DATA SUBPGM
C     FIELD 3
C     BIT 5****EQUIVALENCED 1
C     FIELD 4
C     BIT 6****DUMMY SUBROUTINE/FUNCTION ARGUMENT 1
C     FIELD 5
C     BIT 7****VALUE SET BY P.U. 1
C     FIELD 6
C     BIT 8****VARIABLE USED AS DIMENSION IN VARIABLY DIMENSIONED ARRAY
C     FIELD 7
C     BIT 9-10*SCALAR 0, NUMBER OF ARRAY BOUNDS 1,2,3
C     FIELD 8
C     BITS 11-15**USAGE--UNSET 0, ASF ARG 1, ASF FCN 2, CURRENT P. U.=
C     SUBR 3, CURRENT P.U.=FCN 4, EXTERNAL FCN 5, EXTERNAL SUBR 6,
C     COMMON-NAME 7, ASSIGN/GOTO VARIABLE 8,LABEL 9, VARIABLE 10,
C     CURRENT P.U.=BLOCK DATA 11, CURRENT P.U.=MAIN 12, EXTERNAL ENTITY
C     13, INTRINSIC FCN 14
C     BITS 5-8 ARE 0 IF ENTRY CORRESPONDS TO ENTITY WITHOUT THE
C     ATTRIBUTE MENTIONED
C
C     2ND WD..... XREF LIST TAIL POINTER
C     3D WORD.....EXTRA INFO POINTER
C
C     FOR A VARIABLE, 3D WORD POINTS TO A 2 WORD BLOCK, FIRST WORD
C     CONTAINING STORAGE UNIT LENGTH OF THE VARIABLE (-1 IF VARIABLY
C     DIMENSIONED ARRAY);  SECOND WORD CONTAINING INDEX OF COMMON
C     ENTRY IN DSA;
C     FOR A LABEL, 3D WORD CONTAINS POINTER TO 2 WORD BLOCK ; AFTER
C     LABEL DEFINED, FIRST WORD CONTAINS STMT NUMBER OF FIRST STMT
C     IN CURRENT DO NESTING LEVEL; SECOND WORD CONTAINS NEGATIVE THE
C     NESTING LEVEL;  WHEN END OF THIS NESTING LEVEL IS ENCOUNTERED
C     ALL 2ND WORDS FOR THAT LEVEL ARE UPDATED TO CONTAIN STMT NUMBER
C     OF LAST STMT AT THAT NESTING LEVEL;
C     FOR A COMMON-NAME, 3D WORD POINTS TO HEAD OF LINEAR LINKED LIST
C     OF INDICES OF DSA ENTRIES FOR ORDERED ELEMENTS IN THAT COMMON;
C     FOR THE CURRENT P.U. IF ITS A SUBR OR FCN, 3D WORD CONTAINS
C     A LINEAR LINKED LIST OF INDICES IN DSA OF ENTRIES FOR ORDERED
C     DUMMIES OF THAT SUBPGM;
C
C     4TH WORD..... CHAIN POINTER TO ENTRY IN DSA FOR LAST SYMBOL
C     OR LABEL FOR WHICH A NEW ENTRY WAS CREATED
C     5-7TH WORD.....PACKED CHARACTERS OF SYMBOL OR LABEL
C
      J = NEXT + 2
      DO 150 I=NEXT,J
        DSA(I) = 0
  150 CONTINUE
      J = J + 1
      DO 160 I=1,SYMLEN
        II = I + J
        DSA(II) = L(I)
  160 CONTINUE
C
C     SETONE OF THE CHAIN POINTERS TO PUT THIS SYMBOL ON CHAIN
C
      IF (LABEL) GO TO 170
      DSA(J) = SYMHD
      SYMHD = NEXT
      GO TO 180
  170 DSA(J) = LABHD
      LABHD = NEXT
  180 NEXT = 4 + SYMLEN + NEXT
C
C     BEGINNEW XREF LIST
C
  190 IF (.NOT.LABEL .AND. .NOT.OPT(2)) GO TO 210
      IF (NEXT+2.GE.BNEXT) GO TO 130
      DSA(BNEXT-1) = NOST
      DSA(LOOKUP+1) = BNEXT - 1
      DSA(BNEXT) = BNEXT - 1
      BNEXT = BNEXT - 2
      GO TO 210
C
C     XREF LIST UPDATE; CHECK TO SEE IF STATEMENT NUMBER IS ALREADY
C     THERE
C
  200 IF (.NOT.LABEL .AND. .NOT.OPT(2)) GO TO 210
      IF (NEXT+2.GE.BNEXT) GO TO 130
      J = DSA(LOOKUP+1)
      IF (DSA(J).EQ.NOST) GO TO 210
      DSA(BNEXT) = DSA(J+1)
      DSA(J+1) = BNEXT - 1
      DSA(LOOKUP+1) = BNEXT - 1
      DSA(BNEXT-1) = NOST
      BNEXT = BNEXT - 2
  210 RETURN
      END