![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to END.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / pfort|
Return to END.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 root 1: SUBROUTINE END
2: C
3: C ROUTINE SAVES SYMBOL TABLE FOR 2ND PASS
4: C CHECKS VARIABLE DIMENSIONING IN FCN/SUBR PU'S
5: C CANNOT RESET DUMMY ARGS USED IN VARIABLE DIMENSIONING;
6: C CHECKS SUCH BOUNDS FOR TYPE INTEGER
7: C CALLS OUTSYM TO PRINT SYMBOL TABLE
8: C CHECKS FOR UNDEFINED LABELS,MISSING DO ENDINGS,
9: C PROPER BRANCHING THROUGHOUT PGM,
10: C FIXES UP ALL LABELS WHOSE SCOPE IS NOT YET LIMITED
11: C SETS USAGE OF ALL IDS TO VARIABLE IF USAGE NOT YET SET
12: C RESETS FCN USAGE IN FCN SUBPROGRAM
13: C
14: INTEGER OUTUT, OUTUT2, OUTUT3, OUTUT4
15: INTEGER PDSA, SYMLEN, BNEXT, SYMHD, STACK, DSA
16: LOGICAL OPT, P1ERR
17: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
18: * OUTUT4
19: COMMON /OPTNS/ OPT(5), P1ERR
20: COMMON /FACTS/ NAME, NOST, ITYP, IASF
21: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
22: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
23: COMMON /CEXPRS/ LSTACK, STACK(620)
24: I = IGATT1(NAME,8)
25: IF((I.NE.3 .AND. I.NE.10) .OR. DSA(NAME+2).EQ.0) GOTO 40
26: C
27: C ARGUMENT CHECKING- FOR USE IN VARIABLE DIMENSIONING OF ARRAYS
28: C
29: LL = 1
30: L = DSA(NAME+2)
31: NPAR = 0
32: 10 IF (L.EQ.0) GO TO 40
33: NPAR = NPAR + 1
34: C CHECK FOR PROC ARGS TO ENTER THEIR RELATIVE POSIT
35: C IN ARGLIST IN WD 3 OF THEIR SYMBOL TABLE ENTRY
36: I = IGATT1(DSA(L),8)
37: IF (I.NE.5 .AND. I.NE.6 .AND. I.NE.13) GO TO 20
38: I = DSA(L)
39: DSA(I+2) = NPAR
40: GO TO 30
41: 20 I = IGATT1(DSA(L),6)
42: IF (I.EQ.0) GO TO 30
43: I = IGATT1(DSA(L),7)
44: IF (I.NE.0) GO TO 30
45: I = IGATT1(DSA(L),5)
46: K = DSA(L)
47: IF (I.GT.0) CALL ERROR2(
48: * 57H ILLEGALLY RESET DUMMY ARG USED IN VARIABLE DIMENSIONING ,
49: * 57, DSA(K+4), 1, 1, 1)
50: I = IGATT1(K,1)
51: IF (MOD(I,8).NE.2) CALL ERROR2(
52: * 47H ILLEGAL DATA TYPE USED IN ADJUSTIBLE DIMENSION, 47
53: * , DSA(K+4), 1, 1, 1)
54: 30 L = DSA(L+1)
55: GO TO 10
56: C
57: C OUTPUT TABLE
58: C
59: 40 CALL DOCHK(1)
60: C
61: C CHECK LABELS DEFINED AND WITHIN SCOPE
62: C
63: I = LABHD
64: 50 IF (I.EQ.0) GO TO 110
65: L = IGATT1(I,2)
66: IF (L.EQ.1) GO TO 60
67: CALL ERROR2(17H UNDEFINED LABEL , 17, DSA(I+4), 1, 1, 1)
68: GO TO 100
69: 60 L = IGATT1(I,1)
70: IF (L.NE.1) GO TO 100
71: L = DSA(I+2)
72: L1 = DSA(L)
73: KK = DSA(L+1)
74: L2 = DSA(I+1)
75: C
76: C L3 POINTS TO LAST ELEMENT ON CIRCULAR LIST
77: C
78: L3 = L2
79: 70 IF (DSA(L2).LE.KK .AND. DSA(L2).GE.L1) GO TO 90
80: IF (DSA(L2).LT.0) GO TO 80
81: CALL ERROR2(15H ILLEGAL BRANCH, 15, DSA(L2), -1, 1, 1)
82: GO TO 90
83: 80 DSA(L2) = IABS(DSA(L2))
84: 90 L2 = DSA(L2+1)
85: IF (L2.NE.L3) GO TO 70
86: 100 I = DSA(I+3)
87: GO TO 50
88: C
89: C SET <ID> USAGE IF NOT YET SET
90: C
91: 110 I = SYMHD
92: 120 IF (I.EQ.0) GO TO 150
93: K = IGATT1(I,8)
94: IF (K.NE.0) GO TO 130
95: CALL SATT1(I, 8, 10)
96: GO TO 140
97: 130 IF (K.NE.6) GO TO 140
98: IF (IGATT1(I,1)/8.NE.1) GO TO 140
99: CALL ERROR2(33H SUBROUTINE NAME CANNOT BE TYPED , 33, DSA(I+4),
100: * 1, 1, 1)
101: 140 I = DSA(I+3)
102: GO TO 120
103: C
104: C RESET FCN USAGE IN FCN PROGRAM UNIT
105: C
106: 150 I = IGATT1(NAME,8)
107: IF (I.NE.10) GO TO 160
108: CALL SATT1(NAME, 8, 4)
109: I = IGATT1(NAME,5)
110: IF (I.EQ.0) CALL ERROR1(23H FUNCTION VALUE NOT SET, 23)
111: C
112: C SAVE BINARY COPY OF SYMBOL TABLE
113: C
114: 160 IF (OPT(3) .AND. .NOT.P1ERR) GO TO 170
115: CALL ERROR1(36H P-U NOT SAVED FOR PASS2 PROCESSING , 36)
116: K = 3
117: L = 1
118: WRITE(OUTUT2) L,K,L
119: WRITE(OUTUT3) L,K,L
120: GOTO 180
121: 170 K = 1
122: L = NEXT - 1
123: I = L + 3
124: WRITE (OUTUT2) I, K, (DSA(I),I=1,L), NAME, SYMHD, LABHD
125: L = 3
126: WRITE (OUTUT3) K, L, K
127: 180 CALL OUTSYM
128: RETURN
129: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.