Return to LOOKUP.f CVS log

Up to [Research Unix] / researchv10no / cmd / pfort

Annotation of researchv10no/cmd/pfort/LOOKUP.f, revision 1.1

1.1     ! root        1:       INTEGER FUNCTION LOOKUP(K1, LABEL)
        !             2: C
        !             3: C     STMT(PSTMT)-STMT(K2-1) TO BE ENTERED IN DSA
        !             4: C     LABEL IS TRUE IF SYMBOL IS A LABEL.  ROUTINE
        !             5: C     RETURNS VALUE OF INDEX OF SYMBOL IN DSA, CREATING
        !             6: C     A NEW ENTRY ID NESESSARY.  IT ENTERS SYMBOL INTO
        !             7: C     SYMBOL OR LABEL CHAIN AND CREATES A CROSSREFERENCE
        !             8: C     ENTRY FOR THE CURRENT STATMT NUMBER
        !             9: C
        !            10:       INTEGER PSTMT, SYMLEN, DSA, HASH, L(6), LL(6)
        !            11:       INTEGER BLANK, SYMHD, STMT, OUTUT, BNEXT, Q(70)
        !            12:       INTEGER PDSA, OUTUT2, OUTUT3, OUTUT4
        !            13:       LOGICAL LABEL, ERR, P1ERR, OPT, SYSERR, ABORT
        !            14:       COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
        !            15:      *    OUTUT4
        !            16:       COMMON /DETECT/ ERR, SYSERR, ABORT
        !            17:       COMMON /FACTS/ NAME, NOST, ITYP, IASF
        !            18:       COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
        !            19:       COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
        !            20:       COMMON /CTABL/ LDSA, PDSA, DSA(5000)
        !            21:       COMMON /CHASH/ LHASH, HASH(401)
        !            22:       COMMON /TRANS/ Q
        !            23:       COMMON /OPTNS/ OPT(5), P1ERR
        !            24:       DATA BLANK /1H /
        !            25:       K = K1 - PSTMT
        !            26:       IF (K.LE.6) GO TO 10
        !            27:       CALL ERROR1(39H IDENTIFIER TOO LONG, WILL BE TRUNCATED, 39)
        !            28:       K = 6
        !            29:    10 KK = K
        !            30:       DO 20 I=1,K
        !            31:         II = PSTMT + I - 1
        !            32:         J = STMT(II) + 1
        !            33:         LL(I) = Q(J)
        !            34:    20 CONTINUE
        !            35:       DO 30 I=1,SYMLEN
        !            36:         L(I) = BLANK
        !            37:    30 CONTINUE
        !            38:       CALL S5PACK(LL, L, K)
        !            39: C
        !            40: C     HAVE PACKED SYMBOL;NOW CALCULATE HASH
        !            41: C     HASH IS(PRODUCT OF FIRST AND THIRD LETTERS PLUS SECOND) MOD 257
        !            42: C
        !            43:       IF (KK.LT.3) GO TO 50
        !            44:       IHASHS = STMT(PSTMT)*STMT(PSTMT+2) + STMT(PSTMT+1)
        !            45:    40 IHASHS = MOD(IHASHS,LHASH)
        !            46:       ISAVE = IHASHS
        !            47:       IHASH = IHASHS + 1
        !            48:       GO TO 80
        !            49:    50 IHASHS = STMT(PSTMT)
        !            50:       GO TO (60, 70), KK
        !            51:    60 IHASHS = IHASHS*69 + 69
        !            52:       GO TO 40
        !            53:    70 IHASHS = IHASHS*69 + STMT(PSTMT+1)
        !            54:       GO TO 40
        !            55:    80 IF (HASH(IHASH).EQ.0) GO TO 140
        !            56: C
        !            57: C     IF TABLE EMPTY, CREATE ENTRY, SEND BACK INDEX OF FIRST WORD IN DSA
        !            58: C     ELSE COMPARE SYMBOL TO ID AND RETURN INDEX OF PROPER ENTRY IN HASH
        !            59: C     TABLE  AFTER RESOLVING COLLISION
        !            60: C
        !            61:       DO 90 J=1,SYMLEN
        !            62:         II = HASH(IHASH) + 3 + J
        !            63:         IF (L(J).NE.DSA(II)) GO TO 100
        !            64:    90 CONTINUE
        !            65:       LOOKUP = HASH(IHASH)
        !            66:       IF (DSA(LOOKUP+1)) 190, 190, 200
        !            67: C
        !            68: C     RESOLVE CONFLICTS BY LINEAR CONGRUENCE
        !            69: C
        !            70:   100 IHASHS = MOD(IHASHS+1,LHASH)
        !            71:       IF (IHASHS.EQ.ISAVE) GO TO 110
        !            72:       IHASH = IHASHS + 1
        !            73:       GO TO 80
        !            74:   110 CALL ERROR1(34H IN LOOKUP, TABLE OVERFLOW OF HASH, 34)
        !            75:   120 SYSERR = .TRUE.
        !            76:       RETURN
        !            77:   130 CALL ERROR1(33H IN LOOKUP, TABLE OVERFLOW OF DSA, 33)
        !            78:       GO TO 120
        !            79: C
        !            80: C     CREATE NEW SYMBOL TABLE ENTRY; ZERO ITS CROSSREF TAIL PTR
        !            81: C
        !            82:   140 HASH(IHASH) = NEXT
        !            83:       IF (NEXT+6+SYMLEN.GE.BNEXT) GO TO 130
        !            84:       LOOKUP = NEXT
        !            85: C
        !            86: C*****DSA
        !            87: C     1ST WORD..... ATTRIBUTE WORD
        !            88: C     FIELD 1
        !            89: C
        !            90: C     BITS 0-2*TYPE (FOR SYMBOL) 0 DOUBLE PRECISION, 1 REAL, 2 INT,
        !            91: C      3 COMPLEX,4 LOGICAL, 5 HOLLERITH
        !            92: C      TYPE (FOR LABEL) 1 EXECUTABLE STMT, 2 NONEXEC. STMT,
        !            93: C      3 FORMAT STMT
        !            94: C     BIT 3****EXPLICITLY TYPED 1, IMPLICITLY 0
        !            95: C     FIELD 2
        !            96: C     BIT 4****(FOR SYMBOL) IN COMMON 1, NOT IN COMMON 0
        !            97: C      (FOR LABEL) DEFINED 1, REFERENCED 0
        !            98: C      (FOR COMMON-NAME) INITIALIZED IN BLOCK DATA SUBPGM
        !            99: C     FIELD 3
        !           100: C     BIT 5****EQUIVALENCED 1
        !           101: C     FIELD 4
        !           102: C     BIT 6****DUMMY SUBROUTINE/FUNCTION ARGUMENT 1
        !           103: C     FIELD 5
        !           104: C     BIT 7****VALUE SET BY P.U. 1
        !           105: C     FIELD 6
        !           106: C     BIT 8****VARIABLE USED AS DIMENSION IN VARIABLY DIMENSIONED ARRAY
        !           107: C     FIELD 7
        !           108: C     BIT 9-10*SCALAR 0, NUMBER OF ARRAY BOUNDS 1,2,3
        !           109: C     FIELD 8
        !           110: C     BITS 11-15**USAGE--UNSET 0, ASF ARG 1, ASF FCN 2, CURRENT P. U.=
        !           111: C     SUBR 3, CURRENT P.U.=FCN 4, EXTERNAL FCN 5, EXTERNAL SUBR 6,
        !           112: C     COMMON-NAME 7, ASSIGN/GOTO VARIABLE 8,LABEL 9, VARIABLE 10,
        !           113: C     CURRENT P.U.=BLOCK DATA 11, CURRENT P.U.=MAIN 12, EXTERNAL ENTITY
        !           114: C     13, INTRINSIC FCN 14
        !           115: C     BITS 5-8 ARE 0 IF ENTRY CORRESPONDS TO ENTITY WITHOUT THE
        !           116: C     ATTRIBUTE MENTIONED
        !           117: C
        !           118: C     2ND WD..... XREF LIST TAIL POINTER
        !           119: C     3D WORD.....EXTRA INFO POINTER
        !           120: C
        !           121: C     FOR A VARIABLE, 3D WORD POINTS TO A 2 WORD BLOCK, FIRST WORD
        !           122: C     CONTAINING STORAGE UNIT LENGTH OF THE VARIABLE (-1 IF VARIABLY
        !           123: C     DIMENSIONED ARRAY);  SECOND WORD CONTAINING INDEX OF COMMON
        !           124: C     ENTRY IN DSA;
        !           125: C     FOR A LABEL, 3D WORD CONTAINS POINTER TO 2 WORD BLOCK ; AFTER
        !           126: C     LABEL DEFINED, FIRST WORD CONTAINS STMT NUMBER OF FIRST STMT
        !           127: C     IN CURRENT DO NESTING LEVEL; SECOND WORD CONTAINS NEGATIVE THE
        !           128: C     NESTING LEVEL;  WHEN END OF THIS NESTING LEVEL IS ENCOUNTERED
        !           129: C     ALL 2ND WORDS FOR THAT LEVEL ARE UPDATED TO CONTAIN STMT NUMBER
        !           130: C     OF LAST STMT AT THAT NESTING LEVEL;
        !           131: C     FOR A COMMON-NAME, 3D WORD POINTS TO HEAD OF LINEAR LINKED LIST
        !           132: C     OF INDICES OF DSA ENTRIES FOR ORDERED ELEMENTS IN THAT COMMON;
        !           133: C     FOR THE CURRENT P.U. IF ITS A SUBR OR FCN, 3D WORD CONTAINS
        !           134: C     A LINEAR LINKED LIST OF INDICES IN DSA OF ENTRIES FOR ORDERED
        !           135: C     DUMMIES OF THAT SUBPGM;
        !           136: C
        !           137: C     4TH WORD..... CHAIN POINTER TO ENTRY IN DSA FOR LAST SYMBOL
        !           138: C     OR LABEL FOR WHICH A NEW ENTRY WAS CREATED
        !           139: C     5-7TH WORD.....PACKED CHARACTERS OF SYMBOL OR LABEL
        !           140: C
        !           141:       J = NEXT + 2
        !           142:       DO 150 I=NEXT,J
        !           143:         DSA(I) = 0
        !           144:   150 CONTINUE
        !           145:       J = J + 1
        !           146:       DO 160 I=1,SYMLEN
        !           147:         II = I + J
        !           148:         DSA(II) = L(I)
        !           149:   160 CONTINUE
        !           150: C
        !           151: C     SETONE OF THE CHAIN POINTERS TO PUT THIS SYMBOL ON CHAIN
        !           152: C
        !           153:       IF (LABEL) GO TO 170
        !           154:       DSA(J) = SYMHD
        !           155:       SYMHD = NEXT
        !           156:       GO TO 180
        !           157:   170 DSA(J) = LABHD
        !           158:       LABHD = NEXT
        !           159:   180 NEXT = 4 + SYMLEN + NEXT
        !           160: C
        !           161: C     BEGINNEW XREF LIST
        !           162: C
        !           163:   190 IF (.NOT.LABEL .AND. .NOT.OPT(2)) GO TO 210
        !           164:       IF (NEXT+2.GE.BNEXT) GO TO 130
        !           165:       DSA(BNEXT-1) = NOST
        !           166:       DSA(LOOKUP+1) = BNEXT - 1
        !           167:       DSA(BNEXT) = BNEXT - 1
        !           168:       BNEXT = BNEXT - 2
        !           169:       GO TO 210
        !           170: C
        !           171: C     XREF LIST UPDATE; CHECK TO SEE IF STATEMENT NUMBER IS ALREADY
        !           172: C     THERE
        !           173: C
        !           174:   200 IF (.NOT.LABEL .AND. .NOT.OPT(2)) GO TO 210
        !           175:       IF (NEXT+2.GE.BNEXT) GO TO 130
        !           176:       J = DSA(LOOKUP+1)
        !           177:       IF (DSA(J).EQ.NOST) GO TO 210
        !           178:       DSA(BNEXT) = DSA(J+1)
        !           179:       DSA(J+1) = BNEXT - 1
        !           180:       DSA(LOOKUP+1) = BNEXT - 1
        !           181:       DSA(BNEXT-1) = NOST
        !           182:       BNEXT = BNEXT - 2
        !           183:   210 RETURN
        !           184:       END

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.