Return to SUBFCN.f CVS log

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

researchv10 Norman

      SUBROUTINE SUBFCN(TYPE)
C
C     TYPE IS EXPLICIT TYPE OF FUNCTION, ELSE IS -1
C     ALL FCNS GIVEN EXPLICIT TYPE SINCE FCN NAME CANNOT APPEAR IN
C     NONEXECUTABLE STMT WITHIN FCN SUBPRGM EXCEPT HEAD STMT
C     ROUTINES DEFINES SUBROUTINE AND FUNCTION NAMES AND CREATES
C     LINKED LISTS OF POINTERS TO THEIR ARGUMENTS IN DSA.
C     SETS NAME TO POINT TO CURRENT FUNCN OR SUBRTNE.  IN CASE
C     OF BAD SYNTAX IN NAME CONSTRUCT OR FCN WITHOUT PARAMS.,
C     PROGRAM UNIT BECOMES MAIN PGM BY DEFAULT
C
      INTEGER STMT, PSTMT, DSA, SYMHD, TYPE, BNEXT, S(5), PDSA
      LOGICAL ERR, SYSERR, ABORT
      COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
      COMMON /FACTS/ NAME, NOST, ITYP, IASF
      COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
      COMMON /CTABL/ LDSA, PDSA, DSA(5000)
      COMMON /DETECT/ ERR, SYSERR, ABORT
      DATA S(1) /66/, S(2) /42/, S(3) /30/, S(4) /38/, S(5) /43/
      KCELL = 0
      CALL NEXTOK(PSTMT, K2, I1)
      IF (I1.NE.0) GO TO 120
C
C     SET FCN OR SUBR USE IN SYMBOL TABLE. TYPE FCN AND RECORD EXPLICIT
C     OR IMPLICIT TYPE
C
      K = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 90
      NAME = K
      L = ITYP - 8
      GO TO (10, 20), L
   10 CALL SATT1(K, 8, 3)
      GO TO 40
   20 CALL SATT1(K, 8, 4)
      IF (TYPE.LT.0) GO TO 30
      CALL SATT1(K, 1, TYPE+8)
      GO TO 40
   30 L = 1
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) L = 2
      CALL SATT1(K, 1, L)
   40 IF (STMT(K2).NE.65) GO TO 140
   50 PSTMT = K2 + 1
      IF (PSTMT.GE.NSTMT) GO TO 120
      CALL NEXTOK(PSTMT, K2, L)
      IF (L.NE.0) GO TO 80
C
C     ENTER PARAMETER IN SYMBOL TABLE; TYPE IMPLICITLY; ADD ONTO PARAM
C     LIST HANGING OFF SUBR/FCN NAME; SET DUMMYARG BIT ON; DO NOT SET
C     USAGE
C
      N = LOOKUP(K2,.FALSE.)
      IF (SYSERR) GO TO 90
      I2 = IGATT1(N,4)
      I1 = IGATT1(N,8)
      IF (I1.NE.0 .OR. I2.NE.0) GO TO 80
      L = 1
      IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) L = 2
      CALL SATT1(N, 1, L)
      L = IGATT1(N,4)
      IF (L.EQ.1) GO TO 80
      CALL SATT1(N, 4, 1)
      IF (NEXT+2.GE.BNEXT) GO TO 150
      IF (KCELL.EQ.0) GO TO 60
      DSA(KCELL+1) = NEXT
      GO TO 70
C
C     START PARAM LIST
C
   60 DSA(K+2) = NEXT
   70 KCELL = NEXT
      DSA(NEXT) = N
      DSA(NEXT+1) = 0
      NEXT = NEXT + 2
C
C     SEARCH FOR  ")" OR ","
C
      IF (STMT(K2).EQ.62) GO TO 100
      IF (STMT(K2).EQ.68) GO TO 50
   80 CALL ERROR1(33H ILLEGAL SYNTAX IN PARAMETER LIST, 33)
   90 RETURN
  100 K2 = K2 + 1
  110 IF (K2.EQ.NSTMT) GO TO 90
      CALL ERROR1(39H ILLEGAL CHARACTERS AFTER SUBR/FCN HEAD, 39)
      GO TO 90
  120 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
      PSTMT = 6
      DO 130 I1=1,5
        STMT(I1+5) = S(I1)
  130 CONTINUE
      NAME = LOOKUP(11,.FALSE.)
      IF (SYSERR) GO TO 90
      CALL SATT1(NAME, 8, 11)
      GO TO 90
  140 IF (ITYP.EQ.9) GO TO 110
      CALL ERROR1(20H NO PARAMS SPECIFIED, 20)
      GO TO 120
  150 SYSERR = .TRUE.
      CALL ERROR1(33H IN SUBFCN, TABLE OVERFLOW OF DSA,33)
      GO TO 90
      END

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