Return to SUBFCN.f CVS log

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

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

1.1     ! root        1:       SUBROUTINE SUBFCN(TYPE)
        !             2: C
        !             3: C     TYPE IS EXPLICIT TYPE OF FUNCTION, ELSE IS -1
        !             4: C     ALL FCNS GIVEN EXPLICIT TYPE SINCE FCN NAME CANNOT APPEAR IN
        !             5: C     NONEXECUTABLE STMT WITHIN FCN SUBPRGM EXCEPT HEAD STMT
        !             6: C     ROUTINES DEFINES SUBROUTINE AND FUNCTION NAMES AND CREATES
        !             7: C     LINKED LISTS OF POINTERS TO THEIR ARGUMENTS IN DSA.
        !             8: C     SETS NAME TO POINT TO CURRENT FUNCN OR SUBRTNE.  IN CASE
        !             9: C     OF BAD SYNTAX IN NAME CONSTRUCT OR FCN WITHOUT PARAMS.,
        !            10: C     PROGRAM UNIT BECOMES MAIN PGM BY DEFAULT
        !            11: C
        !            12:       INTEGER STMT, PSTMT, DSA, SYMHD, TYPE, BNEXT, S(5), PDSA
        !            13:       LOGICAL ERR, SYSERR, ABORT
        !            14:       COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
        !            15:       COMMON /FACTS/ NAME, NOST, ITYP, IASF
        !            16:       COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
        !            17:       COMMON /CTABL/ LDSA, PDSA, DSA(5000)
        !            18:       COMMON /DETECT/ ERR, SYSERR, ABORT
        !            19:       DATA S(1) /66/, S(2) /42/, S(3) /30/, S(4) /38/, S(5) /43/
        !            20:       KCELL = 0
        !            21:       CALL NEXTOK(PSTMT, K2, I1)
        !            22:       IF (I1.NE.0) GO TO 120
        !            23: C
        !            24: C     SET FCN OR SUBR USE IN SYMBOL TABLE. TYPE FCN AND RECORD EXPLICIT
        !            25: C     OR IMPLICIT TYPE
        !            26: C
        !            27:       K = LOOKUP(K2,.FALSE.)
        !            28:       IF (SYSERR) GO TO 90
        !            29:       NAME = K
        !            30:       L = ITYP - 8
        !            31:       GO TO (10, 20), L
        !            32:    10 CALL SATT1(K, 8, 3)
        !            33:       GO TO 40
        !            34:    20 CALL SATT1(K, 8, 4)
        !            35:       IF (TYPE.LT.0) GO TO 30
        !            36:       CALL SATT1(K, 1, TYPE+8)
        !            37:       GO TO 40
        !            38:    30 L = 1
        !            39:       IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) L = 2
        !            40:       CALL SATT1(K, 1, L)
        !            41:    40 IF (STMT(K2).NE.65) GO TO 140
        !            42:    50 PSTMT = K2 + 1
        !            43:       IF (PSTMT.GE.NSTMT) GO TO 120
        !            44:       CALL NEXTOK(PSTMT, K2, L)
        !            45:       IF (L.NE.0) GO TO 80
        !            46: C
        !            47: C     ENTER PARAMETER IN SYMBOL TABLE; TYPE IMPLICITLY; ADD ONTO PARAM
        !            48: C     LIST HANGING OFF SUBR/FCN NAME; SET DUMMYARG BIT ON; DO NOT SET
        !            49: C     USAGE
        !            50: C
        !            51:       N = LOOKUP(K2,.FALSE.)
        !            52:       IF (SYSERR) GO TO 90
        !            53:       I2 = IGATT1(N,4)
        !            54:       I1 = IGATT1(N,8)
        !            55:       IF (I1.NE.0 .OR. I2.NE.0) GO TO 80
        !            56:       L = 1
        !            57:       IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) L = 2
        !            58:       CALL SATT1(N, 1, L)
        !            59:       L = IGATT1(N,4)
        !            60:       IF (L.EQ.1) GO TO 80
        !            61:       CALL SATT1(N, 4, 1)
        !            62:       IF (NEXT+2.GE.BNEXT) GO TO 150
        !            63:       IF (KCELL.EQ.0) GO TO 60
        !            64:       DSA(KCELL+1) = NEXT
        !            65:       GO TO 70
        !            66: C
        !            67: C     START PARAM LIST
        !            68: C
        !            69:    60 DSA(K+2) = NEXT
        !            70:    70 KCELL = NEXT
        !            71:       DSA(NEXT) = N
        !            72:       DSA(NEXT+1) = 0
        !            73:       NEXT = NEXT + 2
        !            74: C
        !            75: C     SEARCH FOR  ")" OR ","
        !            76: C
        !            77:       IF (STMT(K2).EQ.62) GO TO 100
        !            78:       IF (STMT(K2).EQ.68) GO TO 50
        !            79:    80 CALL ERROR1(33H ILLEGAL SYNTAX IN PARAMETER LIST, 33)
        !            80:    90 RETURN
        !            81:   100 K2 = K2 + 1
        !            82:   110 IF (K2.EQ.NSTMT) GO TO 90
        !            83:       CALL ERROR1(39H ILLEGAL CHARACTERS AFTER SUBR/FCN HEAD, 39)
        !            84:       GO TO 90
        !            85:   120 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
        !            86:       PSTMT = 6
        !            87:       DO 130 I1=1,5
        !            88:         STMT(I1+5) = S(I1)
        !            89:   130 CONTINUE
        !            90:       NAME = LOOKUP(11,.FALSE.)
        !            91:       IF (SYSERR) GO TO 90
        !            92:       CALL SATT1(NAME, 8, 11)
        !            93:       GO TO 90
        !            94:   140 IF (ITYP.EQ.9) GO TO 110
        !            95:       CALL ERROR1(20H NO PARAMS SPECIFIED, 20)
        !            96:       GO TO 120
        !            97:   150 SYSERR = .TRUE.
        !            98:       CALL ERROR1(33H IN SUBFCN, TABLE OVERFLOW OF DSA,33)
        !            99:       GO TO 90
        !           100:       END

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