![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to DATA.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 DATA.f CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 root 1: SUBROUTINE DATA
2: LOGICAL ERR, SYSERR, ABORT, REPL, ARDECL, SIGN, TOKPNO, ERROR
3: INTEGER DECNT, DATCNT, STMT, PSTMT, GETTOK, STACK, S(10), DSA,
4: * PDSA
5: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
6: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
7: COMMON /FACTS/ NAME, NOST, ITYP, IASF
8: COMMON /DETECT/ ERR, SYSERR, ABORT
9: COMMON /CEXPRS/ LSTACK, STACK(620)
10: DATA IS /1H*/
11: C
12: C ROUTINE PROCESSES A DATA STMT
13: C
14: 10 DECNT = 0
15: 20 IF (ARDECL(K2,KK)) GO TO 30
16: IF (.NOT.ERR) GO TO 30
17: CALL ERROR1(19H ILLEGAL DECLARATOR, 19)
18: IF(.NOT.SYSERR) GOTO 260
19: 30 IF (SYSERR) RETURN
20: C
21: C SET DECLARATOR USAGE AS VARIABLE; CHECK ITS NOT IN BLANK COMMON
22: C CANNOT BE INLABELLED COMMON IF THIS STMT NOT IN BLOCK DATA PGM
23: C FOUND A DECLARATOR ADD IT TO LIST OF ALL DECLS SO CAN CHECK
24: C TYPE OF ITS CORRESPONDING DATA-ITEM; ADD IN COUNT SO CAN
25: C CHECK NUMBER OF DECLS VS. NUMBER OF DATA-ITEMS
26: C KEEP TYPE INFO ON STACK; DECNT IS LENGTH OF STACK
27: C
28: I = IGATT1(KK,8)
29: IF (I.EQ.0) CALL SATT1(KK, 8, 10)
30: I = IGATT1(KK,2)
31: NN = IGATT1(NAME,8)
32: IF (I) 60, 60, 40
33: C
34: C IF VARIABLE IN COMMON, CHECK TO SEE IF CAN LEGALLY APPEAR
35: C IN DATA STMT
36: C
37: 40 I = DSA(KK+2)
38: I = DSA(I+1)
39: CALL S5UNPK(DSA(I+4), S(1), 6)
40: IF (S(1).EQ.IS) GO TO 50
41: C
42: C FOUND NO "*" SO ARE IN LABELLED COMMON
43: C
44: IF (NN.EQ.11) GO TO 70
45: CALL ERROR1(
46: * 55H ILLEGAL TO INITIALIZE VARIABLE IN LABELLED COMMON HERE,
47: * 55)
48: GO TO 260
49: C
50: C FOUND BLANK COMMON
51: C
52: 50 CALL ERROR1(48H ILLEGAL TO INITIALIZE VARIABLES IN BLANK COMMON,
53: * 48)
54: GO TO 260
55: 60 IF (NN.NE.11) GO TO 70
56: CALL ERROR1(33H DATA-ITEM NOT IN LABELLED COMMON, 33)
57: GO TO 260
58: 70 I = IGATT1(KK,1)
59: CALL SATT1(KK, 5, 1)
60: NN = 1
61: IF (IGATT1(KK,7).EQ.0) GO TO 75
62: IF (STMT(K2-1).EQ.62) GO TO 75
63: N = DSA(KK+2)
64: NN = DSA(N)
65: 75 CONTINUE
66: IF (DECNT+3.LE.LSTACK) GO TO 76
67: CALL ERROR1(33H IN DATA, TABLE OVERFLOW OF STACK , 33 )
68: GO TO 260
69: 76 CONTINUE
70: STACK(DECNT+1) = MOD(I,8)
71: STACK(DECNT+2) = KK
72: STACK(DECNT+3) = NN
73: DECNT = DECNT + 3
74: IF (STMT(K2).EQ.67) GO TO 100
75: IF (STMT(K2).NE.68) GO TO 90
76: PSTMT = K2 + 1
77: IF (PSTMT.LT.NSTMT) GO TO 20
78: 80 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
79: RETURN
80: 90 CALL ERROR1(33H ILLEGAL PUNCTUATION IN DATA STMT, 33)
81: GO TO 260
82: C
83: C FIND DATA-ITEMS; CHECK ITS TYPE VS. CORRESPONDING DECLARATOR
84: C SIGN .TRUE. IF DATA-ITEM PRECEEDED BY A SIGN
85: C REPL .TRUE. IF A REPLICATION FACTOR HAS ALREADY BEEN FOUND
86: C
87: 100 DATCNT = 0
88: ERROR = .FALSE.
89: PSTMT = K2 + 1
90: 110 IF (PSTMT.EQ.NSTMT) GO TO 80
91: SIGN = .FALSE.
92: REPL = .FALSE.
93: NN = 1
94: 120 IF (STMT(PSTMT).NE.60 .AND. STMT(PSTMT).NE.61) GO TO 130
95: PSTMT = PSTMT + 1
96: SIGN = .TRUE.
97: 130 IF (PSTMT.EQ.NSTMT) GO TO 80
98: KK = GETTOK(PSTMT,K2)
99: IF (ERR) GO TO 80
100: IF (KK.LT.6) GO TO 150
101: 140 CALL ERROR1(18H ILLEGAL DATA-ITEM, 18)
102: GO TO 260
103: 150 KK = KK + 1
104: GO TO (200, 200, 160, 190, 190, 180), KK
105: C
106: C MUST MAKE SURE THAN AN INTEGER DATA-ITEM ISN'T A REPLICATION FACTO
107: C
108: 160 IF (REPL) GO TO 200
109: IF(SIGN .OR. STMT(K2).NE.66) GOTO 200
110: IF(TOKPNO(PSTMT,K2,NN)) GOTO 170
111: CALL ERROR1(27H ILLEGAL REPLICATION FACTOR ,27)
112: NN = 1
113: 170 REPL = .TRUE.
114: PSTMT = K2 + 1
115: GO TO 120
116: C
117: C CHECK LENGTH OF HOLLERITH DATA-ITEM; MUST FIT INTO INTEGER WORD
118: C
119: 180 IF (STMT(PSTMT)+2048.EQ.1 .OR. ERROR) GO TO 190
120: CALL ERROR1(
121: * 53H WARNING - NH WITH N.GT.1 IS NOT A PORTABLE CONSTRUCT, 53)
122: ERROR = .TRUE.
123: C
124: C CHECK COMPLEX, HOLLERITH, AND LOGICAL DATA-ITEMS ARE UNSIGNED
125: C
126: 190 IF (SIGN) GO TO 140
127: C
128: C CHECK COMPATIBLITY OF DATA-ITEMS WITH DECLARATORS
129: C NN IS REPLICATION FACTOR;
130: C
131: 200 IBR=0
132: DO 220 I = 1,NN
133: IF (STACK(DATCNT+3).EQ.0) DATCNT = DATCNT + 3
134: IF (DATCNT .GE. DECNT) GO TO 240
135: STACK(DATCNT+3) = STACK(DATCNT+3) - 1
136: IF (STACK(DATCNT+1).EQ.KK-1) GO TO 220
137: IF ((STACK(DATCNT+1).NE.2 .OR. KK.NE.6) .AND.
138: * (STACK(DATCNT+1).NE.5 .OR. KK.NE.3)) GO TO 210
139: CALL SATT1(STACK(DATCNT+2), 1, 5)
140: GO TO 220
141: 210 IBR = 1
142: 220 CONTINUE
143: IF(IBR .EQ. 1) CALL ERROR1(52
144: 1H WARNING - DATA-ITEM IS INCOMPATIBLE WITH DECLARATOR ,52)
145: C
146: C CHECK FOR "," BETWEEN DATA-ITEMS
147: C
148: IF (STMT(K2).NE.68) GO TO 230
149: PSTMT = K2 + 1
150: GO TO 110
151: C
152: C CHECK FOR ANOTHER SET OF DECLARATORS/DATA-ITEMS
153: C
154: 230 IF (STMT(K2).NE.67) GO TO 90
155: IF (STACK(DATCNT+3).EQ.0) DATCNT = DATCNT + 3
156: IF (DATCNT.EQ.DECNT) GO TO 250
157: 240 CALL ERROR1(34H MISSING DECLARATORS OR DATA-ITEMS, 34)
158: IF (DATCNT.GE.DECNT) GO TO 260
159: 250 PSTMT = K2 + 1
160: IF (PSTMT.EQ.NSTMT) RETURN
161: IF (STMT(PSTMT).NE.68) GO TO 90
162: PSTMT = PSTMT + 1
163: IF (PSTMT.NE.NSTMT) GO TO 10
164: GO TO 80
165: C
166: C FLUSH TO "/," CONSTRUCT OR END OF STATEMEMT
167: C
168: 260 IF (PSTMT+1.GE.NSTMT) RETURN
169: IF (STMT(PSTMT).EQ.67 .AND. STMT(PSTMT+1).EQ.68) GO TO 270
170: PSTMT = PSTMT + 1
171: GO TO 260
172: 270 PSTMT = PSTMT + 2
173: IF (PSTMT.GE.NSTMT) RETURN
174: GO TO 10
175: END
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.