![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to SUBFCN.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10dc / cmd / pfort|
Return to SUBFCN.f CVS log | Up to [Research Unix] / researchv10dc / cmd / pfort |
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.