![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to prtsht 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 prtsht CVS log | Up to [Research Unix] / researchv10no / cmd / pfort |
1.1 root 1: C XXXXXBLOCKDATA0.f
2: BLOCK DATA
3: C
4: C
5: C
6: C
7: C
8: C
9: C
10: C
11: C
12: C
13: C
14: C
15: C
16: C
17: C
18: C
19: C
20: C
21: C PFORT VERIFIER
22: C
23: C B. G. RYDER
24: C A. D. HALL
25: C
26: C BELL LABORATORIES, MURRAY HILL, NEW JERSEY 07974
27: C
28: C
29: C COPYRIGHT C 1978, BELL TELEPHONE LABORATORIES, INCOR-
30: C PORATED. GENERAL PERMISSION IS GRANTED TO MAKE AND
31: C DISTRIBUTE UNMODIFIED COMPLETE COPIES OF THIS COMPUTER
32: C PROGRAM, BUT NOT FOR PROFIT, PROVIDED THAT THIS COPYRIGHT
33: C NOTICE AND STATEMENT ARE INCLUDED.
34: C
35: C
36: C
37: C
38: C
39: C
40: C
41: C
42: C
43: C
44: C
45: C
46: C
47: C
48: C
49: C
50: C
51: C
52: INTEGER Z
53: COMMON /INTS/ Z(346)
54: DATA Z(1) /3/
55: DATA Z(2) /1HA/
56: DATA Z(3) /1HB/
57: DATA Z(4) /1HS/
58: DATA Z(5) /201/
59: DATA Z(6) /4/
60: DATA Z(7) /1HI/
61: DATA Z(8) /1HA/
62: DATA Z(9) /1HB/
63: DATA Z(10) /1HS/
64: DATA Z(11) /210/
65: DATA Z(12) /4/
66: DATA Z(13) /1HD/
67: DATA Z(14) /1HA/
68: DATA Z(15) /1HB/
69: DATA Z(16) /1HS/
70: DATA Z(17) /192/
71: DATA Z(18) /4/
72: DATA Z(19) /1HA/
73: DATA Z(20) /1HI/
74: DATA Z(21) /1HN/
75: DATA Z(22) /1HT/
76: DATA Z(23) /201/
77: DATA Z(24) /3/
78: DATA Z(25) /1HI/
79: DATA Z(26) /1HN/
80: DATA Z(27) /1HT/
81: DATA Z(28) /202/
82: DATA Z(29) /5/
83: DATA Z(30) /1HI/
84: DATA Z(31) /1HD/
85: DATA Z(32) /1HI/
86: DATA Z(33) /1HN/
87: DATA Z(34) /1HT/
88: DATA Z(35) /194/
89: DATA Z(36) /4/
90: DATA Z(37) /1HA/
91: DATA Z(38) /1HM/
92: DATA Z(39) /1HO/
93: DATA Z(40) /1HD/
94: DATA Z(41) /329/
95: DATA Z(42) /3/
96: DATA Z(43) /1HM/
97: DATA Z(44) /1HO/
98: DATA Z(45) /1HD/
99: DATA Z(46) /338/
100: DATA Z(47) /5/
101: DATA Z(48) /1HA/
102: DATA Z(49) /1HM/
103: DATA Z(50) /1HA/
104: DATA Z(51) /1HX/
105: DATA Z(52) /1H0/
106: DATA Z(53) /273/
107: DATA Z(54) /5/
108: DATA Z(55) /1HA/
109: DATA Z(56) /1HM/
110: DATA Z(57) /1HA/
111: DATA Z(58) /1HX/
112: DATA Z(59) /1H1/
113: DATA Z(60) /265/
114: DATA Z(61) /4/
115: DATA Z(62) /1HM/
116: DATA Z(63) /1HA/
117: DATA Z(64) /1HX/
118: DATA Z(65) /1H0/
119: DATA Z(66) /274/
120: DATA Z(67) /4/
121: DATA Z(68) /1HM/
122: DATA Z(69) /1HA/
123: DATA Z(70) /1HX/
124: DATA Z(71) /1H1/
125: DATA Z(72) /266/
126: DATA Z(73) /5/
127: DATA Z(74) /1HD/
128: DATA Z(75) /1HM/
129: DATA Z(76) /1HA/
130: DATA Z(77) /1HX/
131: DATA Z(78) /1H1/
132: DATA Z(79) /256/
133: DATA Z(80) /5/
134: DATA Z(81) /1HA/
135: DATA Z(82) /1HM/
136: DATA Z(83) /1HI/
137: DATA Z(84) /1HN/
138: DATA Z(85) /1H0/
139: DATA Z(86) /273/
140: DATA Z(87) /5/
141: DATA Z(88) /1HA/
142: DATA Z(89) /1HM/
143: DATA Z(90) /1HI/
144: DATA Z(91) /1HN/
145: DATA Z(92) /1H1/
146: DATA Z(93) /265/
147: DATA Z(94) /4/
148: DATA Z(95) /1HM/
149: DATA Z(96) /1HI/
150: DATA Z(97) /1HN/
151: DATA Z(98) /1H0/
152: DATA Z(99) /274/
153: DATA Z(100) /4/
154: DATA Z(101) /1HM/
155: DATA Z(102) /1HI/
156: DATA Z(103) /1HN/
157: DATA Z(104) /1H1/
158: DATA Z(105) /266/
159: DATA Z(106) /5/
160: DATA Z(107) /1HD/
161: DATA Z(108) /1HM/
162: DATA Z(109) /1HI/
163: DATA Z(110) /1HN/
164: DATA Z(111) /1H1/
165: DATA Z(112) /256/
166: DATA Z(113) /5/
167: DATA Z(114) /1HF/
168: DATA Z(115) /1HL/
169: DATA Z(116) /1HO/
170: DATA Z(117) /1HA/
171: DATA Z(118) /1HT/
172: DATA Z(119) /209/
173: DATA Z(120) /4/
174: DATA Z(121) /1HI/
175: DATA Z(122) /1HF/
176: DATA Z(123) /1HI/
177: DATA Z(124) /1HX/
178: DATA Z(125) /202/
179: DATA Z(126) /4/
180: DATA Z(127) /1HS/
181: DATA Z(128) /1HI/
182: DATA Z(129) /1HG/
183: DATA Z(130) /1HN/
184: DATA Z(131) /329/
185: DATA Z(132) /5/
186: DATA Z(133) /1HI/
187: DATA Z(134) /1HS/
188: DATA Z(135) /1HI/
189: DATA Z(136) /1HG/
190: DATA Z(137) /1HN/
191: DATA Z(138) /338/
192: DATA Z(139) /5/
193: DATA Z(140) /1HD/
194: DATA Z(141) /1HS/
195: DATA Z(142) /1HI/
196: DATA Z(143) /1HG/
197: DATA Z(144) /1HN/
198: DATA Z(145) /320/
199: DATA Z(146) /3/
200: DATA Z(147) /1HD/
201: DATA Z(148) /1HI/
202: DATA Z(149) /1HM/
203: DATA Z(150) /329/
204: DATA Z(151) /4/
205: DATA Z(152) /1HI/
206: DATA Z(153) /1HD/
207: DATA Z(154) /1HI/
208: DATA Z(155) /1HM/
209: DATA Z(156) /338/
210: DATA Z(157) /4/
211: DATA Z(158) /1HS/
212: DATA Z(159) /1HN/
213: DATA Z(160) /1HG/
214: DATA Z(161) /1HL/
215: DATA Z(162) /193/
216: DATA Z(163) /4/
217: DATA Z(164) /1HR/
218: DATA Z(165) /1HE/
219: DATA Z(166) /1HA/
220: DATA Z(167) /1HL/
221: DATA Z(168) /217/
222: DATA Z(169) /5/
223: DATA Z(170) /1HA/
224: DATA Z(171) /1HI/
225: DATA Z(172) /1HM/
226: DATA Z(173) /1HA/
227: DATA Z(174) /1HG/
228: DATA Z(175) /217/
229: DATA Z(176) /4/
230: DATA Z(177) /1HD/
231: DATA Z(178) /1HB/
232: DATA Z(179) /1HL/
233: DATA Z(180) /1HE/
234: DATA Z(181) /200/
235: DATA Z(182) /5/
236: DATA Z(183) /1HC/
237: DATA Z(184) /1HM/
238: DATA Z(185) /1HP/
239: DATA Z(186) /1HL/
240: DATA Z(187) /1HX/
241: DATA Z(188) /331/
242: DATA Z(189) /5/
243: DATA Z(190) /1HC/
244: DATA Z(191) /1HO/
245: DATA Z(192) /1HN/
246: DATA Z(193) /1HJ/
247: DATA Z(194) /1HG/
248: DATA Z(195) /219/
249: DATA Z(196) /3/
250: DATA Z(197) /1HE/
251: DATA Z(198) /1HX/
252: DATA Z(199) /1HP/
253: DATA Z(200) /713/
254: DATA Z(201) /4/
255: DATA Z(202) /1HD/
256: DATA Z(203) /1HE/
257: DATA Z(204) /1HX/
258: DATA Z(205) /1HP/
259: DATA Z(206) /704/
260: DATA Z(207) /4/
261: DATA Z(208) /1HC/
262: DATA Z(209) /1HE/
263: DATA Z(210) /1HX/
264: DATA Z(211) /1HP/
265: DATA Z(212) /731/
266: DATA Z(213) /4/
267: DATA Z(214) /1HA/
268: DATA Z(215) /1HL/
269: DATA Z(216) /1HO/
270: DATA Z(217) /1HG/
271: DATA Z(218) /713/
272: DATA Z(219) /4/
273: DATA Z(220) /1HD/
274: DATA Z(221) /1HL/
275: DATA Z(222) /1HO/
276: DATA Z(223) /1HG/
277: DATA Z(224) /704/
278: DATA Z(225) /4/
279: DATA Z(226) /1HC/
280: DATA Z(227) /1HL/
281: DATA Z(228) /1HO/
282: DATA Z(229) /1HG/
283: DATA Z(230) /731/
284: DATA Z(231) /6/
285: DATA Z(232) /1HA/
286: DATA Z(233) /1HL/
287: DATA Z(234) /1HO/
288: DATA Z(235) /1HG/
289: DATA Z(236) /1H1/
290: DATA Z(237) /1H0/
291: DATA Z(238) /713/
292: DATA Z(239) /6/
293: DATA Z(240) /1HD/
294: DATA Z(241) /1HL/
295: DATA Z(242) /1HO/
296: DATA Z(243) /1HG/
297: DATA Z(244) /1H1/
298: DATA Z(245) /1H0/
299: DATA Z(246) /704/
300: DATA Z(247) /3/
301: DATA Z(248) /1HS/
302: DATA Z(249) /1HI/
303: DATA Z(250) /1HN/
304: DATA Z(251) /713/
305: DATA Z(252) /4/
306: DATA Z(253) /1HD/
307: DATA Z(254) /1HS/
308: DATA Z(255) /1HI/
309: DATA Z(256) /1HN/
310: DATA Z(257) /704/
311: DATA Z(258) /4/
312: DATA Z(259) /1HC/
313: DATA Z(260) /1HS/
314: DATA Z(261) /1HI/
315: DATA Z(262) /1HN/
316: DATA Z(263) /731/
317: DATA Z(264) /3/
318: DATA Z(265) /1HC/
319: DATA Z(266) /1HO/
320: DATA Z(267) /1HS/
321: DATA Z(268) /713/
322: DATA Z(269) /4/
323: DATA Z(270) /1HD/
324: DATA Z(271) /1HC/
325: DATA Z(272) /1HO/
326: DATA Z(273) /1HS/
327: DATA Z(274) /704/
328: DATA Z(275) /4/
329: DATA Z(276) /1HC/
330: DATA Z(277) /1HC/
331: DATA Z(278) /1HO/
332: DATA Z(279) /1HS/
333: DATA Z(280) /731/
334: DATA Z(281) /4/
335: DATA Z(282) /1HT/
336: DATA Z(283) /1HA/
337: DATA Z(284) /1HN/
338: DATA Z(285) /1HH/
339: DATA Z(286) /713/
340: DATA Z(287) /4/
341: DATA Z(288) /1HS/
342: DATA Z(289) /1HQ/
343: DATA Z(290) /1HR/
344: DATA Z(291) /1HT/
345: DATA Z(292) /713/
346: DATA Z(293) /5/
347: DATA Z(294) /1HD/
348: DATA Z(295) /1HS/
349: DATA Z(296) /1HQ/
350: DATA Z(297) /1HR/
351: DATA Z(298) /1HT/
352: DATA Z(299) /704/
353: DATA Z(300) /5/
354: DATA Z(301) /1HC/
355: DATA Z(302) /1HS/
356: DATA Z(303) /1HQ/
357: DATA Z(304) /1HR/
358: DATA Z(305) /1HT/
359: DATA Z(306) /731/
360: DATA Z(307) /4/
361: DATA Z(308) /1HA/
362: DATA Z(309) /1HT/
363: DATA Z(310) /1HA/
364: DATA Z(311) /1HN/
365: DATA Z(312) /713/
366: DATA Z(313) /5/
367: DATA Z(314) /1HD/
368: DATA Z(315) /1HA/
369: DATA Z(316) /1HT/
370: DATA Z(317) /1HA/
371: DATA Z(318) /1HN/
372: DATA Z(319) /704/
373: DATA Z(320) /5/
374: DATA Z(321) /1HA/
375: DATA Z(322) /1HT/
376: DATA Z(323) /1HA/
377: DATA Z(324) /1HN/
378: DATA Z(325) /1H2/
379: DATA Z(326) /841/
380: DATA Z(327) /6/
381: DATA Z(328) /1HD/
382: DATA Z(329) /1HA/
383: DATA Z(330) /1HT/
384: DATA Z(331) /1HA/
385: DATA Z(332) /1HN/
386: DATA Z(333) /1H2/
387: DATA Z(334) /832/
388: DATA Z(335) /4/
389: DATA Z(336) /1HD/
390: DATA Z(337) /1HM/
391: DATA Z(338) /1HO/
392: DATA Z(339) /1HD/
393: DATA Z(340) /832/
394: DATA Z(341) /4/
395: DATA Z(342) /1HC/
396: DATA Z(343) /1HA/
397: DATA Z(344) /1HB/
398: DATA Z(345) /1HS/
399: DATA Z(346) /729/
400: END
401: C XXXXXBLOCKDATA1.f
402: BLOCK DATA
403: INTEGER EX(4,4), PT, PB, AO(4,4), RO(3,3)
404: COMMON /EXPRS/ PT, PB, AO, RO, EX
405: DATA AO(1,1), AO(1,2), AO(2,1) /3*0/, AO(1,3), AO(1,4), AO(3,1),
406: * AO(3,2), AO(4,1), AO(4,3) /6*-1/, AO(2,2) /1/, AO(3,3) /2/,
407: * AO(4,4), AO(2,4), AO(4,2) /3*3/, AO(3,4), AO(2,3) /2*-1/
408: DATA RO(1,1), RO(1,2), RO(2,1), RO(2,2), RO(3,3) /5*4/, RO(1,3),
409: * RO(2,3), RO(3,1), RO(3,2) /4*-1/
410: DATA EX(1,1) /0/, EX(1,2) /0/, EX(1,3) /0/, EX(1,4) /-1/, EX(2,1)
411: * /0/, EX(2,2) /1/, EX(2,3) /1/, EX(2,4) /-1/, EX(3,1) /-1/,
412: * EX(3,2) /-1/, EX(3,3) /2/, EX(3,4) /-1/, EX(4,1) /-1/,
413: * EX(4,2) /-1/, EX(4,3) /3/, EX(4,4) /-1/
414: END
415: C XXXXXBLOCKDATA2.f
416: BLOCK DATA
417: C
418: COMMON /TRANS/ Q(70)
419: INTEGER Q
420: C
421: DATA Q(1) /1H0/, Q(2) /1H1/, Q(3) /1H2/, Q(4) /1H3/, Q(5) /1H4/
422: DATA Q(6) /1H5/, Q(7) /1H6/, Q(8) /1H7/, Q(9) /1H8/, Q(10) /1H9/
423: C
424: DATA Q(31) /1HA/, Q(32) /1HB/, Q(33) /1HC/, Q(34) /1HD/, Q(35) /
425: * 1HE/
426: DATA Q(36) /1HF/, Q(37) /1HG/, Q(38) /1HH/, Q(39) /1HI/, Q(40) /
427: * 1HJ/
428: DATA Q(41) /1HK/, Q(42) /1HL/, Q(43) /1HM/, Q(44) /1HN/, Q(45) /
429: * 1HO/
430: DATA Q(46) /1HP/, Q(47) /1HQ/, Q(48) /1HR/, Q(49) /1HS/, Q(50) /
431: * 1HT/
432: DATA Q(51) /1HU/, Q(52) /1HV/, Q(53) /1HW/, Q(54) /1HX/, Q(55) /
433: * 1HY/
434: DATA Q(56) /1HZ/
435: C
436: DATA Q(61) /1H+/, Q(62) /1H-/, Q(63) /1H)/, Q(64) /1H=/, Q(65) /
437: * 1H./
438: DATA Q(66) /1H(/, Q(67) /1H*/, Q(68) /1H//, Q(69) /1H,/, Q(70) /
439: * 1H /
440: END
441: C XXXXXBLOCKDATA3.f
442: BLOCK DATA
443: INTEGER K(186), KI(30), KT(30)
444: COMMON /STS/ K, KI, KT
445: DATA K(1) /33/, K(2) /44/, K(3) /50/, K(4) /31/, K(5) /41/, K(6)
446: * /34/, K(7) /45/, K(8) /47/, K(9) /34/, K(10) /32/, K(11)
447: * /38/, K(12) /48/, K(13) /38/, K(14) /44/, K(15) /43/
448: DATA K(16) /47/, K(17) /34/, K(18) /30/, K(19) /41/
449: DATA K(20) /38/, K(21) /43/, K(22) /49/, K(23) /34/, K(24) /36/,
450: * K(25) /34/, K(26) /47/
451: DATA K(27) /32/, K(28) /44/, K(29) /42/, K(30) /45/, K(31) /41/,
452: * K(32) /34/, K(33) /53/, K(34) /41/, K(35) /44/, K(36) /36/,
453: * K(37) /38/, K(38) /32/, K(39) /30/, K(40) /41/
454: DATA K(41) /34/, K(42) /53/, K(43) /49/, K(44) /34/, K(45) /47/,
455: * K(46) /43/, K(47) /30/, K(48) /41/, K(49) /33/, K(50) /38/,
456: * K(51) /42/, K(52) /34/, K(53) /43/, K(54) /48/, K(55) /38/,
457: * K(56) /44/, K(57) /43/, K(58) /32/, K(59) /44/, K(60) /42/,
458: * K(61) /42/, K(62) /44/, K(63) /43/, K(64) /48/, K(65) /50/,
459: * K(66) /31/, K(67) /47/, K(68) /44/, K(69) /50/, K(70) /49/,
460: * K(71) /38/, K(72) /43/, K(73) /34/
461: DATA K(74) /35/, K(75) /50/, K(76) /43/, K(77) /32/, K(78) /49/,
462: * K(79) /38/, K(80) /44/, K(81) /43/, K(82) /31/, K(83) /41/,
463: * K(84) /44/, K(85) /32/, K(86) /40/, K(87) /33/, K(88) /30/,
464: * K(89) /49/, K(90) /30/, K(91) /34/, K(92) /46/, K(93) /50/,
465: * K(94) /38/, K(95) /51/, K(96) /30/, K(97) /41/, K(98) /34/,
466: * K(99) /43/, K(100) /32/, K(101) /34/, K(102) /33/, K(103)
467: * /30/, K(104) /49/, K(105) /30/
468: DATA K(106) /30/, K(107) /48/, K(108) /48/, K(109) /38/, K(110)
469: * /36/, K(111) /43/, K(112) /36/, K(113) /44/, K(114) /49/,
470: * K(115) /44/, K(116) /47/, K(117) /34/, K(118) /49/, K(119)
471: * /50/, K(120) /47/, K(121) /43/
472: DATA K(122) /32/, K(123) /44/, K(124) /43/, K(125) /49/, K(126)
473: * /38/, K(127) /43/, K(128) /50/, K(129) /34/, K(130) /32/,
474: * K(131) /30/, K(132) /41/, K(133) /41/, K(134) /48/, K(135)
475: * /49/, K(136) /44/, K(137) /45/, K(138) /38/, K(139) /35/,
476: * K(140) /33/, K(141) /44/, K(142) /45/, K(143) /30/, K(144)
477: * /50/, K(145) /48/, K(146) /34/
478: DATA K(147) /47/, K(148) /34/, K(149) /30/, K(150) /33/, K(151)
479: * /52/, K(152) /47/, K(153) /38/, K(154) /49/, K(155) /34/,
480: * K(156) /47/, K(157) /34/, K(158) /52/, K(159) /38/, K(160)
481: * /43/, K(161) /33/, K(162) /34/, K(163) /43/, K(164) /33/,
482: * K(165) /35/, K(166) /38/, K(167) /41/, K(168) /34/, K(169)
483: * /31/, K(170) /30/, K(171) /32/, K(172) /40/, K(173) /48/,
484: * K(174) /45/, K(175) /30/, K(176) /32/, K(177) /34/, K(178)
485: * /34/, K(179) /43/, K(180) /33/
486: DATA K(181) /35/, K(182) /44/, K(183) /47/, K(184) /42/, K(185)
487: * /30/, K(186) /49/
488: DATA KI(1) /15/, KI(2) /4/, KI(3) /7/, KI(4) /7/, KI(5) /7/,
489: * KI(6) /8/, KI(7) /9/, KI(8) /6/, KI(9) /10/, KI(10) /8/,
490: * KI(11) /9/, KI(12) /11/, KI(13) /4/, KI(14) /6/, KI(15) /4/,
491: * KI(16) /6/, KI(17) /8/, KI(18) /4/, KI(19) /4/, KI(20) /2/,
492: * KI(21) /2/, KI(22) /5/, KI(23) /4/, KI(24) /5/, KI(25) /6/,
493: * KI(26) /7/, KI(27) /9/, KI(28) /3/, KI(29) /6/, KI(30) /0/
494: DATA KT(1), KT(2), KT(3), KT(4), KT(5), KT(6), KT(7), KT(8)
495: * /8*1/, KT(9), KT(10), KT(11) /3*0/, KT(12) /2/, KT(13) /3/,
496: * KT(14), KT(15), KT(16), KT(17), KT(18), KT(19), KT(20),
497: * KT(21), KT(22), KT(23), KT(24), KT(25), KT(26), KT(27)
498: * /14*5/, KT(29), KT(30) /2*5/, KT(28) /6/
499: END
500: C XXXXXMAIN0.f
501: INTEGER STMT, PSTMT, SYMLEN, OUTUT, SYMHD, BNEXT, HASH, DSA,
502: * STACK, DOLIST, DOPT, OUTUT2, OUTUT3, PDSA, OUTUT4, REF, PREF,
503: * PNODE, PLAT, PCOM, COM
504: LOGICAL ERR, SYSERR, OPT, P1ERR, ABORT, P2
505: LOGICAL SW, QBR
506: COMMON /SWS/ SW(10)
507: C*****SWS
508: C SW(1) (LOG) IF TRUE, CAN USE END= OPTION IN READ STMTS
509: C
510: COMMON /OPTNS/ OPT(5), P1ERR
511: C
512: C*****OPTNS
513: C OPT(1) (LOG) IF TRUE, SYMBOL TABLE PRINTED FOR EACH P. U.
514: C OPT(2) (LOG) IF TRUE, CROSS REFERENCES PRINTED FOR EACH SYMBOL
515: C OPT(3) (LOG) IF TRUE, PASS 2 IS EXECUTED
516: C OPT(4) (LOG) IF TRUE, LISTING PRINTED FOR EACH P. U.
517: C OPT(5) (LOG) IF TRUE, FORTRAN PGM COMPILED AFTER VERIFIER
518: C RUN; IF ANY OF THESE ARE FALSE THE CORRESPONDING ACTION IS NOT TA
519: C P1ERR (LOG) SET TO TRUE IF INFO NORMALLY SAVED FOR PASS 2 IS
520: C SUPPRESSED FOR THIS P. U.
521: C
522: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
523: C
524: C*****INPUT
525: C NSTMT (INT) INDEX OF END-OF-INPUT-STMT CHARACTER IN STMT
526: C PSTMT (INT) POINTS TO CURRENT POSITION IN STMT (EXCEPT IN LEXICAL
527: C SUBPGMS WHERE IT IS UPDATED IN CALLING SUBPGM AFTER A TOKEN IS
528: C FOUND)
529: C STMT (INT) ENCODED FORM OF DEBLANKED INPUT STMT
530: C
531: COMMON /CEXPRS/ LSTACK, STACK(620)
532: C
533: C*****CEXPRS
534: C LSTACK (INT) LENGTH OF STACK
535: C STACK(*), (INT) ARRAY USED IN EXPR AS A STACK; ALSO FOR AUXILLARY
536: C STORAGE AND OUTPUT
537: C
538: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
539: * OUTUT4
540: C
541: C*****PARAMS
542: C INUT (INT) LOGICAL INPUT NUMBER FOR THE HOST MACHINE
543: C OUTUT (INT) LOGICAL OUTPUT NUMBER FOR THE HOST MACHINE
544: C NOCHAR (INT) NUMBER OF CHARACTERS PER MACHINE WORD IN HOST
545: C SYMLEN (INT) NUMBER OF WORDS NECESSARY ON HOST TO STORE 6
546: C CHARACTERS (I.E. A FORTRAN SYMBOL)
547: C OUTUT2 (INT), OUTUT3(INT), OUTUT4(INT) LOGICAL OUTPUT NUMBERS
548: C FOR THE HOST MACHINE TO BE USED BY THE VERIFIER FOR INTERPASS
549: C COMMUNICATION
550: C
551: COMMON /FACTS/ NAME, NOST, ITYP, IASF
552: C
553: C*****FACTS
554: C NAME (INT) INDEX IN SYMBOL TABLE OF ENTRY FOR CURRENT P.U.
555: C NOST (INT) STMT NUMBER OF CURRENT STMT BEING PROCESSED
556: C ITYP (INT) TYPE OF STMT CURRENTLY BEING PROCESSED (SEE PU
557: C FOR FURTHER DOC)
558: C
559: COMMON /DETECT/ ERR, SYSERR, ABORT
560: C
561: C*****DETECT
562: C ERROR (LOG) SET TO TRUE IN VARIOUS SUBPGMS USUALLY TO CEASE PROCES
563: C OF CURRENT STMT
564: C SYSERR (LOG) IRRECOVERABLE ERROR IN SYSTEM; (E.G., TABLE OVERFLOW)
565: C IN PASS 1 CAUSES CURRENT P.U. TO HAVE AN END STMT SIMULATED AND
566: C EXECUTION PROCEDES TO NEXT P.U.; IN PASS 2 CAUSES PROCESSING
567: C OF PROGRAM TO CEASE.
568: C
569: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
570: C
571: C*****TABL
572: C NEXT (INT) POINTS TO NEXT FREE WORD IN DSA (COUNTING FROM DSA(1))
573: C LABHD (INT) POINTS TO HEAD OF LINEAR LINKED LIST IN DSA OF ALL
574: C LABELS IN P.U.
575: C SYMHD (INT) POINTS TO HEAD OF LINEAR LINKED LIST IN DSA OF ALL
576: C SYMBOLS IN P.U.
577: C BNEXT (INT) POINTS TO NEXT FREE WORD IN DSA (COUNTING FROM
578: C DSA(LDSA))
579: C
580: COMMON /CHASH/ LHASH, HASH(401)
581: C
582: C*****CHASH
583: C LHASH (INT) LENGTH OF HASH ARRAY
584: C HASH (*) (INT) HASH TABLE USED TO INDEX INTO DSA
585: C
586: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
587: C
588: C*****CTABL
589: C LDSA (INT) LENGTH OF DSA
590: C DSA(*) (INT) SYMBOL TABLE (SEE LOOKUP FOR MORE EXPLICIT DOC)
591: C
592: COMMON /DOS/ DOPT, LDO, DOLIST(192)
593: C
594: C*****DOS
595: C DOPT (INT) POINTER TO FIRST FREE WORD IN DOLIST
596: C LDO (INT) LENGTH OF DOLIST
597: C DOLIST (*) (INT) ARRAY USED AS STACK FOR NESTING OF DOS (USED
598: C TO TEST FOR LEGAL BRANCHING WITHIN P.U. (SEE DOSPEC FOR FURTHER
599: C DOC)
600: C
601: COMMON /LISTDO/ LPT, LEN, LS(64)
602: C
603: C*****LISTDO
604: C LPT (INT) POINTER TO FIRST FREE WORD IN LS
605: C LEN (INT) LENGTH OF LS
606: C LS (*) (INT) ARRAY USED AS STACK FOR NESTING OF IMPLIED
607: C DO'S IN INPUT/OUTPUT STMTS (SEE DOSPEC FOR FURTHER DOC)
608: C
609: COMMON /PASS/ P2, QBR
610: C
611: C*****PASS
612: C P2 (LOG) IF TRUE, VERIFIER IS IN PASS 2; ELSE VERIFIER IS IN PASS
613: C QBR (LOG) IF TRUE, VERIFIER IS TO PRINT ERROR MESSAGES
614: C ELSE IS NOT
615: C
616: COMMON /CREF/ LREF, PREF, REF(100)
617: C
618: C*****CREF
619: C LREF (INT) TOTAL LENGTH OF ARRAY REF
620: C PREF (INT) CURRENT LENGTH OF REF
621: C REF (*) (INT) ARRAY CONTAINING INFORMATION CONCERNING A SUBR/FCN
622: C REF (SEE SETREF FOR FURTHER DOC)
623: C
624: COMMON /HEAD/ LNODE, PNODE, NODE(500)
625: C
626: C*****HEAD
627: C LNODE (INT) LENGTH OF NODE
628: C PNODE (INT) POINTER TO NEXT FREE WORD IN NODE
629: C NODE (*) (INT) ARRAY OF INDICES OF P.U. ENTRIES IN LAT
630: C
631: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
632: C
633: C*****GRAPH
634: C LLAT (INT) LENGTH OF LAT
635: C PLAT (INT) POINTER TO NEXT FREE WORD IN LAT
636: C LAT (*) (INT) ARRAY WHOSE ENTRIES DESCRIBE EACH P.U. IN PGM
637: C AND THEIR INTER-RELNS (SEE SETNOD FOR FURTHER DOC)
638: C
639: COMMON /COMS/ LCOM, PCOM, COM(300)
640: C
641: C*****COMS
642: C LCOM (INT) LENGTH OF COM
643: C PCOM (INT) POINTER TO NEXT FREE WORD IN COM
644: C COM (*) (INT) ARRAY WHOSE ENTRIES DESCRIBE EACH COMMON BLOCK
645: C IN PGM (SEE SETCOM FOR FURTHER DOC)
646: COMMON /SCR1/ LINODE, INODE(500)
647: COMMON /SCR2/ LNNODE, NNODE(500)
648: C
649: C***SCR1,SCR2,SCR3
650: C INODE(INT), NNODE(INT) SCRATCH ARRAYS KEYED ON LENGTH NODE(*)
651: C LINNODE = LNNODE .GE. MAX( LNODE, LCOM/(SYMLEN+5) )
652: C
653: C THREE MORE BLOCK COMMON REGIONS ARE USED : STS -SEE TYPST
654: C TRANS - SEE MAPCHR EXPRS - SEE EXPR FOR FURTHER DOC
655: C
656: QBR = .FALSE.
657: NOCHAR = 4
658: INUT = 5
659: OUTUT = 6
660: OUTUT2 = 7
661: OUTUT3 = 8
662: OUTUT4 = 9
663: C NOCHAR WAS &, OUT2-4 was 12,13,14 in distribution tape
664: REWIND INUT
665: REWIND OUTUT2
666: REWIND OUTUT3
667: REWIND OUTUT4
668: LEN = 64
669: SYMLEN = (5/NOCHAR) + 1
670: P2 = .FALSE.
671: ERR = .FALSE.
672: ABORT = .FALSE.
673: SYSERR = .FALSE.
674: SW(1) = .FALSE.
675: PDSA = 1
676: LDSA = 5000
677: LHASH = 401
678: DO 10 I=1,LHASH
679: HASH(I) = 0
680: 10 CONTINUE
681: OPT(1) = .TRUE.
682: OPT(2) = .TRUE.
683: OPT(3) = .TRUE.
684: OPT(4) = .TRUE.
685: OPT(5) = .FALSE.
686: LSTACK = 620
687: LREF = 100
688: PREF = 1
689: LDO = 192
690: CALL OVRLAY(1)
691: CALL PU
692: IF (.NOT.OPT(3) .OR. SYSERR) GO TO 30
693: P2 = .TRUE.
694: IF (.NOT.OPT(4)) WRITE (OUTUT,99999)
695: 99999 FORMAT (1H1)
696: CALL OVRLAY(2)
697: LLAT = 6000
698: PLAT = 1
699: BNEXT = LDSA
700: NEXT = 1
701: LNODE = 500
702: PNODE = 1
703: LCOM = 300
704: PCOM = 1
705: LINODE = LNODE
706: LNNODE = LNODE
707: C
708: C PASS 1 CAN SUPPRESS PASS 2 PROCESSING FOR SPECIFIC P.U.
709: C BUT NEVER SHUTS OFF PASS 2 COMPLETELY; PASS 2 CAN CEASE
710: C PROCESSING FOR VARIOUS REASONS:
711: C 1. 2 SUBPRGMS WITH SAME NAME(IN SETNOD)
712: C 2. NO PROGRAM UNIT SUCCESSFULLY PASSED TO PASS 2
713: C (IN CONSTR)
714: C 3. RECURSION (IN ASLEV AND INVOKE)
715: C IF MISSING SUBPRGMS ARE DISCOVERED, PASS 2 CAN
716: C PROCEDE WITH INCOMPLETE PROCESSING, A MESSAGE
717: C IS PRINTED TO INFORM THE USER
718: C
719: REWIND OUTUT2
720: REWIND OUTUT3
721: REWIND OUTUT4
722: CALL CONSTR(IROOT)
723: C CAN RETURN FROM CONSTR IN ERROR CONDITION WITH FILES LACKING
724: C VERIFIER SOFTWARE END OF FILE
725: IF (ABORT .OR. SYSERR) GO TO 30
726: REWIND OUTUT4
727: REWIND OUTUT3
728: REWIND OUTUT2
729: CALL CHECKS(IROOT)
730: 20 REWIND INUT
731: CALL OVRLAY(3)
732: CALL COMPIL(.NOT.(ABORT.OR.SYSERR).AND.OPT(5))
733: STOP
734: 30 WRITE (OUTUT,99998)
735: 99998 FORMAT (47H1INTER-PROGRAM-UNIT COMMUNICATIONS NOT VERIFIED)
736: GO TO 20
737: END
738: C XXXXXCOMPIL.f
739: SUBROUTINE COMPIL(FLAG)
740: C
741: LOGICAL FLAG
742: C
743: RETURN
744: C
745: END
746: C XXXXXOVRLAY.f
747: SUBROUTINE OVRLAY(N)
748: C
749: RETURN
750: C
751: END
752: C XXXXXSATT1.f
753: SUBROUTINE SATT1(INDEX, FIELD, ATT)
754: C
755: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
756: C
757: INTEGER INDEX, FIELD, ATT
758: INTEGER LDSA, PDSA, DSA
759: INTEGER FWTH(8), FPOS(8)
760: C
761: DATA FWTH(1) /16/, FPOS(1) /1/
762: DATA FWTH(2) /2/, FPOS(2) /16/
763: DATA FWTH(3) /2/, FPOS(3) /32/
764: DATA FWTH(4) /2/, FPOS(4) /64/
765: DATA FWTH(5) /2/, FPOS(5) /128/
766: DATA FWTH(6) /2/, FPOS(6) /256/
767: DATA FWTH(7) /4/, FPOS(7) /512/
768: DATA FWTH(8) /32/, FPOS(8) /2048/
769: C
770: DSA(INDEX) = DSA(INDEX) + (ATT-MOD(DSA(INDEX)/FPOS(FIELD),
771: * FWTH(FIELD)))*FPOS(FIELD)
772: C
773: RETURN
774: C
775: END
776: C XXXXXIGATT1.f
777: INTEGER FUNCTION IGATT1(INDEX, FIELD)
778: C
779: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
780: C
781: INTEGER INDEX, FIELD
782: INTEGER LDSA, PDSA, DSA
783: INTEGER FWTH(8), FPOS(8)
784: C
785: DATA FWTH(1) /16/, FPOS(1) /1/
786: DATA FWTH(2) /2/, FPOS(2) /16/
787: DATA FWTH(3) /2/, FPOS(3) /32/
788: DATA FWTH(4) /2/, FPOS(4) /64/
789: DATA FWTH(5) /2/, FPOS(5) /128/
790: DATA FWTH(6) /2/, FPOS(6) /256/
791: DATA FWTH(7) /4/, FPOS(7) /512/
792: DATA FWTH(8) /32/, FPOS(8) /2048/
793: C
794: IGATT1 = MOD(DSA(INDEX)/FPOS(FIELD),FWTH(FIELD))
795: C
796: RETURN
797: C
798: END
799: C XXXXXEXCH.f
800: INTEGER FUNCTION EXCH(J1, J2, DSA, LDSA, HASH, LHASH, OFFSET)
801: INTEGER DSA(LDSA), HASH(LHASH), OFFSET
802: INTEGER OUTUT, SYMLEN, OUTUT2, OUTUT3, OUTUT4
803: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
804: * OUTUT4
805: C
806: C DSA(HASH(J1)+OFFSET) CONTAINS ELE TO BE COMPARED
807: C DSA(HASH(J2)+OFFSET) CONTAINS ELE TO BE COMPARED
808: C
809: JJ1 = HASH(J1) + OFFSET
810: JJ2 = HASH(J2) + OFFSET
811: DO 40 I=1,SYMLEN
812: K1 = JJ1 + I - 1
813: K2 = JJ2 + I - 1
814: IF (DSA(K1)) 10, 20, 20
815: 10 IF (DSA(K2)) 30, 50, 50
816: 20 IF (DSA(K2)) 70, 30, 30
817: 30 IF (DSA(K1)-DSA(K2)) 70, 40, 50
818: 40 CONTINUE
819: C
820: C COMPARISON SHOWS ELEMENTS IN PROPER ORDER
821: C
822: 50 EXCH = 0
823: 60 RETURN
824: C
825: C COMPARISON SHOWS NEED FOR EXCHANGE
826: C
827: 70 I = HASH(J1)
828: HASH(J1) = HASH(J2)
829: HASH(J2) = I
830: EXCH = -1
831: GO TO 60
832: END
833: C XXXXXSSORT.f
834: SUBROUTINE SSORT(EX, X, LX, Q, L, OFFSET)
835: INTEGER EX, X(LX), Q(L), OFFSET
836: EXTERNAL EX
837: C
838: C ENTRIES SPACED 1 APART IN HASH TABLE
839: C EX IS EXCHANGE ROUTINE--RETURNS<0 IF EXCHANGES ITEMS
840: C RETURNS >=0 IF DOESN'T
841: C L IS NUMBER OF THINGS TO BE SORTED, SPACING IS 1 HERE
842: C START SHELL SORT
843: C
844: M = 1
845: 10 IF (M.GE.L) GO TO 20
846: M = M*2
847: GO TO 10
848: 20 M = M/2
849: IF (M.LT.1) RETURN
850: K = L - M
851: C
852: C IN PASS1 ARE SORTING SYMBOL TABLE
853: C IN PASS 2 ARE SORTING LATTICE
854: C OR COMMON BLOCK DEFS
855: C
856: DO 50 J=1,K
857: I = J
858: 30 IF (EX(I+M,I,X,LX,Q,L,OFFSET)) 40, 50, 50
859: C
860: C BUBBLE SORT W/I SUBLIST
861: C
862: 40 I = I - M
863: IF (I.GE.1) GO TO 30
864: 50 CONTINUE
865: GO TO 20
866: END
867: C XXXXXERROR1.f
868: SUBROUTINE ERROR1(MESS, LMESS)
869: C
870: INTEGER MESS(20), LMESS
871: INTEGER ZERO(1)
872: C
873: DATA ZERO(1) /0/
874: C
875: CALL ERROR2(MESS, LMESS, ZERO(1), ZERO(1), 1, 1)
876: C
877: RETURN
878: C
879: END
880: C XXXXXERROR2.f
881: SUBROUTINE ERROR2( I, JJ, K, NN, SPBEF, SPAFT )
882: C
883: C PRINTS ERROR MESSAGES AND SYMBOLIC NAME
884: C I IS PACKED HOLLERITH STRING
885: C JJ IS NUMBER OF CHARACTERS TO BE PRINTED ( N = JJ)
886: C K CONTAINS INTEGER OR HOLLERITH INFO TO FOLLOW MESSAGE
887: C NN CONTROLS TYPE OF LINE TO BE PRINTED
888: C
889: C NN = 0 MEANS PRINT MESSAGE
890: C
891: C NN < 0 MEANS IF JJ=0 NO MESSAGE, ELSE PRINT MESSAGE
892: C ON NEXT LINE IF NN = -1 PRINT PGM UNIT AND/OR STMT NO
893: C (CONTROLLED BY CONTENTS OF K).
894: C ON NEXT LINE IF NN = -2 PRINT PARAMETER NUMBER IN K
895: C NN = -3 USED FOR SPACING CONTROL IN LONG MESSAGES
896: C
897: C NN > 0 MEANS PRINT MESSAGE FOLLOWED BY IDENTIFIER IN K
898: C SPBEF, SPAFT CONTROL LINE SPACING BEFORE AND AFTER MESSAGE
899: C IF = 1, BLANK LINE EMMITTED
900: C
901: INTEGER I(1), J(80), OUTUT, PDSA, DSA, M(6), K(6), W
902: INTEGER SPBEF, SPAFT
903: LOGICAL OPT, P1ERR, P2, QBR
904: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
905: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, I1, I2, I3, I4
906: COMMON /FACTS/ NAME, NOST, ITYP, IASF
907: COMMON /OPTNS/ OPT(5), P1ERR
908: COMMON /PASS/ P2, QBR
909: DATA W /1HW/, KK /1H-/
910: C
911: C ERROR IN P.U. DURING PROCESSING OF A HEADING STMT, SPECIFI STMT,
912: C EQUIV STMT, OR DATA STMT CAUSES PASS 2 TO BE SUPPRESSED FOR THAT
913: C P.U.
914: C
915: IF (QBR) GOTO 45
916: IF(SPBEF.EQ.1) WRITE(OUTUT, 99998)
917: N = JJ
918: IF (N.GT.72) N = 72
919: J(2) = KK
920: IF (N.GE.1) CALL S5UNPK(I, J, N)
921: IF (ITYP.LT.14 .AND. J(2).NE.W) P1ERR = .TRUE.
922: IF (NN) 50, 10, 30
923: C
924: C NN=0
925: C
926: 10 CONTINUE
927: WRITE (OUTUT,99997) (J(L),L=1,N)
928: IF(P2 .OR. OPT(4)) GOTO 40
929: CALL S5UNPK(DSA(NAME+4), J(1), 6)
930: WRITE (OUTUT,99999) NOST, (J(L),L=1,6)
931: 99999 FORMAT (16H *** AT STMT NO , I6, 13H IN PGM UNIT , 6A1)
932: 99998 FORMAT(1H )
933: GO TO 40
934: C
935: C NN>0
936: C
937: 30 CONTINUE
938: IF (N.GT.68) N = 68
939: CALL S5UNPK(K, J(73), 6)
940: WRITE (OUTUT,99997) (J(L),L=1,N), KK, KK, (J(L),L=73,78)
941: 99997 FORMAT (4H ***, 76A1)
942: 40 IF(SPAFT.EQ.1) WRITE(OUTUT, 99998)
943: 45 RETURN
944: C
945: C NN<0
946: C
947: 50 CONTINUE
948: IF (N.GE.1) WRITE (OUTUT,99997) (J(L),L=1,N)
949: IF( -2.EQ.NN ) GOTO 70
950: IF( -3.EQ.NN ) GOTO 40
951: CALL S5UNPK(DSA(NAME+4), M(1), 6)
952: C WRITE OUT STMT NO AND/OR PGM UNIT
953: IF (K(1).EQ.0) GO TO 60
954: WRITE (OUTUT,99996) K(1), (M(L),L=1,6)
955: 99996 FORMAT (16H *** AT STMT NO , I6, 1X, 13H IN PGM UNIT , 6A1)
956: GO TO 40
957: 60 WRITE (OUTUT,99995) (M(L),L=1,6)
958: 99995 FORMAT (17H *** IN PGM UNIT , 6A1)
959: GO TO 40
960: C WRITE OUT PARAMETER NO FOR PARAMETERLIST ERRORS
961: 70 WRITE(OUTUT,99994) K(1)
962: 99994 FORMAT(22H *** PARAMETER NUMBER ,I6)
963: GOTO 40
964: END
965: C XXXXXARDECL.f
966: LOGICAL FUNCTION ARDECL(K2, KK)
967: C
968: C K2 IS INDEX OF END OF ARRAY DECLARATOR IN STMT
969: C KK IS SYMBOL TABLE INDEX FOR THIS ARRAY
970: C PROCESSES ARRAY DECLARATOR AND DECLARATOR CONSTRUCTS.
971: C CAN EXPECT ARRAY DECLARATOR, ARRAY ELEMENT; ARRAY, VARIABLE.
972: C ENTERS INTO SYMBOL TABLE AND TYPES ID; SETS USAGE ON ARRAY
973: C DECLARATOR
974: C CHECKS SYNTAX OF BOUNDS; IF VARIABLY DIMENSIONED, BOUNDS
975: C VARIABLE AND ARRAY ITSELF MUST BE DUMMY ARGUMENTS.
976: C ACCUMULATES TOTAL LENGTH OF ARRAY WITH CONSTANT BOUNDS AND STORES
977: C IT OFF ARRAY SYMBOL TABLE ENTRY. -1 LENGTH INDICATES VARIABLE
978: C DIMENSION
979: C CALLED BY DIMENSION, TYPE, COMMON, EQUIVALENCE, DATA STMT.
980: C
981: C ARRY IS TRUE FOR ARRAY ELEMENTS/ARRAY DECLARATORS
982: C FALSE FOR ARRAYS AND VARIABLES
983: C CORNER IS TRUE FOR ARRAY ELEMENTS WITH (1,1,1)--NEEDED IN EQUIV.
984: C STMT ; IF SUCH AN ELEMENT IS RECOGNIZED KK IS SENT AS ITS
985: C NEGATIVE.
986: C
987: LOGICAL ERR, SYSERR, ABORT, TOKPNO, VAR, CORNER, ARRY, FLUSH
988: INTEGER STMT, PSTMT, PDSA, BNEXT, SYMHD, DSA
989: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
990: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
991: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
992: COMMON /FACTS/ NAME, NOST, ITYP, IASF
993: COMMON /DETECT/ ERR, SYSERR, ABORT
994: ERR = .FALSE.
995: FLUSH = .FALSE.
996: ARRY = .FALSE.
997: CORNER = .TRUE.
998: ARDECL = .FALSE.
999: C
1000: C CHECK NAME; CAN'T HAVE BEEN USED PREVIOUSLY AS A NONVAR;
1001: C CHECK TO SEE IF HAVE ARRAY ELEMENT/ARRAY DECLARATOR. IF SO
1002: C ARRY=.TRUE.
1003: C
1004: ICNT = 0
1005: CALL NEXTOK(PSTMT, K2, I1)
1006: IF (I1.EQ.0) GO TO 10
1007: CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
1008: ERR = .TRUE.
1009: GO TO 280
1010: 10 IF (STMT(K2).EQ.65) ARRY = .TRUE.
1011: KK = LOOKUP(K2,.FALSE.)
1012: IF (SYSERR) GO TO 70
1013: ARDECL = .TRUE.
1014: L = IGATT1(KK,8)
1015: IF (L.EQ.0 .OR. L.EQ.10) GO TO 30
1016: IF (ITYP.LT.6 .AND. L.EQ.13) GO TO 30
1017: 20 CALL ERROR1(45H ILLEGAL USE OF PREVIOUSLY DEFINED IDENTIFIER, 45)
1018: ERR = .TRUE.
1019: GO TO 280
1020: C
1021: C SET TYPE (EXPLICITLY FOR TYPE STMTS)
1022: C
1023: 30 I1 = IGATT1(KK,1)
1024: IF (ITYP.GE.6) GO TO 50
1025: C
1026: C TYPE EXPLICITLY
1027: C
1028: IF (I1.GE.8) GO TO 40
1029: CALL SATT1(KK, 1, ITYP+7)
1030: GO TO 60
1031: 40 CALL ERROR1(34H IDENTIFIER TYPED EXPLICITLY TWICE, 34)
1032: GO TO 60
1033: C
1034: C TYPE IMPLICITLY
1035: C
1036: 50 IF (I1.GT.0) GO TO 60
1037: I1 = 1
1038: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
1039: CALL SATT1(KK, 1, I1)
1040: C
1041: C IF NOT ARRAY ELEMENT/ARAY DECLARATOR--RECOGNITION COMPLETE
1042: C
1043: C CHECK NOT A DUMMY ARG IN COMMON, DATA, EQUIV STMT
1044: C
1045: 60 IF (ARRY) GO TO 80
1046: IF (IGATT1(KK,7).EQ.0) GO TO 65
1047: IF (ITYP.EQ.12)
1048: 1 CALL ERROR1(46H WARNING - ILLEGAL USE OF ARRAY IN EQUIVALENCE
1049: 2 , 46)
1050: IF (ITYP.EQ.13)
1051: 1 CALL ERROR1(39H WARNING - ILLEGAL USE OF ARRAY IN DATA, 39)
1052: 65 CONTINUE
1053: I1 = IGATT1(KK,4)
1054: IF (.NOT.(I1.EQ.1 .AND. (ITYP.EQ.8 .OR. ITYP.EQ.12 .OR.
1055: * ITYP.EQ.13))) GO TO 70
1056: ERR = .TRUE.
1057: CALL ERROR1(32H ILLEGAL USAGE OF DUMMY ARGUMENT, 32)
1058: 70 RETURN
1059: 80 ISIZ = 1
1060: VAR = .FALSE.
1061: IF (L.EQ.0) CALL SATT1(KK, 8, 10)
1062: C
1063: C LOOP TO FIND BOUNDS; CHECK THAT VARIABLE BOUNDS ARE DUMMY ARGS
1064: C SET ADJUSTIBLE DIMENSION VARIABLE BIT; SET TYPE IMPLICITLY IF NOT
1065: C ALREADY SET
1066: C ACCUMULATE LENGTH IF IN DIMENSION, COMMON, OR TYPE STMT.
1067: C CHECK FOR REPEAT DIMENSIONING IN THOSE STMTS
1068: C
1069: L = IGATT1(KK,7)
1070: IF (ITYP.EQ.13 .OR. ITYP.EQ.12) GO TO 90
1071: IF (L.EQ.0) GO TO 100
1072: CALL ERROR1(44H ILLEGAL USE OF PREVIOUSLY DIMENSIONED ARRAY, 44)
1073: ERR = .TRUE.
1074: GO TO 270
1075: 90 IF (L.EQ.0) CALL ERROR1(
1076: * 44H ILLEGAL USE OF ARRAY NOT PREVIOUSLY DEFINED, 44)
1077: 100 IF (K2+1.LT.NSTMT) GO TO 120
1078: 110 CALL ERROR1(28H ILLEGAL ARRAY BOUNDS SYNTAX, 28)
1079: GO TO 270
1080: C
1081: C CHECK FOR POSITIVE INTEGER BOUND
1082: C
1083: 120 PSTMT = K2 + 1
1084: IF (.NOT.TOKPNO(PSTMT,I1,LL)) GO TO 130
1085: IF (ITYP.EQ.7 .OR. ITYP.EQ.8 .OR. ITYP.LT.6) ISIZ = ISIZ*LL
1086: IF (ITYP.NE.12) GO TO 170
1087: IF (I1-K2.NE.2 .OR. STMT(PSTMT).NE.1) CORNER = .FALSE.
1088: GO TO 170
1089: C
1090: C SEEK A VARIABLE BOUND
1091: C
1092: 130 CALL NEXTOK(PSTMT, I1, L)
1093: IF (L.NE.0) GO TO 110
1094: IF (ITYP.LT.6 .OR. ITYP.EQ.7) GO TO 140
1095: CALL ERROR1(32H VARIABLE DIMENSION ILLEGAL HERE, 32)
1096: ERR = .TRUE.
1097: GO TO 270
1098: 140 VAR = .TRUE.
1099: L = LOOKUP(I1,.FALSE.)
1100: IF (SYSERR) GO TO 70
1101: N = IGATT1(L,8)
1102: IF (N.NE.0 .AND. N.NE.10) GO TO 20
1103: I2 = IGATT1(L,4)
1104: IF (I2.EQ.1) GO TO 150
1105: CALL ERROR1(42H ILLEGAL USAGE OF VARIABLE IN ARRAY BOUNDS, 42)
1106: ERR = .TRUE.
1107: GO TO 270
1108: 150 I2 = IGATT1(KK,4)
1109: IF (I2.EQ.1) GO TO 160
1110: CALL ERROR1(50H VARIABLY DIMENSIONED ARRAY MUST BE DUMMY ARGUMENT,
1111: * 50)
1112: ERR = .TRUE.
1113: GO TO 270
1114: 160 CALL SATT1(L, 6, 1)
1115: CALL SATT1(L, 8, 10)
1116: N = IGATT1(L,1)
1117: IF (N.GT.0) GO TO 170
1118: N = 1
1119: IF (STMT(K2+1).GE.38 .AND. STMT(K2+1).LE.43) N = 2
1120: CALL SATT1(L, 1, N)
1121: GO TO 170
1122: C
1123: C FIND "," AND ACCUMULATE LENGTH
1124: C
1125: 170 ICNT = ICNT + 1
1126: IF (ICNT.LE.3) GO TO 180
1127: ISIZ = ISIZ/LL
1128: CALL ERROR1(30H WARNING - TOO MANY SUBSCRIPTS, 30)
1129: ICNT = 3
1130: FLUSH = .TRUE.
1131: GO TO 190
1132: 180 K2 = I1
1133: IF (STMT(K2).EQ.68) GO TO 100
1134: C
1135: C FIND ")" STORE LENGTH OR -1 INTO ARRAY SYMBOL TABLE ELEMENT
1136: C
1137: IF (STMT(K2).NE.62) GO TO 110
1138: 190 IF (ITYP.EQ.13 .OR. ITYP.EQ.12) GO TO 260
1139: CALL SATT1(KK, 7, ICNT)
1140: C
1141: C STORE LENGTH OF ARRAY
1142: C
1143: IF (VAR) GO TO 240
1144: IF (DSA(KK+2).EQ.0) GO TO 200
1145: N = DSA(KK+2)
1146: DSA(N) = ISIZ
1147: GO TO 220
1148: 200 IF (NEXT+2.GE.BNEXT) GO TO 210
1149: DSA(KK+2) = NEXT
1150: DSA(NEXT) = ISIZ
1151: DSA(NEXT+1) = 0
1152: NEXT = NEXT + 2
1153: GO TO 220
1154: 210 SYSERR = .TRUE.
1155: CALL ERROR1(33H IN ARDECL, TABLE OVERFLOW OF DSA,33)
1156: 220 IF (FLUSH) GO TO 270
1157: 230 K2 = K2 + 1
1158: GO TO 70
1159: C
1160: C FIXUP FOR VARIABLY DIMENSIONED ARRAYS
1161: C
1162: 240 IF (DSA(KK+2).EQ.0) GO TO 250
1163: N = DSA(KK+2)
1164: DSA(N) = -1
1165: GO TO 220
1166: 250 IF (NEXT+2.GE.BNEXT) GO TO 210
1167: DSA(KK+2) = NEXT
1168: DSA(NEXT) = -1
1169: DSA(NEXT+1) = 0
1170: NEXT = NEXT + 2
1171: GO TO 220
1172: C
1173: C CHECK FORCORNER ELEMENT IN EQUIVALENCE STMT
1174: C
1175: 260 IF (ITYP.NE.12) GO TO 220
1176: IF (CORNER) KK = -KK
1177: GO TO 220
1178: C
1179: C CODE TO FLUSH CONSTRUCT--TO NEXT ")"
1180: C
1181: 270 IF (K2.EQ.NSTMT) GO TO 70
1182: IF (STMT(K2).EQ.62) GO TO 230
1183: K2 = K2 + 1
1184: GO TO 270
1185: C
1186: C CODE TO FLUSH TO NEXT CONSTRUCT ")",",", "/"
1187: C
1188: 280 K = 90
1189: IF (ITYP.EQ.8 .OR. ITYP.EQ.13) K = 67
1190: 290 IF (K2.EQ.NSTMT) GO TO 70
1191: L = STMT(K2)
1192: IF (L.EQ.65) GO TO 270
1193: IF (L.EQ.68 .OR. L.EQ.K) GO TO 70
1194: K2 = K2 + 1
1195: GO TO 290
1196: END
1197: C XXXXXASSASF.f
1198: SUBROUTINE ASSASF(IGP)
1199: INTEGER STMT, PSTMT, PDSA, EXPR, DSA, BNEXT, SYMHD
1200: LOGICAL ERR, SYSERR, ABORT, ASF, DOVAR
1201: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
1202: COMMON /DETECT/ ERR, SYSERR, ABORT
1203: COMMON /FACTS/ NAME, NOST, ITYP, IASF
1204: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
1205: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
1206: C
1207: C PROCESSES ARITHMETIC STMT FCNS AND ASSIGNMENT STMTS
1208: C FIRST LOOKS FOR ELEMENT ON RHS. AND TYPES IT
1209: C
1210: CALL NEXTOK(PSTMT, K2, K)
1211: ASF = .FALSE.
1212: IF (K.NE.0) GO TO 180
1213: K = LOOKUP(K2,.FALSE.)
1214: IF (SYSERR) GO TO 190
1215: I1 = IGATT1(K,1)
1216: IF (I1.NE.0) GO TO 10
1217: I1 = 1
1218: IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I1 = 2
1219: CALL SATT1(K, 1, I1)
1220: C
1221: C LOOK FOR A "(" ; FIND ARRAY = CASE AND SEND IT TO ERROR
1222: C FIND ARRAY ELEMENT = , ID = CASES AND SEND THEM TO
1223: C ASSIGNMENT CODE
1224: C
1225: 10 I2 = IGATT1(K,7)
1226: I1 = MOD(I1,8)
1227: IF (STMT(K2).NE.65 .AND. I2.NE.0) GO TO 180
1228: IF (STMT(K2).NE.65 .OR. I2.NE.0) GO TO 240
1229: C
1230: C ASF DEFN
1231: C
1232: ITYP = 31
1233: ASF = .TRUE.
1234: IGP = 4
1235: NUM = 0
1236: IASF = K
1237: 20 PSTMT = K2 + 1
1238: IF (PSTMT.GE.NSTMT) GO TO 180
1239: C
1240: C ASF HAS LIST OF SCALAR VARIABLES; THEY ARE TYPED AND USAGE SET
1241: C
1242: CALL NEXTOK(PSTMT, K2, I)
1243: IF (I.EQ.0) GO TO 30
1244: CALL ERROR1(17H ILLEGAL ASF DEFN, 17)
1245: GO TO 190
1246: 30 I = LOOKUP(K2,.FALSE.)
1247: IF (SYSERR) GO TO 190
1248: NUM = NUM + 1
1249: I2 = IGATT1(I,1)
1250: IF (I2.GT.0) GO TO 40
1251: I2 = 1
1252: IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I2 = 2
1253: CALL SATT1(I, 1, I2)
1254: 40 I2 = IGATT1(I,8)
1255: IF (I2.EQ.0) GO TO 50
1256: IF (I2.EQ.1) GO TO 60
1257: CALL ERROR1(29H ILLEGAL VARIABLE IN ASF DEFN, 29)
1258: GO TO 210
1259: 50 CALL SATT1(I, 8, 1)
1260: C STORE PTR TO CURRENT ASF-FCN ENTRY IN SYMBOL
1261: C TABLE IN 3D WORD OF ASF-DUMMY ENTRY IN SYM TABLE
1262: 60 DSA(I+2) = K
1263: C
1264: C LIST OF INDICES OF ASF ARGS IS HUNG OFF OF ASF DEF IN DSA
1265: C
1266: IF (DSA(K+2).EQ.0) GO TO 120
1267: L = DSA(K+2)
1268: 70 IF (DSA(L+1).EQ.0) GO TO 80
1269: L = DSA(L+1)
1270: GO TO 70
1271: 80 IF (NEXT+2.LT.BNEXT) GO TO 100
1272: 90 CALL ERROR1(33H IN ASSASF, TABLE OVERFLOW OF DSA, 33)
1273: SYSERR = .TRUE.
1274: GO TO 190
1275: 100 DSA(L+1) = NEXT
1276: 110 DSA(NEXT) = I
1277: DSA(NEXT+1) = 0
1278: NEXT = NEXT + 2
1279: GO TO 130
1280: 120 IF (NEXT+2.GE.BNEXT) GO TO 90
1281: DSA(K+2) = NEXT
1282: GO TO 110
1283: 130 IF (STMT(K2).NE.62) GO TO 170
1284: C
1285: C CHECK FOR TWO ELEMENTS ONLIST BEING THE SAME ID
1286: C
1287: I2 = DSA(K+2)
1288: DO 160 I=1,NUM
1289: L = DSA(K+2)
1290: DO 150 J=1,NUM
1291: IF (I.EQ.J) GO TO 140
1292: IF (DSA(L).NE.DSA(I2)) GO TO 140
1293: CALL ERROR1(18H ILLEGAL ASF-DUMMY, 18)
1294: CALL SATT1(K, 8, 0)
1295: GO TO 190
1296: 140 L = DSA(L+1)
1297: 150 CONTINUE
1298: I2 = DSA(I2+1)
1299: 160 CONTINUE
1300: GO TO 200
1301: 170 IF (STMT(K2).EQ.68) GO TO 20
1302: 180 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
1303: 190 RETURN
1304: C
1305: C = AND EXPR CHECK
1306: C
1307: 200 PSTMT = K2 + 1
1308: 210 IF (PSTMT.GE.NSTMT) GO TO 180
1309: IF (STMT(PSTMT).NE.63) GO TO 180
1310: PSTMT = PSTMT + 1
1311: IF (PSTMT.GE.NSTMT) GO TO 180
1312: L = EXPR(I)
1313: IF (SYSERR) GO TO 190
1314: C
1315: C CHECK THAT ASF WAS NOT DEFINED RECURSIVELY, SET USAGE
1316: C
1317: IF (.NOT.ASF) GO TO 230
1318: I2 = IGATT1(K,8)
1319: IF (I2.EQ.0) GO TO 220
1320: CALL ERROR1(17H ILLEGAL ASF NAME, 17)
1321: GO TO 190
1322: 220 CALL SATT1(K, 8, 2)
1323: 230 IF (L/8.EQ.1) GO TO 280
1324: L = MOD(L,8)
1325: C
1326: C COMPARE TYPES OF RHS AND LHS
1327: C
1328: IF ((L.EQ.3 .AND. I1.EQ.3) .OR. (L.EQ.4 .AND. I1.EQ.4) .OR.
1329: * (L.LE.2 .AND. I1.LE.2) .OR. (L.EQ.5 .AND. I1.EQ.5)) GO TO 190
1330: IF (.NOT.(L.EQ.2 .AND. I1.EQ.5 .OR. L.EQ.5 .AND. I1.EQ.2)) CALL
1331: * ERROR1(38H INCOMPATIBLE DATA TYPES IN ASSIGNMENT, 38)
1332: GO TO 190
1333: C
1334: C PROCESSING FOR ASSIGNMENT STMT
1335: C
1336: 240 I = IGATT1(K,8)
1337: IF (I.NE.0) GO TO 250
1338: I = 10
1339: CALL SATT1(K, 8, 10)
1340: 250 IF (I.EQ.10 .OR. (I.EQ.4 .AND. K.EQ.NAME)) GO TO 260
1341: CALL ERROR1(31H CANNOT ASSIGN VALUE TO THIS ID, 31)
1342: GO TO 190
1343: 260 CALL SATT1(K, 5, 1)
1344: IF (STMT(K2).EQ.65) GO TO 270
1345: IF (DOVAR(K)) CALL ERROR1(
1346: * 57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS,
1347: * 57)
1348: PSTMT = K2
1349: GO TO 210
1350: 270 PSTMT = K2 + 1
1351: IF (PSTMT.GE.NSTMT) GO TO 180
1352: CALL SUBS(I, I2)
1353: C
1354: C PEEL SUBSCRIPTS OFF
1355: C
1356: IF (SYSERR .OR. ERR) GO TO 190
1357: PSTMT = I
1358: GO TO 210
1359: 280 CALL ERROR1(30H ILLEGAL USE OF ARRAY VARIABLE, 30)
1360: GO TO 190
1361: END
1362: C XXXXXASSIGN.f
1363: SUBROUTINE ASSIGN
1364: INTEGER PSTMT, STMT
1365: LOGICAL TOKLAB, ERR, SYSERR, ABORT
1366: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
1367: COMMON /DETECT/ ERR, SYSERR, ABORT
1368: C
1369: C PROCESSES AN ASSIGN STMT: ASSIGN <LABEL> TO <VAR>
1370: C
1371: IF (PSTMT.GE.NSTMT) GO TO 10
1372: IF (.NOT.TOKLAB(1,K2,KK,.FALSE.)) GO TO 80
1373: IF (SYSERR) GO TO 20
1374: PSTMT = K2
1375: IF (PSTMT+2.GE.NSTMT) GO TO 10
1376: IF (STMT(PSTMT).EQ.49 .AND. STMT(PSTMT+1).EQ.44) GO TO 30
1377: 10 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
1378: 20 RETURN
1379: 30 PSTMT = PSTMT + 2
1380: IF (PSTMT.GE.NSTMT) GO TO 10
1381: CALL NEXTOK(PSTMT, K2, K)
1382: IF (K.NE.0) GO TO 10
1383: K = LOOKUP(K2,.FALSE.)
1384: IF (SYSERR) GO TO 20
1385: I1 = IGATT1(K,1)
1386: I2 = IGATT1(K,7)
1387: I3 = IGATT1(K,8)
1388: IF (I3.EQ.0) GO TO 40
1389: IF (I3.NE.8) GO TO 90
1390: GO TO 50
1391: 40 CALL SATT1(K, 8, 8)
1392: 50 IF (I1.NE.0) GO TO 60
1393: I1 = 1
1394: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
1395: CALL SATT1(K, 1, I1)
1396: 60 IF (MOD(I1,8).EQ.2 .AND. I2.EQ.0) GO TO 70
1397: CALL ERROR1(35H ASSIGN VARIABLE NOT INTEGER SCALAR, 35)
1398: GO TO 20
1399: 70 IF (K2.NE.NSTMT) GO TO 10
1400: GO TO 20
1401: 80 CALL ERROR1(14H MISSING LABEL, 14)
1402: GO TO 20
1403: 90 CALL ERROR1(23H ILLEGAL VARIABLE USAGE, 23)
1404: GO TO 20
1405: END
1406: C XXXXXCOMMON.f
1407: SUBROUTINE COMMON
1408: INTEGER PSTMT, PDSA, STMT, DSA, BNEXT, SYMHD, S(4)
1409: LOGICAL ERR, SYSERR, ABORT, ARDECL
1410: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
1411: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
1412: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
1413: COMMON /DETECT/ ERR, SYSERR, ABORT
1414: COMMON /FACTS/ NAME, NOST, ITYP, IASF
1415: DATA S(1) /66/, S(2) /32/, S(3) /44/, S(4) /42/
1416: C
1417: C PROCESSES A COMMON STMT
1418: C FIRST, PEEL OFF NAME OF COMMON AND SET SYMBOL TABLE ENTRY USAGE
1419: C CHECK NAME HAS NOT APPEARED BEFORE IN PGM UNIT
1420: C
1421: IF (STMT(PSTMT).EQ.67) GO TO 30
1422: C
1423: C SET SYMBOL TABLE ENTRY FOR BLANK COMMON
1424: C
1425: 10 I1 = IGATT1(NAME,8)
1426: IF (I1.EQ.11) GO TO 170
1427: IF (PSTMT.GE.NSTMT) GO TO 200
1428: L = PSTMT
1429: DO 20 I1=1,4
1430: STMT(I1) = S(I1)
1431: 20 CONTINUE
1432: PSTMT = 1
1433: KK = LOOKUP(5,.FALSE.)
1434: IF (SYSERR) GO TO 190
1435: PSTMT = L
1436: CALL SATT1(KK, 8, 7)
1437: GO TO 60
1438: 30 PSTMT = PSTMT + 1
1439: IF (STMT(PSTMT).NE.67) GO TO 40
1440: PSTMT = PSTMT + 1
1441: GO TO 10
1442: 40 IF (PSTMT.GE.NSTMT) GO TO 200
1443: CALL NEXTOK(PSTMT, K2, L)
1444: IF (L.NE.0) GO TO 200
1445: KK = LOOKUP(K2,.FALSE.)
1446: IF (SYSERR) GO TO 190
1447: I1 = IGATT1(KK,1)
1448: N = IGATT1(KK,8)
1449: IF (I1.EQ.0 .AND. (N.EQ.0 .OR. N.EQ.7)) GO TO 50
1450: CALL ERROR1(20H ILLEGAL COMMON NAME, 20)
1451: GO TO 190
1452: 50 CALL SATT1(KK, 8, 7)
1453: I1 = IGATT1(NAME,8)
1454: IF (I1.EQ.11) CALL SATT1(KK, 2, 1)
1455: PSTMT = K2 + 1
1456: IF (PSTMT.GE.NSTMT .OR. STMT(K2).NE.67) GO TO 200
1457: C
1458: C ELEMENTS IN COMMON: ARRAYS,VARIABLES,DECLARATIONS OF ARRAYS( NOT
1459: C VARIABLY DIMENSIONED). IMPLICITLY TYPE THEM
1460: C
1461: 60 IF (ARDECL(K2,N)) GO TO 70
1462: CALL ERROR1(47H COMMON ELEMENT NOT VARIABLE, ARRAY, DECLARATOR,
1463: * 47)
1464: GO TO 190
1465: 70 IF (SYSERR .OR. ERR) GO TO 190
1466: C
1467: C SET SYMBOL TABLE ENTRY OF ELEMENT TO SHOW ITS IN COMMON
1468: C PUT POINTER TO COMMON NAME INTO 3D WORD OF ENTRY (OR OFF 3D
1469: C WORD--FOR ARRAYS
1470: C
1471: I1 = IGATT1(N,2)
1472: IF (I1.NE.0) GO TO 160
1473: CALL SATT1(N, 2, 1)
1474: I1 = IGATT1(N,7)
1475: IF (I1.EQ.0) GO TO 80
1476: L = DSA(N+2)
1477: DSA(L+1) = KK
1478: GO TO 90
1479: 80 CALL SATT1(N, 8, 10)
1480: IF (NEXT+2.GE.BNEXT) GO TO 180
1481: DSA(N+2) = NEXT
1482: DSA(NEXT) = 0
1483: DSA(NEXT+1) = KK
1484: NEXT = NEXT + 2
1485: C
1486: C SETUP CHAIN OF ELEMENTS OF COMMON HANGING OFF SYMBOL TABLE
1487: C ENTRY OF COMMON NAME
1488: C
1489: 90 IF (DSA(KK+2).EQ.0) GO TO 130
1490: L = DSA(KK+2)
1491: 100 IF (DSA(L+1).EQ.0) GO TO 110
1492: L = DSA(L+1)
1493: GO TO 100
1494: 110 IF (NEXT+2.GE.BNEXT) GO TO 180
1495: DSA(L+1) = NEXT
1496: 120 DSA(NEXT) = N
1497: DSA(NEXT+1) = 0
1498: NEXT = NEXT + 2
1499: GO TO 140
1500: 130 IF (NEXT+2.GE.BNEXT) GO TO 180
1501: DSA(KK+2) = NEXT
1502: GO TO 120
1503: C
1504: C CHECK FOR END OF STMT
1505: C
1506: 140 IF (K2.EQ.NSTMT) GO TO 190
1507: IF (STMT(K2).NE.68) GO TO 150
1508: PSTMT = K2 + 1
1509: GO TO 60
1510: 150 IF (STMT(K2).NE.67) GO TO 200
1511: PSTMT = K2
1512: GO TO 30
1513: 160 CALL ERROR1(23H ELEMENT IN TWO COMMONS, 23)
1514: GO TO 140
1515: 170 CALL ERROR1(
1516: * 51H BLANK COMMON NOT ALLOWED IN BLOCK DATA SUBPROGRAMS, 51)
1517: GO TO 190
1518: 180 SYSERR = .TRUE.
1519: CALL ERROR1(33H IN COMMON, TABLE OVERFLOW OF DSA,33)
1520: 190 RETURN
1521: 200 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
1522: GO TO 190
1523: END
1524: C XXXXXDIMENS.f
1525: SUBROUTINE DIMENS
1526: C
1527: C PROCESSES DIMENSION STMT, RECORDING OF ARRAY BOUNDS, LENGTH
1528: C ETC. DONE IN ORDER
1529: C
1530: INTEGER STMT, PSTMT
1531: LOGICAL ERR, SYSERR, ABORT, ARDECL
1532: COMMON /DETECT/ ERR, SYSERR, ABORT
1533: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
1534: 10 IF (ARDECL(K2,K3)) GO TO 20
1535: CALL ERROR1(35H ILLEGAL SYNTAX OF ARRAY DECLARATOR, 35)
1536: GO TO 40
1537: 20 IF (SYSERR) RETURN
1538: IF (K2.EQ.NSTMT) GO TO 40
1539: IF (STMT(K2).EQ.68 .AND. K2+1.NE.NSTMT) GO TO 30
1540: CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
1541: GO TO 40
1542: 30 PSTMT = K2 + 1
1543: GO TO 10
1544: 40 RETURN
1545: END
1546: C XXXXXDOCHK.f
1547: SUBROUTINE DOCHK(KK)
1548: INTEGER DOLIST, DOPT, OUTUT, SYMLEN, OUTUT2, DSA, PDSA, OUTUT3,
1549: * STACK, OUTUT4
1550: COMMON /DOS/ DOPT, LDO, DOLIST(192)
1551: COMMON /CEXPRS/ LSTACK, STACK(620)
1552: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
1553: * OUTUT4
1554: COMMON /FACTS/ NAME, NOST, ITYP, IASF
1555: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
1556: C
1557: C KK IS SYMBOL TABLE ENTRY OF LABEL
1558: C ROUTINE CHECKS ALL LABELS FOR BEING END OF DO-STMTS; IF LABEL IS
1559: C END-OF-DO, ALL LABELS WITHIN THAT DO, HAVE END-OF-DEFN STMT NO
1560: C RECORDED IN THEM; DOPT IS DECREMENTED, A MOCK END-OF-DO IS
1561: C CREATED BY THE END STMT IN THE PGM UNIT; DOLIST MUST BE EMPTY
1562: C AFTER THIS PROCESSING OF AN END,
1563: C PERFORMS FIXUP ON SCOPE OF LABELS ENDING MULTIPLE NESTED DO'S
1564: C
1565: IF (ITYP.EQ.28) GO TO 50
1566: IF (DOLIST(DOPT+1).NE.KK) GO TO 40
1567: 10 CALL FIXLAB(.FALSE.)
1568: DOPT = DOPT - 6
1569: IF (ITYP.EQ.15 .OR. ITYP.EQ.16 .OR. (ITYP.GE.19 .AND.
1570: * ITYP.LE.22)) CALL ERROR1(26H ILLEGAL ENDING STMT ON DO, 26)
1571: IF (DOLIST(DOPT+1).NE.KK) GO TO 40
1572: C
1573: C GET REFERENCE TO NESTED DO ENDING AND MAKE REFERENCE
1574: C TO DO STATEMENT A NEGATIVE NUMBER
1575: C SO IT WON'T BE AN ILLEGAL BRANCH
1576: C
1577: K = DSA(KK+1)
1578: L = DOLIST(DOPT)
1579: 20 IF (DSA(K).EQ.L) GO TO 30
1580: K = DSA(K+1)
1581: GO TO 20
1582: 30 DSA(K) = -DSA(K)
1583: GO TO 10
1584: 40 RETURN
1585: 50 CALL FIXLAB(.TRUE.)
1586: IF (DOPT-6.LE.0) GO TO 40
1587: LL = 1
1588: L = DOPT/6
1589: DO 60 I=1,L
1590: J = DOPT + 7 - 6*I
1591: K = DOLIST(J)
1592: CALL S5UNPK(DSA(K+4), STACK(LL), 6)
1593: LL = LL + 6
1594: 60 CONTINUE
1595: LL = LL - 1
1596: IF (LL.LE.55) GO TO 70
1597: 99999 FORMAT (/25H MISSING DO ENDING LABEL , 55A1)
1598: WRITE (OUTUT,99999) (STACK(L),L=1,55)
1599: WRITE (OUTUT,99998) (STACK(L),L=56,LL)
1600: GO TO 40
1601: 99998 FORMAT (25X, 55A1)
1602: 70 WRITE (OUTUT,99999) (STACK(L),L=1,LL)
1603: GO TO 40
1604: END
1605: C XXXXXDOSPEC.f
1606: SUBROUTINE DOSPEC(KK, K2, LOG)
1607: INTEGER STMT, PSTMT, DOPT, DOLIST, LOOKUP
1608: LOGICAL SYSERR, ABORT, DOVAR, ERR, TOKPNO, LOG
1609: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
1610: COMMON /LISTDO/ LPT, LEN, LS(64)
1611: COMMON /DOS/ DOPT, LDO, DOLIST(192)
1612: COMMON /FACTS/ NAME, NOST, ITYP, IASF
1613: COMMON /DETECT/ ERR, SYSERR, ABORT
1614: C
1615: C ROUTINE RECOGNIZES DO-SPECIFICATION CONSTRUCT
1616: C DOLIST ARRAY IS DO STACK USED TO CHECK NESTING; 6 WORD ENTRY
1617: C WORD 1-CURRENT STMT NO
1618: C WORD 2-INDEX OF LABEL IN DSA
1619: C WORD 3-INDEX OF DO CONTROL VARIABLE IN DSA
1620: C WORD 4-6,-INDICES OF LIMITS IN DSA OR 0 FOR CONSTANT LIMITS
1621: C LS ARRAY IS IMPLICIT DO STACK- IN EACH ENTRY IS SAME DATA
1622: C AS WORDS 3-6 OF DOLIST ENTRIES.
1623: C
1624: IF (.NOT.LOG) GO TO 10
1625: IF (LPT.LE.1) GO TO 20
1626: LPT = LPT - 4
1627: LS(LPT) = 0
1628: LS(LPT+1) = 0
1629: LS(LPT+2) = 0
1630: LS(LPT+3) = 0
1631: GO TO 40
1632: 10 IF (DOPT.LE.LDO-11) GO TO 30
1633: 20 CALL ERROR1(20H DO NESTING TOO DEEP, 20)
1634: GO TO 190
1635: 30 DOPT = DOPT + 6
1636: DOLIST(DOPT) = NOST
1637: DOLIST(DOPT+1) = KK
1638: DOLIST(DOPT+2) = 0
1639: DOLIST(DOPT+3) = 0
1640: DOLIST(DOPT+4) = 0
1641: DOLIST(DOPT+5) = 0
1642: C
1643: C DO CONTROL VARIABLE MUST BE INTEGER, SCALAR VARIABLE
1644: C
1645: 40 IF (PSTMT.LT.NSTMT) GO TO 60
1646: 50 CALL ERROR1(35H ILLEGAL SYNTAX IN DO SPECIFICATION, 35)
1647: GO TO 190
1648: 60 CALL NEXTOK(PSTMT, K2, K)
1649: IF (K.NE.0) GO TO 50
1650: K = LOOKUP(K2,.FALSE.)
1651: IF (SYSERR) GO TO 180
1652: I1 = IGATT1(K,1)
1653: IF (I1.GT.0) GO TO 70
1654: I1 = 1
1655: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
1656: CALL SATT1(K, 1, I1)
1657: 70 I2 = IGATT1(K,7)
1658: I3 = IGATT1(K,8)
1659: IF (MOD(I1,8).NE.2 .OR. I2.NE.0) GO TO 220
1660: IF (I3.NE.0) GO TO 80
1661: I3 = 10
1662: CALL SATT1(K, 8, 10)
1663: 80 IF (I3.NE.10) GO TO 220
1664: CALL SATT1(K, 5, 1)
1665: IF (DOVAR(K)) CALL ERROR1(
1666: * 57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS,
1667: * 57)
1668: I3 = IGATT1(K,2)
1669: IF (I3.EQ.1) CALL ERROR1(37H WARNING - CONTROL VARIABLE IN COMMON,
1670: * 37)
1671: IF (K.EQ.NAME) CALL ERROR1(
1672: * 49H WARNING - FUNCTION NAME USED AS CONTROL VARIABLE, 49)
1673: IF (.NOT.LOG) GO TO 90
1674: LS(LPT) = K
1675: GO TO 100
1676: 90 DOLIST(DOPT+2) = K
1677: C
1678: C FIND AN =
1679: C
1680: 100 IF (STMT(K2).NE.63) GO TO 50
1681: C
1682: C DO-LIMITS LIMS COUNTS NUMBER OF LIMITS; THESE MUST BE INTEGER
1683: C SCALAR VARIABLES OR POSITIVE INTEGER CONSTANTS
1684: C
1685: LIMS = 0
1686: 110 PSTMT = K2 + 1
1687: IF (PSTMT.GE.NSTMT) GO TO 50
1688: IF (.NOT.TOKPNO(PSTMT,K2,K)) GO TO 120
1689: LIMS = LIMS + 1
1690: GO TO 170
1691: 120 CALL NEXTOK(PSTMT, K2, K)
1692: IF (K.NE.0) GO TO 210
1693: K = LOOKUP(K2,.FALSE.)
1694: IF (SYSERR) GO TO 180
1695: LIMS = LIMS + 1
1696: IF (.NOT.LOG) GO TO 130
1697: IF (LS(LPT).EQ.K) CALL ERROR1(17H ILLEGAL DO LIMIT, 17)
1698: I1 = LPT + LIMS
1699: LS(I1) = K
1700: GO TO 140
1701: 130 IF (DOLIST(DOPT+2).EQ.K) CALL ERROR1(17H ILLEGAL DO LIMIT, 17)
1702: I1 = DOPT + 2 + LIMS
1703: DOLIST(I1) = K
1704: 140 I1 = IGATT1(K,1)
1705: I2 = IGATT1(K,7)
1706: I3 = IGATT1(K,8)
1707: IF (I3.NE.0) GO TO 150
1708: CALL SATT1(K, 8, 10)
1709: I3 = 10
1710: 150 IF (I3.NE.10) GO TO 50
1711: IF (I1.GT.0) GO TO 160
1712: I1 = 1
1713: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
1714: CALL SATT1(K, 1, I1)
1715: 160 IF (MOD(I1,8).NE.2 .OR. I2.NE.0) GO TO 210
1716: C
1717: C CHECK FOR END OF STMT
1718: C
1719: 170 IF (K2.LT.NSTMT .AND. STMT(K2).NE.62) GO TO 200
1720: C
1721: C IF THERE ARE NO MORE CHARS, WE ARE DONE WITH THIS STMT;
1722: C THERE MUST BE AT LEAST 2 AND NO MORE THAN 3 LIMITS IN DO
1723: C
1724: IF (LIMS.LE.1) GO TO 230
1725: 180 RETURN
1726: 190 ERR = .TRUE.
1727: GO TO 180
1728: C
1729: C CHECK FOR A "," MUST FIND HERE
1730: C
1731: 200 IF (STMT(K2).NE.68) GO TO 50
1732: IF (LIMS.GE.3) GO TO 230
1733: GO TO 110
1734: 210 CALL ERROR1(47H DO LIMIT NOT INTEGER SCALAR VAR OR POS INTEGER,
1735: * 47)
1736: GO TO 190
1737: 220 CALL ERROR1(36H CONTROL VARIABLE NOT INTEGER SCALAR, 36)
1738: GO TO 190
1739: 230 CALL ERROR1(18H ILLEGAL DO LIMITS, 18)
1740: GO TO 190
1741: END
1742: C XXXXXDOVAR.f
1743: LOGICAL FUNCTION DOVAR(INDX)
1744: INTEGER DOPT, DOLIST
1745: COMMON /DOS/ DOPT, LDO, DOLIST(192)
1746: C
1747: C CHECKS VAR AT DSA(INDX) NOT IN DOSTACK ALREADY
1748: C AS A LIMIT OR INDEX OF PREVIOUSLY DEFINED AND CURRENTLY
1749: C DEFINED DO
1750: C
1751: DOVAR = .FALSE.
1752: IF (DOPT) 40, 40, 10
1753: 10 DO 30 I=1,DOPT,6
1754: L1 = I + 2
1755: L2 = L1 + 3
1756: DO 20 K=L1,L2
1757: IF (DOLIST(K).EQ.INDX) GO TO 50
1758: 20 CONTINUE
1759: 30 CONTINUE
1760: 40 RETURN
1761: 50 DOVAR = .TRUE.
1762: GO TO 40
1763: END
1764: C XXXXXEQUIV.f
1765: SUBROUTINE EQUIV
1766: INTEGER STMT, PSTMT, PDSA, DSA, TYPE, STACK, BNEXT, SYMHD
1767: LOGICAL ARDECL, CORNR, SAME, ERR, SYSERR, ABORT
1768: COMMON /DETECT/ ERR, SYSERR, ABORT
1769: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
1770: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
1771: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
1772: COMMON /CEXPRS/ LSTACK, STACK(620)
1773: C
1774: C PROCESSES AN EQUIVALENCE STMT-FINDS DECLARATORS SEPARATED BY ,
1775: C IF DIFFERENT TYPE VARIABLES INVOLVED, CHECKS FOR USE OF CORNER
1776: C ELEMENTS; ARDECL CALLED TO PROCESS DECLARATORS
1777: C SAME IS .TRUE. IF ALL ITEMS EQUIVALENCED IN ONE (--) ARE SAME TYPE
1778: C CORNR IS .TRUE. IF ALL ITEMS EQUIV. IN ONE (--) ARE CORNER ELES.
1779: C E.G. A(1,1,1)
1780: C
1781: 10 IF (STMT(PSTMT).EQ.65) GO TO 30
1782: 20 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
1783: GO TO 150
1784: 30 TYPE = -1
1785: IPT = 1
1786: CORNR = .TRUE.
1787: SAME = .TRUE.
1788: 40 PSTMT = PSTMT + 1
1789: IF (PSTMT.GE.NSTMT) GO TO 20
1790: IF (.NOT.ARDECL(K2,KK)) GO TO 150
1791: IF (SYSERR .OR. ERR) GO TO 150
1792: C
1793: C KK>= 0 FOR AN ARRAY ELEMENT MEANS IT WASN'T A CORNER ELEMENT
1794: C
1795: L = IGATT1(IABS(KK),7)
1796: IF (KK.GT.0 .AND. L.GT.0) CORNR = .FALSE.
1797: KK = IABS(KK)
1798: C
1799: C SET USAGE, IF UNSET
1800: C
1801: L = IGATT1(KK,8)
1802: IF (L.EQ.0) CALL SATT1(KK, 8, 10)
1803: C
1804: C STORE VARIABLE IN STACK, CHECK VARIABLE TYPE
1805: C
1806: STACK(IPT) = KK
1807: IPT = IPT + 1
1808: CALL SATT1(KK, 3, 1)
1809: I = IGATT1(KK,1)
1810: I = MOD(I,8)
1811: IF (-1.EQ.TYPE) TYPE = I
1812: IF (TYPE.EQ.I) GO TO 50
1813: SAME = .FALSE.
1814: C
1815: C END OF DELARATOR CHECKS; NEED , OR )
1816: C
1817: 50 IF (STMT(K2).NE.68) GO TO 60
1818: PSTMT = K2
1819: GO TO 40
1820: 60 IF (STMT(K2).NE.62) GO TO 20
1821: C
1822: C CHECK FOR CORNER ELEMENTS IF ARRAY ELEMENTS WERE USED
1823: C
1824: IF (.NOT.SAME .AND. .NOT.CORNR) CALL ERROR1(
1825: * 53H WARNING - USE CORNER ELEMENTS WHEN MIXING DATA TYPES, 53)
1826: C
1827: C CHECK FOR ELEMENTS IN COMMON; MAKE SURE ONLY ONE COMMON
1828: C REGION APPEARS
1829: C
1830: KK = IPT - 1
1831: C
1832: C PUT COMMON REGIONS OF EACH DECLARATOR (IF ANY) ON STACK
1833: C
1834: DO 80 I=1,KK
1835: L = IGATT1(STACK(I),2)
1836: IF (L) 80, 80, 70
1837: 70 IF(IPT+1.GT.LSTACK) GOTO 160
1838: L = STACK(I)
1839: L = DSA(L+2)
1840: STACK(IPT) = DSA(L+1)
1841: IPT = IPT + 1
1842: 80 CONTINUE
1843: IF (KK+2.GE.IPT) GO TO 90
1844: CALL ERROR1(40H EQUIVALENCE CONFLICTS WITH COMMON DEFNS, 40)
1845: GO TO 130
1846: 90 IF (KK+1.EQ.IPT) GO TO 130
1847: C
1848: C MARK ALL DECLARATORS IN EQUIV (--) AS IF IN COMMON BLOCK
1849: C THAT ANY ONE OF THEM IS ACTUALLY IN
1850: C
1851: DO 120 I=1,KK
1852: L = IGATT1(STACK(I),2)
1853: IF (L.EQ.1) GO TO 120
1854: CALL SATT1(STACK(I), 2, 1)
1855: L = STACK(I)
1856: IF (DSA(L+2)) 100, 100, 110
1857: 100 IF(NEXT+2.GE.BNEXT) GOTO 170
1858: DSA(L+2) = NEXT
1859: DSA(NEXT) = 0
1860: DSA(NEXT+1) = STACK(IPT-1)
1861: NEXT = NEXT + 2
1862: GO TO 120
1863: 110 L = DSA(L+2)
1864: DSA(L+1) = STACK(IPT-1)
1865: 120 CONTINUE
1866: 130 IF (K2+1.EQ.NSTMT) GO TO 150
1867: IF (STMT(K2+1).NE.68) GO TO 20
1868: PSTMT = K2 + 2
1869: GO TO 10
1870: 150 RETURN
1871: 160 CALL ERROR1(34H IN EQUIV, TABLE OVERFLOW OF STACK,34)
1872: 180 SYSERR = .TRUE.
1873: GOTO 150
1874: 170 CALL ERROR1(32H IN EQUIV, TABLE OVERFLOW OF DSA, 32)
1875: GOTO 180
1876: END
1877: C XXXXXEXTERN.f
1878: SUBROUTINE EXTERN
1879: LOGICAL ERR, SYSERR, ABORT
1880: LOGICAL BR, INTEXT
1881: INTEGER STMT, PSTMT
1882: COMMON /FACTS/ NAME, NOST, ITYP, IASF
1883: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
1884: COMMON /DETECT/ ERR, SYSERR, ABORT
1885: C
1886: C PROCESS AN EXTERNAL STMT. CAUSES IDS TO BE MARKED AS EXTERNAL
1887: C PROCEDURES. ERROR OCCURS IF ID HAS PREVIOUSLY DEFINED INCONSISTANT
1888: C USAGE. EXTERNAL CAN'T APPEAR IN BLOCK DATA PGM UNIT.
1889: C
1890: L = IGATT1(NAME,8)
1891: IF (L.EQ.11) GO TO 60
1892: 10 CALL NEXTOK(PSTMT, K2, KK)
1893: IF (KK.EQ.0) GO TO 20
1894: CALL ERROR1(19H ILLEGAL IDENTIFIER, 19)
1895: GO TO 70
1896: 20 KK = LOOKUP(K2,.FALSE.)
1897: IF (SYSERR) RETURN
1898: L = IGATT1(KK,8)
1899: IF (L.EQ.0) GO TO 30
1900: CALL ERROR1(26H ILLEGAL USE OF IDENTIFIER, 26)
1901: GO TO 40
1902: 30 CALL SATT1(KK, 8, 13)
1903: C
1904: C CAUSE EXTERNAL BIT TO BE SET IF POSSIBLE BASIC EXTERNAL
1905: C
1906: 40 BR = INTEXT(KK,0,0,.FALSE.)
1907: IF (K2.EQ.NSTMT) GO TO 70
1908: IF (STMT(K2).NE.68) GO TO 50
1909: PSTMT = K2 + 1
1910: GO TO 10
1911: 50 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
1912: GO TO 70
1913: 60 CALL ERROR1(
1914: *60H ILLEGAL USAGE OF EXTERNAL STMT WITHIN BLOCK DATA SUBPROGRAM,
1915: * 60)
1916: 70 RETURN
1917: END
1918: C XXXXXFIXLAB.f
1919: SUBROUTINE FIXLAB(ND)
1920: C
1921: C ROUTINE SETS END-OF-DEF-STMT NO FOR LABELS
1922: C WHEN CALLED BY END STMT, FIXES ALL LABEL DEFS YET UNBOUND
1923: C TO THE END OF PGM STMT NO. WHEN CALLED BY DO STMT
1924: C FIXES UP ALL LABELS AT THE LEVEL OF THE CURRENT
1925: C DO TO END-OF-DO STMT NO; ND TRUE MEANS AN END STMT CALLED FIXLAB
1926: C
1927: LOGICAL ND
1928: INTEGER DOLIST, DOPT, BNEXT, SYMHD, DSA, PDSA
1929: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
1930: COMMON /DOS/ DOPT, LDO, DOLIST(192)
1931: COMMON /FACTS/ NAME, NOST, ITYP, IASF
1932: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
1933: LEV = -DOPT/6
1934: I = LABHD
1935: 10 IF (I.EQ.0) RETURN
1936: K = IGATT1(I,2)
1937: IF (K.NE.1) GO TO 30
1938: K = IGATT1(I,1)
1939: IF (K.NE.1) GO TO 30
1940: K = DSA(I+2)
1941: IF (ND) GO TO 20
1942: IF (DSA(K+1).EQ.LEV) DSA(K+1) = NOST
1943: GO TO 30
1944: 20 IF (DSA(K+1).LE.0) DSA(K+1) = NOST
1945: 30 I = DSA(I+3)
1946: GO TO 10
1947: END
1948: C XXXXXFORMAT.f
1949: SUBROUTINE FORMAT
1950: INTEGER STMT, PSTMT
1951: LOGICAL TOKPNO, SIGN, ERROR
1952: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
1953: C
1954: C ROUTINE PROCESSES FORMAT STMT
1955: C FORMAT (Q1 T1 Z1 T2 Z2 ... TN Q2)
1956: C Q1,Q2 ARE EMPTY OR ARE SEPARARTERS
1957: C T1,T2 ETC. ARE FORMAT-ITEMS
1958: C Z1,Z2, ETC. ARE SEPARATERS
1959: C CHECKS FOR <= 2 LEVELS OF PARENTHESES
1960: C
1961: ERROR = .FALSE.
1962: ICNT = 0
1963: C
1964: C "("
1965: C
1966: IF (STMT(PSTMT).EQ.65) GO TO 30
1967: 10 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
1968: C
1969: C SEARCH FOR FORMAT ITEMS
1970: C
1971: 20 RETURN
1972: 30 ICNT = ICNT + 1
1973: IF (ICNT.GT.2) CALL ERROR1(28H TOO MANY PARENTHESES LEVELS, 28)
1974: PSTMT = PSTMT + 1
1975: C
1976: C LOOK FOR Q1
1977: C
1978: CALL SEPAR(I)
1979: C TAKES CARE OF FORMAT()
1980: IF (STMT(PSTMT).EQ.62) GO TO 180
1981: IF (STMT(PSTMT-1).EQ.68) CALL ERROR1(25H ILLEGAL PUNCTUATION (, ,
1982: * 25)
1983: 40 IF (STMT(PSTMT).EQ.65) GO TO 30
1984: IF (PSTMT.GE.NSTMT) GO TO 10
1985: SIGN = .FALSE.
1986: C
1987: C SEARCH FOR REPEAT FACTER (POSITIVE INTEGER)
1988: C
1989: IF (TOKPNO(PSTMT,K2,N)) GO TO 70
1990: C
1991: C HOLLERITH STRINGS
1992: C
1993: IF (STMT(PSTMT).LT.0) GO TO 120
1994: C
1995: C "-" IN P SCALING FORMAT-ITEM
1996: C
1997: IF (STMT(PSTMT).NE.61) GO TO 50
1998: SIGN = .TRUE.
1999: PSTMT = PSTMT + 1
2000: 50 IF (PSTMT.GE.NSTMT) GO TO 10
2001: C
2002: C LOOK FOR <INT> IN PSCALING FORMAT-ITEM
2003: C P SCALING FORMAT-ITEM
2004: C ( - ) <INTEGER> P REPEAT (A,I,L) <WIDTH> . <INT>
2005: C
2006: CALL NEXTOK(PSTMT, K2, K)
2007: C
2008: C CHECK FOR USE OF "-" WITH NON P-SCALING CONSTRUCTS
2009: C
2010: IF (K.NE.1 .AND. SIGN) GO TO 100
2011: IF (K.EQ.1) GO TO 60
2012: N = STMT(PSTMT)
2013: GO TO 90
2014: 60 SIGN = .TRUE.
2015: PSTMT = K2
2016: N = STMT(PSTMT)
2017: GO TO 80
2018: C
2019: C LOOK FOR PART OF FORMAT-ITEM AFTER REPEAT FACTOR
2020: C
2021: 70 PSTMT = K2
2022: N = STMT(PSTMT)
2023: C
2024: C "("
2025: C
2026: IF (N.EQ.65) GO TO 30
2027: C
2028: C "X"
2029: C
2030: IF (N.EQ.53) GO TO 120
2031: C
2032: C "P"
2033: C
2034: 80 IF (N.EQ.45) GO TO 130
2035: IF (SIGN) GO TO 100
2036: C
2037: C A,I,L
2038: C
2039: 90 IF (N.EQ.30 .OR. N.EQ.38 .OR. N.EQ.41) GO TO 110
2040: C
2041: C D,E,F,G
2042: C
2043: IF (N.GE.33 .AND. N.LE.36) GO TO 150
2044: 100 CALL ERROR1(20H ILLEGAL FORMAT ITEM, 20)
2045: GO TO 20
2046: C
2047: C A,I,L FOUND. LOOK FOR <WIDTH>
2048: C
2049: 110 IF (PSTMT+1.GE.NSTMT) GO TO 10
2050: PSTMT = PSTMT + 1
2051: IF (.NOT.TOKPNO(PSTMT,K2,I)) GO TO 100
2052: IF (N.NE.30 .OR. I.EQ.1 .OR. ERROR) GO TO 160
2053: CALL ERROR1(48H WARNING - A FORMAT ITEM NOT PORTABLE FOR N.GT.1,
2054: * 48)
2055: ERROR = .TRUE.
2056: GO TO 160
2057: C
2058: C SKIP TO NEXT CHAR IN X OR HOLLERITH
2059: C
2060: 120 PSTMT = PSTMT + 1
2061: GO TO 170
2062: C
2063: C LOOK FOR CONSTRUCT FOLLOWING THE P. CAN BE A REPEAT
2064: C
2065: 130 IF (PSTMT+1.GE.NSTMT) GO TO 10
2066: PSTMT = PSTMT + 1
2067: IF (STMT(PSTMT).GT.9 .OR. STMT(PSTMT).LT.0) GO TO 140
2068: CALL NEXTOK(PSTMT, K2, K)
2069: IF (K.NE.1) GO TO 10
2070: PSTMT = K2
2071: C
2072: C AFTER D,E,F,G FIND <WIDTH> . <INT>
2073: C
2074: 140 IF (STMT(PSTMT).LT.33 .OR. STMT(PSTMT).GT.36) GO TO 10
2075: 150 IF (PSTMT+1.GE.NSTMT) GO TO 10
2076: PSTMT = PSTMT + 1
2077: IF (.NOT.TOKPNO(PSTMT,K2,N)) GO TO 100
2078: IF (STMT(K2).NE.64) GO TO 100
2079: IF (K2+1.GE.NSTMT) GO TO 10
2080: PSTMT = K2 + 1
2081: CALL NEXTOK(PSTMT, K2, K)
2082: IF (K.NE.1) GO TO 100
2083: 160 PSTMT = K2
2084: C
2085: C FINISHED A FORMAT-ITEM
2086: C LOOK FOR SEPARATER OR ")"
2087: C
2088: 170 IF (STMT(PSTMT).NE.62) GO TO 210
2089: 180 ICNT = ICNT - 1
2090: IF (ICNT.LT.0) GO TO 190
2091: IF (PSTMT+1.LT.NSTMT) GO TO 200
2092: IF (ICNT.EQ.0) GO TO 20
2093: 190 CALL ERROR1(28H ILLEGAL PARENTHESES NESTING, 28)
2094: GO TO 20
2095: 200 PSTMT = PSTMT + 1
2096: GO TO 170
2097: 210 CALL SEPAR(I)
2098: IF (I.EQ.0) CALL ERROR1(24H MISSING FIELD SEPARATOR, 24)
2099: IF (STMT(PSTMT).NE.62) GO TO 40
2100: IF (STMT(PSTMT-1).EQ.68) CALL ERROR1(25H ILLEGAL PUNCTUATION ,) ,
2101: * 25)
2102: GO TO 180
2103: END
2104: C XXXXXGETTOK.f
2105: INTEGER FUNCTION GETTOK(K1, K2)
2106: C
2107: C GETTOK FINDS NEXT TOKEN IN STMT(K1)-STMT(K2-1)
2108: C AND RETURNS A VALUE:
2109: C 0= DOUBLE PRECISION CONSTANT-
2110: C 2= INTEGER CONSTANT
2111: C 1= REAL CONSTANT-
2112: C 3= COMPLEX CONSTANT
2113: C 4= LOGICAL CONSTANT
2114: C 5= HOLLERITH CONSTANT
2115: C 6= ID
2116: C >10=OPERATOR (10+CODE FOR OPERATOR;HERE ARRAY AND FCN REFS ARE 16
2117: C
2118: INTEGER PSTMT, STMT
2119: LOGICAL ERR, SYSERR, ABORT, TOKLOP, TOKRL, TOKCOM, TOKLOG
2120: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
2121: COMMON /DETECT/ ERR, SYSERR, ABORT
2122: 10 GETTOK = -1
2123: IF (.NOT.TOKRL(K1,K2,K)) GO TO 20
2124: GETTOK = 1
2125: IF (K.EQ.0) GETTOK = 0
2126: GO TO 40
2127: 20 CALL NEXTOK(K1, K2, K)
2128: K = K + 1
2129: GO TO (50, 30, 60, 70), K
2130: 30 GETTOK = 2
2131: 40 RETURN
2132: C
2133: C PROCESS ID, SEE IF ITS A FCN CALL OR ARRAY NAME
2134: C
2135: 50 GETTOK = 6
2136: IF (STMT(K2).NE.65) GO TO 40
2137: GETTOK = 16
2138: K2 = K2 + 1
2139: GO TO 40
2140: 60 GETTOK = 5
2141: GO TO 40
2142: 70 K = STMT(K1)
2143: IF (K.EQ.64) GO TO 100
2144: IF (K.EQ.65) GO TO 80
2145: IF (K.EQ.62) GETTOK = 12
2146: IF (K.EQ.68) GETTOK = 18
2147: IF (K.EQ.60 .OR. K.EQ.61) GETTOK = 11
2148: IF (K.EQ.66 .OR. K.EQ.67) GETTOK = 17
2149: IF (K2.EQ.K1+2) GETTOK = 13
2150: IF (GETTOK+1) 40, 120, 40
2151: 80 GETTOK = 15
2152: IF (TOKCOM(K1,K)) GO TO 90
2153: GO TO 40
2154: 90 GETTOK = 3
2155: K2 = K
2156: GO TO 40
2157: C
2158: C CHECK FOR LOGICAL CONSTANTS,OPERATORS
2159: C
2160: 100 IF (.NOT.TOKLOG(K1,K2)) GO TO 110
2161: GETTOK = 4
2162: GO TO 40
2163: 110 IF (.NOT.TOKLOP(K1,K2,K)) GO TO 120
2164: GETTOK = K
2165: GO TO 40
2166: 120 CALL ERROR1(26H ILLEGAL CHARACTER IGNORED, 26)
2167: IF (K1+1.GE.NSTMT) GO TO 130
2168: K1 = K1 + 1
2169: GO TO 10
2170: 130 ERR = .TRUE.
2171: RETURN
2172: END
2173: C XXXXXGOTO.f
2174: SUBROUTINE GOTO
2175: INTEGER STMT, PSTMT
2176: LOGICAL TOKLAB, DONE, ERR, SYSERR, ABORT
2177: COMMON /DETECT/ ERR, SYSERR, ABORT
2178: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
2179: C
2180: C PROCESSES UNCONDITIONAL, ASSIGNED, AND COMPUTED GOTO STMTS
2181: C
2182: IF (PSTMT.GE.NSTMT) GO TO 100
2183: DONE = .FALSE.
2184: C
2185: C UNCONDITIONAL GOTO
2186: C
2187: IF (TOKLAB(1,K2,K,.FALSE.)) GO TO 110
2188: C
2189: C COMPUTED GOTO
2190: C
2191: IF (SYSERR) GO TO 110
2192: IF (STMT(PSTMT).EQ.65) GO TO 70
2193: C
2194: C ASSIGNED GOTO: GOTO <VAR> , ( <LAB> , ETC. )
2195: C
2196: 10 CALL NEXTOK(PSTMT, K2, K)
2197: IF (K.NE.0) GO TO 100
2198: K = LOOKUP(K2,.FALSE.)
2199: IF (SYSERR) GO TO 110
2200: I1 = IGATT1(K,1)
2201: IF (I1.NE.0) GO TO 20
2202: I1 = 1
2203: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
2204: CALL SATT1(K, 1, I1)
2205: 20 I2 = IGATT1(K,7)
2206: IF (MOD(I1,8).NE.2 .OR. I2.NE.0) CALL ERROR1(
2207: * 31H NOT AN INTEGER SCALAR VARIABLE, 31)
2208: I1 = IGATT1(K,8)
2209: IF (DONE) GO TO 40
2210: C
2211: C CHECK FOR ASSIGN VARIABLE IN USAGE
2212: C
2213: IF (I1.EQ.0) GO TO 30
2214: IF (I1.NE.8) CALL ERROR1(26H ID NOT AN ASSIGN VARIABLE, 26)
2215: GO TO 60
2216: 30 CALL SATT1(K, 8, 8)
2217: GO TO 60
2218: C
2219: C CHECK FOR VARIABLE IN USAGE
2220: C
2221: 40 IF (I1.EQ.0) GO TO 50
2222: IF (I1.NE.10) CALL ERROR1(19H ILLEGAL ID IN GOTO, 19)
2223: GO TO 130
2224: 50 CALL SATT1(K, 8, 10)
2225: GO TO 130
2226: C
2227: C LOOK FOR ","
2228: C
2229: 60 IF (STMT(K2).NE.68) GO TO 100
2230: K2 = K2 + 1
2231: DONE = .TRUE.
2232: IF (STMT(K2).NE.65) GO TO 100
2233: GO TO 80
2234: 70 PSTMT = PSTMT + 1
2235: GO TO 90
2236: 80 PSTMT = K2 + 1
2237: C
2238: C LOOK FOR ( <LAB> , ETC.)
2239: C
2240: 90 IF (PSTMT.GE.NSTMT) GO TO 100
2241: IF (.NOT.TOKLAB(1,K2,K,.FALSE.)) GO TO 100
2242: IF(SYSERR) GOTO 110
2243: IF (STMT(K2).EQ.68) GO TO 80
2244: IF (STMT(K2).NE.62) GO TO 100
2245: IF (DONE) GO TO 120
2246: DONE = .TRUE.
2247: IF (STMT(K2+1).NE.68) GO TO 100
2248: PSTMT = K2 + 2
2249: IF (PSTMT.LT.NSTMT) GO TO 10
2250: 100 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
2251: 110 RETURN
2252: C
2253: C CHECK END OF STMT IS REACHED
2254: C
2255: 120 K2 = K2 + 1
2256: 130 IF (K2.NE.NSTMT) CALL ERROR1(
2257: * 34H EXTRANEOUS INFO AFTER END OF STMT, 34)
2258: GO TO 110
2259: END
2260: C XXXXXID.f
2261: SUBROUTINE ID(K2)
2262: INTEGER STMT, PSTMT
2263: LOGICAL ERR, SYSERR, ABORT, DOVAR
2264: COMMON /DETECT/ ERR, SYSERR, ABORT
2265: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
2266: COMMON /FACTS/ NAME, NOST, ITYP, IASF
2267: C
2268: C ROUTINE CHECKS IDENTIFIERS IN <LIST> FOR BEING ARRAY,ARRAY ELEMENT
2269: C OR VARIABLE.- RETURNS ERR=.TRUE. IF MUST CEASE PROCESSING
2270: C FIRST CHECK USAGE
2271: C
2272: K = LOOKUP(K2,.FALSE.)
2273: IF (SYSERR) GO TO 50
2274: C
2275: C CHECK USAGE
2276: C
2277: I3 = IGATT1(K,8)
2278: IF (I3.NE.0) GO TO 10
2279: CALL SATT1(K, 8, 10)
2280: GO TO 20
2281: 10 IF (I3.NE.10) CALL ERROR1(27H ILLEGAL IDENTIFIER IN LIST, 27)
2282: C
2283: C SET TYPE
2284: C
2285: 20 I3 = IGATT1(K,1)
2286: IF (I3.NE.0) GO TO 30
2287: I3 = 1
2288: IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I3 = 2
2289: CALL SATT1(K, 1, I3)
2290: C
2291: C CHECK FOR READING INTO DO CONTROL VARIABLE OR LIMIT
2292: C
2293: 30 IF (ITYP.NE.23) GO TO 40
2294: IF (DOVAR(K)) CALL ERROR1(
2295: * 57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS,
2296: * 57)
2297: C
2298: C MARK VARIABLES AS SET IF VALUES READ IN
2299: C
2300: CALL SATT1(K, 5, 1)
2301: C
2302: C SEPARATE OUT ARRAY ELEMENTS AND CHECK SUBSCRIPTS
2303: C
2304: 40 IF (STMT(K2).NE.65) GO TO 50
2305: I3 = IGATT1(K,7)
2306: IF (I3.EQ.0) GO TO 60
2307: PSTMT = K2 + 1
2308: IF (PSTMT.GE.NSTMT) GO TO 80
2309: CALL SUBS(K2, I3)
2310: ERR = .FALSE.
2311: 50 RETURN
2312: 60 CALL ERROR1(40H ILLEGAL SUBSCRIPTING OF SCALAR VARIABLE, 40)
2313: 70 ERR = .TRUE.
2314: GO TO 50
2315: 80 CALL ERROR1(19H SUBSCRIPTING ERROR, 19)
2316: GO TO 70
2317: END
2318: C XXXXXIDLIST.f
2319: LOGICAL FUNCTION IDLIST(IDO)
2320: INTEGER PSTMT, STMT
2321: LOGICAL ERR, SYSERR, ABORT, IDO
2322: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
2323: COMMON /DETECT/ ERR, SYSERR, ABORT
2324: C
2325: C RECOGNIZES IDLIST=<ID> �, <ID>! ;LAST <ID> CANNOT BE FOLLOWED BY
2326: C A '='; IDLIST MUST CONTAIN AT LEAST ONE ID. IDLIST=.FALSE. WILL
2327: C BE RETURNED FOR AN IRRECOVERABLE SYNTAX ERROR.
2328: C IDO SET TO .TRUE. WHEN <IDLIST> IS FOLLOWED BY <DOSPEC>
2329: C
2330: IDO = .FALSE.
2331: IDLIST = .TRUE.
2332: IF (PSTMT.GE.NSTMT) GO TO 60
2333: CALL NEXTOK(PSTMT, K2, K)
2334: IF (K.NE.0) GO TO 60
2335: IF (STMT(K2).EQ.63) GO TO 20
2336: CALL ID(K2)
2337: IF (ERR .OR. SYSERR) GO TO 20
2338: 10 PSTMT = K2
2339: IF (STMT(PSTMT).EQ.68 .AND. STMT(PSTMT+1).EQ.65 .OR.
2340: * STMT(PSTMT).EQ.62 .OR. PSTMT.EQ.NSTMT) GO TO 30
2341: IF (STMT(PSTMT).EQ.68) GO TO 50
2342: CALL ERROR1(35H ILLEGAL TOKEN FOLLOWING IDENTIFIER, 35)
2343: 20 IDLIST = .FALSE.
2344: ERR = .FALSE.
2345: 30 RETURN
2346: 40 IDO = .TRUE.
2347: GO TO 30
2348: C
2349: C MAKE SURE <ID> = ISN'T NEXT CONSTRUCT
2350: C
2351: 50 K2 = K2 + 1
2352: IF (K2.GE.NSTMT) GO TO 60
2353: CALL NEXTOK(K2, K3, K)
2354: IF (STMT(K3).EQ.63) GO TO 40
2355: PSTMT = K2
2356: K2 = K3
2357: CALL ID(K2)
2358: IF (ERR .OR. SYSERR) GO TO 20
2359: GO TO 10
2360: 60 CALL ERROR1(23H ILLEGAL SYNTAX IN LIST, 23)
2361: GO TO 20
2362: END
2363: C XXXXXIFS.f
2364: SUBROUTINE IFS(LOG)
2365: LOGICAL TOKLAB, ERR, SYSERR, ABORT, LOG
2366: INTEGER STMT, PSTMT, EXPR
2367: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
2368: COMMON /DETECT/ ERR, SYSERR, ABORT
2369: C
2370: C ROUTINE PROCESSES ARITHMETIC AND LOGICAL IF STMTS
2371: C LOG RETURNED AS TRUE IF LOGICAL-IF IS ENCOUNTERED;PU CHECKS FOR
2372: C ACCEPTIBLE EXECUTABLE STMT AFTER LOGICAL EXPRESSION
2373: C
2374: LOG = .FALSE.
2375: L = MOD(EXPR(I),8)
2376: IF (-1.EQ.L .OR. SYSERR) GO TO 30
2377: LOG = L.EQ.4
2378: IF (LOG) GO TO 30
2379: C
2380: C ARITHMETIC IF--SEARCH FOR <LAB>,<LAB>,<LAB>
2381: C
2382: IF (L.GT.2) GO TO 50
2383: I = 0
2384: IF (PSTMT.GE.NSTMT) GO TO 20
2385: 10 IF (.NOT.TOKLAB(1,K2,L,.FALSE.)) GO TO 40
2386: IF (SYSERR) GO TO 30
2387: I = I + 1
2388: IF (I.EQ.3) GO TO 60
2389: IF (STMT(K2).NE.68) GO TO 20
2390: PSTMT = K2 + 1
2391: IF (PSTMT.LT.NSTMT) GO TO 10
2392: 20 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
2393: 30 RETURN
2394: 40 CALL ERROR1(14H MISSING LABEL, 14)
2395: GO TO 30
2396: 50 CALL ERROR1(39H COMPLEX EXPRESSION ILLEGAL IN ARITH-IF, 39)
2397: GO TO 30
2398: 60 IF (K2.EQ.NSTMT) GO TO 30
2399: CALL ERROR1(34H EXTRANEOUS INFO AFTER END OF STMT, 34)
2400: GO TO 30
2401: END
2402: C XXXXXINTEXT.f
2403: LOGICAL FUNCTION INTEXT(LL, L1, L2, BR)
2404: C
2405: C LL POINTS TO DSA ENTRY OF FCN NAME
2406: C L1 POINTS INTO STACK TO BEGINNING OF ARGS
2407: C L2 POINTS INTO STACK TO LAST ARG ENTRY
2408: C BR .TRUE. MEANS LOOK FOR BOTH EXTERNALS ND INTRINS
2409: C BR FALSE MEANS JUST LOOK FOR EXTERNALS
2410: C ROUTINE CHECKS FOR REFERENCES TO INTRINSIC OR BASIC EXTERNAL
2411: C FCNS; RETURNS TRUE IF FINDS INTRINSIC FCN. CHECKS INTRINSICS
2412: C ARGS FOR USAGE, TYPE AND NUMBER. MARKS POSSIBLE BASIC EXTDRNAL
2413: C FCNS SENT DOWN TO IT
2414: C
2415: INTEGER STACK, BL, PDSA, DSA, FCN(6), Z
2416: LOGICAL BR
2417: COMMON /CEXPRS/ LSTACK, STACK(620)
2418: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
2419: COMMON /INTS/ Z(346)
2420: COMMON /FACTS/ NAME, NOST, ITYP, IASF
2421: DATA BL /1H /
2422: INTEXT = .FALSE.
2423: CALL S5UNPK(DSA(LL+4), FCN(1), 6)
2424: K = 1
2425: DO 40 I=1,55
2426: K1 = K + 1
2427: K2 = K1 + Z(K) - 1
2428: L = 0
2429: DO 10 J=K1,K2
2430: L = L + 1
2431: IF (FCN(L).NE.Z(J)) GO TO 30
2432: 10 CONTINUE
2433: IF (L.EQ.6) GO TO 60
2434: L = L + 1
2435: DO 20 J=L,6
2436: IF (FCN(J).NE.BL) GO TO 30
2437: 20 CONTINUE
2438: GO TO 60
2439: 30 K = K2 + 2
2440: 40 CONTINUE
2441: 50 RETURN
2442: C
2443: C DIFFERENTIATES BETWEEN A POSSIBLE BASIC EXTERNAL AND POSSIBLE
2444: C INTRINSIC FCN
2445: C
2446: 60 L = MOD(Z(K2+1),1024)/512
2447: C
2448: C IF POSSIBLE BASIC EXTERNAL CHECK TYPE AND SET IT IF NOT ALREADY
2449: C EXPLICITLY SET
2450: C
2451: IF (L.NE.1) GO TO 70
2452: L = IGATT1(LL,1)
2453: IF (L/8.GE.1) GO TO 190
2454: L = MOD(Z(K2+1),8)
2455: IF (BR) L = L + 8
2456: CALL SATT1(LL, 1, L)
2457: C
2458: C MARK AS USED IN PASS 1
2459: C
2460: GO TO 190
2461: C
2462: C CHEKC IF IN EXTERNAL STMT IF SO NOT AN INTRINSIC
2463: C
2464: 70 IF (.NOT.BR) GO TO 50
2465: L = IGATT1(LL,8)
2466: IF (L.EQ.13) GO TO 50
2467: C
2468: C CHECK IF EXPLICITLY TYPES DIFFERENTLY THAN EXPECTED
2469: C
2470: L = IGATT1(LL,1)
2471: J = MOD(Z(K2+1),8)
2472: IF (L.GE.8) GO TO 80
2473: CALL SATT1(LL, 1, J+8)
2474: GO TO 90
2475: 80 IF (J.NE.MOD(L,8)) GO TO 50
2476: C
2477: C K POINTS TO THE FUNCTION ENTRY IN Z
2478: C K1 POINTS TO FIRST LETTER IN FCN-NAME; K2 TO LAST LETTER
2479: C FIELDS IN ATTRIBUTE WORD ARE AS FOLLOWS:
2480: C BITS 0-2 TYPE FCN
2481: C BITS 3-5 TYPE ARGS
2482: C BIT 6 IF 1, FIXED NO ARGS; IF 0 VARIABLE NO OF ARGS
2483: C BITS 7-8 MINIMUM NUMBER OF ARGS
2484: C BITS 9 IF 0, INTRINSIC; IF 1 BASIC EXTERNAL
2485: C BITS 10 IF 1 USED IN PASS 1; ELSE NOT REFERENCED
2486: C
2487: C FCN IS INTRINSIC
2488: C CHECK NUMBER OF ARGS
2489: C
2490: 90 I = MOD(Z(K2+1),128)/64
2491: J = MOD(Z(K2+1),512)/128
2492: IF (I) 100, 100, 120
2493: C
2494: C VARIABLE NUMBER OF ARGS ALLOWED
2495: C MUST BE AT LEAST J
2496: C
2497: 100 IF ((L2-L1+1)/2.GE.J) GO TO 130
2498: 110 CALL ERROR2(29H INCORRECT NUMBER OF ARGS IN , 29, DSA(LL+4),
2499: * 1, 1, 1)
2500: GO TO 180
2501: C
2502: C FIXED NUMBER OF ARGS
2503: C
2504: 120 IF ((L2-L1+1)/2.NE.J) GO TO 110
2505: C
2506: C CHECK THRU ARG LIST OR PROPER TYPE ID AS AN ARG;
2507: C CHECK TYPE AND THAT ARGS ARE SCALARS
2508: C
2509: 130 L = MOD(Z(K2+1),64)/8
2510: DO 170 N=L1,L2,2
2511: C
2512: C CHECK FOR EXPRESSION AS ARG
2513: C
2514: IF (STACK(N).EQ.0) GO TO 160
2515: C
2516: C CHECK USAGE
2517: C
2518: I = IGATT1(STACK(N),8)
2519: IF (I.EQ.10 .OR. ((I.EQ.2 .OR. I.EQ.5 .OR. I.EQ.14) .AND.
2520: * STACK(N+1).NE.6)) GO TO 160
2521: IF (I.NE.0) GO TO 140
2522: CALL SATT1(STACK(N), 8, 10)
2523: GO TO 160
2524: 140 IF (I.EQ.1 .AND. ITYP.NE.31) GO TO 150
2525: I = STACK(N)
2526: IF (DSA(I+2).EQ.IASF) GO TO 160
2527: 150 CALL ERROR2(40H ILLEGAL ARGUMENT IN INTRINSIC REFERENCE, 40,
2528: * DSA(LL+4), 1, 1, 1)
2529: GO TO 170
2530: C
2531: C CHECK STRUCTURE
2532: C
2533: 160 IF (STACK(N+1)/8.EQ.1) CALL ERROR2(
2534: * 48H ILLEGAL STRUCTURE OF ARG IN INTRINSIC REFERENCE, 48,
2535: * DSA(LL+4), 1, 1, 1)
2536: C
2537: C CHECK TYPE
2538: C
2539: IF (MOD(STACK(N+1),8).NE.L) CALL ERROR2(
2540: * 43H ILLEGAL TYPE OF ARG IN INTRINSIC REFERENCE, 43,
2541: * DSA(LL+4), 1, 1, 1)
2542: 170 CONTINUE
2543: 180 INTEXT = .TRUE.
2544: I = IGATT1(LL,8)
2545: IF (I.NE.0) GO TO 190
2546: CALL SATT1(LL, 8, 14)
2547: C
2548: C MARK FCN AS USED
2549: C
2550: 190 K = Z(K2+1)/1024
2551: IF (K.EQ.0) Z(K2+1) = Z(K2+1) + 1024
2552: GO TO 50
2553: END
2554: C XXXXXIO.f
2555: SUBROUTINE IO
2556: LOGICAL ERR, SYSERR, TOKPNO, OK, ABORT, TOKLAB
2557: INTEGER STMT, PSTMT
2558: INTEGER EN(4)
2559: LOGICAL SW
2560: COMMON /FACTS/ NAME, NOST, ITYP, IASF
2561: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
2562: COMMON /DETECT/ ERR, SYSERR, ABORT
2563: COMMON /SWS/ SW(10)
2564: DATA EN(1), EN(2), EN(3), EN(4) /34,43,33,63/
2565: C
2566: C ROUTINE RECOGNIZES READ,WRITE,REWIND,BACKSPACE,ENDFILE,PAUSE STMTS
2567: C
2568: OK = .TRUE.
2569: ASSIGN 160 TO IFORM
2570: IF (ITYP.NE.23 .AND. ITYP.NE.24) GO TO 240
2571: C
2572: C SYNTAX OF READ, WRITE STMTS IS THE SAME EXCEPT A BINARY WRITE
2573: C NEEDS A <LIST>. (SEE USE OF OK)
2574: C "READ" (�<UNIT> / <UNIT> , <FORM>!) �<LIST>!
2575: C <UNIT> IS INTEGER SCALAR VARIABLE OR POSITIVE INTEGER CONST
2576: C <FORM> IS <LABEL> OR <ARRAY NAME>.
2577: C
2578: IF (STMT(PSTMT).NE.65) GO TO 230
2579: PSTMT = PSTMT + 1
2580: IF (PSTMT.GE.NSTMT) GO TO 120
2581: 10 IF (TOKPNO(PSTMT,K2,K)) GO TO 60
2582: CALL NEXTOK(PSTMT, K2, K)
2583: IF (K.EQ.0) GO TO 20
2584: CALL ERROR1(13H ILLEGAL UNIT, 13)
2585: GO TO 110
2586: 20 K = LOOKUP(K2,.FALSE.)
2587: IF (SYSERR) GO TO 110
2588: I1 = IGATT1(K,1)
2589: I2 = IGATT1(K,7)
2590: I3 = IGATT1(K,8)
2591: IF (I3.NE.0) GO TO 30
2592: CALL SATT1(K, 8, 10)
2593: GO TO 40
2594: 30 IF (I3.EQ.10) GO TO 40
2595: CALL ERROR1(13H ILLEGAL UNIT, 13)
2596: 40 IF (I1.NE.0) GO TO 50
2597: I1 = 1
2598: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
2599: CALL SATT1(K, 1, I1)
2600: 50 IF (MOD(I1,8).NE.2 .OR. I2.NE.0) CALL ERROR1(13H ILLEGAL UNIT, 13)
2601: 60 PSTMT = K2
2602: C
2603: C DISTINGUISH ( <UNIT> ) FROM ( <UNIT>,<FORM> )
2604: C
2605: IF (ITYP.NE.23 .AND. ITYP.NE.24) GO TO 100
2606: IF (STMT(PSTMT).EQ.68) GO TO 130
2607: IF (STMT(PSTMT).EQ.62 .AND. ITYP.EQ.24) OK = .FALSE.
2608: C
2609: C CODE FINDS ")" AND TRIES TO FIND LIST
2610: C
2611: 70 IF (STMT(PSTMT).NE.62) GO TO 230
2612: PSTMT = PSTMT + 1
2613: IF (PSTMT.GE.NSTMT) GO TO 90
2614: CALL LIST
2615: GO TO 110
2616: 80 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
2617: PSTMT = PSTMT + 1
2618: GO TO 70
2619: 90 IF (OK) GO TO 110
2620: CALL ERROR1(13H MISSING LIST, 13)
2621: 100 IF (PSTMT.LT.NSTMT) CALL ERROR1(
2622: * 34H EXTRANEOUS INFO AFTER END OF STMT, 34)
2623: 110 RETURN
2624: 120 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
2625: GO TO 110
2626: C
2627: C IDENTIFY END= IF THERE
2628: C
2629: 130 IF (ITYP.NE.23) GO TO IFORM, (160, 80)
2630: I1 = PSTMT + 1
2631: DO 140 K=1,4
2632: IF (STMT(I1).NE.EN(K)) GO TO IFORM, (160, 80)
2633: I1 = I1 + 1
2634: 140 CONTINUE
2635: IF (.NOT.SW(1)) CALL ERROR1(
2636: * 37H WARNING - NON-PORTABLE EOF CONSTRUCT, 37)
2637: C
2638: C HAVE FOUND END=, TRY FOR LABEL
2639: C
2640: PSTMT = I1
2641: IF(.NOT.TOKLAB(1,K2,K,.FALSE.))
2642: 1CALL ERROR1(44H MISSING LABEL IN NON-PORTABLE EOF CONSTRUCT ,44)
2643: IF(SYSERR) GOTO 110
2644: 150 PSTMT = K2
2645: GO TO 70
2646: C
2647: C SEARCH FOR FORM
2648: C
2649: 160 PSTMT = PSTMT + 1
2650: IF (PSTMT.GE.NSTMT) GO TO 230
2651: IF (TOKLAB(3,K2,K,.FALSE.)) GO TO 220
2652: IF(SYSERR) GOTO 110
2653: CALL NEXTOK(PSTMT, K2, K)
2654: IF (K.EQ.0) GO TO 180
2655: 170 CALL ERROR1(13H ILLEGAL FORM, 13)
2656: GO TO 110
2657: 180 K = LOOKUP(K2,.FALSE.)
2658: IF (SYSERR) GO TO 110
2659: I1 = IGATT1(K,1)
2660: I2 = IGATT1(K,7)
2661: I3 = IGATT1(K,8)
2662: IF (I3.NE.0) GO TO 190
2663: CALL SATT1(K, 8, 10)
2664: GO TO 200
2665: 190 IF (I3.EQ.10) GO TO 200
2666: CALL ERROR1(13H ILLEGAL FORM, 13)
2667: 200 IF (I1.NE.0) GO TO 210
2668: I1 = 2
2669: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
2670: CALL SATT1(K, 1, I1)
2671: 210 IF((MOD(I1,8).NE.2.AND.MOD(I1,8).NE.5).OR.I2.EQ.0) GOTO 170
2672: C
2673: C HAVE SUCCESSFULLY FOUND A FORM
2674: C
2675: 220 IF (SYSERR) GO TO 110
2676: PSTMT = K2
2677: ASSIGN 80 TO IFORM
2678: IF (STMT(PSTMT).EQ.68) GO TO 130
2679: GO TO 70
2680: 230 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
2681: GO TO 110
2682: C
2683: C LAST 4 I-O STMTS
2684: C
2685: 240 IF (ITYP.EQ.27 .OR. ITYP.EQ.22) CALL ERROR1(
2686: * 39H WARNING - USE OF NON-PORTABLE I/O STMT, 39)
2687: IF (ITYP.EQ.22) GO TO 100
2688: IF (PSTMT.LT.NSTMT) GO TO 10
2689: CALL ERROR1(13H MISSING UNIT, 13)
2690: GO TO 110
2691: END
2692: C XXXXXLDOVAR.f
2693: SUBROUTINE LDOVAR
2694: COMMON /LISTDO/ LPT, LEN, LS(64)
2695: C
2696: C CHECKS PROPER NESTING OF DOS WITHIN LIST CONSTRUCT
2697: C
2698: IF (LPT.GE.61) GO TO 50
2699: DO 40 KQ=LPT,60,4
2700: KK = KQ + 4
2701: DO 30 L=1,4
2702: LL = L + KQ - 1
2703: IF (LS(LL)) 10, 30, 10
2704: 10 DO 20 K=KK,61,4
2705: IF (LS(K).EQ.LS(LL)) CALL ERROR1(
2706: *57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS, 57)
2707: 20 CONTINUE
2708: 30 CONTINUE
2709: 40 CONTINUE
2710: 50 RETURN
2711: END
2712: C XXXXXNEXTOK.f
2713: SUBROUTINE NEXTOK(K1, K2, CODE)
2714: INTEGER STMT, CODE, PSTMT
2715: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
2716: C
2717: C NEXT TOKEN IN STMT(K1)-STMT(K2-1). CODES ARE:
2718: C DIGIT STRING(1)
2719: C HOLLERITH(2)
2720: C IDENTIFIER(0)
2721: C SPECIAL CHARACTER(3)
2722: C
2723: IF (STMT(K1).LT.0) GO TO 50
2724: IF (STMT(K1).GT.9) GO TO 20
2725: C
2726: C DIGIT STRING
2727: C
2728: CODE = 1
2729: K2 = K1 + 1
2730: 10 IF (K2.EQ.NSTMT) GO TO 60
2731: IF ((STMT(K2).GT.9) .OR. (STMT(K2).LT.0)) GO TO 60
2732: K2 = K2 + 1
2733: GO TO 10
2734: 20 IF (STMT(K1).GT.55) GO TO 40
2735: C
2736: C IDENTIFIER
2737: C
2738: CODE = 0
2739: K4 = K1 + 1
2740: K2 = K4
2741: DO 30 I=K4,NSTMT
2742: IF (STMT(I).GT.55 .OR. STMT(I).LT.0) GO TO 60
2743: K2 = K2 + 1
2744: 30 CONTINUE
2745: C
2746: C
2747: C SPECIAL CHARACTER
2748: C
2749: 40 K2 = K1 + 1
2750: CODE = 3
2751: IF (STMT(K1).NE.66) GO TO 60
2752: IF (STMT(K2).EQ.66) K2 = K2 + 1
2753: GO TO 60
2754: C
2755: C HOLLERITH
2756: C
2757: 50 CODE = 2
2758: K2 = K1 + 1
2759: 60 RETURN
2760: END
2761: C XXXXXOUTSYM.f
2762: SUBROUTINE OUTSYM
2763: INTEGER HASH, STACK, BL, DSA, OUTUT, SYMHD, BNEXT, SYMLEN, ATT(8)
2764: INTEGER CODE(11), CC(30), C(4), Q(70), SYM, PDSA
2765: INTEGER OUTUT2, OUTUT3, OUTUT4
2766: LOGICAL OK
2767: LOGICAL OPT, P1ERR, COMM
2768: COMMON /CHASH/ LHASH, HASH(401)
2769: COMMON /OPTNS/ OPT(5), P1ERR
2770: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
2771: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
2772: * OUTUT4
2773: COMMON /TABL/ NEXT, LAB, SYM, BNEXT
2774: COMMON /FACTS/ NAME, NOST, ITYP, IASF
2775: COMMON /CEXPRS/ LSTACK, STACK(620)
2776: COMMON /TRANS/ Q
2777: DATA BL /1H /
2778: DATA CODE(1) /1HD/, CODE(2) /1HR/, CODE(3) /1HI/, CODE(4) /1HC/,
2779: * CODE(5) /1HL/, CODE(11) /1HE/, CODE(7) /1HA/, CODE(8) /1HS/,
2780: * CODE(9) /1HF/, CODE(10) /1HN/, CODE(6) /1HH/, C(1) /4/, C(2)
2781: * /11/, C(3) /7/, C(4) /8/
2782: DATA CC(2), CC(16), CC(20), CC(22), CC(26), CC(28) /6*1H /,
2783: * CC(3), CC(5), CC(9), CC(11) /1HF,1HS,1HF,1HF/, CC(1), CC(4) /
2784: * 1HU,1HA/, CC(6), CC(8), CC(10), CC(12), CC(14) /1HF,4*1HN/,
2785: * CC(7), CC(13) /2*1HS/, CC(15) /1HC/, CC(17) /1HG/, CC(18) /
2786: * 1HT/, CC(19) /1HL/, CC(21) /1HV/, CC(25) /1HM/, CC(23) /1HB/,
2787: * CC(24) /1HD/, CC(27) /1HE/
2788: DATA CC(29) /1HI/, CC(30) /1HF/
2789: C
2790: C ROUTINE PRINTS OUT SYMBOL TABLE FOR A PROGRAM UNIT
2791: C
2792: IF (NAME.EQ.0 .OR. .NOT.OPT(1)) RETURN
2793: II = IGATT1(NAME,8)
2794: CALL S5UNPK(DSA(NAME+4), STACK(1), 6)
2795: WRITE (OUTUT,99999) (STACK(I),I=1,6)
2796: 99999 FORMAT (14H1PROGRAM UNIT , 5X, 6A1)
2797: IF (II.EQ.11 .OR. II.EQ.12 .OR. DSA(NAME+2).EQ.0) GO TO 60
2798: C
2799: C PRINT FCN/SUBROUTINE ARGS
2800: C
2801: KK = DSA(NAME+2)
2802: I = 0
2803: 10 L = 20
2804: CALL RDLIST(KK, 9, M, 0)
2805: IF (M) 20, 60, 20
2806: 20 DO 30 I1=1,M
2807: J = STACK(I1) + 4
2808: CALL S5UNPK(DSA(J), STACK(L), 6)
2809: L = L + 7
2810: STACK(L-1) = BL
2811: 30 CONTINUE
2812: MM = M*7 + 19
2813: IF (I) 40, 40, 50
2814: 40 WRITE (OUTUT,99998) (STACK(L),L=20,MM)
2815: 99998 FORMAT (//10H ARGUMENTS, 9X, 63A1)
2816: I = 1
2817: GO TO 10
2818: 50 WRITE (OUTUT,99997) (STACK(L),L=20,MM)
2819: 99997 FORMAT (19X, 63A1)
2820: GO TO 10
2821: C
2822: C PRINT SYMBOLS FOR PROGRAM UNIT
2823: C
2824: 60 CALL SORT(SYM, LBR)
2825: COMM = .FALSE.
2826: WRITE (OUTUT,99996)
2827: 99996 FORMAT (//1X, 4HNAME, 5X, 4HTYPE, 2X, 3HUSE, 1X, 10HATTRIBUTES,
2828: * 1X, 10HREFERENCES//)
2829: DO 230 JBR=1,LBR
2830: SYMHD = HASH(JBR)
2831: DO 70 I=20,35
2832: STACK(I) = BL
2833: 70 CONTINUE
2834: DO 80 I=1,8
2835: ATT(I) = IGATT1(SYMHD,I)
2836: 80 CONTINUE
2837: C SKIPS OVER SYMBOL TABLE ENTRY FOR MAIN, BLOCK DATA,
2838: C AND CURRENT SUBROUTINE NAME
2839: IF (SYMHD.EQ.NAME .AND. ATT(8).NE.4) GO TO 230
2840: IF (ATT(8).NE.7) GO TO 90
2841: COMM = .TRUE.
2842: GO TO 230
2843: 90 CALL S5UNPK(DSA(SYMHD+4), STACK(20), 6)
2844: I1 = ATT(8)
2845: L = 2*(I1+1) - 1
2846: STACK(28) = CC(L)
2847: STACK(29) = CC(L+1)
2848: C LEAVE BLANK IRRELEVANT TYPE INFO FOR EXT SUBR, COMMON, EXT ENTS
2849: IF(ATT(8).EQ.6 .OR. ATT(8).EQ.7 .OR. ATT(8).EQ.13)
2850: 1 GOTO 100
2851: I1 = MOD(ATT(1),8)
2852: IF (ATT(1).GE.8) STACK(26)=CODE(11)
2853: STACK(27) = CODE(I1 + 1)
2854: 100 DO 110 I=1,4
2855: L = I + 29
2856: J = C(I)
2857: IF (ATT(I+1).EQ.1) STACK(L) = CODE(J)
2858: 110 CONTINUE
2859: IF (ATT(8).EQ.7) STACK(30) = BL
2860: IF (ATT(8).NE.10 .AND. ATT(8).NE.8) GO TO 140
2861: IF (ATT(7)) 120, 130, 120
2862: 120 STACK(34) = CODE(7)
2863: J = ATT(7) + 1
2864: STACK(35) = Q(J)
2865: GO TO 140
2866: 130 STACK(34) = CODE(8)
2867: C
2868: C XREF LIST
2869: C
2870: 140 IF (OPT(2)) GO TO 160
2871: 150 WRITE (OUTUT,99995) (STACK(L),L=20,35)
2872: GO TO 230
2873: 160 OK = .FALSE.
2874: N = DSA(SYMHD+1)
2875: IF (N.LE.0) GO TO 150
2876: N = DSA( N+1 )
2877: 170 CALL RFLIST( N, M, J, DSA(SYMHD+1) )
2878: C
2879: C FIRST TIME PRINT WHOLE LINE
2880: C
2881: K = M
2882: IF (M.GE.57) K = 57
2883: WRITE (OUTUT,99995) (STACK(L),L=20,35), (STACK(L),L=50,K)
2884: 99995 FORMAT (1X, 6A1, 5X, 2A1, 3X, 2A1, 3X, 6A1, 2X, 8(I5, 1X))
2885: IF (M-57) 220, 220, 180
2886: 180 L = (M-57)/8
2887: LL = 58
2888: IF (L) 220, 210, 190
2889: 190 DO 200 K=1,L
2890: LK = LL + 7
2891: WRITE (OUTUT,99994) (STACK(I),I=LL,LK)
2892: LL = LK + 1
2893: 200 CONTINUE
2894: IF (LK.EQ.M) GO TO 220
2895: 210 WRITE (OUTUT,99994) (STACK(I),I=LL,M)
2896: 99994 FORMAT (30X, 8(I5, 1X))
2897: C
2898: C MAY HAVE TO CALL REFLIST AGAIN
2899: C
2900: 220 IF (J) 230, 230, 170
2901: 230 CONTINUE
2902: C
2903: C PRINT LABELS
2904: C
2905: IF (LAB.EQ.0) GO TO 320
2906: CALL SORT(LAB, LBR)
2907: DO 310 JBR=1,LBR
2908: LABHD = HASH(JBR)
2909: CALL S5UNPK(DSA(LABHD+4), STACK(20), 6)
2910: OK = .FALSE.
2911: IF (OPT(2)) GO TO 240
2912: WRITE (OUTUT,99993) (STACK(L),L=20,25)
2913: GO TO 310
2914: 240 II = DSA(LABHD+1)
2915: II = DSA(II+1)
2916: 250 CALL RFLIST(II, M, J, DSA(LABHD+1) )
2917: K = M
2918: IF (M.GE.57) K = 57
2919: WRITE (OUTUT,99993) (STACK(I),I=20,25), (STACK(I),I=50,K)
2920: 99993 FORMAT (1X, 6A1, 23X, 8(I5, 1X))
2921: IF (M-57) 300, 300, 260
2922: 260 L = (M-57)/8
2923: LL = 58
2924: IF (L) 300, 290, 270
2925: 270 DO 280 K=1,L
2926: LK = LL + 7
2927: WRITE (OUTUT,99992) (STACK(I),I=LL,LK)
2928: LL = LK + 1
2929: 280 CONTINUE
2930: IF (LK.EQ.M) GO TO 300
2931: 290 WRITE (OUTUT,99992) (STACK(I),I=LL,M)
2932: 99992 FORMAT (30X, 8(I5, 1X))
2933: 300 IF (J) 310, 310, 250
2934: 310 CONTINUE
2935: 320 IF (.NOT.COMM) GO TO 390
2936: CALL SORT(SYM, LBR)
2937: WRITE (OUTUT,99991)
2938: 99991 FORMAT (//14H COMMON BLOCKS//)
2939: DO 380 JBR=1,LBR
2940: SYMHD = HASH(JBR)
2941: I = IGATT1(SYMHD,8)
2942: IF (I.NE.7) GO TO 380
2943: CALL S5UNPK(DSA(SYMHD+4), STACK(100), 6)
2944: N = 0
2945: II = DSA(SYMHD+2)
2946: 330 L = 11
2947: CALL RDLIST(II, 10, M, 0)
2948: IF (M) 340, 380, 340
2949: 340 DO 350 I=1,M
2950: J = STACK(I) + 4
2951: CALL S5UNPK(DSA(J), STACK(L), 6)
2952: L = L + 7
2953: STACK(L-1) = BL
2954: 350 CONTINUE
2955: L = L - 1
2956: IF (N) 360, 360, 370
2957: 360 WRITE (OUTUT,99990) (STACK(I),I=100,105), (STACK(I),I=11,L)
2958: 99990 FORMAT (1X, 6A1, 3X, 70A1)
2959: N = 1
2960: GO TO 330
2961: 370 WRITE (OUTUT,99989) (STACK(K),K=11,L)
2962: 99989 FORMAT (10X, 70A1)
2963: GO TO 330
2964: 380 CONTINUE
2965: 390 RETURN
2966: END
2967: C XXXXXPOP.f
2968: SUBROUTINE POP
2969: LOGICAL ERR, SYSERR, ABORT
2970: INTEGER PB, PT, STACK, OP(12), EX(4,4), AO(4,4), RO(3,3)
2971: COMMON /CEXPRS/ LSTACK, STACK(620)
2972: COMMON /EXPRS/ PT, PB, AO, RO, EX
2973: COMMON /DETECT/ ERR, SYSERR, ABORT
2974: DATA OP(1), OP(3), OP(7), OP(9), OP(10), OP(11) /6*2/, OP(4) /1/,
2975: * OP(5) /0/, OP(6), OP(8), OP(2) /3*-1/, OP(12) /1/
2976: C
2977: C JOB OF SUBROUTINE IS TO POP THE STACK; DOES ALL POPS
2978: C EXCEPT REMOVAL OF "FCN(" CONSTRUCTION
2979: C OP(I) CONTAINS NUM OF ARGS OF OPERATER I PB CHECKED BEFORE
2980: C CALLING POP; POP CHECKS PT; ERROR RETURNS FROM THIS ROUTINE STOP
2981: C EXPRESSION PROCESSING (I.E. ERR=.TRUE.)
2982: C
2983: ERR = .FALSE.
2984: I = STACK(PB+1)
2985: K = OP(I-10)
2986: IF (K) 190, 180, 10
2987: 10 L = PT - 1
2988: KQ = K
2989: 20 IF (K) 80, 80, 30
2990: 30 IF (STACK(L)/8.EQ.1) GO TO 220
2991: IF (STACK(L).GE.8 .OR. STACK(L-1).EQ.0) GO TO 40
2992: J = IGATT1(STACK(L-1),8)
2993: IF (J.EQ.0) CALL SATT1(STACK(L-1), 8, 10)
2994: 40 GO TO (60, 50), K
2995: 50 K1 = MOD(STACK(L),8) + 1
2996: GO TO 70
2997: 60 K2 = MOD(STACK(L),8) + 1
2998: 70 L = L - 2
2999: K = K - 1
3000: GO TO 20
3001: C
3002: C 11 +,- 12 ) 13 ** 14 .NOT. 15 ( 16 FCN( 17 *,/ 18 ,
3003: C 19 .AND. 20 .OR. 21 .EQ. 22 UNARY +,-
3004: C
3005: 80 L = I - 10
3006: GO TO (90, 190, 120, 150, 190, 190, 90, 190, 130, 130, 100, 140),
3007: * L
3008: 90 IF (K1.GT.4 .OR. K2.GT.4) GO TO 210
3009: KK = AO(K1,K2)
3010: GO TO 160
3011: 100 IF (K1.GT.3 .OR. K2.GT.3) GO TO 110
3012: KK = RO(K1,K2)
3013: GO TO 160
3014: 110 IF ((K1.NE.6 .OR. K2.NE.6) .AND. (K1.NE.6 .OR. K2.NE.3) .AND.
3015: * (K1.NE.3 .OR. K2.NE.6) ) GO TO 210
3016: KK = 4
3017: GO TO 160
3018: 120 IF (K1.GT.4 .OR. K2.GT.4) GO TO 210
3019: KK = EX(K2,K1)
3020: GO TO 160
3021: 130 KK = 4
3022: IF (K1.NE.5 .OR. K2.NE.5) GO TO 210
3023: GO TO 160
3024: 140 KK = K2 - 1
3025: IF (KK.LT.0 .OR. KK.GT.3) GO TO 210
3026: GO TO 160
3027: 150 IF (K2.NE.5) GO TO 210
3028: KK = 4
3029: 160 IF (-1.EQ.KK) GO TO 210
3030: C
3031: C STORE ON STACK 0 TO SHOW EXPRESSION RESULT(NO DSA INDEX)
3032: C ALSO STORE TYPE OF RESULTING OPERAND
3033: C
3034: PT = PT - 2*KQ
3035: STACK(PT) = 0
3036: STACK(PT+1) = KK
3037: PT = PT + 2
3038: PB = PB + 1
3039: 170 RETURN
3040: C
3041: C POPPING "("
3042: C
3043: 180 PB = PB + 1
3044: GO TO 170
3045: 190 CALL ERROR1(25H ILLEGAL ELEMENT ON STACK, 25)
3046: 200 ERR = .TRUE.
3047: RETURN
3048: 210 CALL ERROR1(34H ILLEGAL COMBINATION OF DATA TYPES, 34)
3049: GO TO 200
3050: 220 CALL ERROR1(21H ILLEGAL USE OF ARRAY, 21)
3051: GO TO 200
3052: END
3053: C XXXXXRDLIST.f
3054: SUBROUTINE RDLIST(HEAD, L, N, M)
3055: C
3056: C HEAD IS THE HEAD OF A LINEAR LINKED LIST IN DSA
3057: C L IS MAX NUMBER OF ITEMS DESIRED
3058: C N IS NUMBER OF ITEMS RETURNED
3059: C M IS END OF LIST MARKER
3060: C
3061: INTEGER HEAD, STACK, DSA, PDSA
3062: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
3063: COMMON /CEXPRS/ LSTACK, STACK(620)
3064: N = 0
3065: 10 IF (HEAD.EQ.M .OR. N.GE.L) GO TO 20
3066: N = N + 1
3067: STACK(N) = DSA(HEAD)
3068: HEAD = DSA(HEAD+1)
3069: GO TO 10
3070: 20 RETURN
3071: END
3072: C XXXXXRFLIST.f
3073: SUBROUTINE RFLIST( I1, I2, I4, I3 )
3074: C
3075: C I1 IS POINTER TO FIRST ELEMENT ON XREF LIST IN DSA
3076: C I2 IS COUNT OF HOW MANY REFS ARE RETURNED IN STACK
3077: C I4 IS 1 IF RFLIST MUST BE CALLED AGAIN; ELSE IS 0
3078: C I3 IS LAST OF LIST ELEMENTS
3079: C
3080: INTEGER DSA, PDSA, STACK
3081: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
3082: COMMON /CEXPRS/ LSTACK, STACK(620)
3083: I4 = 0
3084: I2 = 49
3085: 10 IF ( I2+1.GE.LSTACK ) GOTO 30
3086: I2 = I2 + 1
3087: STACK(I2) = DSA(I1)
3088: IF( I1.EQ.I3 ) GOTO 20
3089: I1 = DSA(I1+1)
3090: GOTO 10
3091: 20 RETURN
3092: 30 I4 = 1
3093: GO TO 20
3094: END
3095: C XXXXXSEPAR.f
3096: SUBROUTINE SEPAR(ICHAR)
3097: C
3098: C FINDS SEPARATER CONSTRUCT IN FORMAT STMTS
3099: C SEPARATER IS A COMBINATION OF "/" AND ","
3100: C ",," IS ALWAYS ILLEGAL IN A SEPARATER
3101: C MIXING OF "/" AND "," IS WARNED AGAINST
3102: C
3103: C ICHAR CONTAINS LENGTH OF SEPARATOR FOUND
3104: INTEGER PSTMT, STMT
3105: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
3106: ICHAR = PSTMT
3107: ICOM = 0
3108: C
3109: C " , "
3110: C
3111: 10 IF (STMT(PSTMT).NE.68) GO TO 20
3112: ICOM = ICOM + 1
3113: C
3114: C CHECK FOR ",,"
3115: C
3116: PSTMT = PSTMT + 1
3117: IF (STMT(PSTMT).EQ.68) GO TO 30
3118: 20 IF (STMT(PSTMT).NE.67) GO TO 50
3119: PSTMT = PSTMT + 1
3120: GO TO 10
3121: 30 CALL ERROR1(19H ILLEGAL ADJACENT ,, 19)
3122: C
3123: C FLUSH TO NEXT NON-SEPARATER
3124: C
3125: 40 PSTMT = PSTMT + 1
3126: IF (STMT(PSTMT).EQ.67 .OR. STMT(PSTMT).EQ.68) GO TO 40
3127: 50 ICHAR = PSTMT - ICHAR
3128: IF (ICOM.GT.0 .AND. ICHAR.GT.1) CALL ERROR1(
3129: * 36H ILLEGAL MIXING OF / AND , IN FORMAT, 36)
3130: RETURN
3131: END
3132: C XXXXXSETNAM.f
3133: SUBROUTINE SETNAM(KK)
3134: LOGICAL ERR, SYSERR, ABORT
3135: INTEGER STMT, PSTMT, S(5)
3136: COMMON /FACTS/ NAME, NOST, ITYP, IASF
3137: COMMON /DETECT/ ERR, SYSERR, ABORT
3138: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
3139: DATA S(1) /66/, S(2) /42/, S(3) /30/, S(4) /38/, S(5) /43/
3140: C
3141: C KK=11 FOR BLOCK DATA PGM; KK=12 FOR MAIN PGM
3142: C NAME POINTS TO SYMBOL TABLE ENTRY FOR NEW PGM
3143: C
3144: IF (KK.EQ.11) GO TO 30
3145: PSTMT = 1
3146: DO 10 I=1,5
3147: STMT(I) = S(I)
3148: 10 CONTINUE
3149: NAME = LOOKUP(6,.FALSE.)
3150: IF (SYSERR) RETURN
3151: CALL SATT1(NAME, 8, 12)
3152: 20 RETURN
3153: 30 PSTMT = 5
3154: STMT(PSTMT) = S(1)
3155: NAME = LOOKUP(11,.FALSE.)
3156: IF (SYSERR) RETURN
3157: CALL SATT1(NAME, 8, 11)
3158: GO TO 20
3159: END
3160: C XXXXXSORT.f
3161: SUBROUTINE SORT(IPT, L)
3162: EXTERNAL EXCH
3163: INTEGER HASH, PDSA, DSA
3164: COMMON /CHASH/ LHASH, HASH(401)
3165: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
3166: C
3167: C PUT ALL SUMBOL INDICES IN HASH TABLE TO SORT THEM
3168: C
3169: L = 0
3170: I = IPT
3171: 10 IF (I.EQ.0) GO TO 20
3172: L = L + 1
3173: HASH(L) = I
3174: I = DSA(I+3)
3175: GO TO 10
3176: C
3177: C CALL SORT ROUTINE
3178: C UPON RETURN HASH CONTAINS INDICES OF ALL SYMBOLS OR LABELS IN
3179: C DSA IN LEXICOGRAPHIC ORDER
3180: C
3181: 20 CALL SSORT(EXCH, DSA, LDSA, HASH, L, 4)
3182: RETURN
3183: END
3184: C XXXXXSUBS.f
3185: SUBROUTINE SUBS(K2, NO)
3186: INTEGER STMT, PSTMT
3187: LOGICAL ERR, SYSERR, ABORT, TOKPNO
3188: COMMON /DETECT/ ERR, SYSERR, ABORT
3189: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
3190: C
3191: C STMT(PSTMT)-STMT(K2-1) CONTAIN SUBSCRIPT CONSTRUCT
3192: C NO IS NUMBER OF SUBSCRIPTS EXPECTED
3193: C ROUTINE CHECKS SYNTAX AND NUMBER OF SUBSCRIPTS
3194: C IF FLUSH OF CONSTRUCT IS NECESSARY, AND NSTMT IS REACHED
3195: C ERR=.TRUE.
3196: C
3197: ICNT = 0
3198: 10 CALL NEXTOK(PSTMT, K2, K)
3199: IF (K.EQ.0) GO TO 70
3200: IF (TOKPNO(PSTMT,K2,LL)) GO TO 60
3201: 20 CALL ERROR1(28H ILLEGAL SYNTAX OF SUBSCRIPT, 28)
3202: C
3203: C FLUSH TO END OF SUBSCRIPT CONSTRUCTION
3204: C
3205: 30 IF (STMT(K2).EQ.62) GO TO 40
3206: K2 = K2 + 1
3207: IF (K2.LT.NSTMT) GO TO 30
3208: ERR = .TRUE.
3209: GO TO 50
3210: 40 K2 = K2 + 1
3211: 50 RETURN
3212: 60 IF (STMT(K2).NE.66) GO TO 130
3213: PSTMT = K2 + 1
3214: IF (PSTMT.GE.NSTMT) GO TO 20
3215: CALL NEXTOK(PSTMT, K2, K)
3216: IF (K.NE.0) GO TO 20
3217: C
3218: C ACESS SYMBOL TABLE ENTRY FOR VARIABLE TO DETERMINE
3219: C USAGE AND TYPE
3220: C
3221: 70 KQ = LOOKUP(K2,.FALSE.)
3222: IF (SYSERR) GO TO 30
3223: I1 = IGATT1(KQ,1)
3224: I1 = MOD(I1,8)
3225: I2 = IGATT1(KQ,7)
3226: I3 = IGATT1(KQ,8)
3227: IF (I3.EQ.0) GO TO 90
3228: IF (I3.EQ.10) GO TO 100
3229: 80 CALL ERROR1(43H ILLEGAL VARIABLE IN SUBSCRIPT CONSTRUCTION, 43)
3230: GO TO 120
3231: 90 CALL SATT1(KQ, 8, 10)
3232: C
3233: C IMPLICITLY TYPE VARIABLES FIRST ENCOUNTERED IN SUBSCRIPT
3234: C CONSTRUCT
3235: C
3236: 100 IF (I1.GT.0) GO TO 110
3237: I1 = 1
3238: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
3239: CALL SATT1(KQ, 1, I1)
3240: 110 IF (I2.NE.0 .OR. I1.NE.2) GO TO 80
3241: 120 IF (STMT(K2).NE.60 .AND. STMT(K2).NE.61) GO TO 130
3242: CALL NEXTOK(K2+1, K3, K)
3243: IF (K.NE.1) GO TO 20
3244: K2 = K3
3245: 130 ICNT = ICNT + 1
3246: IF (STMT(K2).EQ.68) GO TO 140
3247: IF (STMT(K2).NE.62) GO TO 20
3248: IF (NO.NE.ICNT) CALL ERROR1(34H INCOMPATIBLE NUMBER OF SUBSCRIPTS,
3249: * 34)
3250: IF (ICNT.GT.3) CALL ERROR1(20H TOO MANY SUBSCRIPTS, 20)
3251: GO TO 40
3252: 140 PSTMT = K2 + 1
3253: IF (PSTMT.GE.NSTMT) GO TO 20
3254: GO TO 10
3255: END
3256: C XXXXXSUBFCN.f
3257: SUBROUTINE SUBFCN(TYPE)
3258: C
3259: C TYPE IS EXPLICIT TYPE OF FUNCTION, ELSE IS -1
3260: C ALL FCNS GIVEN EXPLICIT TYPE SINCE FCN NAME CANNOT APPEAR IN
3261: C NONEXECUTABLE STMT WITHIN FCN SUBPRGM EXCEPT HEAD STMT
3262: C ROUTINES DEFINES SUBROUTINE AND FUNCTION NAMES AND CREATES
3263: C LINKED LISTS OF POINTERS TO THEIR ARGUMENTS IN DSA.
3264: C SETS NAME TO POINT TO CURRENT FUNCN OR SUBRTNE. IN CASE
3265: C OF BAD SYNTAX IN NAME CONSTRUCT OR FCN WITHOUT PARAMS.,
3266: C PROGRAM UNIT BECOMES MAIN PGM BY DEFAULT
3267: C
3268: INTEGER STMT, PSTMT, DSA, SYMHD, TYPE, BNEXT, S(5), PDSA
3269: LOGICAL ERR, SYSERR, ABORT
3270: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
3271: COMMON /FACTS/ NAME, NOST, ITYP, IASF
3272: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
3273: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
3274: COMMON /DETECT/ ERR, SYSERR, ABORT
3275: DATA S(1) /66/, S(2) /42/, S(3) /30/, S(4) /38/, S(5) /43/
3276: KCELL = 0
3277: CALL NEXTOK(PSTMT, K2, I1)
3278: IF (I1.NE.0) GO TO 120
3279: C
3280: C SET FCN OR SUBR USE IN SYMBOL TABLE. TYPE FCN AND RECORD EXPLICIT
3281: C OR IMPLICIT TYPE
3282: C
3283: K = LOOKUP(K2,.FALSE.)
3284: IF (SYSERR) GO TO 90
3285: NAME = K
3286: L = ITYP - 8
3287: GO TO (10, 20), L
3288: 10 CALL SATT1(K, 8, 3)
3289: GO TO 40
3290: 20 CALL SATT1(K, 8, 4)
3291: IF (TYPE.LT.0) GO TO 30
3292: CALL SATT1(K, 1, TYPE+8)
3293: GO TO 40
3294: 30 L = 1
3295: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) L = 2
3296: CALL SATT1(K, 1, L)
3297: 40 IF (STMT(K2).NE.65) GO TO 140
3298: 50 PSTMT = K2 + 1
3299: IF (PSTMT.GE.NSTMT) GO TO 120
3300: CALL NEXTOK(PSTMT, K2, L)
3301: IF (L.NE.0) GO TO 80
3302: C
3303: C ENTER PARAMETER IN SYMBOL TABLE; TYPE IMPLICITLY; ADD ONTO PARAM
3304: C LIST HANGING OFF SUBR/FCN NAME; SET DUMMYARG BIT ON; DO NOT SET
3305: C USAGE
3306: C
3307: N = LOOKUP(K2,.FALSE.)
3308: IF (SYSERR) GO TO 90
3309: I2 = IGATT1(N,4)
3310: I1 = IGATT1(N,8)
3311: IF (I1.NE.0 .OR. I2.NE.0) GO TO 80
3312: L = 1
3313: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) L = 2
3314: CALL SATT1(N, 1, L)
3315: L = IGATT1(N,4)
3316: IF (L.EQ.1) GO TO 80
3317: CALL SATT1(N, 4, 1)
3318: IF (NEXT+2.GE.BNEXT) GO TO 150
3319: IF (KCELL.EQ.0) GO TO 60
3320: DSA(KCELL+1) = NEXT
3321: GO TO 70
3322: C
3323: C START PARAM LIST
3324: C
3325: 60 DSA(K+2) = NEXT
3326: 70 KCELL = NEXT
3327: DSA(NEXT) = N
3328: DSA(NEXT+1) = 0
3329: NEXT = NEXT + 2
3330: C
3331: C SEARCH FOR ")" OR ","
3332: C
3333: IF (STMT(K2).EQ.62) GO TO 100
3334: IF (STMT(K2).EQ.68) GO TO 50
3335: 80 CALL ERROR1(33H ILLEGAL SYNTAX IN PARAMETER LIST, 33)
3336: 90 RETURN
3337: 100 K2 = K2 + 1
3338: 110 IF (K2.EQ.NSTMT) GO TO 90
3339: CALL ERROR1(39H ILLEGAL CHARACTERS AFTER SUBR/FCN HEAD, 39)
3340: GO TO 90
3341: 120 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
3342: PSTMT = 6
3343: DO 130 I1=1,5
3344: STMT(I1+5) = S(I1)
3345: 130 CONTINUE
3346: NAME = LOOKUP(11,.FALSE.)
3347: IF (SYSERR) GO TO 90
3348: CALL SATT1(NAME, 8, 11)
3349: GO TO 90
3350: 140 IF (ITYP.EQ.9) GO TO 110
3351: CALL ERROR1(20H NO PARAMS SPECIFIED, 20)
3352: GO TO 120
3353: 150 SYSERR = .TRUE.
3354: CALL ERROR1(33H IN SUBFCN, TABLE OVERFLOW OF DSA,33)
3355: GO TO 90
3356: END
3357: C XXXXXTOKCOM.f
3358: LOGICAL FUNCTION TOKCOM(K1, K2)
3359: C
3360: C TOKCOM RETURNS TRUE IS FINDS CONST IN STMT(K1)-STMT(K2-1)
3361: C ( (OPTIONAL SIGN) REAL CONST, (OPTIONAL SIGN) REAL CONST ) IS
3362: C COMPLEX CONSTRUCT; TOKCOM RESETS K2
3363: C
3364: LOGICAL TOKRL
3365: INTEGER STMT, PSTMT
3366: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
3367: TOKCOM = .FALSE.
3368: IF (STMT(K1).NE.65) GO TO 10
3369: K3 = K1 + 1
3370: IF (STMT(K3).EQ.60 .OR. STMT(K3).EQ.61) K3 = K3 + 1
3371: IF (TOKRL(K3,K2,K)) IF (K-1) 10, 20, 10
3372: 10 RETURN
3373: 20 IF (STMT(K2).NE.68) GO TO 10
3374: K3 = K2 + 1
3375: IF (STMT(K3).EQ.60 .OR. STMT(K3).EQ.61) K3 = K3 + 1
3376: IF (TOKRL(K3,K2,K)) IF (K-1) 10, 30, 10
3377: GO TO 10
3378: 30 IF (STMT(K2).NE.62) GO TO 10
3379: K2 = K2 + 1
3380: TOKCOM = .TRUE.
3381: GO TO 10
3382: END
3383: C XXXXXTOKLAB.f
3384: LOGICAL FUNCTION TOKLAB(K1, K2, KK, DEF)
3385: INTEGER STMT, PSTMT, SYMHD, DSA, PDSA, BNEXT, DOPT, DOLIST
3386: LOGICAL DEF, NON0, SYSERR, ABORT, ERR
3387: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
3388: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
3389: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
3390: COMMON /DETECT/ ERR, SYSERR, ABORT
3391: COMMON /DOS/ DOPT, LDO, DOLIST(192)
3392: COMMON /FACTS/ NAME, NOST, ITYPE, IASF
3393: C
3394: C LOOKS FOR DEFNS OF LABEL IF DEF = .TRUE., ELSE LOOKS FOR
3395: C REFS. IF IT FINDS A LABEL TOKLAB=.TRUE.
3396: C IN REFERENCE LABEL IS IN STMT(PSTMT)-STMT(K2-1)
3397: C IN DEFN LABEL IS IN STMT(1)-STMT(K2-1)
3398: C KK IS SYMBOL TABLE INDEX OF LABEL
3399: C K1 IS TYPE OF LABEL EXPECTED OR DEFINED--1-EXECUTABLE
3400: C 2-NONEXECUTABLE, 3-FORMAT
3401: C IN REF, ROUTINE SETS USAGE OF SYMBOL AND CHECKS FOR
3402: C COMPATIBLE REFERENCES(I.E. GOTO 5 AND WRITE(6,5) ARE INCOMPAT.)
3403: C IN DEF, ROUTINE SETS USAGE OF SYMBOL, CHECKS FOR DUPLICATE
3404: C DEFNS, CHECKS FOR COMPATIBLITY BETWEEN DEFN AND PREVIOUS
3405: C REFS, CREATES SCOPE AREA FOR LABEL INITIALIZING WORD1 TO
3406: C CURRENT HEADING STMT NO ON DOLIST AND WORD2 TO CURRENT LEVEL
3407: C IN REFS AND DEFS LABELS MUST BE POSITIVE NUMBERS
3408: C
3409: TOKLAB = .FALSE.
3410: IF (DEF) GO TO 80
3411: NON0 = .FALSE.
3412: J = PSTMT + 4
3413: IF (J.GT.NSTMT) J = NSTMT
3414: K3 = PSTMT
3415: DO 10 K2 = PSTMT,J
3416: IF(STMT(K2).GT.9 .OR. STMT(K2).LT.0) GOTO 60
3417: IF(STMT(K2) .GT. 0) NON0 = .TRUE.
3418: IF(.NOT.NON0) K3 = K3+1
3419: 10 CONTINUE
3420: K2 = J+1
3421: IF(.NOT.NON0) GOTO 70
3422: C NOTE CAN CHANGE PSTMT HERE BECAUSE WE KNOW WE HAVE A LAB
3423: 20 PSTMT = K3
3424: KK = LOOKUP(K2,.TRUE.)
3425: IF (SYSERR) GO TO 50
3426: IF (ITYPE.EQ.14) DSA(BNEXT+1) = -DSA(BNEXT+1)
3427: I = IGATT1(KK,8)
3428: IF (I.EQ.0) CALL SATT1(KK, 8, 9)
3429: I1 = IGATT1(KK,1)
3430: IF (I1.NE.0) GO TO 30
3431: CALL SATT1(KK, 1, K1)
3432: GO TO 40
3433: 30 IF (K1.NE.I1) CALL ERROR1(30H INCOMPATIBLE LABEL REFERENCES, 30)
3434: 40 TOKLAB = .TRUE.
3435: 50 RETURN
3436: 60 IF (K2.EQ.PSTMT) GO TO 50
3437: IF (NON0) GO TO 20
3438: 70 CALL ERROR1(30H LABEL MUST BE POSITIVE NUMBER, 30)
3439: GO TO 50
3440: C
3441: C TAKES DEF OF LABEL; CHECKS FOR DUPLICATE DEFS.; SETS DEFINED
3442: C BIT IN SYMBOL TABLE; STORES BEGINNING BINDING STMT NO
3443: C
3444: 80 K2 = 0
3445: NON0 = .FALSE.
3446: DO 90 I=1,5
3447: IF (STMT(I).EQ.69) GO TO 90
3448: IF ((STMT(I).GT.9) .OR. (STMT(I).LT.0)) GO TO 140
3449: IF (STMT(I).GT.0) NON0 = .TRUE.
3450: IF (.NOT.NON0) GO TO 90
3451: K2 = K2 + 1
3452: STMT(K2) = STMT(I)
3453: 90 CONTINUE
3454: IF (K2.EQ.0) GO TO 50
3455: IF (.NOT.NON0) GO TO 70
3456: K2 = K2 + 1
3457: KK = LOOKUP(K2,.TRUE.)
3458: IF (SYSERR) GO TO 50
3459: I = IGATT1(KK,2)
3460: IF (I.EQ.1) GO TO 120
3461: CALL SATT1(KK, 2, 1)
3462: CALL SATT1(KK, 8, 9)
3463: I1 = IGATT1(KK,1)
3464: IF (I1.EQ.0) GO TO 100
3465: IF (I1.EQ.K1) GO TO 110
3466: CALL ERROR1(44H ILLEGAL REFERENCE TO LABEL IN PREVIOUS CODE, 44)
3467: 100 CALL SATT1(KK, 1, K1)
3468: 110 IF (K1.NE.1) GO TO 40
3469: IF (NEXT+2.GE.BNEXT) GO TO 130
3470: DSA(KK+2) = NEXT
3471: DSA(NEXT) = DOLIST(DOPT)
3472: DSA(NEXT+1) = -DOPT/6
3473: NEXT = NEXT + 2
3474: GO TO 40
3475: 120 CALL ERROR1(16H DUPLICATE LABEL, 16)
3476: GO TO 50
3477: 130 CALL ERROR1(33H IN TOKLAB, TABLE OVERFLOW OF DSA, 33)
3478: SYSERR = .TRUE.
3479: GO TO 50
3480: 140 CALL ERROR1(24H ILLEGAL SYMBOL IN LABEL, 24)
3481: GO TO 50
3482: END
3483: C XXXXXTOKLOG.f
3484: LOGICAL FUNCTION TOKLOG(K1, K2)
3485: C
3486: C ROUTINE RETURNS TRUE IF FINDS .TRUE. OR .FALSE.
3487: C IN STMT(K1)-STMT(K2-1)
3488: C
3489: INTEGER STMT, CONS(13), PSTMT
3490: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
3491: DATA CONS(1) /64/, CONS(2) /35/, CONS(3) /30/, CONS(4) /41/,
3492: * CONS(5) /48/, CONS(6) /34/, CONS(7) /64/, CONS(8) /64/,
3493: * CONS(9) /49/, CONS(10) /47/, CONS(11) /50/, CONS(12) /34/,
3494: * CONS(13) /64/
3495: TOKLOG = .FALSE.
3496: KCNT = 1
3497: L1 = 1
3498: L2 = 7
3499: K2 = K1
3500: 10 DO 20 I=L1,L2
3501: IF (STMT(K2).NE.CONS(I)) GO TO 30
3502: K2 = K2 + 1
3503: 20 CONTINUE
3504: TOKLOG = .TRUE.
3505: RETURN
3506: 30 KCNT = KCNT + 1
3507: IF (KCNT.GE.3) RETURN
3508: K2 = K1
3509: L1 = 8
3510: L2 = 13
3511: GO TO 10
3512: END
3513: C XXXXXTOKLOP.f
3514: LOGICAL FUNCTION TOKLOP(K1, K2, KCODE)
3515: C
3516: C ROUTINE RETURNS TRUE IF FINDS LOGICAL OR RELATIONAL
3517: C OPERATORS IN STMT(K1)-STMT(K2-1); RETURNS OPERATOR CODE
3518: C IN KCODE (SEE EXPR FOR CODES)
3519: C
3520: INTEGER C(20), CC(9), CODE(9), PSTMT, STMT
3521: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
3522: DATA C(1) /30/, C(2) /43/, C(3) /33/, C(4) /43/, C(5) /44/, C(6)
3523: * /49/, C(7) /44/, C(8) /47/, C(9) /34/, C(10) /46/, C(11)
3524: * /43/, C(12) /34/, C(13) /36/, C(14) /49/, C(15) /36/, C(16)
3525: * /34/, C(17) /41/, C(18) /49/, C(19) /41/, C(20) /34/
3526: DATA CC(1), CC(2) /2*3/, CC(3), CC(4), CC(5), CC(6), CC(7),
3527: * CC(8), CC(9) /7*2/, CODE(1) /19/, CODE(2) /14/, CODE(3) /20/,
3528: * CODE(4), CODE(5), CODE(6), CODE(7), CODE(8), CODE(9) /6*21/
3529: TOKLOP = .FALSE.
3530: IF (STMT(K1).NE.64) RETURN
3531: J = 1
3532: DO 30 I=1,9
3533: KK = J + CC(I) - 1
3534: K2 = K1 + 1
3535: DO 10 L=J,KK
3536: IF (STMT(K2).NE.C(L)) GO TO 20
3537: K2 = K2 + 1
3538: 10 CONTINUE
3539: KCODE = CODE(I)
3540: IF (STMT(K2).NE.64) RETURN
3541: K2 = K2 + 1
3542: TOKLOP = .TRUE.
3543: RETURN
3544: 20 J = J + CC(I)
3545: 30 CONTINUE
3546: RETURN
3547: END
3548: C XXXXXTOKPNO.f
3549: LOGICAL FUNCTION TOKPNO(K1, K2, LL)
3550: C
3551: C ROUTINE RECOGNIZES A POSITIVE INTEGER CONSTANT
3552: C IN STMT(K1)-STMT(K2-1), AND RETURNS ITS VALUE IN LL
3553: C
3554: INTEGER STMT, PSTMT
3555: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
3556: TOKPNO = .FALSE.
3557: CALL NEXTOK(K1, K2, K)
3558: IF (K.NE.1) RETURN
3559: K=K2-1
3560: LL = 0
3561: DO 10 KK=K1,K
3562: LL = 10 * LL + STMT(KK)
3563: 10 CONTINUE
3564: IF (LL.GT.0) TOKPNO = .TRUE.
3565: RETURN
3566: END
3567: C XXXXXTOKRL.f
3568: LOGICAL FUNCTION TOKRL(K1, K2, CODE)
3569: INTEGER STMT, CODE, PSTMT
3570: LOGICAL TOKLOP
3571: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
3572: C
3573: C ROUTINE RETURNS TRUE IF FINDS A REAL CONSTANT IN
3574: C STMT(K1)-STMT(K2-1) . ELSE IT RETURNS FALSE.
3575: C BASIC CONSTRUCT IS: <INT> . <INT>
3576: C <INT> .
3577: C . <INT>
3578: C EACH OF THESE MAY BE FOLLOWED BY <D,E> <+,-> <INT>
3579: C ALSO LEGAL IS IN-CONST FOLLOWED BY EXPONENT CONSTRUCT
3580: C
3581: TOKRL = .FALSE.
3582: CALL NEXTOK(K1, K2, K)
3583: IF (K.EQ.3 .AND. STMT(K1).EQ.64) GO TO 10
3584: IF (K.EQ.1 .AND. STMT(K2).EQ.64) GO TO 40
3585: C IF HAVE INT-CONST NEED EXPONENT FOR THIS TO BE A REAL-CONST
3586: IF (K-1) 80, 50, 80
3587: C
3588: C FIND BASIC REAL CONSTANT
3589: C
3590: C (. INT-CONST) CONSTRUCT
3591: 10 CALL NEXTOK(K2, K3, K)
3592: IF (K.NE.1) GO TO 80
3593: 20 K2 = K3
3594: 30 TOKRL = .TRUE.
3595: CODE = 1
3596: GO TO 50
3597: C (INT-CONST .) CONSTRUCT; CHECK FOR (INT . INT )
3598: 40 K2 = K2 + 1
3599: CALL NEXTOK(K2, K3, K)
3600: IF (K.EQ.1) GO TO 20
3601: IF (TOKLOP(K2-1,K4,K)) GO TO 80
3602: GO TO 30
3603: C
3604: C CHECK FOR EXPONENT
3605: C
3606: 50 IF (STMT(K2).NE.33) GO TO 60
3607: CODE = 0
3608: GO TO 70
3609: 60 IF (STMT(K2).NE.34) GO TO 80
3610: CODE = 1
3611: 70 K3 = K2 + 1
3612: IF (K3.EQ.NSTMT) GO TO 80
3613: IF ((STMT(K3).EQ.60) .OR. (STMT(K3).EQ.61)) K3 = K3 + 1
3614: CALL NEXTOK(K3, K4, K)
3615: IF (K.NE.1) GO TO 80
3616: K2 = K4
3617: TOKRL = .TRUE.
3618: 80 RETURN
3619: END
3620: C XXXXXTYPE.f
3621: SUBROUTINE TYPE
3622: LOGICAL ERR, SYSERR, ARDECL, ABORT
3623: INTEGER STMT, PSTMT, DSA, PDSA
3624: COMMON /DETECT/ ERR, SYSERR, ABORT
3625: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
3626: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
3627: C
3628: C PROCESSES TYPE STMT BY FINDING IDS OR ARRAY DECLS
3629: C THEY ARE ENTERED INTO SYMBOL TABLE AND TYPED EXPLICITLY
3630: C NO USAGE IS SET.
3631: C
3632: 10 IF (.NOT.ARDECL(K2,INDX)) GO TO 20
3633: IF (SYSERR) GO TO 30
3634: L = IGATT1(INDX,6)
3635: IF(L.EQ.1) CALL ERROR1(63
3636: 1H WARNING - SHOULD TYPE ADJUSTABLE DIMENSION VARIABLE BEFORE USE
3637: 2, 63)
3638: IF (K2.EQ.NSTMT) GO TO 30
3639: IF (STMT(K2).EQ.68 .AND. K2+1.NE.NSTMT) GO TO 40
3640: 20 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
3641: 30 RETURN
3642: 40 PSTMT = K2 + 1
3643: GO TO 10
3644: END
3645: C XXXXXTYPST.f
3646: SUBROUTINE TYPST(ITYP, KK, KL)
3647: INTEGER PSTMT, K(186), KI(30), STMT, CODE, KT(30)
3648: LOGICAL ERR, SYSERR, ASSMT, ABORT
3649: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
3650: COMMON /DETECT/ ERR, SYSERR, ABORT
3651: COMMON /STS/ K, KI, KT
3652: C
3653: C*****STS
3654: C K(*) (INT) ARRAY CONTAINS A TABLE OF INTERNAL CODES FOR EACH
3655: C "KEYWORD" IN FORTRAN STMTS
3656: C KI(*) (INT) ARRAY CONTAINING NUMBER OF CHARACTERS IN EACH
3657: C KEYWORD IN K
3658: C KT(*) (INT) ARRAY CONTAINING CLASS OF EACH STMT IN K
3659: C (SEE PU FOR FURTHER DOC OF IGP -CLASS)
3660: C TEST IF ITS AN ASSIGNMENT; IF SO ITYP = 30
3661: C ELSE SEARCH K ARRAY FOR STMT; ITYP CONTAINS CODED
3662: C TYPE OF STMT; KK CONTAINS GENERAL CLASS OF STMTS IT FALLS IN
3663: C KL IS COUNT OF NUMBER OF LETTERS IN FIRST WORD OF STMT
3664: C
3665: CALL TYPST2(ASSMT)
3666: IF (ASSMT) GO TO 40
3667: J = 1
3668: CODE = 0
3669: 10 I = PSTMT
3670: CODE = CODE + 1
3671: L = J + KI(CODE) - 1
3672: DO 20 LL=J,L
3673: IF (STMT(I).NE.K(LL)) GO TO 30
3674: I = I + 1
3675: 20 CONTINUE
3676: ITYP = CODE
3677: KK = KT(CODE)
3678: KL = KI(CODE)
3679: RETURN
3680: 30 J = L + 1
3681: IF (CODE.LT.29) GO TO 10
3682: ERR = .TRUE.
3683: RETURN
3684: 40 ITYP = 30
3685: KK = KT(30)
3686: KL = 0
3687: RETURN
3688: END
3689: C XXXXXTYPST2.f
3690: SUBROUTINE TYPST2(ASSMT)
3691: INTEGER PSTMT, STMT
3692: LOGICAL EQUALS, ASSMT
3693: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
3694: C
3695: C ALGORITHM FOR IDENTIFYING ASSIGNMENT STMTS:
3696: C
3697: EQUALS = .FALSE.
3698: LEVEL = 0
3699: IGP = 0
3700: C
3701: C 62.....) 63.....= 65.....( 68.....,
3702: C
3703: DO 40 I=PSTMT,NSTMT
3704: IF (STMT(I).EQ.65) LEVEL = LEVEL + 1
3705: IF (STMT(I).NE.62) GO TO 10
3706: LEVEL = LEVEL - 1
3707: IF (EQUALS) GO TO 40
3708: IF (LEVEL.EQ.0) IGP = IGP + 1
3709: IF (IGP.EQ.1 .AND. LEVEL.EQ.0 .AND. STMT(I+1).NE.63) GO TO 60
3710: GO TO 40
3711: 10 IF (LEVEL) 50, 20, 30
3712: 20 IF (STMT(I).EQ.68) GO TO 60
3713: IF (STMT(I).EQ.63) EQUALS = .TRUE.
3714: GO TO 40
3715: 30 IF (STMT(I).EQ.63) GO TO 60
3716: 40 CONTINUE
3717: IF (.NOT.EQUALS) GO TO 60
3718: ASSMT = .TRUE.
3719: 50 RETURN
3720: 60 ASSMT = .FALSE.
3721: GO TO 50
3722: END
3723: C XXXXXSATT2.f
3724: SUBROUTINE SATT2(INDEX, FIELD, ATT)
3725: C
3726: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
3727: C
3728: INTEGER INDEX, FIELD, ATT
3729: INTEGER LLAT, PLAT, LAT
3730: INTEGER FWTH(8), FPOS(8)
3731: C
3732: DATA FWTH(1) /16/, FPOS(1) /1/
3733: DATA FWTH(2) /2/, FPOS(2) /16/
3734: DATA FWTH(3) /2/, FPOS(3) /32/
3735: DATA FWTH(4) /2/, FPOS(4) /64/
3736: DATA FWTH(5) /2/, FPOS(5) /128/
3737: DATA FWTH(6) /2/, FPOS(6) /256/
3738: DATA FWTH(7) /4/, FPOS(7) /512/
3739: DATA FWTH(8) /32/, FPOS(8) /2048/
3740: C
3741: LAT(INDEX) = LAT(INDEX) + (ATT-MOD(LAT(INDEX)/FPOS(FIELD),
3742: * FWTH(FIELD)))*FPOS(FIELD)
3743: C
3744: RETURN
3745: C
3746: END
3747: C XXXXXIGATT2.f
3748: INTEGER FUNCTION IGATT2(INDEX, FIELD)
3749: C
3750: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
3751: C
3752: INTEGER INDEX, FIELD
3753: INTEGER LLAT, PLAT, LAT
3754: INTEGER FWTH(8), FPOS(8)
3755: C
3756: DATA FWTH(1) /16/, FPOS(1) /1/
3757: DATA FWTH(2) /2/, FPOS(2) /16/
3758: DATA FWTH(3) /2/, FPOS(3) /32/
3759: DATA FWTH(4) /2/, FPOS(4) /64/
3760: DATA FWTH(5) /2/, FPOS(5) /128/
3761: DATA FWTH(6) /2/, FPOS(6) /256/
3762: DATA FWTH(7) /4/, FPOS(7) /512/
3763: DATA FWTH(8) /32/, FPOS(8) /2048/
3764: C
3765: IGATT2 = MOD(LAT(INDEX)/FPOS(FIELD),FWTH(FIELD))
3766: C
3767: RETURN
3768: C
3769: END
3770: C XXXXXCALLS.f
3771: SUBROUTINE CALLS
3772: INTEGER STMT, PSTMT, EXPR, M(3), OUTUT3, OUTUT4
3773: LOGICAL ERR, SYSERR, ABORT
3774: LOGICAL OPT, P1ERR
3775: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
3776: COMMON /PARAMS/ I1, I2, I6, I4, I5, OUTUT3, OUTUT4
3777: COMMON /DETECT/ ERR, SYSERR, ABORT
3778: COMMON /FACTS/ NAME, NOST, ITYP, IASF
3779: COMMON /OPTNS/ OPT(5), P1ERR
3780: DATA M(1) /4/, M(2) /2/, M(3) /0/
3781: C
3782: C CHECK FOR LEGAL SUBROUTINE NAME BEFORE CALLING EXPR
3783: C TO PROCESS ARGUMENTS
3784: C IF NO ARGS, CALLS SAVES PASS 2 DATA ITSELF WITHOUT
3785: C CALLING EXPR
3786: C
3787: IF (PSTMT.GE.NSTMT) GO TO 10
3788: CALL NEXTOK(PSTMT, K2, K)
3789: IF (K.NE.0) GO TO 10
3790: IF (K2.EQ.NSTMT) GO TO 40
3791: IF (STMT(K2).EQ.65) GO TO 30
3792: 10 CALL ERROR1(26H MISSING ROUTINE NAME OR (, 26)
3793: 20 RETURN
3794: C
3795: C BY A CALL TO EXPR
3796: C
3797: 30 I3 = EXPR(K)
3798: IF (SYSERR) GO TO 20
3799: IF (PSTMT.NE.NSTMT) CALL ERROR1(18H ILLEGAL CALL STMT, 18)
3800: GO TO 20
3801: C
3802: C SAVE SUBROUTINE CALL W/O ARGS
3803: C
3804: 40 K = LOOKUP(K2,.FALSE.)
3805: IF (SYSERR) GO TO 20
3806: I3 = IGATT1(K,8)
3807: IF (I3.NE.13 .AND. I3.NE.0) GO TO 50
3808: CALL SATT1(K, 8, 6)
3809: GO TO 60
3810: C
3811: C MAKE SURE EXTERNAL REFERENCED ID IS NOT USED AS ANYTHING
3812: C OTHER AS A SUBROUTINE ELSEWHERE IN THIS P-U
3813: C
3814: 50 IF (I3.EQ.6) GO TO 60
3815: CALL ERROR1(24H ILLEGAL SUBROUTINE NAME, 24)
3816: GO TO 20
3817: 60 IF (OPT(3) .AND. .NOT.P1ERR) WRITE (OUTUT3) M, K, NOST, M(3)
3818: GO TO 20
3819: END
3820: C XXXXXDATA.f
3821: SUBROUTINE DATA
3822: LOGICAL ERR, SYSERR, ABORT, REPL, ARDECL, SIGN, TOKPNO, ERROR
3823: INTEGER DECNT, DATCNT, STMT, PSTMT, GETTOK, STACK, S(10), DSA,
3824: * PDSA
3825: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
3826: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
3827: COMMON /FACTS/ NAME, NOST, ITYP, IASF
3828: COMMON /DETECT/ ERR, SYSERR, ABORT
3829: COMMON /CEXPRS/ LSTACK, STACK(620)
3830: DATA IS /1H*/
3831: C
3832: C ROUTINE PROCESSES A DATA STMT
3833: C
3834: 10 DECNT = 0
3835: 20 IF (ARDECL(K2,KK)) GO TO 30
3836: IF (.NOT.ERR) GO TO 30
3837: CALL ERROR1(19H ILLEGAL DECLARATOR, 19)
3838: IF(.NOT.SYSERR) GOTO 260
3839: 30 IF (SYSERR) RETURN
3840: C
3841: C SET DECLARATOR USAGE AS VARIABLE; CHECK ITS NOT IN BLANK COMMON
3842: C CANNOT BE INLABELLED COMMON IF THIS STMT NOT IN BLOCK DATA PGM
3843: C FOUND A DECLARATOR ADD IT TO LIST OF ALL DECLS SO CAN CHECK
3844: C TYPE OF ITS CORRESPONDING DATA-ITEM; ADD IN COUNT SO CAN
3845: C CHECK NUMBER OF DECLS VS. NUMBER OF DATA-ITEMS
3846: C KEEP TYPE INFO ON STACK; DECNT IS LENGTH OF STACK
3847: C
3848: I = IGATT1(KK,8)
3849: IF (I.EQ.0) CALL SATT1(KK, 8, 10)
3850: I = IGATT1(KK,2)
3851: NN = IGATT1(NAME,8)
3852: IF (I) 60, 60, 40
3853: C
3854: C IF VARIABLE IN COMMON, CHECK TO SEE IF CAN LEGALLY APPEAR
3855: C IN DATA STMT
3856: C
3857: 40 I = DSA(KK+2)
3858: I = DSA(I+1)
3859: CALL S5UNPK(DSA(I+4), S(1), 6)
3860: IF (S(1).EQ.IS) GO TO 50
3861: C
3862: C FOUND NO "*" SO ARE IN LABELLED COMMON
3863: C
3864: IF (NN.EQ.11) GO TO 70
3865: CALL ERROR1(
3866: * 55H ILLEGAL TO INITIALIZE VARIABLE IN LABELLED COMMON HERE,
3867: * 55)
3868: GO TO 260
3869: C
3870: C FOUND BLANK COMMON
3871: C
3872: 50 CALL ERROR1(48H ILLEGAL TO INITIALIZE VARIABLES IN BLANK COMMON,
3873: * 48)
3874: GO TO 260
3875: 60 IF (NN.NE.11) GO TO 70
3876: CALL ERROR1(33H DATA-ITEM NOT IN LABELLED COMMON, 33)
3877: GO TO 260
3878: 70 I = IGATT1(KK,1)
3879: CALL SATT1(KK, 5, 1)
3880: NN = 1
3881: IF (IGATT1(KK,7).EQ.0) GO TO 75
3882: IF (STMT(K2-1).EQ.62) GO TO 75
3883: N = DSA(KK+2)
3884: NN = DSA(N)
3885: 75 CONTINUE
3886: IF (DECNT+3.LE.LSTACK) GO TO 76
3887: CALL ERROR1(33H IN DATA, TABLE OVERFLOW OF STACK , 33 )
3888: GO TO 260
3889: 76 CONTINUE
3890: STACK(DECNT+1) = MOD(I,8)
3891: STACK(DECNT+2) = KK
3892: STACK(DECNT+3) = NN
3893: DECNT = DECNT + 3
3894: IF (STMT(K2).EQ.67) GO TO 100
3895: IF (STMT(K2).NE.68) GO TO 90
3896: PSTMT = K2 + 1
3897: IF (PSTMT.LT.NSTMT) GO TO 20
3898: 80 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
3899: RETURN
3900: 90 CALL ERROR1(33H ILLEGAL PUNCTUATION IN DATA STMT, 33)
3901: GO TO 260
3902: C
3903: C FIND DATA-ITEMS; CHECK ITS TYPE VS. CORRESPONDING DECLARATOR
3904: C SIGN .TRUE. IF DATA-ITEM PRECEEDED BY A SIGN
3905: C REPL .TRUE. IF A REPLICATION FACTOR HAS ALREADY BEEN FOUND
3906: C
3907: 100 DATCNT = 0
3908: ERROR = .FALSE.
3909: PSTMT = K2 + 1
3910: 110 IF (PSTMT.EQ.NSTMT) GO TO 80
3911: SIGN = .FALSE.
3912: REPL = .FALSE.
3913: NN = 1
3914: 120 IF (STMT(PSTMT).NE.60 .AND. STMT(PSTMT).NE.61) GO TO 130
3915: PSTMT = PSTMT + 1
3916: SIGN = .TRUE.
3917: 130 IF (PSTMT.EQ.NSTMT) GO TO 80
3918: KK = GETTOK(PSTMT,K2)
3919: IF (ERR) GO TO 80
3920: IF (KK.LT.6) GO TO 150
3921: 140 CALL ERROR1(18H ILLEGAL DATA-ITEM, 18)
3922: GO TO 260
3923: 150 KK = KK + 1
3924: GO TO (200, 200, 160, 190, 190, 180), KK
3925: C
3926: C MUST MAKE SURE THAN AN INTEGER DATA-ITEM ISN'T A REPLICATION FACTO
3927: C
3928: 160 IF (REPL) GO TO 200
3929: IF(SIGN .OR. STMT(K2).NE.66) GOTO 200
3930: IF(TOKPNO(PSTMT,K2,NN)) GOTO 170
3931: CALL ERROR1(27H ILLEGAL REPLICATION FACTOR ,27)
3932: NN = 1
3933: 170 REPL = .TRUE.
3934: PSTMT = K2 + 1
3935: GO TO 120
3936: C
3937: C CHECK LENGTH OF HOLLERITH DATA-ITEM; MUST FIT INTO INTEGER WORD
3938: C
3939: 180 IF (STMT(PSTMT)+2048.EQ.1 .OR. ERROR) GO TO 190
3940: CALL ERROR1(
3941: * 53H WARNING - NH WITH N.GT.1 IS NOT A PORTABLE CONSTRUCT, 53)
3942: ERROR = .TRUE.
3943: C
3944: C CHECK COMPLEX, HOLLERITH, AND LOGICAL DATA-ITEMS ARE UNSIGNED
3945: C
3946: 190 IF (SIGN) GO TO 140
3947: C
3948: C CHECK COMPATIBLITY OF DATA-ITEMS WITH DECLARATORS
3949: C NN IS REPLICATION FACTOR;
3950: C
3951: 200 IBR=0
3952: DO 220 I = 1,NN
3953: IF (STACK(DATCNT+3).EQ.0) DATCNT = DATCNT + 3
3954: IF (DATCNT .GE. DECNT) GO TO 240
3955: STACK(DATCNT+3) = STACK(DATCNT+3) - 1
3956: IF (STACK(DATCNT+1).EQ.KK-1) GO TO 220
3957: IF ((STACK(DATCNT+1).NE.2 .OR. KK.NE.6) .AND.
3958: * (STACK(DATCNT+1).NE.5 .OR. KK.NE.3)) GO TO 210
3959: CALL SATT1(STACK(DATCNT+2), 1, 5)
3960: GO TO 220
3961: 210 IBR = 1
3962: 220 CONTINUE
3963: IF(IBR .EQ. 1) CALL ERROR1(52
3964: 1H WARNING - DATA-ITEM IS INCOMPATIBLE WITH DECLARATOR ,52)
3965: C
3966: C CHECK FOR "," BETWEEN DATA-ITEMS
3967: C
3968: IF (STMT(K2).NE.68) GO TO 230
3969: PSTMT = K2 + 1
3970: GO TO 110
3971: C
3972: C CHECK FOR ANOTHER SET OF DECLARATORS/DATA-ITEMS
3973: C
3974: 230 IF (STMT(K2).NE.67) GO TO 90
3975: IF (STACK(DATCNT+3).EQ.0) DATCNT = DATCNT + 3
3976: IF (DATCNT.EQ.DECNT) GO TO 250
3977: 240 CALL ERROR1(34H MISSING DECLARATORS OR DATA-ITEMS, 34)
3978: IF (DATCNT.GE.DECNT) GO TO 260
3979: 250 PSTMT = K2 + 1
3980: IF (PSTMT.EQ.NSTMT) RETURN
3981: IF (STMT(PSTMT).NE.68) GO TO 90
3982: PSTMT = PSTMT + 1
3983: IF (PSTMT.NE.NSTMT) GO TO 10
3984: GO TO 80
3985: C
3986: C FLUSH TO "/," CONSTRUCT OR END OF STATEMEMT
3987: C
3988: 260 IF (PSTMT+1.GE.NSTMT) RETURN
3989: IF (STMT(PSTMT).EQ.67 .AND. STMT(PSTMT+1).EQ.68) GO TO 270
3990: PSTMT = PSTMT + 1
3991: GO TO 260
3992: 270 PSTMT = PSTMT + 2
3993: IF (PSTMT.GE.NSTMT) RETURN
3994: GO TO 10
3995: END
3996: C XXXXXDOSTMT.f
3997: SUBROUTINE DOSTMT
3998: LOGICAL TOKLAB, ERR, SYSERR, ABORT
3999: INTEGER STMT, PSTMT
4000: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
4001: COMMON /DETECT/ ERR, SYSERR, ABORT
4002: C
4003: C ROUTINE PROCESSES A DO STMT. DOSTMT PEELS OFF THE
4004: C LABEL. CALLS DOSPEC TO GET THE <DO-SPECIFICATION>
4005: C
4006: IF (TOKLAB(1,K2,KK,.FALSE.)) GO TO 10
4007: CALL ERROR1(23H MISSING LABEL AFTER DO, 23)
4008: GO TO 20
4009: 10 IF (SYSERR) GO TO 20
4010: PSTMT = K2
4011: CALL DOSPEC(KK, K2, .FALSE.)
4012: 20 RETURN
4013: END
4014: C XXXXXEND.f
4015: SUBROUTINE END
4016: C
4017: C ROUTINE SAVES SYMBOL TABLE FOR 2ND PASS
4018: C CHECKS VARIABLE DIMENSIONING IN FCN/SUBR PU'S
4019: C CANNOT RESET DUMMY ARGS USED IN VARIABLE DIMENSIONING;
4020: C CHECKS SUCH BOUNDS FOR TYPE INTEGER
4021: C CALLS OUTSYM TO PRINT SYMBOL TABLE
4022: C CHECKS FOR UNDEFINED LABELS,MISSING DO ENDINGS,
4023: C PROPER BRANCHING THROUGHOUT PGM,
4024: C FIXES UP ALL LABELS WHOSE SCOPE IS NOT YET LIMITED
4025: C SETS USAGE OF ALL IDS TO VARIABLE IF USAGE NOT YET SET
4026: C RESETS FCN USAGE IN FCN SUBPROGRAM
4027: C
4028: INTEGER OUTUT, OUTUT2, OUTUT3, OUTUT4
4029: INTEGER PDSA, SYMLEN, BNEXT, SYMHD, STACK, DSA
4030: LOGICAL OPT, P1ERR
4031: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
4032: * OUTUT4
4033: COMMON /OPTNS/ OPT(5), P1ERR
4034: COMMON /FACTS/ NAME, NOST, ITYP, IASF
4035: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
4036: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
4037: COMMON /CEXPRS/ LSTACK, STACK(620)
4038: I = IGATT1(NAME,8)
4039: IF((I.NE.3 .AND. I.NE.10) .OR. DSA(NAME+2).EQ.0) GOTO 40
4040: C
4041: C ARGUMENT CHECKING- FOR USE IN VARIABLE DIMENSIONING OF ARRAYS
4042: C
4043: LL = 1
4044: L = DSA(NAME+2)
4045: NPAR = 0
4046: 10 IF (L.EQ.0) GO TO 40
4047: NPAR = NPAR + 1
4048: C CHECK FOR PROC ARGS TO ENTER THEIR RELATIVE POSIT
4049: C IN ARGLIST IN WD 3 OF THEIR SYMBOL TABLE ENTRY
4050: I = IGATT1(DSA(L),8)
4051: IF (I.NE.5 .AND. I.NE.6 .AND. I.NE.13) GO TO 20
4052: I = DSA(L)
4053: DSA(I+2) = NPAR
4054: GO TO 30
4055: 20 I = IGATT1(DSA(L),6)
4056: IF (I.EQ.0) GO TO 30
4057: I = IGATT1(DSA(L),7)
4058: IF (I.NE.0) GO TO 30
4059: I = IGATT1(DSA(L),5)
4060: K = DSA(L)
4061: IF (I.GT.0) CALL ERROR2(
4062: * 57H ILLEGALLY RESET DUMMY ARG USED IN VARIABLE DIMENSIONING ,
4063: * 57, DSA(K+4), 1, 1, 1)
4064: I = IGATT1(K,1)
4065: IF (MOD(I,8).NE.2) CALL ERROR2(
4066: * 47H ILLEGAL DATA TYPE USED IN ADJUSTIBLE DIMENSION, 47
4067: * , DSA(K+4), 1, 1, 1)
4068: 30 L = DSA(L+1)
4069: GO TO 10
4070: C
4071: C OUTPUT TABLE
4072: C
4073: 40 CALL DOCHK(1)
4074: C
4075: C CHECK LABELS DEFINED AND WITHIN SCOPE
4076: C
4077: I = LABHD
4078: 50 IF (I.EQ.0) GO TO 110
4079: L = IGATT1(I,2)
4080: IF (L.EQ.1) GO TO 60
4081: CALL ERROR2(17H UNDEFINED LABEL , 17, DSA(I+4), 1, 1, 1)
4082: GO TO 100
4083: 60 L = IGATT1(I,1)
4084: IF (L.NE.1) GO TO 100
4085: L = DSA(I+2)
4086: L1 = DSA(L)
4087: KK = DSA(L+1)
4088: L2 = DSA(I+1)
4089: C
4090: C L3 POINTS TO LAST ELEMENT ON CIRCULAR LIST
4091: C
4092: L3 = L2
4093: 70 IF (DSA(L2).LE.KK .AND. DSA(L2).GE.L1) GO TO 90
4094: IF (DSA(L2).LT.0) GO TO 80
4095: CALL ERROR2(15H ILLEGAL BRANCH, 15, DSA(L2), -1, 1, 1)
4096: GO TO 90
4097: 80 DSA(L2) = IABS(DSA(L2))
4098: 90 L2 = DSA(L2+1)
4099: IF (L2.NE.L3) GO TO 70
4100: 100 I = DSA(I+3)
4101: GO TO 50
4102: C
4103: C SET <ID> USAGE IF NOT YET SET
4104: C
4105: 110 I = SYMHD
4106: 120 IF (I.EQ.0) GO TO 150
4107: K = IGATT1(I,8)
4108: IF (K.NE.0) GO TO 130
4109: CALL SATT1(I, 8, 10)
4110: GO TO 140
4111: 130 IF (K.NE.6) GO TO 140
4112: IF (IGATT1(I,1)/8.NE.1) GO TO 140
4113: CALL ERROR2(33H SUBROUTINE NAME CANNOT BE TYPED , 33, DSA(I+4),
4114: * 1, 1, 1)
4115: 140 I = DSA(I+3)
4116: GO TO 120
4117: C
4118: C RESET FCN USAGE IN FCN PROGRAM UNIT
4119: C
4120: 150 I = IGATT1(NAME,8)
4121: IF (I.NE.10) GO TO 160
4122: CALL SATT1(NAME, 8, 4)
4123: I = IGATT1(NAME,5)
4124: IF (I.EQ.0) CALL ERROR1(23H FUNCTION VALUE NOT SET, 23)
4125: C
4126: C SAVE BINARY COPY OF SYMBOL TABLE
4127: C
4128: 160 IF (OPT(3) .AND. .NOT.P1ERR) GO TO 170
4129: CALL ERROR1(36H P-U NOT SAVED FOR PASS2 PROCESSING , 36)
4130: K = 3
4131: L = 1
4132: WRITE(OUTUT2) L,K,L
4133: WRITE(OUTUT3) L,K,L
4134: GOTO 180
4135: 170 K = 1
4136: L = NEXT - 1
4137: I = L + 3
4138: WRITE (OUTUT2) I, K, (DSA(I),I=1,L), NAME, SYMHD, LABHD
4139: L = 3
4140: WRITE (OUTUT3) K, L, K
4141: 180 CALL OUTSYM
4142: RETURN
4143: END
4144: C XXXXXEXPR.f
4145: INTEGER FUNCTION EXPR(LOGEX)
4146: C
4147: C LOGEX IS A DUMMY ARG , NEVER USED
4148: C FALSE IF AN ARITHMETIC EXPRESSION WAS FOUND
4149: C PRE IS PRECEDENCE TABLE, PRE(I,J) GIVES ACTION TAKEN WHEN OP I
4150: C IS ON THE STACK, OP J IN THE INPUT
4151: C CUROP IS CURRENT TOKEN TYPE
4152: C PREVOP IS PREVIOUS TOKEN TYPE (LAST ONE PROCESSED BEFORE CUROP)
4153: C STACK IS OPERAND STACK GROWING FROM TOP (1,2 ETC)
4154: C OPERATER STACK GROWING FROM BOTTOM UP(100,99 ETC)
4155: C PARENS COUNTS NESTING LEVEL OF PARENTHESES AND FUNCTION CALLS
4156: C
4157: C*****EXPRS
4158: C PT (INT) POINTER TO NEXT FREE WORD ON OPERAND STACK (GROWS
4159: C FROM STACK(1))
4160: C PB (INT) POINTER TO NEXT FREE WORD ON OPERATOR STACK (GROWS
4161: C FROM STACK(LSTACK))
4162: C AO(*,*) (INT) ARRAY GIVES TYPES OF ARITH OPERATIONS
4163: C AO(I,J) = TYPE OF (TYPE I <ARITH-OP> TYPE J)
4164: C RO(*,*) (INT) ARRAY TELLS LEGALITY OF RELATIONAL OPERATIONS
4165: C RO(I,J) = 1 IF TYPE I <RELOP> TYPEJ IS LEGAL; ELSE IS 0
4166: C EX(*,*) (INT) ARRAY GIVES TYPES OF ** OPERATION
4167: C EX(I,J) = TYPE OF (TYPE I <**> TYPE J)
4168: C
4169: INTEGER PRE(12,12), EX(4,4), AO(4,4), CUROP, PREVOP, RO(3,3),
4170: * STACK, PARENS, STMT, PSTMT, PT, PB, SYMLEN, PDSA, OUTUT,
4171: * GETTOK, IBR(14), JBR(13), ADJ(5,4), OUTUT2, DSA, OUTUT3,
4172: * OUTUT4, PREF, REF
4173: LOGICAL FLUSH, ERR, SYSERR, CALLST, DOVAR, OPT, ABORT, P1ERR
4174: LOGICAL INTEXT
4175: COMMON /DETECT/ ERR, SYSERR, ABORT
4176: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
4177: COMMON /EXPRS/ PT, PB, AO, RO, EX
4178: COMMON /CEXPRS/ LSTACK, STACK(620)
4179: COMMON /CREF/ LREF, PREF, REF(100)
4180: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
4181: * OUTUT4
4182: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
4183: COMMON /OPTNS/ OPT(5), P1ERR
4184: COMMON /FACTS/ NAME, NOST, ITYP, IASF
4185: DATA K /0/
4186: DATA PRE(1,1) /6/, PRE(1,2) /6/, PRE(1,3) /4/, PRE(1,5) /4/,
4187: * PRE(1,6) /2/, PRE(1,7) /4/, PRE(1,8) /6/, PRE(1,9) /6/,
4188: * PRE(1,10) /6/, PRE(1,4) /-1/, PRE(1,11) /6/, PRE(2,1) /-1/,
4189: * PRE(2,2) /-1/, PRE(2,3) /-1/, PRE(2,5) /-1/, PRE(2,6) /-1/,
4190: * PRE(2,7) /-1/, PRE(2,8) /-1/, PRE(2,9) /-1/, PRE(2,10) /-1/,
4191: * PRE(2,4) /-1/, PRE(2,11) /-1/, PRE(3,1) /6/, PRE(3,2) /6/,
4192: * PRE(3,3) /-1/, PRE(3,5) /4/, PRE(3,6) /2/, PRE(3,7) /6/,
4193: * PRE(3,8) /6/, PRE(3,9) /6/, PRE(3,10) /6/, PRE(3,4) /-1/,
4194: * PRE(3,11) /6/, PRE(5,1) /5/, PRE(5,2) /7/, PRE(5,3) /4/,
4195: * PRE(5,5) /4/, PRE(5,6) /2/, PRE(5,7) /4/, PRE(5,8) /-1/,
4196: * PRE(5,9) /4/, PRE(5,10) /4/, PRE(5,4) /4/, PRE(5,11) /4/,
4197: * PRE(6,1) /5/, PRE(6,2) /1/, PRE(6,3) /4/, PRE(6,5) /4/,
4198: * PRE(6,6) /2/, PRE(6,7) /4/, PRE(6,8) /3/, PRE(6,9) /4/,
4199: * PRE(6,10) /4/, PRE(6,4) /4/, PRE(6,11) /4/
4200: DATA PRE(7,1) /6/, PRE(7,2) /6/, PRE(7,3) /4/, PRE(7,5) /4/,
4201: * PRE(7,6) /2/, PRE(7,7) /6/, PRE(7,8) /6/, PRE(7,9) /6/,
4202: * PRE(7,10) /6/, PRE(7,4) /-1/, PRE(7,11) /6/, PRE(8,1) /-1/,
4203: * PRE(8,2) /-1/, PRE(8,3) /-1/, PRE(8,5) /-1/, PRE(8,6) /-1/,
4204: * PRE(8,7) /-1/, PRE(8,8) /-1/, PRE(8,9) /-1/, PRE(8,10) /-1/,
4205: * PRE(8,4) /-1/, PRE(8,11) /-1/, PRE(9,1) /5/, PRE(9,2) /6/,
4206: * PRE(9,3) /4/, PRE(9,5) /4/, PRE(9,6) /2/, PRE(9,7) /4/,
4207: * PRE(9,8) /6/, PRE(9,9) /6/, PRE(9,10) /6/, PRE(9,4) /4/,
4208: * PRE(9,11) /4/, PRE(10,1) /5/, PRE(10,2) /6/, PRE(10,3) /4/,
4209: * PRE(10,5) /4/, PRE(10,6) /2/, PRE(10,7) /4/, PRE(10,8) /6/,
4210: * PRE(10,9) /4/, PRE(10,10) /6/, PRE(10,4) /4/, PRE(10,11) /4/,
4211: * PRE(4,1) /5/, PRE(4,2) /6/, PRE(4,3) /4/, PRE(4,5) /4/,
4212: * PRE(4,6) /2/, PRE(4,7) /4/, PRE(4,8) /6/, PRE(4,9) /6/,
4213: * PRE(4,10) /6/, PRE(4,4) /-1/, PRE(4,11) /4/, PRE(11,1) /5/,
4214: * PRE(11,2) /6/, PRE(11,3) /4/, PRE(11,5) /4/, PRE(11,6) /2/,
4215: * PRE(11,7) /4/, PRE(11,8) /6/, PRE(11,9) /6/, PRE(11,10) /6/,
4216: * PRE(11,4) /-1/, PRE(11,11) /6/
4217: DATA PRE(12,1), PRE(12,3), PRE(12,7), PRE(12,11) /4*6/, PRE(12,2)
4218: * /6/, PRE(12,5) /4/, PRE(12,6) /2/, PRE(12,8) /6/, PRE(12,4),
4219: * PRE(12,9), PRE(12,10) /3*6/, PRE(1,12), PRE(2,12), PRE(3,12),
4220: * PRE(7,12), PRE(12,12) /5*-1/, PRE(5,12), PRE(6,12),
4221: * PRE(8,12), PRE(9,12), PRE(10,12), PRE(4,12), PRE(11,12) /7*4/
4222: DATA IBR(1), IBR(3), IBR(7), IBR(12) /4*1/, IBR(2) /2/, IBR(4),
4223: * IBR(11) /2*3/, IBR(9), IBR(10) /2*5/, IBR(8), IBR(5), IBR(6)
4224: * /3*4/, IBR(13) /2/, IBR(14) /4/, JBR(1), JBR(12) /2*1/,
4225: * JBR(2), JBR(3), JBR(7), JBR(9), JBR(10), JBR(11), JBR(8)
4226: * /7*2/, JBR(4) /3/, JBR(5), JBR(6) /2*4/, JBR(13) /4/
4227: DATA ADJ(1,1), ADJ(1,2), ADJ(1,3) /3*-1/, ADJ(1,4) /0/, ADJ(2,1),
4228: * ADJ(2,2) /2*0/, ADJ(2,3), ADJ(2,4) /2*-1/, ADJ(3,1) /1/,
4229: * ADJ(3,4) /0/, ADJ(3,2), ADJ(3,3) /2*-1/, ADJ(5,1) /1/,
4230: * ADJ(5,3), ADJ(5,4) /2*0/, ADJ(5,2) /-1/, ADJ(4,1), ADJ(4,3),
4231: * ADJ(4,4) /3*0/, ADJ(4,2) /-1/
4232: C
4233: C CODES IN OPERAND STACK
4234: C 0....DOUBLE PRECISION 1....REAL 2....INTEGER
4235: C 3....COMPLEX 4....LOGICAL 5....HOLLERITH
4236: C 6....PROCEDURE NAME
4237: C CODES FOR OPERATORS
4238: C 11 +,- 12 ) 13 ** 14 .NOT. 15 ( 16 FCN(
4239: C 17 /,* 18 , 19 .AND. 20 .OR. 21 .EQ. 22 UNARY -,+
4240: C
4241: PB = LSTACK
4242: PT = 1
4243: CALLST = .FALSE.
4244: PREVOP = -1
4245: CUROP = 0
4246: PARENS = 0
4247: FLUSH = .FALSE.
4248: EXPR = -1
4249: 10 IF (PSTMT.LT.NSTMT .AND. .NOT.CALLST) GO TO 110
4250: C
4251: C FINISH RECOGNITION OF EXPRESSION; POP OPERAND STACK AND RETURN
4252: C TYPE OF EXPRESSION
4253: C
4254: 20 IF (PARENS.EQ.0) GO TO 40
4255: 30 CALL ERROR1(37H UNBALANCED PARENTHESES IN EXPRESSION, 37)
4256: IF (FLUSH) GO TO 530
4257: GO TO 80
4258: 40 IF (PB.EQ.LSTACK .OR. CALLST) GO TO 60
4259: 50 CALL POP
4260: IF (ERR) GO TO 530
4261: IF (PB.LT.LSTACK) GO TO 50
4262: 60 IF (PT.NE.3) GO TO 90
4263: IF (STACK(1).EQ.0) GO TO 70
4264: I = IGATT1(STACK(1),8)
4265: IF (I.EQ.0) CALL SATT1(STACK(1), 8, 10)
4266: 70 EXPR = STACK(2)
4267: 80 PSTMT = K2
4268: ERR = .FALSE.
4269: RETURN
4270: 90 CALL ERROR1(29H INVALID SYNTAX IN EXPRESSION, 29)
4271: IF (FLUSH) GO TO 530
4272: GO TO 80
4273: 100 CALL ERROR1(31H EXPRESSION TOO LONG TO PROCESS, 31)
4274: GO TO 530
4275: C
4276: C CONTINUING PROCESSING THE EXPRESSION, IDENTIFY NEXT TOKEN,
4277: C
4278: 110 CUROP = GETTOK(PSTMT,K2)
4279: IF (ERR) GO TO 80
4280: C
4281: C SEE END OF EXPRESSION: ")" <ID> OR <LABEL>; GETTOK RETURNS
4282: C SAME CODES AS THOSE ABOVE EXCEPT 6 IS ID, 16 IS FCN( OR ARRAY ELE
4283: C
4284: IF (CUROP.NE.6 .AND. CUROP.NE.2 .AND. CUROP.NE.16 .OR.
4285: * PREVOP.NE.12) GO TO 120
4286: K2 = PSTMT
4287: GO TO 20
4288: C
4289: C CHECK FOR ADJACENT OPERATORS OR OPERANDS.
4290: C
4291: 120 IF (PREVOP.LE.6) GO TO 130
4292: I = IBR(PREVOP-10)
4293: GO TO 140
4294: 130 I = IBR(13)
4295: IF(PREVOP.EQ.(-1)) I = IBR(14)
4296: 140 IF (CUROP.LE.6) GO TO 150
4297: I2 = JBR(CUROP-10)
4298: GO TO 160
4299: 150 I2 = JBR(13)
4300: 160 IF (I.GE.3 .AND. I2.EQ.1) CUROP = 22
4301: IF (ADJ(I,I2)) 170, 190, 180
4302: 170 CALL ERROR1(44H ADJACENT PLACEMENT OF OPERATORS OR OPERANDS, 44)
4303: GO TO 530
4304: 180 CALL ERROR1(
4305: * 54H WARNING - ADJACENT PLACEMENT OF OPERATOR AND UNARY -+, 54)
4306: 190 IF (CUROP.GT.6 .AND. CUROP.NE.16) GO TO 290
4307: IF (CUROP.LT.6) GO TO 280
4308: C
4309: C PROCESS ID OR FCN( OR ARRAY ELEMENT OR ARRAY
4310: C LOOKUP SYMBOL TABLE ENTRY TO IDENTIFY ARRAYS AND TO IMPLICITLY
4311: C TYPE IDENTIFIERS IF NECESSARY.
4312: C
4313: IF (CUROP.EQ.6) GO TO 200
4314: K = LOOKUP(K2-1,.FALSE.)
4315: GO TO 210
4316: 200 K = LOOKUP(K2,.FALSE.)
4317: 210 IF (SYSERR) GO TO 530
4318: I1 = IGATT1(K,1)
4319: I2 = IGATT1(K,7)
4320: I3 = IGATT1(K,8)
4321: C
4322: C IMPLICITLY TYPE IDENTIFIERS AND FCNS
4323: C
4324: IF (I1.GT.0) GO TO 220
4325: I1 = 1
4326: IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
4327: CALL SATT1(K, 1, I1)
4328: C
4329: C SEPARATE ARRAY ELEMENT, FCN REFERENCE,ASF REF.
4330: C
4331: 220 I1 = MOD(I1,8)
4332: IF (CUROP.NE.16) GO TO 250
4333: IF (I2.EQ.0) GO TO 240
4334: C
4335: C ARRAY ELEMENT--CHECK FOR BEING IN ASF DEF AND PEEL OFF
4336: C SUBSCRIPTS, CHECKING THEIR NUMBER
4337: C
4338: IF (ITYP.NE.31) GO TO 230
4339: CALL ERROR1(39H ILLEGAL USE OF ARRAY IN ASF DEFINITION, 39)
4340: 230 CUROP = I1
4341: I1 = CUROP + 16
4342: PSTMT = K2
4343: CALL SUBS(K2, I2)
4344: IF (ERR .OR. SYSERR) GO TO 80
4345: GO TO 270
4346: C
4347: C PROCESS FCN( OR ASF( REFERENCE; CHECK USAGE TO SEE
4348: C IF IS A LEGAL FCN OR ASF NAME I.E. IF WAS USED
4349: C AS A FCN, SUBR, ASF, OR WAS IN AN EXTERNAL STMT.
4350: C
4351: 240 IF (I3.EQ.0 .OR. I3.EQ.2 .OR. I3.EQ.5 .OR. I3.EQ.6 .OR. I3.EQ.13
4352: * .OR. I3.EQ.14) GO TO 290
4353: C
4354: C ACTUAL USAGE WILL BE DETERMINED BY CODE WHICH
4355: C STORES CALL TEMPLATE
4356: C
4357: CALL ERROR1(18H ILLEGAL USE OF ID, 18)
4358: GO TO 530
4359: C
4360: C VARIABLE, ARRAY, PROCEDURE NAME
4361: C
4362: 250 IF (I2.EQ.0) GO TO 260
4363: C
4364: C ARRAY
4365: C
4366: CUROP = I1
4367: I1 = CUROP + 8
4368: IF (I3.EQ.0) CALL SATT1(K, 8, 10)
4369: GO TO 270
4370: C
4371: C VARIABLE OR PROCEDURE
4372: C LEAVE IDS USAGE UNSET
4373: C THEY WILL BE SET LATER BY APPEARING AS OPERANDS OR BY BEING
4374: C DEFINED AS FCN OR SUBROUTINE REFS BY FOLLOWING PGMS
4375: C
4376: 260 IF (I3.EQ.0) GO TO 270
4377: IF (I3.EQ.5 .OR. I3.EQ.6 .OR. I3.EQ.13) I1 = 6
4378: IF (I3.EQ.10 .OR. I1.EQ.6) GO TO 270
4379: IF (ITYP.EQ.31 .AND. I3.EQ.1 .AND. DSA(K+2).EQ.IASF) GO TO 270
4380: CALL ERROR1(36H ILLEGAL VARIABLE USED IN EXPRESSION, 36)
4381: GO TO 530
4382: C
4383: C ENTER ARRAY,ID, PROCEDURE NAME, ARRAY ELEMENT INTO OPERAND STACK
4384: C UPDATE PREVOP,PSTMT. ALSO ENTER SYMBOL TABLE INDEX FOR THESE
4385: C PREVOP = 0,1,...6 FOR OPERANDS
4386: C 11,12,...22 FOR OPERATORS
4387: C
4388: 270 IF (PT+2.GE.PB) GO TO 100
4389: STACK(PT) = K
4390: STACK(PT+1) = I1
4391: PT = PT + 2
4392: PREVOP = CUROP
4393: PSTMT = K2
4394: GO TO 10
4395: C
4396: C ARE PROCESSING A CONSTANT
4397: C
4398: 280 I1 = CUROP
4399: K = 0
4400: GO TO 270
4401: C
4402: C ARE PROCESSING AN OPERATER
4403: C PRE(I,J) CONTAINS ACTION TAKEN GIVEN OPERATOR I ON STACK
4404: C AND OPERATOR J IN INPUT
4405: C
4406: 290 KNAME = K
4407: IF (CUROP.EQ.15 .OR. CUROP.EQ.16) PARENS = PARENS + 1
4408: IF (CUROP.EQ.12) PARENS = PARENS - 1
4409: IF (PARENS.GE.0) GO TO 300
4410: FLUSH = .TRUE.
4411: GO TO 30
4412: C
4413: C CHECKS FOR LEADING UNARY +,- IN EXPRESSIONS
4414: C
4415: 300 IF (PB.EQ.LSTACK) GO TO 460
4416: I = STACK(PB+1) - 10
4417: I2 = CUROP - 10
4418: K = PRE(I,I2)
4419: 310 IF (-1.NE.K) GO TO 320
4420: FLUSH = .TRUE.
4421: GO TO 90
4422: 320 GO TO (330, 470, 520, 480, 480, 490, 510), K
4423: C
4424: C CREATE TEMPLATE FROM FCN CALL
4425: C
4426: 330 IF (ITYP.EQ.18 .AND. PARENS.EQ.0) CALLST = .TRUE.
4427: L1 = STACK(PB+2)
4428: L2 = PT - 1
4429: C
4430: C CHECK FOR NO ARGS
4431: C
4432: IF (L2.GT.L1) GO TO 340
4433: CALL ERROR1(18H MISSING ARGUMENTS, 18)
4434: GO TO 450
4435: C
4436: C CHECK FOR NOT CHANGING THROUGH SUBROUTINE CALL THE DO CONTROL
4437: C VARIABLE OF A CURRENT LOOP OR ANY ADJUSTIBLE DIMENSION DUMMY ARG
4438: C
4439: 340 DO 380 I=L1,L2,2
4440: IF (STACK(I)) 350, 380, 350
4441: 350 IF (DOVAR(STACK(I))) STACK(I+1) = STACK(I+1) + 32
4442: I1 = IGATT1(STACK(I),4)
4443: IF (I1) 380, 380, 360
4444: 360 I1 = IGATT1(STACK(I),6)
4445: IF (I1) 380, 380, 370
4446: 370 STACK(I+1) = STACK(I+1) + 64
4447: 380 CONTINUE
4448: C
4449: C CHECK FOR USE OF ID AS FCN ONCE AND AS SUBROUTINE LATER
4450: C OR VICE VERSA
4451: C
4452: I = STACK(PB+3)
4453: L = IGATT1(I,8)
4454: IF (L.EQ.2 .OR. L.EQ.5 .OR. L.EQ.6) GO TO 410
4455: IF (.NOT.INTEXT(I,L1,L2,.TRUE.)) GO TO 390
4456: C
4457: C FOUND AN INTRINSIC FCN
4458: C CHECK NOT IN A CALL STMT USED AS A SUBROUTINE
4459: C
4460: IF (CALLST) GO TO 420
4461: GO TO 450
4462: C
4463: C DEFINE FCN( USAGE IF UNSET
4464: C SET USAGE OF ID USED AS A PROC
4465: C
4466: 390 IF (CALLST) GO TO 400
4467: CALL SATT1(I, 8, 5)
4468: GO TO 430
4469: 400 CALL SATT1(I, 8, 6)
4470: GO TO 430
4471: C
4472: C CHECK USAGE OF PROC ALREADY USED IN PROGRAM UNIT
4473: C
4474: 410 IF (CALLST .AND. L.EQ.6 .OR. .NOT.CALLST .AND. (L.EQ.5 .OR.
4475: * L.EQ.2)) GO TO 430
4476: 420 CALL ERROR1(18H ILLEGAL REFERENCE, 18)
4477: GO TO 450
4478: 430 IF (.NOT.OPT(3) .OR. P1ERR) GO TO 450
4479: C
4480: C LOAD INTO STACK COUNT OF WORDS IN DESCRIPTOR, INDEX OF FCN
4481: C IN SYMBOL TABLE, STMT NO OF REFERENCE
4482: C
4483: IF (PT+3.GE.PB) GO TO 100
4484: STACK(PT) = PT - STACK(PB+2)
4485: STACK(PT+1) = STACK(PB+3)
4486: STACK(PT+2) = NOST
4487: STACK(PT+3) = 6 - IGATT1(STACK(PB+3),8)
4488: L3 = PT + 3
4489: ICOD = 2
4490: L = L2 - L1 + 5
4491: IF (L.LE.LREF) GO TO 440
4492: CALL ERROR1(44H IN EXPR, TABLE OVERFLOW OF REF, REF IGNORED, 44)
4493: GO TO 450
4494: 440 WRITE (OUTUT3) L, ICOD, (STACK(I),I=PT,L3), (STACK(I),I=L1,L2)
4495: C
4496: C FCN REF POPPED AND PROPER TYPE PUT ON OPERAND STACK
4497: C
4498: 450 PT = STACK(PB+2)
4499: I1 = IGATT1(STACK(PB+3),1)
4500: STACK(PT) = 0
4501: STACK(PT+1) = MOD(I1,8)
4502: PT = PT + 2
4503: PB = PB + 3
4504: GO TO 520
4505: C
4506: C HANDLES FIRST OPERATOR IN EXPRESSION--WILL ALWAYS BE PUSHED ONTO
4507: C OPERATOR STACK. FCN( HAS SPECIAL PUSH.
4508: C
4509: 460 IF (CUROP.NE.16) GO TO 480
4510: C
4511: C FOUND "FCN(" CONSTRUCT ; STORE 3 THINGS IN STACK
4512: C PTR TO FCN NAME IN SYMBOL TABLE; PTR TO 1ST ARGE IN STACK ;
4513: C OPERAND CODE FOR FCN(
4514: C
4515: 470 IF (PB-3.LE.PT) GO TO 100
4516: STACK(PB) = KNAME
4517: STACK(PB-1) = PT
4518: STACK(PB-2) = CUROP
4519: PB = PB - 3
4520: GO TO 520
4521: C
4522: C SIMPLE PUSH ONTO OPERATOR STACK
4523: C
4524: 480 IF (PB-1.EQ.PT) GO TO 100
4525: STACK(PB) = CUROP
4526: PB = PB - 1
4527: GO TO 520
4528: C
4529: C POP OPERATOR FROM STACK. IF STACK EMPTY, PUSH CUROP ONTO
4530: C STACK. ELSE TAKE ACTION SPECIFIED BY PRE(TOP OPERATOR,CUROP).
4531: C
4532: 490 CALL POP
4533: IF (ERR) GO TO 530
4534: IF (PB.LT.LSTACK) GO TO 500
4535: GO TO 480
4536: 500 I = STACK(PB+1) - 10
4537: K = PRE(I,CUROP-10)
4538: GO TO 310
4539: C
4540: C POP "(" WHEN HAVE FINISHED A PARENTHESIZED EXPRESSION
4541: C
4542: 510 CALL POP
4543: IF (ERR) GO TO 530
4544: C
4545: C UPDATE PREVOP,PSTMT AFTER FINISHING PROCESSING AN OPERATOR
4546: C
4547: 520 PREVOP = CUROP
4548: PSTMT = K2
4549: GO TO 10
4550: C
4551: C JOB OF THIS CODE IS TO FLISH TO END OF UNRECOGNIZABLE
4552: C EXPRESSION
4553: C
4554: 530 K2 = PSTMT
4555: ERR = .FALSE.
4556: 540 IF (K2.GE.NSTMT) GO TO 80
4557: IF (STMT(K2).EQ.65) PARENS = PARENS + 1
4558: IF (STMT(K2).NE.62) GO TO 550
4559: PARENS = PARENS - 1
4560: IF (PARENS.EQ.0) GO TO 560
4561: 550 K2 = K2 + 1
4562: GO TO 540
4563: 560 I = GETTOK(K2,I2)
4564: K2 = I2
4565: IF ((I.EQ.1 .OR. I.EQ.6) .OR. ERR) GO TO 80
4566: GO TO 540
4567: END
4568: C XXXXXINSTMT.f
4569: SUBROUTINE INSTMT(EOF, NCARD)
4570: LOGICAL ILLEG, ILHOL, ILCONT
4571: LOGICAL NEWRD, EOF, CONT, OPT, P1ERR
4572: INTEGER PSTMT, CARD(80), OUTUT, BLK, STATE, HCOUNT, STMT
4573: INTEGER SYMLEN, OUTUT2, OUTUT3, OUTUT4
4574: DIMENSION IBR(5)
4575: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
4576: COMMON /OPTNS/ OPT(5), P1ERR
4577: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
4578: * OUTUT4
4579: COMMON /FACTS/ NAME, NOST, ITYP, IASF
4580: DATA NEWRD /.TRUE./
4581: DATA IBR(1), IBR(2), IBR(3), IBR(4), IBR(5) /1H*,1HC,1H.,1H0,1H /
4582: DATA CARD(1) /1H /
4583: C
4584: C ROUTINE INPUTS AN ENTIRE FORTRAN STATEMENT. IT IS PASSED 1 CHAR
4585: C PER ELEMENT IN THE ARRAY STMT.
4586: C IN SHOULD BE CALLED AGAIN IF ERR IS TRUE.
4587: C EACH CARD IS WRITTEN OUT BEFORE BEING PARSED.
4588: C IN DEBLANKS CARDS USES THE VARIABLE STATE TO FIND
4589: C HOLLERITHS:
4590: C STATE = 0.....LOOK FOR BREAK CHAR
4591: C 1.....HAVE BREAK CHAR AND NEED DIGIT
4592: C 2.....HAVE DIGIT AND NEED DIGIT OR "H"
4593: C 3....NEED TO SKIP OVER THESE CHARS, PART OF HOLLERITH
4594: C NOTE: USE "90" AS AN END OF STMT MARKER
4595: C
4596: C NEWRD IS TRUE IF A NEW CARD IS NECESSARY; ELSE CARD IN BUFFER
4597: C IS USED. EOF IS TRUE WHEN END-OF-FILE CARD ("." IN COL 1)
4598: C IS READ NCARD GIVES # OF CARDS READ FOR THIS STMT
4599: C
4600: 10 NOST = NOST + 1
4601: STATE = 0
4602: NSTMT = 0
4603: ILLEG = .FALSE.
4604: ILCONT = .FALSE.
4605: ILHOL = .FALSE.
4606: NCARD = 0
4607: CONT = .FALSE.
4608: 20 IF (NEWRD) CALL IN(CARD, INUT)
4609: IF (CARD(1).NE.IBR(2) .OR. CARD(2).NE.IBR(1)) GO TO 40
4610: C
4611: C DEAL WITH OPTIONS CARD
4612: C
4613: IF (CONT) GO TO 50
4614: CALL INOPT(CARD)
4615: 30 IF (OPT(4)) WRITE (OUTUT,99999) CARD
4616: 99999 FORMAT (11X, 80A1)
4617: NEWRD = .TRUE.
4618: GO TO 20
4619: 40 IF (CARD(1).NE.IBR(2)) GO TO 70
4620: C
4621: C DEAL WITH COMMENT CARD
4622: C
4623: IF (.NOT.CONT) GO TO 30
4624: C
4625: C HAVE COMPLETED STMT
4626: C
4627: 50 NEWRD = .FALSE.
4628: NSTMT = NSTMT + 1
4629: STMT(NSTMT) = 90
4630: 60 IF (ILLEG) CALL ERROR1(
4631: * 40H WARNING - NON-FORTRAN CHARACTER IGNORED, 40)
4632: IF (ILHOL) CALL ERROR1(
4633: * 46H WARNING - NON-FORTRAN CHARACTER IN HOLLERITH , 46)
4634: IF (ILCONT) CALL ERROR1(
4635: * 45H WARNING - NON-FORTRAN CONTINUATION CHARACTER, 45)
4636: RETURN
4637: 70 IF (CARD(1).NE.IBR(3)) GO TO 80
4638: C
4639: C HAVE EOF
4640: C
4641: IF (CONT) GO TO 50
4642: EOF = .TRUE.
4643: GO TO 60
4644: 80 IF (CARD(6).EQ.IBR(4) .OR. CARD(6).EQ.IBR(5)) GO TO 100
4645: C
4646: C DEAL WITH CONTINUATION CARD
4647: C
4648: II = MAPCHR(CARD(6),ILCONT)
4649: IF (CONT) GO TO 110
4650: CALL ERROR1(40H WARNING - CONTINUATION NOT ALLOWED HERE, 40)
4651: C
4652: C FLUSH TO NEXT NONCONTINUATION CARD
4653: C
4654: 90 IF (OPT(4)) WRITE (OUTUT,99998) NOST, CARD
4655: 99998 FORMAT (1H , I5, 5X, 80A1)
4656: CALL IN(CARD, INUT)
4657: IF (CARD(1).NE.IBR(1) .AND. CARD(1).NE.IBR(2) .AND.
4658: * CARD(1).NE.IBR(3) .AND. CARD(6).NE.IBR(4) .AND.
4659: * CARD(6).NE.IBR(5)) GO TO 90
4660: NEWRD = .FALSE.
4661: GO TO 10
4662: C
4663: C DEAL WITH A NON-CONTINUATION CARD
4664: C
4665: 100 IF (CONT) GO TO 50
4666: C DEAL WITH A LEGAL CONTIN OR NONCONTIN CARD
4667: 110 NCARD = NCARD + 1
4668: IF (NCARD.LT.21) GO TO 120
4669: CALL ERROR1(33H WARNING - TOO MANY CONTINUATIONS, 33)
4670: GO TO 90
4671: 120 IF (OPT(4)) WRITE (OUTUT,99998) NOST, CARD
4672: NEWRD = .TRUE.
4673: BLK = 0
4674: IF (NSTMT.NE.0) GO TO 150
4675: DO 130 I=1,5
4676: NSTMT = NSTMT + 1
4677: STMT(NSTMT) = MAPCHR(CARD(I),ILLEG)
4678: 130 CONTINUE
4679: 140 I = 7
4680: GO TO 180
4681: 150 DO 160 I=1,5
4682: IF (MAPCHR(CARD(I),ILLEG).NE.69) GO TO 170
4683: 160 CONTINUE
4684: GO TO 140
4685: 170 CALL ERROR1(40H WARNING - ILLEGAL LABEL WILL BE IGNORED, 40)
4686: GO TO 140
4687: 180 IF (I.LE.72) GO TO 200
4688: C
4689: C AFTER TRANSLATE CARD CHECK FOR BLANK CARD
4690: C AND GO BACK FOR A CONTINUATION CARD
4691: C
4692: IF (BLK.NE.66) GO TO 190
4693: CALL ERROR1(33H WARNING - BLANK CARD ENCOUNTERED, 33)
4694: GO TO 90
4695: 190 CONT = .TRUE.
4696: GO TO 20
4697: 200 IF (STATE.NE.3) GO TO 210
4698: C
4699: C STATE 3 --ARE PROCESSING A HOLLERITH
4700: C
4701: HCOUNT = HCOUNT - 1
4702: KK = MAPCHR(CARD(I),ILHOL)
4703: IF (HCOUNT.EQ.0) STATE = 0
4704: GO TO 290
4705: 210 NSTMT = NSTMT + 1
4706: STMT(NSTMT) = MAPCHR(CARD(I),ILLEG)
4707: IF (STMT(NSTMT).NE.69) GO TO 220
4708: C
4709: C BLANK ENCOUNTERED AND DELETED
4710: C
4711: BLK = BLK + 1
4712: NSTMT = NSTMT - 1
4713: GO TO 290
4714: 220 KK = STATE + 1
4715: GO TO (280, 260, 230), KK
4716: C
4717: C STATE 2--SKIP OVER LEADING DIGIT STRING; LOOK FOR H
4718: C
4719: 230 IF (STMT(NSTMT).LE.9) GO TO 290
4720: IF (STMT(NSTMT).NE.37) GO TO 270
4721: C
4722: C PROCESS HOLLERITH COUNT
4723: C
4724: STMT(NSTMT) = -STMT(NSTMT)
4725: STATE = 3
4726: KK = NSTMT - KST
4727: I10 = 1
4728: HCOUNT = 0
4729: DO 240 K=1,KK
4730: JJ = NSTMT - K
4731: HCOUNT = HCOUNT + I10*STMT(JJ)
4732: I10 = I10*10
4733: 240 CONTINUE
4734: STMT(KST) = HCOUNT - 2048
4735: NSTMT = KST
4736: IF (HCOUNT.LE.0) GO TO 250
4737: GO TO 290
4738: C
4739: C AVOID THE 0H CONSTRUCTION
4740: C
4741: 250 CALL ERROR1(44H WARNING - 0H ILLEGAL HOLLERITH CONSTRUCTION, 44)
4742: STATE = 0
4743: GO TO 290
4744: C
4745: C STATE 1--LOOK FOR START OF DIGIT STRING BEFORE H
4746: C
4747: 260 IF (STMT(NSTMT).GT.9) GO TO 270
4748: STATE = 2
4749: KST = NSTMT
4750: GO TO 290
4751: C
4752: C CHECK FOR NESTED SPECIAL HEADING CHARS
4753: C
4754: 270 STATE = 0
4755: 280 IF ((STMT(NSTMT).LT.65) .OR. (STMT(NSTMT).GT.68)) GO TO 290
4756: STATE = 1
4757: 290 I = I + 1
4758: GO TO 180
4759: END
4760: C XXXXXIN.f
4761: SUBROUTINE IN(CARD, INUT)
4762: C
4763: INTEGER CARD(80)
4764: LOGICAL EOF
4765: C
4766: DATA EOF /.FALSE./
4767: DATA IDOT /1H./
4768: C
4769: IF (EOF) RETURN
4770: C
4771: C READ A CARD. PHYSICAL EOF SHOULD TRANSFER TO 100
4772: C
4773: READ (INUT,99999) CARD
4774: 99999 FORMAT (80A1)
4775: IF (CARD(1).NE.IDOT) RETURN
4776: C
4777: C HERE FOR EOF
4778: C
4779: 100 CARD(1) = IDOT
4780: EOF = .TRUE.
4781: C
4782: RETURN
4783: END
4784: C XXXXXINOPT.f
4785: SUBROUTINE INOPT(CARD)
4786: INTEGER S(8), CARD(80), J(5)
4787: LOGICAL OPT, P1ERR
4788: COMMON /OPTNS/ OPT(5), P1ERR
4789: DATA S(1), S(2), S(3), S(4), S(5), S(6), S(7) /1HS,1HR,1HP,1HL,
4790: * 1HC,1H,,1HN/, S(8) /1H /
4791: C
4792: C OPT(1) IF TRUE, PRINT SYMBOL TABLE
4793: C IF FALSE, NOSYMBOL TABLE PRINTED
4794: C OPT(2) IF TRUE, PRINT CROSS REFERENCES
4795: C IF FALSE, NO REFS PRINTED
4796: C OPT(3) IF TRUE, DO PASS 2; ELSE DO NOT
4797: C OPT(4) IF TRUE GET LISTING OF PGM; ELSE DO NOT
4798: C OPT(5) IF TRUE, COMPILE PGM AFTER PROCESSING; ELSE DO NOT
4799: C SET OPTIONS FROM CARD READ IN BY "IN"
4800: C P2 IS TURNED OFF ONLY ONCE A RUN; IT CANNOT BE TURNED ON AGAIN
4801: C OPTIONS CARD IS ONLY ACCEPTED IF SYNTAX ON CARD IS OK
4802: C SYNTAX IS C* FOLLOWED BY AT LEAST ONE OPTION OF THEFORM
4803: C OPT BLANKS, OPT N, AT LEAST ONE OF (S,R,P,L,C), OPT BLANKS
4804: C WHERE OPTIONS ARE SEPARATEDBY COMMAS
4805: C
4806: DO 10 I=1,5
4807: J(I) = 0
4808: 10 CONTINUE
4809: IP = 2
4810: 20 IP = IP + 1
4811: IF (IP.GE.73) GO TO 60
4812: C DEBLANK LEADING BLANKS
4813: IF (CARD(IP).EQ.S(8)) GO TO 20
4814: L = 1
4815: C
4816: C CHECK FOR NEGATIVE
4817: C
4818: IF (CARD(IP).NE.S(7)) GO TO 30
4819: L = -1
4820: IP = IP + 1
4821: IF (IP.GE.73) GO TO 60
4822: 30 DO 40 I=1,5
4823: IF (S(I).NE.CARD(IP)) GO TO 40
4824: J(I) = J(I) + L
4825: GO TO 50
4826: 40 CONTINUE
4827: GOTO 100
4828: C
4829: C FLUSH BLANKS TO NEXT COMMA
4830: C
4831: 50 IP = IP + 1
4832: IF (IP.GE.73) GO TO 60
4833: IF (CARD(IP).EQ.S(6)) GO TO 20
4834: IF(CARD(IP).NE.S(8)) GOTO 100
4835: GO TO 50
4836: 60 DO 90 K=1,5
4837: IF (J(K)) 70, 90, 80
4838: 70 OPT(K) = .FALSE.
4839: GO TO 90
4840: C DO NOT LET USER TURN ON PASS2 AFTER WE TURN IT OFF
4841: 80 IF (K.EQ.3 .AND. .NOT.OPT(3)) GO TO 90
4842: OPT(K) = .TRUE.
4843: 90 CONTINUE
4844: 100 RETURN
4845: END
4846: C XXXXXLIST.f
4847: SUBROUTINE LIST
4848: INTEGER STMT, PSTMT
4849: LOGICAL ERR, SYSERR, ABORT, IDLIST, IDO, FINDO
4850: LOGICAL SIO
4851: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
4852: COMMON /DETECT/ ERR, SYSERR, ABORT
4853: COMMON /LISTDO/ LPT, LEN, LS(64)
4854: C
4855: C ROUTINE PROCESSES THE LIST CONSTRUCT, USED IN I-O STMTS
4856: C LEV USED TO COUNT PARENTHESES LEVELS
4857: C
4858: SIO = .FALSE.
4859: LPT = LEN + 1
4860: FINDO = .FALSE.
4861: ICNT = 0
4862: LEV = 0
4863: 10 IF (STMT(PSTMT).NE.65) GO TO 20
4864: LEV = LEV + 1
4865: IF (LEV.GT.ICNT) ICNT = ICNT + 1
4866: PSTMT = PSTMT + 1
4867: GO TO 10
4868: 20 IF (PSTMT.GE.NSTMT) GO TO 120
4869: C
4870: C ALLOW <ID>=ARRAY,ARRAY ELE., VARIABLE
4871: C
4872: IF (.NOT.IDLIST(IDO)) GO TO 130
4873: C
4874: C FALSE RETURN SIGNIFIES ERROR IN IDLIST
4875: C TRUE RETURN SIGNIFIES NO ERROR IN IDLIST
4876: C IDO = .TRUE. MEANS , <DOSPEC> IS NEXT
4877: C IDO = .FALSE. MEANS AT END-OF-STMT, ", (" , OR ")"
4878: C
4879: C FOUND <DOSPEC> )
4880: C
4881: IF (SYSERR) GO TO 130
4882: IF (.NOT.IDO) GO TO 30
4883: PSTMT = PSTMT + 1
4884: GO TO 100
4885: C
4886: C FOUND END OF SIMPLE LIST "( <IDLIST> )"
4887: C
4888: 30 IF (STMT(PSTMT).EQ.62) GO TO 60
4889: 40 IF (PSTMT.NE.NSTMT) GO TO 50
4890: C
4891: C AT END OF STMT
4892: C
4893: IF (FINDO) CALL LDOVAR
4894: IF (LEV.NE.0) GO TO 120
4895: GO TO 130
4896: C
4897: C NEED "," AND NEW <LIST> CONSTRUCT
4898: C
4899: 50 IF (STMT(PSTMT).NE.68) GO TO 120
4900: PSTMT = PSTMT + 1
4901: GO TO 10
4902: C
4903: C MUST CHECK FOR ILLEGALLY NESTED SIMPLE LISTS
4904: C SIMPLE LIST= ( <IDLIST> )
4905: C ICNT COUNTAINS LEVEL OF LAST SIMPLE LIST WITHIN A
4906: C PARENTHESIZED EXPRESSION
4907: C
4908: 60 SIO = .TRUE.
4909: IF (LEV.EQ.0) GO TO 120
4910: PSTMT = PSTMT + 1
4911: IF (ICNT.LE.LEV) GO TO 80
4912: 70 CALL ERROR1(28H ILLEGAL PARENTHESES NESTING, 28)
4913: GO TO 130
4914: 80 LEV = LEV - 1
4915: IF (LEV) 120, 110, 90
4916: C
4917: C CHECK FOR CONSTRUCT FOLLOWING <DOSPEC>
4918: C
4919: 90 IF (STMT(PSTMT).EQ.62) GO TO 70
4920: IF (STMT(PSTMT).NE.68) GO TO 120
4921: CALL NEXTOK(PSTMT+1, K2, K)
4922: IF (K.NE.0 .OR. STMT(K2).NE.63) GO TO 40
4923: PSTMT = PSTMT + 1
4924: C
4925: C LOOK FOR DOSPEC
4926: C
4927: 100 CALL DOSPEC(0, K2, .TRUE.)
4928: IF (SYSERR .OR. ERR) GO TO 130
4929: FINDO = .TRUE.
4930: IF (STMT(K2).NE.62) GO TO 120
4931: PSTMT = K2 + 1
4932: IF (ICNT.GT.LEV) ICNT = ICNT - 1
4933: GO TO 80
4934: C
4935: C CHECK NESTED DOSPECS IN LIST
4936: C
4937: 110 IF (LEV.NE.0 .OR. .NOT.FINDO) GO TO 40
4938: FINDO = .FALSE.
4939: CALL LDOVAR
4940: LPT = LEN + 1
4941: GO TO 40
4942: 120 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
4943: IF (FINDO) CALL LDOVAR
4944: 130 IF (SIO) CALL ERROR1(34H REDUNDANT PARENTHESES ARE ILLEGAL, 34)
4945: RETURN
4946: END
4947: C XXXXXLOOKUP.f
4948: INTEGER FUNCTION LOOKUP(K1, LABEL)
4949: C
4950: C STMT(PSTMT)-STMT(K2-1) TO BE ENTERED IN DSA
4951: C LABEL IS TRUE IF SYMBOL IS A LABEL. ROUTINE
4952: C RETURNS VALUE OF INDEX OF SYMBOL IN DSA, CREATING
4953: C A NEW ENTRY ID NESESSARY. IT ENTERS SYMBOL INTO
4954: C SYMBOL OR LABEL CHAIN AND CREATES A CROSSREFERENCE
4955: C ENTRY FOR THE CURRENT STATMT NUMBER
4956: C
4957: INTEGER PSTMT, SYMLEN, DSA, HASH, L(6), LL(6)
4958: INTEGER BLANK, SYMHD, STMT, OUTUT, BNEXT, Q(70)
4959: INTEGER PDSA, OUTUT2, OUTUT3, OUTUT4
4960: LOGICAL LABEL, ERR, P1ERR, OPT, SYSERR, ABORT
4961: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
4962: * OUTUT4
4963: COMMON /DETECT/ ERR, SYSERR, ABORT
4964: COMMON /FACTS/ NAME, NOST, ITYP, IASF
4965: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
4966: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
4967: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
4968: COMMON /CHASH/ LHASH, HASH(401)
4969: COMMON /TRANS/ Q
4970: COMMON /OPTNS/ OPT(5), P1ERR
4971: DATA BLANK /1H /
4972: K = K1 - PSTMT
4973: IF (K.LE.6) GO TO 10
4974: CALL ERROR1(39H IDENTIFIER TOO LONG, WILL BE TRUNCATED, 39)
4975: K = 6
4976: 10 KK = K
4977: DO 20 I=1,K
4978: II = PSTMT + I - 1
4979: J = STMT(II) + 1
4980: LL(I) = Q(J)
4981: 20 CONTINUE
4982: DO 30 I=1,SYMLEN
4983: L(I) = BLANK
4984: 30 CONTINUE
4985: CALL S5PACK(LL, L, K)
4986: C
4987: C HAVE PACKED SYMBOL;NOW CALCULATE HASH
4988: C HASH IS(PRODUCT OF FIRST AND THIRD LETTERS PLUS SECOND) MOD 257
4989: C
4990: IF (KK.LT.3) GO TO 50
4991: IHASHS = STMT(PSTMT)*STMT(PSTMT+2) + STMT(PSTMT+1)
4992: 40 IHASHS = MOD(IHASHS,LHASH)
4993: ISAVE = IHASHS
4994: IHASH = IHASHS + 1
4995: GO TO 80
4996: 50 IHASHS = STMT(PSTMT)
4997: GO TO (60, 70), KK
4998: 60 IHASHS = IHASHS*69 + 69
4999: GO TO 40
5000: 70 IHASHS = IHASHS*69 + STMT(PSTMT+1)
5001: GO TO 40
5002: 80 IF (HASH(IHASH).EQ.0) GO TO 140
5003: C
5004: C IF TABLE EMPTY, CREATE ENTRY, SEND BACK INDEX OF FIRST WORD IN DSA
5005: C ELSE COMPARE SYMBOL TO ID AND RETURN INDEX OF PROPER ENTRY IN HASH
5006: C TABLE AFTER RESOLVING COLLISION
5007: C
5008: DO 90 J=1,SYMLEN
5009: II = HASH(IHASH) + 3 + J
5010: IF (L(J).NE.DSA(II)) GO TO 100
5011: 90 CONTINUE
5012: LOOKUP = HASH(IHASH)
5013: IF (DSA(LOOKUP+1)) 190, 190, 200
5014: C
5015: C RESOLVE CONFLICTS BY LINEAR CONGRUENCE
5016: C
5017: 100 IHASHS = MOD(IHASHS+1,LHASH)
5018: IF (IHASHS.EQ.ISAVE) GO TO 110
5019: IHASH = IHASHS + 1
5020: GO TO 80
5021: 110 CALL ERROR1(34H IN LOOKUP, TABLE OVERFLOW OF HASH, 34)
5022: 120 SYSERR = .TRUE.
5023: RETURN
5024: 130 CALL ERROR1(33H IN LOOKUP, TABLE OVERFLOW OF DSA, 33)
5025: GO TO 120
5026: C
5027: C CREATE NEW SYMBOL TABLE ENTRY; ZERO ITS CROSSREF TAIL PTR
5028: C
5029: 140 HASH(IHASH) = NEXT
5030: IF (NEXT+6+SYMLEN.GE.BNEXT) GO TO 130
5031: LOOKUP = NEXT
5032: C
5033: C*****DSA
5034: C 1ST WORD..... ATTRIBUTE WORD
5035: C FIELD 1
5036: C
5037: C BITS 0-2*TYPE (FOR SYMBOL) 0 DOUBLE PRECISION, 1 REAL, 2 INT,
5038: C 3 COMPLEX,4 LOGICAL, 5 HOLLERITH
5039: C TYPE (FOR LABEL) 1 EXECUTABLE STMT, 2 NONEXEC. STMT,
5040: C 3 FORMAT STMT
5041: C BIT 3****EXPLICITLY TYPED 1, IMPLICITLY 0
5042: C FIELD 2
5043: C BIT 4****(FOR SYMBOL) IN COMMON 1, NOT IN COMMON 0
5044: C (FOR LABEL) DEFINED 1, REFERENCED 0
5045: C (FOR COMMON-NAME) INITIALIZED IN BLOCK DATA SUBPGM
5046: C FIELD 3
5047: C BIT 5****EQUIVALENCED 1
5048: C FIELD 4
5049: C BIT 6****DUMMY SUBROUTINE/FUNCTION ARGUMENT 1
5050: C FIELD 5
5051: C BIT 7****VALUE SET BY P.U. 1
5052: C FIELD 6
5053: C BIT 8****VARIABLE USED AS DIMENSION IN VARIABLY DIMENSIONED ARRAY
5054: C FIELD 7
5055: C BIT 9-10*SCALAR 0, NUMBER OF ARRAY BOUNDS 1,2,3
5056: C FIELD 8
5057: C BITS 11-15**USAGE--UNSET 0, ASF ARG 1, ASF FCN 2, CURRENT P. U.=
5058: C SUBR 3, CURRENT P.U.=FCN 4, EXTERNAL FCN 5, EXTERNAL SUBR 6,
5059: C COMMON-NAME 7, ASSIGN/GOTO VARIABLE 8,LABEL 9, VARIABLE 10,
5060: C CURRENT P.U.=BLOCK DATA 11, CURRENT P.U.=MAIN 12, EXTERNAL ENTITY
5061: C 13, INTRINSIC FCN 14
5062: C BITS 5-8 ARE 0 IF ENTRY CORRESPONDS TO ENTITY WITHOUT THE
5063: C ATTRIBUTE MENTIONED
5064: C
5065: C 2ND WD..... XREF LIST TAIL POINTER
5066: C 3D WORD.....EXTRA INFO POINTER
5067: C
5068: C FOR A VARIABLE, 3D WORD POINTS TO A 2 WORD BLOCK, FIRST WORD
5069: C CONTAINING STORAGE UNIT LENGTH OF THE VARIABLE (-1 IF VARIABLY
5070: C DIMENSIONED ARRAY); SECOND WORD CONTAINING INDEX OF COMMON
5071: C ENTRY IN DSA;
5072: C FOR A LABEL, 3D WORD CONTAINS POINTER TO 2 WORD BLOCK ; AFTER
5073: C LABEL DEFINED, FIRST WORD CONTAINS STMT NUMBER OF FIRST STMT
5074: C IN CURRENT DO NESTING LEVEL; SECOND WORD CONTAINS NEGATIVE THE
5075: C NESTING LEVEL; WHEN END OF THIS NESTING LEVEL IS ENCOUNTERED
5076: C ALL 2ND WORDS FOR THAT LEVEL ARE UPDATED TO CONTAIN STMT NUMBER
5077: C OF LAST STMT AT THAT NESTING LEVEL;
5078: C FOR A COMMON-NAME, 3D WORD POINTS TO HEAD OF LINEAR LINKED LIST
5079: C OF INDICES OF DSA ENTRIES FOR ORDERED ELEMENTS IN THAT COMMON;
5080: C FOR THE CURRENT P.U. IF ITS A SUBR OR FCN, 3D WORD CONTAINS
5081: C A LINEAR LINKED LIST OF INDICES IN DSA OF ENTRIES FOR ORDERED
5082: C DUMMIES OF THAT SUBPGM;
5083: C
5084: C 4TH WORD..... CHAIN POINTER TO ENTRY IN DSA FOR LAST SYMBOL
5085: C OR LABEL FOR WHICH A NEW ENTRY WAS CREATED
5086: C 5-7TH WORD.....PACKED CHARACTERS OF SYMBOL OR LABEL
5087: C
5088: J = NEXT + 2
5089: DO 150 I=NEXT,J
5090: DSA(I) = 0
5091: 150 CONTINUE
5092: J = J + 1
5093: DO 160 I=1,SYMLEN
5094: II = I + J
5095: DSA(II) = L(I)
5096: 160 CONTINUE
5097: C
5098: C SETONE OF THE CHAIN POINTERS TO PUT THIS SYMBOL ON CHAIN
5099: C
5100: IF (LABEL) GO TO 170
5101: DSA(J) = SYMHD
5102: SYMHD = NEXT
5103: GO TO 180
5104: 170 DSA(J) = LABHD
5105: LABHD = NEXT
5106: 180 NEXT = 4 + SYMLEN + NEXT
5107: C
5108: C BEGINNEW XREF LIST
5109: C
5110: 190 IF (.NOT.LABEL .AND. .NOT.OPT(2)) GO TO 210
5111: IF (NEXT+2.GE.BNEXT) GO TO 130
5112: DSA(BNEXT-1) = NOST
5113: DSA(LOOKUP+1) = BNEXT - 1
5114: DSA(BNEXT) = BNEXT - 1
5115: BNEXT = BNEXT - 2
5116: GO TO 210
5117: C
5118: C XREF LIST UPDATE; CHECK TO SEE IF STATEMENT NUMBER IS ALREADY
5119: C THERE
5120: C
5121: 200 IF (.NOT.LABEL .AND. .NOT.OPT(2)) GO TO 210
5122: IF (NEXT+2.GE.BNEXT) GO TO 130
5123: J = DSA(LOOKUP+1)
5124: IF (DSA(J).EQ.NOST) GO TO 210
5125: DSA(BNEXT) = DSA(J+1)
5126: DSA(J+1) = BNEXT - 1
5127: DSA(LOOKUP+1) = BNEXT - 1
5128: DSA(BNEXT-1) = NOST
5129: BNEXT = BNEXT - 2
5130: 210 RETURN
5131: END
5132: C XXXXXMAPCHR.f
5133: INTEGER FUNCTION MAPCHR(CHAR, ERR)
5134: C
5135: C MAPCHR RETURNS THE INTERNAL CODE OF THE CHARACTER CHAR
5136: C
5137: INTEGER CHAR
5138: INTEGER LET(46), ICODE(46)
5139: LOGICAL ERR
5140: C
5141: DATA LET(7), ICODE(7) /1H0,0/
5142: DATA LET(16), ICODE(16) /1H1,1/
5143: DATA LET(22), ICODE(22) /1H2,2/
5144: DATA LET(24), ICODE(24) /1H3,3/
5145: DATA LET(26), ICODE(26) /1H4,4/
5146: DATA LET(28), ICODE(28) /1H5,5/
5147: DATA LET(25), ICODE(25) /1H6,6/
5148: DATA LET(38), ICODE(38) /1H7,7/
5149: DATA LET(34), ICODE(34) /1H8,8/
5150: DATA LET(32), ICODE(32) /1H9,9/
5151: DATA LET(3), ICODE(3) /1HA,30/
5152: DATA LET(36), ICODE(36) /1HB,31/
5153: DATA LET(14), ICODE(14) /1HC,32/
5154: DATA LET(6), ICODE(6) /1HD,33/
5155: DATA LET(5), ICODE(5) /1HE,34/
5156: DATA LET(33), ICODE(33) /1HF,35/
5157: DATA LET(27), ICODE(27) /1HG,36/
5158: DATA LET(37), ICODE(37) /1HH,37/
5159: DATA LET(8), ICODE(8) /1HI,38/
5160: DATA LET(44), ICODE(44) /1HJ,39/
5161: DATA LET(46), ICODE(46) /1HK,40/
5162: DATA LET(13), ICODE(13) /1HL,41/
5163: DATA LET(12), ICODE(12) /1HM,42/
5164: DATA LET(4), ICODE(4) /1HN,43/
5165: DATA LET(2), ICODE(2) /1HO,44/
5166: DATA LET(18), ICODE(18) /1HP,45/
5167: DATA LET(43), ICODE(43) /1HQ,46/
5168: DATA LET(11), ICODE(11) /1HR,47/
5169: DATA LET(15), ICODE(15) /1HS,48/
5170: DATA LET(10), ICODE(10) /1HT,49/
5171: DATA LET(30), ICODE(30) /1HU,50/
5172: DATA LET(42), ICODE(42) /1HV,51/
5173: DATA LET(45), ICODE(45) /1HW,52/
5174: DATA LET(39), ICODE(39) /1HX,53/
5175: DATA LET(35), ICODE(35) /1HY,54/
5176: DATA LET(41), ICODE(41) /1HZ,55/
5177: DATA LET(31), ICODE(31) /1H+,60/
5178: DATA LET(29), ICODE(29) /1H-,61/
5179: DATA LET(19), ICODE(19) /1H),62/
5180: DATA LET(23), ICODE(23) /1H=,63/
5181: DATA LET(17), ICODE(17) /1H.,64/
5182: DATA LET(20), ICODE(20) /1H(,65/
5183: DATA LET(21), ICODE(21) /1H*,66/
5184: DATA LET(40), ICODE(40) /1H/,67/
5185: DATA LET(9), ICODE(9) /1H,,68/
5186: DATA LET(1), ICODE(1) /1H ,69/
5187: C
5188: DO 10 I=1,46
5189: IF (CHAR.EQ.LET(I)) GO TO 20
5190: 10 CONTINUE
5191: C
5192: C UNKNOWN, RETURN BLANK AND SET ERR = .TRUE.
5193: C
5194: MAPCHR = 69
5195: ERR = .TRUE.
5196: RETURN
5197: C
5198: C KNOWN, RETURN INTERNAL CODE, LEAVE ERR ALONE
5199: C
5200: 20 MAPCHR = ICODE(I)
5201: RETURN
5202: END
5203: C XXXXXPU.f
5204: SUBROUTINE PU
5205: INTEGER STMT, PSTMT, SYMLEN, OUTUT, SYMHD, BNEXT, HASH, DSA
5206: INTEGER STACK, DOPT, DOLIST, PDSA, OUTUT2, OUTUT3, OUTUT4
5207: INTEGER Q(70)
5208: LOGICAL ERR, BLKD, SYSERR, LOGIF1, LOGIF2, LAB, EOF
5209: LOGICAL NEW, TOKLAB, EXECUT, P1ERR, OPT, RET, ABORT
5210: LOGICAL P2, QBR
5211: COMMON /OPTNS/ OPT(5), P1ERR
5212: COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
5213: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
5214: * OUTUT4
5215: COMMON /CEXPRS/ LSTACK, STACK(620)
5216: COMMON /FACTS/ NAME, NOST, ITYP, IASF
5217: COMMON /DETECT/ ERR, SYSERR, ABORT
5218: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
5219: COMMON /CHASH/ LHASH, HASH(401)
5220: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
5221: COMMON /DOS/ DOPT, LDO, DOLIST(192)
5222: COMMON /TRANS/ Q
5223: COMMON /PASS/ P2, QBR
5224: C
5225: C ROUTINE HANDLES CYCLING THROUGH STMTS OF A PGM UNIT. NEW IS
5226: C USED TO HANDLE P.U.'S WITHOUT END STMTS. FLUSHING OF STMTS
5227: C TO NEXT END OR HEADING STMT IS PROVIDED FOR ILLEGAL SEQUENCING
5228: C LOGIF1,LOGIF2 ARE USED TO CYCLE THROUGH LOGICAL IF STMTS
5229: C EOF OF INPUT FILE
5230: C ERR USED AS ERROR DIAGNOSTIC INDICATOR
5231: C NEWRD, NEW USED TO CONTROL INPUT
5232: C
5233: EOF = .FALSE.
5234: NEW = .FALSE.
5235: C
5236: C INTER-PROGRAM INITIALIZATION
5237: C NOST CONTAINS CURRENT STATEMENT NUMBER
5238: C ITYP CONTAINS TYPE OF STMT
5239: C BLKD IS TRUE FOR BLOCK DATA PGM UNIT, ELSE FALSE
5240: C EXECUT IS TRUE FOR AT LEAST ONE EXECUTABLE STMT IN
5241: C PROGRAM UNIT EXISTING
5242: C NAME CONTAINS INDEX IN DSA OF PGM UNIT NAME
5243: C P1ERR USED TO CONTROL WRITING OF SYMBOL TABLE FOR
5244: C PASS 2
5245: C RET IS TRUE IF RETURN STMT OCCURS IN P.U. ELSE FALSE
5246: C NEXT, BNEXT POINT INTO DSA
5247: C LABHD POINTS TO HEAD OF LABELS LIST IN DSA
5248: C SYMHD POINTS TO HEAD OF SYMBOLS LIST IN DSA
5249: C KGP, IGP USED TO CHECK STMT SEQUENCING
5250: C DOPT,DOLIST USED TO CHECK DO LOOP NESTING
5251: C
5252: 10 NOST = 0
5253: ITYP = 0
5254: LTYP = 0
5255: BLKD = .FALSE.
5256: EXECUT = .FALSE.
5257: NAME = 0
5258: P1ERR = .FALSE.
5259: RET = .FALSE.
5260: NEXT = 1
5261: BNEXT = LDSA
5262: LABHD = 0
5263: SYMHD = 0
5264: KGP = 0
5265: DOPT = 1
5266: DOLIST(1) = 1
5267: DO 20 I=2,6
5268: DOLIST(I) = 0
5269: 20 CONTINUE
5270: DO 30 I=1,LHASH
5271: HASH(I) = 0
5272: 30 CONTINUE
5273: C
5274: C DONT GOTO NEW PAGE IF NOT PRODUCING LISTING
5275: C
5276: IF (.NOT.OPT(4)) GO TO 40
5277: WRITE (OUTUT,99999)
5278: 99999 FORMAT (32H1PFORT VERIFIER 1/12/79 VERSION //)
5279: C
5280: C INPUT NEW STMT; RETURN WHEN HIT EOF STMT
5281: C FIND LABELS
5282: C
5283: C HEADING STMT INADVERTENTLY READ BECAUSE OF MISSING END
5284: C
5285: 40 IF (.NOT.NEW) GO TO 70
5286: NEW = .FALSE.
5287: NOST = 1
5288: IF (.NOT.OPT(4)) GO TO 80
5289: K = NSTMT - 1
5290: DO 50 I=1,K
5291: II = STMT(I) + 1
5292: STACK(I) = Q(II)
5293: 50 CONTINUE
5294: WRITE (OUTUT,99998) NOST, (STACK(I),I=1,K)
5295: 99998 FORMAT (1H , I5, 5X, 80A1)
5296: GO TO 80
5297: 60 CALL ERROR1(20H UNRECOGNIZABLE STMT, 20)
5298: ERR = .FALSE.
5299: 70 CALL INSTMT(EOF, NCARD)
5300: IF (EOF) GO TO 400
5301: 80 LAB = .FALSE.
5302: C
5303: C TYPST TYPES THE CURRENT STAMT
5304: C ITYP IS NO 1-30 TELLING STMT WE HAVE
5305: C KGP IS LEVEL NO 0-6 OF STMT.
5306: C ICNT IS NO OF CHARACTERS IN STMT IE KI(ITYP)
5307: C
5308: PSTMT = 6
5309: CALL TYPST(ITYP, IGP, ICNT)
5310: IF (ERR) GO TO 60
5311: PSTMT = 6 + ICNT
5312: IF (ITYP.GE.6) GO TO 100
5313: I = ITYP - 1
5314: CALL TYPST(ITYP, II, K2)
5315: IF (ITYP.NE.10) GO TO 90
5316: PSTMT = PSTMT + K2
5317: IGP = II
5318: GO TO 110
5319: 90 ITYP = I + 1
5320: 100 I = -1
5321: 110 II = 1
5322: IF (ITYP.LT.14 .OR. ITYP.EQ.28 .OR. ITYP.EQ.31) II = 2
5323: IF (ITYP.EQ.29) II = 3
5324: KEEP = PSTMT
5325: PSTMT = 1
5326: IF (TOKLAB(II,K2,KK,.TRUE.)) LAB = .TRUE.
5327: IF (SYSERR) GO TO 450
5328: C
5329: C CHECK FOR MAIN PROGRAM OR OTHER HEADING STMTS
5330: C
5331: IF (NAME) 140, 120, 140
5332: 120 IF (IGP) 130, 150, 130
5333: 130 CALL SETNAM(12)
5334: GO TO 150
5335: 140 IF (IGP.EQ.0) GO TO 490
5336: C
5337: C CHECK SEQUENCING OF STMTS
5338: C
5339: 150 IF (BLKD .AND. IGP.GT.3 .AND. ITYP.NE.28) GO TO 160
5340: IF (IGP.GE.KGP) GO TO 170
5341: CALL ERROR1(24H ILLEGAL STMT SEQUENCING, 24)
5342: GO TO 450
5343: 160 CALL ERROR1(32H ILLEGAL STMTS IN BLOCK DATA PGM, 32)
5344: GO TO 450
5345: C
5346: C CHECK FOR FIRST ASF DEFN OR EXECUTABLE STMT.
5347: C TO RESET USAGE OF FCN SUBPGM NAME IN SYMBOL TABLE
5348: C
5349: 170 IF (EXECUT .OR. IGP.LT.4) GO TO 180
5350: EXECUT = .TRUE.
5351: K = IGATT1(NAME,8)
5352: IF (K.EQ.4) CALL SATT1(NAME, 8, 10)
5353: 180 PSTMT = KEEP
5354: LOGIF2 = .FALSE.
5355: C
5356: C VALUES OF ITYP
5357: C 1-5 TYPE STMTS: 1 DP, 2 REAL, 3 INT, 4 COMP, 5 LOG
5358: C 6-8 OTHER SPECIFICATION STMTS: 6 EXTERNAL, 7 DIMENSION
5359: C 8 COMMON
5360: C 9-11 HEADING STMTS: 9 SUBROUTINE, 10 FUNCTION, 11 BLOCK DATA
5361: C 12 EQUIVALENCE
5362: C 13 DATA
5363: C 14-27,30,32 EXECUTABLE STMTS: 14 ASSIGN, 15 GOTO, 16 RETURN,
5364: C 17 CONTINUE, 18 CALL, 19 STOP, 20 IF, 21 DO, 22 PAUSE,
5365: C 23 READ, 24 WRITE, 25 REWIND, 26 ENDFILE, 27 BACKSPACE, 30
5366: C ASSIGNMENT, 32 LOGICAL IF
5367: C 28 END
5368: C 29 FORMAT
5369: C 31 ASF DEFN
5370: C CLASS CODES
5371: C 0-HEADING STMTS
5372: C 1-SPECIFICATION STMTS (INCLUDING TYPE STMTS)
5373: C 2-EQUIVALENCE
5374: C 3-DATA
5375: C 4-ASF DEF
5376: C 5-EXECUTABLE STMTS AND FORMAT STMTS
5377: C 6-END STMT
5378: C
5379: 190 GO TO (200, 200, 200, 200, 200, 210, 220, 250, 230, 230, 240,
5380: * 270, 260, 350, 330, 360, 380, 370, 380, 300, 280, 340, 340,
5381: * 340, 340, 340, 340, 410, 390, 290), ITYP
5382: C
5383: C TYPE STMTS (SYSERR)
5384: C
5385: 200 CALL TYPE
5386: GO TO 430
5387: C
5388: C EXTERNAL STMT (SYSERR)
5389: C
5390: 210 CALL EXTERN
5391: GO TO 430
5392: C
5393: C DIMENSION STMT(SYSERR)
5394: C
5395: 220 CALL DIMENS
5396: GO TO 430
5397: C
5398: C SUBR/FCN DEFNS (SYSERR)
5399: C
5400: 230 CALL SUBFCN(I)
5401: GO TO 430
5402: C
5403: C BLOCK DATA STMT (SYSERR)
5404: C
5405: 240 CALL SETNAM(11)
5406: BLKD = .TRUE.
5407: GO TO 430
5408: C
5409: C COMMON STMT
5410: C
5411: 250 CALL COMMON
5412: GO TO 430
5413: 260 CALL DATA
5414: GO TO 430
5415: 270 CALL EQUIV
5416: GO TO 430
5417: 280 CALL DOSTMT
5418: GO TO 430
5419: 290 CALL ASSASF(IGP)
5420: IF (IGP.EQ.4 .AND. LOGIF2) GO TO 320
5421: GO TO 430
5422: C
5423: C IF STMTS
5424: C
5425: 300 CALL IFS(LOGIF1)
5426: C
5427: C FOUND AN ARITH. IF
5428: C
5429: IF (.NOT.LOGIF1) GO TO 430
5430: C
5431: C FOUND LOGICAL IF WITHIN LOGICAL IF
5432: C
5433: IF (LOGIF1 .AND. LOGIF2) GO TO 320
5434: C
5435: C FOUND A LOGICAL IF; MUS PROCESS REST OFSTMT
5436: C
5437: LOGIF2 = .TRUE.
5438: CALL TYPST(ITYP, K, K2)
5439: IF (.NOT.ERR) GO TO 310
5440: CALL ERROR1(20H UNRECOGNIZABLE STMT, 20)
5441: GO TO 430
5442: 310 IF (K.NE.4 .AND. K.NE.5 .OR. ITYP.EQ.21 .OR. ITYP.EQ.29) GO TO 320
5443: PSTMT = PSTMT + K2
5444: GO TO 190
5445: 320 CALL ERROR1(27H ILLEGAL STMT IN LOGICAL IF, 27)
5446: GO TO 430
5447: C
5448: C GOTO STMTS
5449: C
5450: 330 CALL GOTO
5451: GO TO 430
5452: C
5453: C I-O STMTS
5454: C
5455: 340 CALL IO
5456: GO TO 430
5457: C
5458: C ASSIGN STMT
5459: C
5460: 350 CALL ASSIGN
5461: GO TO 430
5462: C
5463: C RETURN CANNOT APPEAR IN MAIN PGM
5464: C
5465: 360 I = IGATT1(NAME,8)
5466: IF (I.EQ.12) CALL ERROR1(
5467: * 44H RETURN STATEMENT MAY NOT APPEAR IN MAIN PGM, 44)
5468: RET = .TRUE.
5469: GO TO 380
5470: C
5471: C CALL STMT
5472: C
5473: 370 CALL CALLS
5474: GO TO 430
5475: C
5476: C CHECK FOR EXTRANEOUS INFO AFTER STOP AND CONTINUE STMTS
5477: C
5478: 380 IF (PSTMT.NE.NSTMT) CALL ERROR1(
5479: * 34H EXTRANEOUS INFO AFTER END OF STMT, 34)
5480: GO TO 430
5481: C
5482: C FORMAT
5483: C
5484: 390 IF (.NOT.LAB) CALL ERROR1(26H MISSING FORMAT STMT LABEL, 26)
5485: CALL FORMAT
5486: GO TO 430
5487: C
5488: C CODE TO HANDLE END-OF-FILE WITHOUT AN END STMT
5489: C
5490: 400 IF (ITYP.EQ.28 .OR. ITYP.EQ.0) GO TO 500
5491: CALL ERROR1(37H WARNING - MISSING END STMT SIMULATED, 37)
5492: LAB = .FALSE.
5493: ITYP = 28
5494: 410 CALL END
5495: C
5496: C CHECK FOR NO CONTINUATION
5497: C
5498: IF (NCARD.GT.1) CALL ERROR1(34H END LINE CANNOT HAVE CONTINUATION,
5499: * 34)
5500: C
5501: C CHECK FOR ENDING ON A GOTO,ARITH IF, STOP OR RETURN
5502: C
5503: IF ((LTYP.EQ.16 .OR. LTYP.EQ.15 .OR. LTYP.EQ.19 .OR. LTYP.EQ.20)
5504: * .OR. BLKD) GO TO 420
5505: CALL ERROR1(29H ILLEGAL LAST EXECUTABLE STMT, 29)
5506: C
5507: C CHECK THERE HAVE BEEN EXECUTABLE STMTS
5508: C CHECK FOR A RETURN STMT IF NECESSARY
5509: C
5510: 420 IF (KGP.NE.5 .AND. .NOT.BLKD) CALL ERROR1(
5511: * 42H ILLEGAL PROGRAM UNIT, NO EXECUTABLE STMTS, 42)
5512: I = IGATT1(NAME,8)
5513: IF (I.EQ.11 .OR. I.EQ.12 .OR. RET) GO TO 430
5514: CALL ERROR1(36H MISSING RETURN STMT IN PROGRAM UNIT, 36)
5515: C
5516: C CHECK STMT LABELS FOR DOENDINGS, UPDATE KGP, CHECK TABLE SIZE
5517: C CHECK FOR CANCELLING SAVING OF SYMBOL TABLE FOR PASS2
5518: C DUE TO ERRORS IN THIS PGM UNIT
5519: C
5520: 430 KGP = IGP
5521: IF (ITYP.NE.29) LTYP = ITYP
5522: IF (LOGIF2) LTYP = 32
5523: IF (SYSERR) GO TO 450
5524: IF (.NOT.LAB) GO TO 440
5525: CALL DOCHK(KK)
5526: IF (ITYP.LT.14 .OR. ITYP.EQ.28 .OR. ITYP.EQ.31) CALL ERROR1(
5527: * 37H WARNING - LABELED NONEXECUTABLE STMT, 37)
5528: 440 IF (EOF) GO TO 500
5529: ERR = .FALSE.
5530: IF (ITYP.EQ.28) GO TO 10
5531: GO TO 70
5532: C
5533: C FLUSH CODE TO NEXT HEADR OR END SMT
5534: C
5535: 450 CALL ERROR1(44H CODE FLUSHED UNTIL NEXT END OR HEADING STMT, 44)
5536: P1ERR = .TRUE.
5537: IF (SYSERR) SYSERR = .FALSE.
5538: LAB = .FALSE.
5539: 460 CALL INSTMT(EOF, NCARD)
5540: IF (EOF) GO TO 500
5541: PSTMT = 6
5542: CALL TYPST(ITYP, IGP, ICNT)
5543: IF (.NOT.ERR) GO TO 470
5544: ERR = .FALSE.
5545: GO TO 460
5546: 470 IF (ITYP.EQ.28) GO TO 410
5547: IF (ITYP.GT.5) GO TO 480
5548: PSTMT = PSTMT + ICNT
5549: CALL TYPST(ITYP, IGP, ICNT)
5550: IF (ERR) ERR = .FALSE.
5551: IF (ITYP.EQ.10) GO TO 490
5552: GO TO 460
5553: 480 IF (ITYP.LT.9 .OR. ITYP.GT.11) GO TO 460
5554: C
5555: C HAVE FOUND A HEADER STMT; SIMULATE AN END STMT
5556: C
5557: 490 NEW = .TRUE.
5558: CALL ERROR1(37H WARNING - MISSING END STMT SIMULATED, 37)
5559: ITYP = 28
5560: LAB = .FALSE.
5561: GO TO 410
5562: C
5563: C PUT ENDING MARKER ON THE DATA FOR PASS2
5564: C
5565: 500 I = 1
5566: II = 4
5567: WRITE (OUTUT3) I, II, I
5568: WRITE (OUTUT2) I, II, I
5569: RETURN
5570: END
5571: C XXXXXCOMCHK.f
5572: SUBROUTINE COMCHK(MAIN)
5573: INTEGER TEMP(1), PLAT, STAR, PCOM, COM, PNODE, SYMLEN
5574: INTEGER ZERO(1)
5575: COMMON /COMS/ LCOM, PCOM, COM(300)
5576: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
5577: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
5578: COMMON /HEAD/ LNODE, PNODE, NODE(500)
5579: COMMON /SCR2/ LNN, NN(500)
5580: DATA STAR /1H*/
5581: DATA ZERO(1) /0/
5582: C
5583: C ALGORITHM TO CHECK FOR LEGAL USE OF COMMON IN PGM UNITS
5584: C NODE(MAIN) POINTS TO SUPEROOT ENTRY IN LAT
5585: C
5586: IF (PCOM.LE.0) GO TO 130
5587: LK = 1
5588: 10 IF (LK.GE.PCOM-1) GO TO 130
5589: C
5590: C CHECK COMMON ISNT BLANK COMMON
5591: C
5592: CALL S5UNPK(COM(LK), TEMP, 1)
5593: IF (TEMP(1).EQ.STAR) GO TO 120
5594: C
5595: C CHECK THAT COMMON BLOCK NOT IN BLOCK DATA PGM
5596: C NEED NOT CHECK THE COMMON
5597: C
5598: K = LK + SYMLEN + 1
5599: IF (COM(K).EQ.1) GO TO 120
5600: C
5601: C NEED ALGORITHM TO CHECK OUT THIS COMMON
5602: C
5603: L = PNODE - 1
5604: DO 20 K=1,L
5605: NN(K) = 0
5606: IF (NODE(K).LT.0) NN(K) = 1
5607: 20 CONTINUE
5608: ICNT = 0
5609: NN(MAIN) = 2
5610: C
5611: C SEARCH FOR A 2 NODE
5612: C
5613: 30 L = PNODE - 1
5614: DO 40 K=1,L
5615: IF (NN(K).EQ.2) GO TO 50
5616: 40 CONTINUE
5617: GO TO 120
5618: C
5619: C FOUND A 2 NODE; CHANGE TO 1 TO SHOW HAVE VISITED IT;
5620: C IF SUBPGM CONTAINS COMMON IN QUESTION INCREMENT COUNT;
5621: C IF COUNT> 1 ERROR IN USAGE
5622: C IF SUBPGM DOESN'T CONTAIN COMMON, MARK HIS DESC 2 IF THEY ARE 0.
5623: C
5624: 50 NN(K) = 1
5625: LBR = NODE(K)
5626: L = NODE(K) + SYMLEN + 2
5627: L = LAT(L)
5628: 60 IF (L.EQ.0) GO TO 90
5629: IF (LAT(L).NE.LK) GO TO 80
5630: C
5631: C FOUND COMMON LK AT THIS NODE
5632: C MARK NODE TO A 3
5633: C
5634: NN(K) = 3
5635: ICNT = ICNT + 1
5636: IF (ICNT.LE.1) GO TO 30
5637: CALL ERROR2(31H ILLEGAL USAGE OF COMMON BLOCK , 31, COM(LK),
5638: * 1, 1, 0)
5639: K = PNODE - 1
5640: DO 70 I=1,K
5641: L = NODE(I)
5642: IF (NN(I).EQ.3) CALL ERROR2(19H WHICH APPEARED IN , 19, LAT(L),
5643: * 1, 0, 0)
5644: 70 CONTINUE
5645: CALL ERROR2( 1H1, 0, ZERO(1), -3, 0, 1)
5646: GO TO 120
5647: 80 L = LAT(L+2)
5648: GO TO 60
5649: C
5650: C ARE DONE SEARCHING FOR COMMON LK AT THIS NODE
5651: C ADD DESCENDENTS ONTO LIST TO BE VISITED
5652: C
5653: 90 L = NODE(K) + SYMLEN + 4
5654: L = LAT(L)
5655: 100 IF (L.EQ.0) GO TO 30
5656: K = PNODE - 1
5657: C
5658: C FIND DESC OF NODE AND IF NOT VISITED SET TO 2
5659: C
5660: DO 110 I=1,K
5661: IF (NODE(I).NE.LAT(L)) GO TO 110
5662: IF (NN(I).EQ.0) NN(I) = 2
5663: 110 CONTINUE
5664: L = LAT(L+1)
5665: GO TO 100
5666: 120 LK = LK + SYMLEN + 5
5667: GO TO 10
5668: 130 RETURN
5669: END
5670: C XXXXXCOMPAR.f
5671: LOGICAL FUNCTION COMPAR(A, B)
5672: INTEGER SYMLEN, A(2), B(2)
5673: COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
5674: C
5675: C ROUTINE TESTS TWO IDENTIFIERS FOR SAMENESS; RETURNS TRUE IF
5676: C SAME, ELSE FALSE
5677: C
5678: DO 10 I=1,SYMLEN
5679: IF (A(I).NE.B(I)) GO TO 30
5680: 10 CONTINUE
5681: COMPAR = .TRUE.
5682: 20 RETURN
5683: 30 COMPAR = .FALSE.
5684: GO TO 20
5685: END
5686: C XXXXXFINDND.f
5687: INTEGER FUNCTION FINDND(K1, K2)
5688: INTEGER K1(2)
5689: INTEGER PLAT, PNODE
5690: LOGICAL COMPAR
5691: COMMON /HEAD/ LNODE, PNODE, NODE(500)
5692: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
5693: C
5694: C FINDS SUBPROGRAM WHOSE PACKED NAME IS IN K1(2) AND
5695: C RETURNS INDEX OF ITS LAT ENTRY AS VALUE OF FINFND
5696: C RETURNS IN K2 INDEX IN NODE OF LAT INDEX
5697: C IGNORES ASF NODES IN LAT BY IGNORING NEGATIVE NODE
5698: C ENTRIES
5699: C
5700: IF (PNODE-1) 40, 40, 10
5701: 10 K = PNODE - 1
5702: DO 30 I=1,K
5703: IF (NODE(I)) 30, 30, 20
5704: 20 FINDND = NODE(I)
5705: K2 = I
5706: IF (COMPAR(LAT(FINDND),K1)) GO TO 50
5707: 30 CONTINUE
5708: 40 FINDND = 0
5709: 50 RETURN
5710: END
5711: C XXXXXFINDCM.f
5712: INTEGER FUNCTION FINDCM(K1)
5713: INTEGER K1(2)
5714: INTEGER PCOM, COM, SYMLEN
5715: LOGICAL COMPAR
5716: COMMON /COMS/ LCOM, PCOM, COM(300)
5717: COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
5718: C
5719: C ROUTINE FINDS COMMON BLOCK WHOSE NAME IS AT K1 IN COM
5720: C RETURNS INDEX IN COM OR 0 IF CANNOT FIND IT
5721: C
5722: IF (PCOM-1) 30, 30, 10
5723: 10 K = PCOM - 1
5724: KK = SYMLEN + 5
5725: DO 20 I=1,K,KK
5726: FINDCM = I
5727: IF (COMPAR(COM(I),K1)) GO TO 40
5728: 20 CONTINUE
5729: 30 FINDCM = 0
5730: 40 RETURN
5731: END
5732: C XXXXXINREF.f
5733: INTEGER FUNCTION INREF(IDUM)
5734: INTEGER REF, PREF
5735: COMMON /CREF/ LREF, PREF, REF(100)
5736: C
5737: C ROUTINE TO INPUT CALL TEMPLATES, RETURNS -1 FOR EOF, 0 FOR END
5738: C OF REFS FOR THIS PGM UNIT, AND 1 FOR REF RETRIEVED
5739: C
5740: READ (IDUM) PREF, K, (REF(L),L=1,PREF)
5741: IF (K-3) 10, 30, 40
5742: 10 INREF = 1
5743: 20 RETURN
5744: 30 INREF = 0
5745: GO TO 20
5746: 40 INREF = -1
5747: GO TO 20
5748: END
5749: C XXXXXINSYM.f
5750: LOGICAL FUNCTION INSYM(IDUM,II)
5751: INTEGER OUTUT, OUTUT2, OUTUT3, SYMHD, PDSA, SYMLEN, DSA, BNEXT
5752: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3, I1
5753: COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
5754: COMMON /FACTS/ NAME, NOST, ITYP, IASF
5755: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
5756: C
5757: C ROUTINE TO INPUT SYMBOL TABLE; RETURNS TRUE FOR SUCCESSFUL, ELSE
5758: C FALSE. KCODE=1 FOR TABLE, 3 FOR DUMMY TABLE, 4 FOR EOF
5759: C DUMMY TABLE CAUSES REFS FOR THIS PU TO BE FLUSHED IF
5760: C IDUM NE 0
5761: C
5762: 5 READ(OUTUT2) PDSA, KCODE, (DSA(I),I=1,PDSA)
5763: IF (KCODE-3) 10, 40, 30
5764: 10 NAME = DSA(PDSA-2)
5765: SYMHD = DSA(PDSA-1)
5766: LABHD = DSA(PDSA)
5767: PDSA = PDSA - 3
5768: INSYM = .TRUE.
5769: 20 RETURN
5770: 30 INSYM = .FALSE.
5771: GO TO 20
5772: C FLUSH REFS FOR DUMMY TABLE IF IDUM NONZERO
5773: 40 IF(IDUM.EQ.0) GOTO 5
5774: 50 IF(INREF(IDUM)) 60, 60, 50
5775: C WRITE END OF REFS FOR DUMMY REFS IF II NE 0; ELSE GOT TO
5776: C NEXT SYMBOL TABLE
5777: 60 IF(II.EQ.0) GOTO 5
5778: L = 1
5779: K = 3
5780: WRITE(II) L,K,L
5781: GOTO 5
5782: END
5783: C XXXXXMATCH.f
5784: INTEGER FUNCTION MATCH(HEAD, INCR, N)
5785: INTEGER PLAT, HEAD
5786: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
5787: C
5788: C ROUTINE READS DOEN A LINEAR LINKED LIST IN LAT TO FIND ENTRY
5789: C WHOSE FIRST WORD CONTAINS N; EACH LIST ELEMENT IS INCR+1 LONG;
5790: C HEAD IS POINTER TO FIRST LIST ELEMENT
5791: C RETURNS 0 FOR NO MATCH ON LIST OR THE EMPTY LIST
5792: C
5793: IF (HEAD) 40, 40, 10
5794: 10 MATCH = HEAD
5795: 20 IF (LAT(MATCH).EQ.N) GO TO 50
5796: MATCH = MATCH + INCR
5797: IF (LAT(MATCH)) 40, 40, 30
5798: 30 MATCH = LAT(MATCH)
5799: GO TO 20
5800: 40 MATCH = 0
5801: 50 RETURN
5802: END
5803: C XXXXXMKCOM.f
5804: SUBROUTINE MKCOM(PP, K)
5805: INTEGER PLAT, PDSA, FINDCM, DSA, SYMLEN, PP, PCOM, COM
5806: LOGICAL SYSERR, ERR, ABORT
5807: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
5808: COMMON /COMS/ LCOM, PCOM, COM(300)
5809: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
5810: COMMON /DETECT/ ERR, SYSERR, ABORT
5811: COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
5812: C
5813: C WANT TO MARK COMMONLIST ENTRY SET FOR SUBPGM PP; MAY HAVE TO
5814: C CREATE ENTRY
5815: C
5816: N = FINDCM(DSA(K+4))
5817: L = SYMLEN + 2 + PP
5818: KK = -K
5819: IF (N.NE.0) KK = N
5820: C
5821: C LOOK FOR DSA ENTRY ON LIST
5822: C
5823: I = MATCH(LAT(L),2,KK)
5824: IF (I) 30, 30, 10
5825: 10 LAT(I+1) = 1
5826: 20 RETURN
5827: C
5828: C CREATE NEW ENTRY
5829: C
5830: 30 IF (PLAT+3.GT.LLAT) GO TO 40
5831: LAT(PLAT+1) = 1
5832: LAT(PLAT+2) = LAT(L)
5833: LAT(L) = PLAT
5834: LAT(PLAT) = KK
5835: PLAT = PLAT + 3
5836: GO TO 20
5837: 40 SYSERR = .TRUE.
5838: CALL ERROR1(32H IN MKCOM, TABLE OVERFLOW OF LAT, 32)
5839: GO TO 20
5840: END
5841: C XXXXXOUTCOM.f
5842: INTEGER FUNCTION OUTCOM(IH, L)
5843: INTEGER STACK,PLAT
5844: LOGICAL ERR, SYSERR, ABORT
5845: COMMON /DETECT/ ERR, SYSERR, ABORT
5846: COMMON /CEXPRS/ LSTACK, STACK(620)
5847: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
5848: C
5849: C READS DOWN COM LIST OF PU NODE, PUTS INDICES OF ENTRIES
5850: C IN STACK. IH IS HEAD OF LIST, L RETURNS NO OF ENTRIES
5851: C
5852: OUTCOM = 0
5853: IF (IH) 40, 40, 10
5854: 10 L = 1
5855: K = IH
5856: 20 IF (L+1.GT.LSTACK) GOTO 50
5857: STACK(L) = LAT(K)
5858: IF (LAT(K+1).EQ.1) STACK(L) = -STACK(L)
5859: L = L + 1
5860: K = LAT(K+2)
5861: IF (K) 30, 30, 20
5862: 30 L = L - 1
5863: IF(L.GT.0) OUTCOM=1
5864: 40 RETURN
5865: 50 SYSERR = .TRUE.
5866: CALL ERROR1(35H IN OUTCOM, TABLE OVERFLOW OF STACK, 35)
5867: GO TO 40
5868: END
5869: C XXXXXOUTLAT.f
5870: INTEGER FUNCTION OUTLAT(IH, L, ISR)
5871: INTEGER STACK, PLAT
5872: LOGICAL ERR, SYSERR, ABORT
5873: COMMON /DETECT/ ERR, SYSERR, ABORT
5874: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
5875: COMMON /CEXPRS/ LSTACK, STACK(620)
5876: INTEGER SYMLEN
5877: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
5878: C
5879: C IH POINTS TO A PARENTS OR DESCS LIST IN LAT; L IS NUM
5880: C OF ELEMENTS FOUND ON LIST; ISR IS ENTRY IN LAT OF
5881: C SUPERROOT
5882: C
5883: C
5884: OUTLAT = 0
5885: IF (IH) 50, 50, 10
5886: 10 K = IH
5887: L = 1
5888: 20 M = LAT(K)
5889: C SKIP OVER CALLS TO ASFS AND OVER SUPEROOT
5890: IF(MOD(IGATT2(M+SYMLEN+6,1),8).EQ.4 .OR. M.EQ.ISR) GOTO 30
5891: IF(L+1.GT.LSTACK) GOTO 60
5892: STACK(L) = M
5893: L = L + 1
5894: 30 K = LAT(K+1)
5895: IF (K) 40, 40, 20
5896: 40 L = L - 1
5897: IF (L.GT.0) OUTLAT = 1
5898: 50 RETURN
5899: 60 CALL ERROR1(35H IN OUTLAT, TABLE OVERFLOW OF STACK, 35)
5900: SYSERR = .TRUE.
5901: GO TO 50
5902: END
5903: C XXXXXOUT2A.f
5904: SUBROUTINE OUT2A( IT, JJ, N, ISW )
5905: C
5906: C IT CONTINAS TITLE FOR FIRST LINE OF OUTPUT
5907: C JJ CONTAINS NUMBER OF CHARS IN TITLE, J<=25
5908: C N CONTAINS NUMBER OF ELEMENTS TO BE PRINTED
5909: C ISW TELLS IF THESE ARE COMMON NAMES OR PROC NAMES
5910: C
5911: INTEGER IT(25), II(25), BL, PLAT, PCOM, COM, STACK, OUTUT, S
5912: INTEGER BUF(54)
5913: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
5914: COMMON /PARAMS/ II1, OUTUT, II2, II3, II4, II5, II6
5915: COMMON /CEXPRS/ LSTACK, STACK(620)
5916: COMMON /COMS/ LCOM, PCOM, COM(300)
5917: DATA BL/1H /,S/1HS/
5918: C
5919: C UNPACK TITLE
5920: C
5921: NN = JJ
5922: IF(JJ.GT.25) NN=25
5923: CALL S5UNPK( IT(1), II(1), NN)
5924: K1 = NN + 1
5925: IF(K1.GT.25) GOTO 15
5926: DO 10 K =K1, 25
5927: II(K) = BL
5928: 10 CONTINUE
5929: C
5930: C SETUP FIRST LINE OF ELEMENTS
5931: C
5932: 15 K = 6
5933: IF (K.GT.N) K = N
5934: IB = 1
5935: DO 50 I = 1, K
5936: IL = STACK(I)
5937: GOTO (20, 30),ISW
5938: C FOR PARE OR DESC LISTS
5939: 20 CALL S5UNPK( LAT(IL), BUF(IB), 6 )
5940: BUF(IB + 7) = BL
5941: GOTO 40
5942: C FOR COMMON LISTS- INDEX TO ELEMENTS IS NEGATIVE
5943: C IF COMMON IS SET BY PGM UNIT
5944: 30 BUF(IB + 7) = BL
5945: IF(IL.LT.0) BUF(IB + 7) = S
5946: IL = IABS(IL)
5947: CALL S5UNPK( COM(IL), BUF(IB), 6 )
5948: 40 BUF(IB + 6) = BL
5949: BUF(IB + 8) = BL
5950: IB = IB + 9
5951: 50 CONTINUE
5952: IB = IB - 1
5953: WRITE(OUTUT,99999) (II(L),L=1,25), (BUF(I),I=1,IB)
5954: 99999 FORMAT(80A1)
5955: IF(K.EQ.N) GOTO 110
5956: C WRITE SUBSEQUENT LINES
5957: 60 IB = 1
5958: K1 = K + 1
5959: K = K + 6
5960: IF (K.GT.N) K = N
5961: DO 100 I = K1, K
5962: IL = STACK(I)
5963: GOTO (70, 80), ISW
5964: C FOR PAR OR DESC LISTS
5965: 70 CALL S5UNPK( LAT(IL), BUF(IB), 6 )
5966: BUF(IB + 7) = BL
5967: GOTO 90
5968: C FOR COMMON LISTS
5969: 80 BUF(IB + 7) = BL
5970: IF(IL.LT.0) BUF(IB + 7) = S
5971: IL = IABS(IL)
5972: CALL S5UNPK( COM(IL), BUF(IB), 6 )
5973: 90 BUF(IB + 6) = BL
5974: BUF(IB +8) = BL
5975: IB = IB + 9
5976: 100 CONTINUE
5977: IB = IB - 1
5978: WRITE(OUTUT,99998) (BUF(I),I =1,IB)
5979: 99998 FORMAT(25X,55A1)
5980: IF(K.LT.N) GOTO 60
5981: 110 RETURN
5982: END
5983: C XXXXXOUT2C.f
5984: SUBROUTINE OUT2C
5985: INTEGER COM, PCOM, STACK, BL, SYMLEN, OUTUT, S, PLAT
5986: EXTERNAL EXCH
5987: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, I1, I2, I3
5988: COMMON /COMS/ LCOM, PCOM, COM(300)
5989: COMMON /CEXPRS/ LSTACK, STACK(620)
5990: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
5991: COMMON /SCR2/ LICOM, ICOM(500)
5992: DATA BL /1H /, S /1HS/
5993: C
5994: C PRINTS COM ARRAY
5995: C
5996: IF (PCOM-1) 80, 80, 10
5997: 10 K1 = SYMLEN + 5
5998: K = 1
5999: LCOMS = (PCOM-1)/(SYMLEN+5)
6000: DO 20 I=1,LCOMS
6001: ICOM(I) = K
6002: K = K + K1
6003: 20 CONTINUE
6004: CALL SSORT(EXCH, COM, LCOM, ICOM, LCOMS, 0)
6005: WRITE (OUTUT,99999)
6006: 99999 FORMAT (///14H1COMMON BLOCKS///1X, 4HNAME, 3X, 3HSET, 1X,
6007: * 18H DP,COM INT,RL,LOG//)
6008: DO 70 IBR=1,LCOMS
6009: I = ICOM(IBR)
6010: CALL S5UNPK(COM(I), STACK(1), 6)
6011: DO 30 L=1,3
6012: II = I + SYMLEN + L
6013: KK = 7 + L
6014: STACK(KK) = COM(II)
6015: 30 CONTINUE
6016: IF (STACK(8)) 40, 40, 50
6017: 40 STACK(8) = BL
6018: GO TO 60
6019: 50 STACK(8) = S
6020: 60 WRITE (OUTUT,99998) (STACK(II),II=1,6), STACK(8),
6021: * (STACK(II),II=9,10)
6022: 99998 FORMAT (1X, 6A1, 3X, A1, I8, 3X, I8)
6023: 70 CONTINUE
6024: 80 RETURN
6025: END
6026: C XXXXXSCAN.f
6027: SUBROUTINE SCAN(MAINND)
6028: INTEGER PLAT, SYMLEN, PNODE, STACK
6029: LOGICAL ERR, SYSERR, ABORT
6030: COMMON /DETECT/ ERR, SYSERR, ABORT
6031: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
6032: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
6033: COMMON /CEXPRS/ LSTACK, STACK(620)
6034: COMMON /HEAD/ LNODE, PNODE, NODE(500)
6035: COMMON/ SCR1/ LINODE, INODE(500)
6036: COMMON /SCR2/ LICOM, ICOM(500)
6037: C
6038: C SUBROUTINE PERCOLATES SETTING INFO ABOUT ARGUMENTS AND COMMON
6039: C UP THE LATTICE---IN ORDER THAT UNSAFE REFS CAN BE CHECKED
6040: C
6041: C
6042: C STACK(1)-(LSTACK) KEEPS TRACK OF PATH FROM CURRENT TERMINAL NODE
6043: C TO SUPEROOT NODE
6044: C INODE(J) IS 0 IF A NODE IS UNVISITED SO FAR ON ALL PATHS
6045: C 1 IF A NODE HAS BEEN VISITED ON AT LEAST ONE PATH
6046: C SYSERR IS SET BY SCAN
6047: C
6048: DO 10 I=1,PNODE
6049: INODE(I) = 0
6050: 10 CONTINUE
6051: INODE(MAINND) = 1
6052: MAIN = NODE(MAINND)
6053: NUM = 0
6054: C
6055: C CYCLE THROUGH ALL TERMINAL NODES
6056: C
6057: 20 NUM = NUM + 1
6058: IF (NUM.GT.PNODE-1) GO TO 240
6059: C
6060: C CHECK IF AN NODE IS ASF OR IF IT HAS DESC
6061: C OR IF IT HAS NO PARENTS
6062: C
6063: IF (NODE(NUM).LE.0) GO TO 20
6064: I = NODE(NUM) + SYMLEN + 4
6065: C
6066: C NO PARENTS
6067: C
6068: IF (LAT(I-1).EQ.0) GO TO 20
6069: C
6070: C TEST DESC FOR BEING ALL ASFS
6071: C
6072: IF (LAT(I).EQ.0) GO TO 40
6073: L = LAT(I)
6074: 30 K = LAT(L) + SYMLEN + 6
6075: IF (MOD(LAT(K),8).NE.4) GO TO 20
6076: L = LAT(I+1)
6077: IF (L) 40, 40, 30
6078: C
6079: C HAVE A TERMINAL NODE;NOW CAN START RECURSIVE TRAVERSE OF ALL
6080: C PATHS UPWARDS FROM IT TO ROOT
6081: C ILEN--POINTER TO TOP OF CURRENT PATH
6082: C JNODE--CURRENT NODE
6083: C
6084: 40 INODE(NUM) = 1
6085: ILEN = 2
6086: STACK(2) = NODE(NUM)
6087: STACK(1) = 0
6088: C
6089: C STACK ENTRY IS 1ST WORD-POINTER TO NODE ON LIST OF PARS OFPREV
6090: C NODE; 2ND WORD-NODE INDEX
6091: C PROCESS NODE
6092: C 1. CHECK EACH ARG. IF NOT SET OR IF PARENTS ARGLINKS NONEXISTANT
6093: C SKIP TO NEXT ARG (IF NO ARGS GOTO 2); ELSE MARK EACH PARENT
6094: C ARGLIST ENTRY AS SET FOR A SET ARG.
6095: C 2. ADD EACH COMMON REGION TO PARENTS' LIST OF COMMON REGIONS
6096: C 3. GET NEW NODE
6097: C
6098: 50 J = STACK(ILEN) + SYMLEN + 1
6099: C
6100: C ARG PROCESSING
6101: C
6102: J = LAT(J)
6103: 60 IF (J.EQ.0) GO TO 90
6104: I = IGATT2(J,5)
6105: IF (I.NE.1 .OR. LAT(J+2).EQ.0) GO TO 80
6106: L = LAT(J+2)
6107: 70 IF (L.EQ.0) GO TO 80
6108: C
6109: C SET PARENT ARGS
6110: C
6111: CALL SATT2(LAT(L), 5, 1)
6112: L = LAT(L+1)
6113: GO TO 70
6114: C
6115: C GO ON TO NEXT ARG
6116: C
6117: 80 J = LAT(J+3)
6118: GO TO 60
6119: C
6120: C COMMON PROCESSING
6121: C
6122: 90 J = STACK(ILEN) + SYMLEN + 2
6123: II = 0
6124: J = LAT(J)
6125: C
6126: C ACCUMULATE COMMON REGIONS
6127: C
6128: 100 IF (J.EQ.0) GO TO 110
6129: ICOM(II+1) = LAT(J)
6130: IF (LAT(J+1).NE.0) ICOM(II+1) = -ICOM(II+1)
6131: II = II + 1
6132: J = LAT(J+2)
6133: GO TO 100
6134: 110 IF (II.EQ.0) GO TO 150
6135: C
6136: C GET PARENT NODE AND ADD COMMON REGIONS TO IT
6137: C
6138: K = STACK(ILEN) + SYMLEN + 3
6139: K = LAT(K)
6140: 120 L = LAT(K) + SYMLEN + 2
6141: DO 140 I=1,II
6142: LL = MATCH(LAT(L),2,IABS(ICOM(I)))
6143: IF (LL.EQ.0) GO TO 130
6144: IF (ICOM(I).LT.0) LAT(LL+1) = 1
6145: GO TO 140
6146: C
6147: C COPY COMMONNODE ENTRIES ONTO PARENTS LIST
6148: C
6149: 130 IF (PLAT+3.GT.LLAT) GO TO 270
6150: LAT(PLAT+2) = LAT(L)
6151: LAT(PLAT+1) = 0
6152: LAT(PLAT) = IABS(ICOM(I))
6153: IF (ICOM(I).LT.0) LAT(PLAT+1) = 1
6154: LAT(L) = PLAT
6155: PLAT = PLAT + 3
6156: 140 CONTINUE
6157: C
6158: C GOONTO NEW PARENT
6159: C
6160: K = LAT(K+1)
6161: IF (K.NE.0) GO TO 120
6162: C
6163: C FIND A PARENT OF THIS NODE AND TRY TO VISIT IT NEXT
6164: C I CONTAINS POINTER TO PARENT LIST POSITION OF THE PARENT;
6165: C J CONTAINS PARENTS INDEX IN LAT
6166: C IF NO MORE PARENTS, MUST BACKUP A LEVEL
6167: C
6168: 150 I = STACK(ILEN) + SYMLEN + 3
6169: 160 IF (LAT(I).EQ.0) GO TO 200
6170: I = LAT(I)
6171: 170 J = LAT(I)
6172: C
6173: C CHECK THAT NEW ENTRY HAS PARENTS
6174: C AND THAT IT IS NOT THE SUPEROOT
6175: C
6176: K = J + SYMLEN + 3
6177: IF (LAT(K).GT.0) GO TO 210
6178: C
6179: C IF THIS PARENT UNACCEPTIBLE GO ONTO NEXT PARENT
6180: C MARK UNACCEPTIBLE AS VISITED SO WONT BE RECURSIVE
6181: C
6182: LL = PNODE - 1
6183: DO 180 L=1,LL
6184: IF (J.NE.NODE(L)) GO TO 180
6185: INODE(L) = 1
6186: GO TO 190
6187: 180 CONTINUE
6188: 190 I = I + 1
6189: GO TO 160
6190: C
6191: C MUST BACK DOWN THE PATH TO THE NEXT JUNCTURE WITH
6192: C AN UNTRIED PATH; CHECK FIRST FOR DONE WITH ENTIRE PATH
6193: C
6194: 200 IF (STACK(ILEN-1).EQ.0) GO TO 20
6195: ILEN = ILEN - 2
6196: J = STACK(ILEN+1)
6197: IF (LAT(J+1).EQ.0) GO TO 200
6198: C
6199: C FOUND AN UNTRIED PATH ON THE STACK
6200: C
6201: I = LAT(J+1)
6202: GO TO 170
6203: C
6204: C MARK ENTRY AS VISITED
6205: C
6206: 210 LL = PNODE - 1
6207: DO 220 L=1,LL
6208: IF (J.NE.NODE(L)) GO TO 220
6209: INODE(L) = 1
6210: GO TO 230
6211: 220 CONTINUE
6212: C
6213: C ENTER ON STACK
6214: C
6215: 230 IF (ILEN+2.GT.LSTACK) GO TO 260
6216: STACK(ILEN+1) = I
6217: STACK(ILEN+2) = J
6218: ILEN = ILEN + 2
6219: GO TO 50
6220: 240 RETURN
6221: 250 SYSERR = .TRUE.
6222: GO TO 240
6223: 260 CALL ERROR1(33H IN SCAN, TABLE OVERFLOW OF STACK, 33)
6224: GO TO 250
6225: 270 CALL ERROR1(31H IN SCAN, TABLE OVERFLOW OF LAT, 31)
6226: GO TO 250
6227: END
6228: C XXXXXSETARG.f
6229: INTEGER FUNCTION SETARG(PP, N)
6230: INTEGER PLAT, DSA, PP, SYMLEN, PDSA
6231: LOGICAL ERR, SYSERR, ABORT
6232: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
6233: COMMON /DETECT/ ERR, SYSERR, ABORT
6234: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
6235: COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
6236: C
6237: C SETS UP LIST OF ARGUMENTS , HANGING OFF NODE AT LAT(PP)
6238: C ARGES ARE KEPT IN ORDERED LINEAR LINKED LIST
6239: C ORDERING CORRESPONDS TO LEFT TO RIGHT APPEARENCE IN DEFN
6240: C N-SUBPRGM ENTRY IN DSA
6241: C PP- CURRENT RTNE NODE IN LAT
6242: C ARGUMENT NODE
6243: C WD 1 ATTRIBUTES
6244: C WD2 LENGTH WITH -1 FOR VARIABLEY DIMENSIONED ARRAYS
6245: C WD3 HEAD OF PARENT REFS LIST
6246: C WD4 HEAD OF DESCENDENTS REFS LIST
6247: C WD5 PTR TO NEXT ARG
6248: C
6249: C FIND FIRST ARGUMENT & ZERO COUNT
6250: C
6251: J = DSA(N+2)
6252: SETARG = 0
6253: IPROC = 0
6254: C
6255: C FIND FIRST ENTRY ON DSA ARGLIST;
6256: C KK HEAD OF TO BE CREATED ARGLIST IN LAT
6257: C
6258: I = DSA(J)
6259: KK = PP + SYMLEN + 1
6260: C
6261: C SETUP STORAGE FOR ARG ENTRY
6262: C
6263: 10 IF (PLAT+4.GE.LLAT) GO TO 80
6264: C
6265: C ENTER ATTRIBUTE WORD AND ZERO REST OF ENTRY
6266: C
6267: LAT(PLAT) = DSA(I)
6268: LAT(KK) = PLAT
6269: KK = PLAT + 3
6270: DO 20 IA=1,3
6271: L = IA + PLAT
6272: LAT(L) = 0
6273: 20 CONTINUE
6274: K = IGATT1(I,8)
6275: IF (K.NE.10) GO TO 50
6276: C
6277: C GET STRUCTURE OF ARG
6278: C
6279: K = IGATT1(I,7)
6280: IF (K) 40, 40, 30
6281: C
6282: C ARRAY
6283: C
6284: 30 K = DSA(I+2)
6285: LAT(PLAT+1) = DSA(K)
6286: GO TO 60
6287: C
6288: C SCALAR
6289: C
6290: 40 LAT(PLAT+1) = 1
6291: GO TO 60
6292: C SET RELATIVE ORDER OF PROC ARGS IN ITS 2ND WORD
6293: 50 IPROC = IPROC + 1
6294: LAT(PLAT+1) = IPROC
6295: C
6296: C CHECK FOR MORE ARGS; ADVANCE PLAT
6297: C
6298: 60 PLAT = PLAT + 4
6299: SETARG = SETARG + 1
6300: IF (DSA(J+1)) 90, 90, 70
6301: 70 J = DSA(J+1)
6302: I = DSA(J)
6303: GO TO 10
6304: 80 SYSERR = .TRUE.
6305: CALL ERROR1(33H IN SETARG, TABLE OVERFLOW OF LAT, 33)
6306: 90 RETURN
6307: END
6308: C XXXXXSETASF.f
6309: SUBROUTINE SETASF(PP, K)
6310: INTEGER PP, SYMLEN, PLAT, PDSA, SETARG, PNODE, DSA
6311: LOGICAL ERR, SYSERR, ABORT
6312: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
6313: COMMON /HEAD/ LNODE, PNODE, NODE(500)
6314: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
6315: COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
6316: COMMON /DETECT/ ERR, SYSERR, ABORT
6317: C
6318: C SETUP ASF NODE; IT HAS A NODE JUST LIKE A RTNE
6319: C EXCEPT ITS INDEX IN NODE IS NEGATIVE
6320: C PP-COM ADDRESS OF PARENT SUBPGM
6321: C K-DSA ADDRESS OF ASF ENTRY
6322: C
6323: IF (PNODE+1.GT.LNODE) GO TO 40
6324: IF (PLAT+SYMLEN+11.GT.LLAT) GO TO 60
6325: C
6326: C CREATE NEW NODE ENTRY
6327: C
6328: NODE(PNODE) = -PLAT
6329: PNODE = PNODE + 1
6330: C
6331: C ENTER NAME AND ZERO REST OF NODE
6332: C
6333: DO 10 I=1,SYMLEN
6334: L = K + 3 + I
6335: LL = PLAT + I - 1
6336: LAT(LL) = DSA(L)
6337: 10 CONTINUE
6338: DO 20 I=1,6
6339: L = LL + I
6340: LAT(L) = 0
6341: 20 CONTINUE
6342: C
6343: C SET LAST ELEMENT TO TYPE OF PGM UNIT
6344: C STORE IN SAME WORD ASF TYPE
6345: C
6346: I = IGATT1(K,1)
6347: LAT(L+1) = 4 + 8*MOD(I,8)
6348: C
6349: C SETUP PARENT'S LIST TO POINT TO PP IN ASF NODE
6350: C
6351: L = PLAT + SYMLEN + 3
6352: LAT(L) = L + 4
6353: LAT(L+4) = PP
6354: LAT(L+5) = 0
6355: KQ = PLAT
6356: PLAT = L + 6
6357: C
6358: C SETUP REFERENCE IN PP'S DESCENDENTS LIST
6359: C
6360: II = PP + SYMLEN + 4
6361: LAT(PLAT) = KQ
6362: LAT(PLAT+1) = LAT(II)
6363: LAT(II) = PLAT
6364: PLAT = PLAT + 2
6365: C
6366: C SETUP ARGUMENTS
6367: C
6368: L = KQ + SYMLEN
6369: LAT(L) = SETARG(KQ,K)
6370: 30 RETURN
6371: 40 CALL ERROR1(34H IN SETASF, TABLE OVERFLOW OF NODE, 34)
6372: 50 SYSERR = .TRUE.
6373: GO TO 30
6374: 60 CALL ERROR1(33H IN SETASF, TABLE OVERFLOW OF LAT, 33)
6375: GO TO 50
6376: END
6377: C XXXXXSETCOM.f
6378: SUBROUTINE SETCOM(PP, K)
6379: LOGICAL SYSERR, ERR, ABORT, BLANK
6380: INTEGER PLAT, DSA, SYMLEN, PP, PDSA, COM, PCOM, R(5), S(3),
6381: * FINDND, ST, SS(1), FINDCM
6382: INTEGER ZERO(1)
6383: COMMON /FACTS/ NAME, NOST, ITYP, IASF
6384: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
6385: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
6386: COMMON /DETECT/ ERR, SYSERR, ABORT
6387: COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
6388: COMMON /COMS/ LCOM, PCOM, COM(300)
6389: C
6390: C COM ENTRY
6391: C WORD 1.....PACKED CHARACTERS OF COMMON-NAME
6392: C WORD 2....TOTAL LENGTH OF COMMON BLOCK
6393: C WORD 3.....1 IF COMMON INITIALIZED BY BLOCK DATA SUBPGM
6394: C 0 IF NOT
6395: C WORDS 4-8...TOTAL LENGTHS OF COMPLEX, DOUBLE PRECIS,
6396: C REAL, INTEGER, LOGICAL DATA TYPES RESPECTIVELY
6397: C WORD 9.....INDEX IN LAT OF ENTRY OF P.U. WHICH CONTAINS
6398: C THIS DEFN OF THE COMMON BLOCK
6399: C
6400: C FINDS COMMON BLOCK ENTRY IN COM- ELSE CREATES AND INITIALIZES NEW
6401: C ENTRY. CHECKS NEW ENTRY BLOCK NOT ALREADY A SUBPGM NAME.
6402: C GATHERS INFO ON ORDER, TYPE, LENGTH OF ENTRIES IN THE COMMON-
6403: C CHECKS FOR VARIABLY DIMENSIONED ARRAYS.
6404: C FORMS COMMONLIST ENTRY FOR BLOCK OFF SUBPGM AT LAT(PP)
6405: C IF FOUND COMMON IN COM, COMPARES OLD DEFN TO NEW FOR ORDER, LEN,
6406: C TYPE OF ENTRIES; FLAGS INCONSISTENCIES; NOTES IF COMMON IN
6407: C TWO BLOCK DATA PGMS. COMMON IS AT DSA(K)
6408: C
6409: DATA R(1), R(4) /2*1/, R(2), R(3), R(5) /3*2/, ST /1H*/
6410: DATA ZERO(1) /0/
6411: C
6412: C CHECK ISNT IN NODE AS PROCEDURE NAME
6413: C
6414: IF (FINDND(DSA(K+4),KK)) 20, 20, 10
6415: 10 CALL ERROR2(41H COMMON BLOCK HAS SAME NAME AS SUBPROGRAM, 41,
6416: * DSA(K+4), 1, 1, 1)
6417: C
6418: C CHECK IF IN COM ALREADY
6419: C
6420: 20 KK = FINDCM(DSA(K+4))
6421: IF (KK) 30, 30, 60
6422: C
6423: C CREATE NEW ENTRY
6424: C
6425: 30 IF (PCOM+SYMLEN+5.GT.LCOM) GO TO 260
6426: DO 40 I=1,SYMLEN
6427: L = PCOM + I - 1
6428: LL = K + I + 3
6429: COM(L) = DSA(LL)
6430: 40 CONTINUE
6431: C
6432: C MARK COMMON SET WHEN IT IS CREATED BY A BLOCK-DATA
6433: C SUBPROGRAM WHICH SET IT
6434: C
6435: DO 50 I=1,4
6436: LL = L + I
6437: COM(LL) = 0
6438: 50 CONTINUE
6439: COM(LL+1) = PP
6440: IF (IGATT1(NAME,8).EQ.11 .AND. IGATT1(K,2).EQ.1) COM(L+2) = 1
6441: KK = PCOM
6442: PCOM = PCOM + SYMLEN + 5
6443: C
6444: C GATHER INFO ABT LENGTH,TYPE,ORDER OF ELEMENTS
6445: C
6446: 60 L = 0
6447: S(1) = 0
6448: S(2) = 0
6449: S(3) = 0
6450: I = DSA(K+2)
6451: 70 IF (I) 130, 130, 80
6452: C
6453: C READING LIST OF ELEMENTS IN COMMON-CHECK TYPE,STRUCTURE
6454: C
6455: 80 K1 = IGATT1(DSA(I),1)
6456: K2 = IGATT1(DSA(I),7)
6457: K1 = MOD(K1,8)
6458: IF (K1.EQ.5) K1 = 2
6459: C
6460: C R(I) CONTAINS PROPER ORDER OF TYPE I IN DEFN OF COMMON
6461: C
6462: LL = R(K1+1)
6463: IF (LL.LT.L) GO TO 120
6464: IF (K2) 90, 90, 100
6465: 90 S(LL) = S(LL) + 1
6466: GO TO 110
6467: 100 K2 = DSA(I)
6468: K2 = DSA(K2+2)
6469: S(LL) = S(LL) + DSA(K2)
6470: 110 I = DSA(I+1)
6471: L = LL
6472: GO TO 70
6473: C
6474: C ACCUMULATE COUNTS OF TYPES-NOTE TYPES OUT OF ORDER CAUSES
6475: C TRUNCATION OF THE DEFINITION
6476: C
6477: 120 CALL ERROR2(41H ILLEGAL ORDERING OF DATA-TYPES IN COMMON, 41,
6478: * COM(KK), 1, 1, 0)
6479: CALL ERROR2(1H1, 0, ZERO(1), -1, 0, 1)
6480: 130 S(3) = S(1) + S(2)
6481: C
6482: C HANG COMMONLIST ENTRY OFF PP NODE, IF NOT ALREADY THERE FROM SET
6483: C
6484: L = PP + SYMLEN + 2
6485: I = MATCH(LAT(L),2,-K)
6486: IF (I.GT.0) GO TO 140
6487: I = MATCH(LAT(L),2,KK)
6488: IF (I.LE.0) GO TO 150
6489: 140 LAT(I) = KK
6490: GO TO 160
6491: C
6492: C CREATE NEW ENTRY
6493: C
6494: 150 IF (PLAT+3.GT.LLAT) GO TO 280
6495: LAT(PLAT) = KK
6496: LAT(PLAT+1) = 0
6497: LAT(PLAT+2) = LAT(L)
6498: LAT(L) = PLAT
6499: PLAT = PLAT + 3
6500: 160 I = KK + SYMLEN
6501: IF (COM(I)) 170, 170, 190
6502: C
6503: C NEW DEFN
6504: C
6505: 170 COM(I) = S(3)
6506: COM(I+2) = S(1)
6507: COM(I+3) = S(2)
6508: 180 RETURN
6509: C
6510: C COMPARE LENGTHS OF EACH TYPE
6511: C
6512: 190 L = KK + SYMLEN + 2
6513: BLANK = .FALSE.
6514: CALL S5UNPK(COM(KK), SS(1), 1)
6515: IF (SS(1).EQ.ST) BLANK = .TRUE.
6516: IBR = 0
6517: IF (COM(L+1).NE.S(2)) IBR = 1
6518: IF (COM(L).NE.S(1)) IBR = -1
6519: C BLANK COMMON DEFNS MATCH
6520: IF (IBR.EQ.0 .AND. BLANK) GO TO 180
6521: C NAMED COMMON DEFNS MATCH
6522: IF (IBR.EQ.0 .AND. .NOT.BLANK) GO TO 210
6523: C BLANK COMMON DONT MATCH
6524: IF (IBR.NE.0 .AND. BLANK) GO TO 230
6525: C NAMED COMMONS DONT MATCH -- ERROR
6526: 200 CALL ERROR2(25H INCOMPATIBLE COMMON DEFN, 25, COM(KK), 1, 1,
6527: * 0)
6528: K1 = KK + SYMLEN + 4
6529: K1 = COM(K1)
6530: CALL ERROR2(3H IN, 3, LAT(K1), 1, 0, 0)
6531: CALL ERROR2(4H AND, 4, LAT(PP), 1, 0, 1)
6532: IF (BLANK) GO TO 180
6533: C
6534: C CHECK DOUBLE SETTING OF BLOCK
6535: C
6536: 210 IF (IGATT1(K,2).NE.1 .OR. IGATT1(NAME,8).NE.11) GO TO 180
6537: IF (COM(L-1).NE.1) GO TO 220
6538: CALL ERROR2(
6539: * 53H COMMON BLOCK INITIALIZED IN TWO BLOCK DATA SUBPGMS , 53,
6540: * COM(KK), 1, 1, 1)
6541: GO TO 180
6542: 220 COM(L-1) = 1
6543: GO TO 180
6544: C
6545: C CHECK ARE LENGTHENING BLANK COMMON OFF THE END
6546: C
6547: 230 IF(IBR.EQ.(-1)) GOTO 250
6548: C ARE LENGTHENING OFF END
6549: C KEEP LONGEST DEFN
6550: IF (COM(L+1).GT.S(2)) GO TO 180
6551: 240 COM(L+1) = S(2)
6552: LL = SYMLEN + KK
6553: COM(LL) = S(3)
6554: COM(LL+4) = PP
6555: GO TO 180
6556: C SEE ARE REALLY LENGTHENING OFF END IF
6557: C DEFNS DIFFER IN FIRST DATA TYPE AREAS
6558: 250 IF (S(1).LT.COM(L) .AND. S(2).EQ.0) GO TO 180
6559: IF (.NOT.(S(1).GT.COM(L) .AND. COM(L+1).EQ.0)) GO TO 200
6560: COM(L) = S(1)
6561: GO TO 240
6562: 260 CALL ERROR1(33H IN SETCOM, TABLE OVERFLOW OF COM, 33)
6563: 270 SYSERR = .TRUE.
6564: GO TO 180
6565: 280 CALL ERROR1(33H IN SETCOM, TABLE OVERFLOW OF LAT, 33)
6566: GO TO 270
6567: END
6568: C XXXXXSETEXT.f
6569: SUBROUTINE SETEXT
6570: INTEGER Z, FINDND, PLAT, PNODE, PP, SS(3), SYMLEN
6571: INTEGER BLANK
6572: LOGICAL ERR, SYSERR, ABORT
6573: COMMON /SCR1/ LINODE, INODE(500)
6574: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
6575: COMMON /INTS/ Z(346)
6576: COMMON /DETECT/ ERR, SYSERR, ABORT
6577: COMMON /HEAD/ LNODE, PNODE, NODE(500)
6578: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
6579: DATA BLANK /1H /
6580: C
6581: C SUBROUTINE SETS UP DEFNS FOR BASIC EXTERNAL FCNS USED IN PASS 1
6582: C FLUSH PAST INTRINSICS IN TABLE
6583: C
6584: K = 1
6585: DO 10 I=1,31
6586: K = K + Z(K) + 2
6587: 10 CONTINUE
6588: C
6589: C SEARCH EXTERNAL ENTRIES IN TABLE TO SEE WHICH HAVE BEEN USED
6590: C
6591: DO 90 I=1,24
6592: N = K + Z(K) + 1
6593: L = Z(N)/1024
6594: IF (L) 80, 80, 20
6595: C
6596: C SEE IF THIS EXTERNAL FCN HAS BEEN USER DEFINED
6597: C
6598: 20 L = Z(K)
6599: DO 30 J=1,SYMLEN
6600: SS(J) = BLANK
6601: 30 CONTINUE
6602: CALL S5PACK(Z(K+1), SS, L)
6603: LL = FINDND(SS(1),J)
6604: IF (LL.NE.0) GO TO 80
6605: C
6606: C SETUP LATTICE ENTRY FOR THIS EXERNAL FCN
6607: C
6608: IF (PNODE+1.GE.LNODE) GO TO 120
6609: IF (PLAT+SYMLEN+8.GE.LLAT) GO TO 110
6610: C SET LEVEL OF BASIC EXTERNAL FUNCTION TO -2
6611: INODE(PNODE) = -2
6612: NODE(PNODE) = PLAT
6613: PNODE = PNODE + 1
6614: DO 40 J=1,SYMLEN
6615: L = PLAT + J - 1
6616: LAT(L) = SS(J)
6617: 40 CONTINUE
6618: PP = PLAT
6619: PLAT = PLAT + SYMLEN
6620: LAT(PLAT) = MOD(Z(N),512)/128
6621: L = PLAT + 1
6622: LL = PLAT + 5
6623: DO 50 NN=L,LL
6624: LAT(NN) = 0
6625: 50 CONTINUE
6626: LAT(PLAT+6) = 6 + 8*MOD(Z(N),8)
6627: NO = LAT(PLAT)
6628: PLAT = PLAT + 7
6629: C
6630: C FILL IN ARG ENTRIES
6631: C NO CONTAINS NUMBER OF ARGS
6632: C
6633: IF ((PLAT+4)*NO.GE.LLAT) GO TO 110
6634: L = PP + SYMLEN + 1
6635: 60 LL = PLAT + 3
6636: DO 70 NN=PLAT,LL
6637: LAT(NN) = 0
6638: 70 CONTINUE
6639: CALL SATT2(PLAT, 1, MOD(Z(N),64)/8)
6640: CALL SATT2(PLAT, 4, 1)
6641: CALL SATT2(PLAT, 8, 10)
6642: LAT(L) = PLAT
6643: LAT(PLAT+1) = 1
6644: L = PLAT + 3
6645: PLAT = PLAT + 4
6646: IF (NO.EQ.1) GO TO 80
6647: NO = NO - 1
6648: GO TO 60
6649: 80 K = N + 1
6650: 90 CONTINUE
6651: 100 RETURN
6652: 110 CALL ERROR1(33H IN SETEXT, TABLE OVERFLOW OF LAT, 33)
6653: GO TO 130
6654: 120 CALL ERROR1(34H IN SETEXT, TABLE OVERFLOW OF NODE, 34)
6655: 130 SYSERR = .TRUE.
6656: GO TO 100
6657: END
6658: C XXXXXSETPD.f
6659: SUBROUTINE SETPD(I, K2)
6660: INTEGER PDSA, DSA, PLAT, SYMLEN
6661: LOGICAL ERR, SYSERR, ABORT
6662: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
6663: COMMON /DETECT/ ERR, SYSERR, ABORT
6664: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
6665: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
6666: C
6667: C SUBROUTINE ADDS PGM UNIT AT LAT(I) ONTO K2 DESC-LIST
6668: C ADDS K2 ONTO I PARENTS LIST
6669: C
6670: IF (PLAT+4.GT.LLAT) GO TO 20
6671: C
6672: C SEE THAT K2 IS NOT ALREADY ON I PARENTS LIST
6673: C 0 RETURN INDICATES EMPTY LIST OR NO MATCH
6674: C
6675: J = I + SYMLEN + 3
6676: IF (MATCH(LAT(J),1,K2).NE.0) GO TO 10
6677: LAT(PLAT+1) = LAT(J)
6678: LAT(PLAT) = K2
6679: LAT(J) = PLAT
6680: J = K2 + SYMLEN + 4
6681: LAT(PLAT+3) = LAT(J)
6682: LAT(PLAT+2) = I
6683: LAT(J) = PLAT + 2
6684: PLAT = PLAT + 4
6685: 10 RETURN
6686: C
6687: C ERROR RETURNS
6688: C
6689: 20 SYSERR = .TRUE.
6690: CALL ERROR1(32H IN SETPD, TABLE OVERFLOW OF LAT, 32)
6691: GO TO 10
6692: END
6693: C XXXXXSETREF.f
6694: SUBROUTINE SETREF(GREEN,INDIR)
6695: INTEGER CHK1, KBR(1)
6696: INTEGER REF, PREF, PDSA, DSA, PLAT, PNODE, FINDND, SYMLEN
6697: LOGICAL ERR, SYSERR, ABORT, COMPAR, GREEN, INDIR
6698: COMMON /HEAD/ LNODE, PNODE, NODE(500)
6699: COMMON/ SCR1/ LINODE, INODE(500)
6700: COMMON /FACTS/ NAME, NOST, ITYP, IASF
6701: COMMON /CREF/ LREF, PREF, REF(100)
6702: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
6703: COMMON /DETECT/ ERR, SYSERR, ABORT
6704: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
6705: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
6706: COMMON /TABL/ NEXT, LABHD, ISYM, IBNEXT
6707: DATA IBR /1/, JBR /3/, KBR(1) /0/
6708: C
6709: C GREEN = T IF ENCOUNTER EXTERNAL ENTITIES AT ALL
6710: C INDIR = T IF ENCOUNTER ANY INDIRECT REFS
6711: C READS IN ALL REFS FOR A PROGRAM UNIT; FINDS MISSING
6712: C SUBPROGRAM REFS AND DISCARDS THEM; CHECKS ASF REFS AND
6713: C DISCARDS THEM; WRITES INDIRECT REFS OUT ON I6 WITHOUT
6714: C PROCESSING; DOES MINIMAL CHECKING OF DIRECT REFS
6715: C CREATING PAR/DESC LINKS AND WRITING GOOD
6716: C REFS OUT ON I6, AFTER DONE WITH REFS, SEARCHES
6717: C FOR EXTERNAL ENTITIES (USAGE 13) TO FIX UP LEVELS
6718: C
6719: IJK = FINDND(DSA(NAME+4),IIJK)
6720: C READ IN A NEW REF; IF HIT END OF REFS RECORD
6721: C END OF REFS ON I6 AND RETURN
6722: 10 IF (INREF(I5)) 20, 20, 80
6723: C WRITE END OF REFS
6724: 20 WRITE (I6) IBR, JBR, IBR
6725: C CHECK FOR NON DUMMY EXTERNALS IN SYMBOL TABLE WHICH
6726: C C AUSE CHANGES IN LEVEL CALCS
6727: K = ISYM
6728: 30 IF (K) 40, 40, 50
6729: 150 SYSERR=.TRUE.
6730: CALL ERROR1(33H IN SETREF, TABLE OVERFLOW OF LAT,33)
6731: 40 RETURN
6732: 50 IF (IGATT1(K,8).NE.13 .OR. IGATT1(K,4).EQ.1) GO TO 70
6733: L = FINDND(DSA(K+4),IL)
6734: IF (L.NE.0) GO TO 60
6735: CALL ERROR2(18H MISSING EXTERNAL , 18, DSA(K+4), 1, 1, 0)
6736: CALL ERROR2(1H1,0,KBR(1),-1, 0, 1)
6737: GO TO 70
6738: C FOUND AN EXTERNAL ENTITY
6739: 60 GREEN = .TRUE.
6740: C ENTER ONTO GREEN LINKS LIST AT NODE
6741: N = IJK + SYMLEN + 3
6742: C J IS HEAD OF GREEN LINKS LIST (SEE SETPD)
6743: 160 IF(LAT(N+1).LE.0) GOTO 170
6744: N = LAT(N+1)
6745: GOTO 160
6746: 170 J = N+1
6747: IF(PLAT+2.GT.LLAT) GOTO 150
6748: LAT(PLAT) = -L
6749: LAT(PLAT+1) = LAT(J)
6750: LAT(J) = -PLAT
6751: PLAT = PLAT+2
6752: IF(-2.EQ.INODE(IL).OR.INODE(IL).GT.INODE(IIJK)) GOTO 70
6753: INODE(IL) = INODE(IIJK) + 1
6754: CALL ASLEV(-IL)
6755: IF (ABORT .OR. SYSERR) GO TO 40
6756: 70 K = DSA(K+3)
6757: GO TO 30
6758: C
6759: C REF IS WD1--NUMBER OF ARGS(2 WD ENTRIES)
6760: C WD2--PTR TO PGM UNIT CALLED IN DSA
6761: C WD3--STMT NO OF CALL
6762: C WD4--CODE, 0 FOR SUBR REFS; 1 FOR FCN REFS
6763: C WD5+-ARG ENTRIES (WD1-SYMBOL TABLE INDEX OR 0
6764: C WD2-TYPE/STRUCTURE INFO)
6765: C
6766: 80 IF (REF(4).LT.4) GO TO 100
6767: C
6768: C ASF REFERENCE; CHECKED AND THEN DISCARDED
6769: C
6770: K1 = PNODE - 1
6771: DO 90 I=1,K1
6772: IF (NODE(I).GE.0) GO TO 90
6773: IJR = IABS(NODE(I))
6774: L = IJR + SYMLEN + 3
6775: L = LAT(L)
6776: K = REF(2)
6777: C
6778: C IF HAVE ASF REF, FIND ASF BY NAME AND PAR CHECKS
6779: C
6780: IF (COMPAR(DSA(K+4),LAT(IJR)) .AND. LAT(L).EQ.IJK) GO TO 110
6781: 90 CONTINUE
6782: L = REF(2) + 4
6783: CALL ERROR2(18H MISSING ASF DEFN , 18, DSA(L), 1, 1, 0)
6784: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
6785: GO TO 10
6786: C
6787: C WRITE INDIRECT REF OUT ON I6
6788: C
6789: 100 K2 = IGATT1(REF(2),4)
6790: IF(K2.EQ.0) GOTO 140
6791: INDIR = .TRUE.
6792: GOTO 130
6793: C CHECK FOR MISSING SUBPROGRAM
6794: 140 K1 = REF(2)
6795: IJR = FINDND(DSA(K1+4),IIJR)
6796: IF (IJR.NE.0) GO TO 110
6797: CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(K1+4), 1
6798: * ,1, 0)
6799: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
6800: GO TO 10
6801: C CHECK DIRECT REFS AND ASF REFS
6802: C 1 MEANS OK 0 MEANS N.G.
6803: 110 IF (CHK1(IJK,IJR)) 10, 10, 120
6804: 120 IF (REF(4).EQ.4) GO TO 10
6805: C GOOD DIRECT REF; CREATE PAR/DES LINKS
6806: CALL SETPD(IJR, IJK)
6807: IF (SYSERR) GO TO 40
6808: IF (-2.EQ.INODE(IIJR) .OR. INODE(IIJR).GT.INODE(IIJK)) GO TO 130
6809: C FIX UP LEVELS
6810: INODE(IIJR) = INODE(IIJK) + 1
6811: CALL ASLEV(IIJR)
6812: IF (SYSERR .OR. ABORT) GO TO 40
6813: 130 WRITE (I6) PREF, IBR, (REF(L),L=1,PREF)
6814: GO TO 10
6815: END
6816: C XXXXXUNSAFE.f
6817: SUBROUTINE UNSAFE
6818: C
6819: C ROUTINE READS IN ALL DIRECT AND INDIRECT REFS FOR THE CURRENT
6820: C PGM-UNIT; CHECKS FOR THE 3 UNSAFE REFS
6821: C
6822: LOGICAL IBR
6823: INTEGER PLAT, PDSA, DSA, SYMLEN, PREF, REF, INREF, FINDCM
6824: COMMON /CREF/ LREF, PREF, REF(100)
6825: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
6826: COMMON /FACTS/ NAME, I1, I2, IASF
6827: COMMON /PARAMS/ I3, I4, I5, SYMLEN, I6, I7, I8
6828: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
6829: 10 IF (INREF(I7).LE.0) RETURN
6830: C CHECK FOR REF WITHOUT ARGS
6831: I = REF(1)
6832: IF (I.EQ.0) GO TO 10
6833: LL = REF(2)
6834: L = LL + SYMLEN + 1
6835: L = LAT(L)
6836: C
6837: C LPOINTS TO DUMMY ARGUMENT IN LAT
6838: C
6839: DO 70 K=1,I,2
6840: J = 4 + K
6841: IF (REF(J).EQ.0) GO TO 20
6842: N = IGATT1(REF(J),8)
6843: IF (N.EQ.10 .OR. N.EQ.4) GO TO 30
6844: GO TO 60
6845: C
6846: C LOOK FOR EXPRESSION BEING MATCHED TO AN ARG WHICH
6847: C IS SET; TYPE 1 UNSAFE REF
6848: C
6849: 20 IF (IGATT2(L,5).EQ.0) GO TO 60
6850: CALL ERROR2(
6851: * 56H EXPRESSION MATCHED TO POSSIBLY SET ARG IN REFERENCE TO ,
6852: * 56, LAT(LL), 1, 1, 0)
6853: CALL ERROR2(24H TYPE 1 UNSAFE REFERENCE, 24, REF(3), -1, 0, 1)
6854: GO TO 60
6855: C
6856: C CHECK FOR ACTUAL ARG IN COMMON BEING SENT DOWN WHERE RTNE
6857: C BENEATH CHANGES ARG OR COMMON REGION
6858: C TYPE 3 UNSAFE REFERENCE
6859: C
6860: 30 N = IGATT1(REF(J),2)
6861: IF (N.NE.1) GO TO 40
6862: C
6863: C SEE IF ACTUAL IS AN ARRAY
6864: C
6865: N = IGATT2(L,7)
6866: IF (N.NE.0) GO TO 40
6867: N = REF(J) + 2
6868: N = DSA(N)
6869: N = DSA(N+1) + 4
6870: N = FINDCM(DSA(N))
6871: NN = LL + SYMLEN + 2
6872: NN = MATCH(LAT(NN),2,N)
6873: IF (NN.EQ.0) GO TO 40
6874: N = IGATT2(L,5)
6875: IF (N.EQ.0 .AND. LAT(NN+1).EQ.0) GO TO 40
6876: CALL ERROR2(42H ARG OR COMMON MAY BE SET BY REFERENCE TO , 42,
6877: * LAT(LL), 1, 1, 0)
6878: CALL ERROR2(24H TYPE 3 UNSAFE REFERENCE, 24, REF(3), -1, 0, 1)
6879: C
6880: C CHECK FOR DO CONTROL VAR OR LIMIT MATCHED
6881: C TO DUMMY ARG POSSIBLY SET
6882: C
6883: 40 NN = IGATT2(L,5)
6884: IF (NN.EQ.0) GO TO 60
6885: NN = REF(J+1)/32
6886: IF (NN.NE.1) GO TO 50
6887: CALL ERROR2(
6888: * 51H DO CONTROL VARIABLE OR LIMIT CAN BE SET IN REF TO , 51,
6889: * LAT(LL), 1, 1, 0)
6890: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
6891: C
6892: C CHECK FOR ADJUSTIBLE DIMENSION VARIABLE MATCHED TO DUMMY
6893: C ARG POSSIBLY SET
6894: C
6895: 50 NN = REF(J+1)/64
6896: IF (NN.NE.1) GO TO 60
6897: CALL ERROR2(
6898: * 52H ADJUSTIBLE DIMENSION VARIABLE CAN BE SET IN REF TO ,
6899: * 52, LAT(LL), 1, 1, 0)
6900: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
6901: 60 L = LAT(L+3)
6902: 70 CONTINUE
6903: C
6904: C CHECK FOR SAME ACTUAL ARG SENT DOWN FOR DIFFERENT DUMMY-ARGS
6905: C AND ONE OF DUMMIES MAY BE SET
6906: C
6907: C TYPE 2 UNSAFE REFERENCE
6908: IF (REF(1).LE.2) GO TO 130
6909: LR = LL + SYMLEN + 1
6910: LR = LAT(LR)
6911: C
6912: C OUTER LOOP GOES TO NEXT TO LAST ARG
6913: C
6914: I = REF(1) + 3
6915: II = I - 2
6916: DO 120 K=5,II,2
6917: J = REF(K)
6918: IF (J.EQ.0) GO TO 110
6919: JBR = IGATT1(J,8)
6920: IF (JBR.NE.10 .AND. JBR.NE.4) GO TO 110
6921: L = LAT(LR+3)
6922: MM = K + 2
6923: DO 100 M=MM,I,2
6924: IF (REF(M).NE.J) GO TO 90
6925: C
6926: C HAVE TWO ACTUALS MAPPED ONTO DIFFERENT DUMMIES
6927: C
6928: C IF BOTH DUMMIES ARE ARRAYS OR BOTH ARE UNSET, NO UNSAFE
6929: IF( IGATT2(L,7).NE.0 .AND. IGATT2(LR,7).NE.0 ) GOTO 90
6930: IF( IGATT2(L,5).EQ.0 .AND. IGATT2(LR,5).EQ.0 ) GOTO 90
6931: 80 CALL ERROR2(64
6932: *H ACTUAL ARG ASSOCIATED WITH 2 DUMMY ARGS POSSIBLY SET IN REF TO
6933: *, 64, LAT(LL), 1, 1, 0)
6934: CALL ERROR2(24H TYPE 2 UNSAFE REFERENCE, 24, REF(3), -1, 0, 1)
6935: 90 L = LAT(L+3)
6936: 100 CONTINUE
6937: 110 LR = LAT(LR+3)
6938: 120 CONTINUE
6939: C
6940: C CHECK FOR EXTERNAL FCNS WITHIN ASF-DEFS WHICH CONTAIN
6941: C ASF-DUMMIES AND WHICH SET THEIR ARGS
6942: C
6943: 130 IF (REF(4).NE.1) GO TO 10
6944: II = REF(1) + 3
6945: IBR = .FALSE.
6946: DO 140 K=5,II,2
6947: J = REF(K)
6948: IF (J.EQ.0) GO TO 140
6949: IF (IGATT1(J,8).EQ.1) IBR = .TRUE.
6950: 140 CONTINUE
6951: IF (.NOT.IBR) GO TO 10
6952: C
6953: C SEE IF EXTERNAL FCN SETS ANY OF ITS ARGS
6954: C
6955: K = LL + SYMLEN + 1
6956: K = LAT(K)
6957: II = REF(1)/2
6958: DO 150 L=1,II
6959: IF (IGATT2(K,8).EQ.10 .AND. IGATT2(K,5).EQ.1) IBR = .FALSE.
6960: 150 CONTINUE
6961: IF (IBR) GO TO 10
6962: CALL ERROR2(37H ILLEGAL USAGE OF ASF-DUMMY IN REF TO, 37,
6963: * LAT(LL), 1, 1, 0)
6964: CALL ERROR2(1H , 0, REF(3), -1 ,0, 1)
6965: GO TO 10
6966: END
6967: C XXXXXCHECKS.f
6968: SUBROUTINE CHECKS(IROOT)
6969: C
6970: C MAIN IS INDEX IN NODE OF SUPEROOT IN LAT
6971: C
6972: LOGICAL ERR, SYSERR, ABORT, INSYM
6973: COMMON /PARAMS/ I1, I2, I3, I4, I5, I6, I7
6974: COMMON /DETECT/ ERR, SYSERR, ABORT
6975: CALL COMCHK(IROOT)
6976: CALL SCAN(IROOT)
6977: IF (SYSERR) GO TO 20
6978: 10 IF(.NOT.INSYM(I6,0)) GOTO 30
6979: CALL UNSAFE
6980: GO TO 10
6981: 20 WRITE (I2,99999)
6982: 99999 FORMAT (31H1UNSAFE REFERENCES NOT VERIFIED)
6983: 30 RETURN
6984: END
6985: C XXXXXCONSTR.f
6986: SUBROUTINE CONSTR(MAINND)
6987: LOGICAL SYSERR, ERR, ABORT, INSYM, GREEN, INDIR
6988: LOGICAL OVER
6989: C NOTE SETNOD SETS ABORT FOR 2 P.U. WITH SAME NAME
6990: C CONSTR SETS ABORT IF IT FINDS NO SYMBOL TABLES FROM PASS1
6991: C ASLEV SETS ABORT IF IT FINDS RECURSION IN CALLING GRAPH
6992: INTEGER OUTUT2, OUTUT3, OUTUT4, SYMLEN
6993: INTEGER PNODE, PLAT, LS(2)
6994: COMMON /HEAD/ LNODE, PNODE, NODE(500)
6995: COMMON /SCR1/ LINODE, INODE(500)
6996: COMMON /PARAMS/ I1, I2, I3, SYMLEN, OUTUT2, OUTUT3, OUTUT4
6997: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
6998: COMMON /DETECT/ ERR, SYSERR, ABORT
6999: DATA IBR /1/, JBR /4/
7000: DATA LS(1) /1H,/, LS(2) /1H /
7001: C
7002: C CONSTR DIRECTS THE FIRST PORTION OF PASS2
7003: C CALLS SETNOD TO CONSTRUCT THE LAT NODES FOR EACH P.U..
7004: C CALLS SETEXT TO SETUP BASIC EXERNALS NODES
7005: C AS NEEDED.
7006: C CALLS SETREF TO MAKE CONNECTS BETWEEN THE NODES
7007: C CALLS INVOKE TO CALCULATE LEVELS AND ASSIMILATE
7008: C ALL PROC INFO NECESSARY
7009: C CALLS ERASE TO GET RID OF NON-REFERENCE LINKS IN
7010: C CALLING GRAPH
7011: C CALLS CHKALL TO DO FINAL CHECKS OF ALL REFS AND TO
7012: C WRITE ALL GOOD REFS OUT FOR FUTURE PROCESSING
7013: C FORMS SUPERROOT IN GRAPH
7014: C CALLS OUTPUT ROUTINES WHENEVER CAN, TO GIVE PARTIAL
7015: C LISTINGS OF CURRENT DATA STRUCTURE
7016: C
7017: C USE INSYM TO POSSIBLY SKIP OVER BAD REFS WITH DUMMY SYM TBL
7018: C SETREF READS REFS FROM OUTUT3, WRITES ON OUTUT4
7019: C INVOKE READS FROM OUTUT4
7020: C CHKALL READS FROM OUTUT4, WRITES OUTUT3
7021: C UNSAFE READS FROM OUTUT3
7022: C INITIALIZE LEVEL ARRAY AND ISR
7023: ISR = 0
7024: DO 10 I=1,LNODE
7025: INODE(I) = 0
7026: 10 CONTINUE
7027: C INITIALIZE LOGICAL FLAGS FOR DETECTION OF PRESENCE OF
7028: C EXTERNAL ENTITIES (GREEN) AND INDIRECT REFS(INDIR)
7029: GREEN = .FALSE.
7030: INDIR = .FALSE.
7031: 20 IF(.NOT.INSYM(0,0)) GOTO 30
7032: C
7033: C SUCCESSFULLY READ SYMBOL TABLE
7034: C
7035: CALL SETNOD
7036: IF (SYSERR .OR. ABORT) GO TO 130
7037: GO TO 20
7038: 30 REWIND OUTUT2
7039: IF (PNODE.EQ.1) GO TO 150
7040: C CHANGE LEVEL ON ASFS SO DONT PROCESS THEM
7041: L = PNODE - 1
7042: DO 40 I=1,L
7043: IF (NODE(I).LT.0) INODE(I) = -2
7044: 40 CONTINUE
7045: C
7046: C SETUP BASIC EXTERNAL DEFNS AS NEEDED
7047: C
7048: CALL SETEXT
7049: IF (SYSERR) GO TO 130
7050: C
7051: C READ IN SYMBOL TABLES
7052: C SETREF WILL READ IN REFS
7053: C
7054: 50 IF(.NOT.INSYM(OUTUT3, OUTUT4)) GOTO 60
7055: CALL SETREF ( GREEN, INDIR )
7056: IF (SYSERR .OR. ABORT) GO TO 130
7057: GO TO 50
7058: 60 REWIND OUTUT2
7059: REWIND OUTUT3
7060: WRITE (OUTUT4) IBR, JBR, IBR
7061: REWIND OUTUT4
7062: IF(.NOT.INDIR) GOTO 70
7063: C
7064: C CALL LEVEL ALG
7065: C
7066: CALL INVOKE
7067: IF (ABORT .OR. SYSERR) GO TO 130
7068: REWIND OUTUT2
7069: REWIND OUTUT4
7070: C
7071: C CHECK AND EXPAND REFS AND SAVE ALL GOOD ONES FOR LATER
7072: C
7073: 70 IF(.NOT.INSYM(OUTUT4,OUTUT3)) GOTO 80
7074: CALL CHKALL
7075: IF (SYSERR) GO TO 130
7076: GO TO 70
7077: 80 WRITE (OUTUT3) IBR, JBR, IBR
7078: C
7079: C CONSTRUCT SUPEROOT IN LAT
7080: C
7081: IF (PNODE+1.GT.LNODE) GO TO 180
7082: IF (PLAT+SYMLEN+7.GT.LLAT) GO TO 160
7083: NODE(PNODE) = PLAT
7084: C MAINND IS SUPEROOT INDEX IN NODE
7085: C ISR IS SUPEROOT INDEX IN LAT
7086: MAINND = PNODE
7087: ISR = PLAT
7088: PNODE = PNODE + 1
7089: LAT(PLAT) = LS(1)
7090: PLAT = PLAT + 1
7091: IF (SYMLEN.EQ.1) GO TO 100
7092: DO 90 I=2,SYMLEN
7093: L = PLAT + I - 2
7094: LAT(L) = LS(2)
7095: 90 CONTINUE
7096: PLAT = L + 1
7097: 100 L = PLAT + 5
7098: DO 110 I=PLAT,L
7099: LAT(I) = 0
7100: 110 CONTINUE
7101: LAT(L+1) = 5
7102: PLAT = L + 2
7103: C
7104: C LOOK FOR CALLABLE PGM UNITS WITHOUT PARENTS
7105: C
7106: L = PNODE - 2
7107: DO 120 I=1,L
7108: K = SYMLEN + 3 + IABS(NODE(I))
7109: IF (LAT(K).EQ.0) CALL SETPD(IABS(NODE(I)), ISR)
7110: IF (SYSERR) GO TO 130
7111: 120 CONTINUE
7112: 130 IF(.NOT.GREEN) GOTO 190
7113: C ERASE GREEN LINKS
7114: L = PNODE - 2
7115: DO 210 I = 1,L
7116: C SKIP ASF NODES
7117: IF(NODE(I) .LT. 0) GOTO 210
7118: C FIND HEAD OF GREEN LINKS
7119: N = NODE(I) + SYMLEN + 3
7120: 220 IF(LAT(N+1) .LE. 0) GOTO 230
7121: N = LAT(N+1)
7122: GOTO 220
7123: 230 LAT(N+1) = 0
7124: 210 CONTINUE
7125: 190 OVER = SYSERR
7126: SYSERR = .FALSE.
7127: CALL OUT2 (ISR)
7128: SYSERR = SYSERR.OR.OVER
7129: IF(SYSERR) CALL ERROR1(
7130: * 56H ILLEGAL COMMON USAGE AND UNSAFE REFERENCES NOT VERIFIED,
7131: * 56)
7132: CALL OUT2C
7133: 140 RETURN
7134: 150 ABORT = .TRUE.
7135: GO TO 140
7136: 160 CALL ERROR1(33H IN CONSTR, TABLE OVERFLOW OF LAT, 33)
7137: 170 SYSERR = .TRUE.
7138: GO TO 130
7139: 180 CALL ERROR1(34H IN CONSTR, TABLE OVERFLOW OF NODE, 34)
7140: GO TO 170
7141: END
7142: C XXXXXOUT2.f
7143: SUBROUTINE OUT2(ISR)
7144: INTEGER SYMLEN, PNODE, BL, PLAT, STACK, Q(3), C(12),
7145: * OUTLAT, OUTCOM, OUTUT
7146: LOGICAL ERR, SYSERR, ABORT
7147: EXTERNAL EXCH
7148: COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, I1, I2, II1
7149: COMMON /DETECT/ ERR, SYSERR, ABORT
7150: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
7151: COMMON /CEXPRS/ LSTACK, STACK(620)
7152: COMMON /HEAD/ LNODE, PNODE, NODE(500)
7153: COMMON /SCR1/ LINODE, INODE(500)
7154: DATA C(1) /1HE/, C(2) /1HD/, C(3) /1HR/, C(4) /1HI/, C(5) /1HC/,
7155: * C(6) /1HL/, C(7) /1HS/, C(8) /1HA/, C(9) /1HF/, IP /1HP/, IBL
7156: * /1H-/, C(12) /1HU/, C(10) /1HB/, C(11) /1HN/
7157: DATA BL /1H /
7158: C
7159: C ROUTINE PRINTS CALLING GRAPH
7160: C
7161: IF (PNODE.LE.2) GO TO 110
7162: C
7163: C GRAPH
7164: C
7165: I3 = PNODE - 1
7166: IF (ISR.NE.0) I3 = I3 - 1
7167: C
7168: C SORT LATTICE
7169: C
7170: DO 10 I=1,I3
7171: INODE(I) = IABS(NODE(I))
7172: 10 CONTINUE
7173: CALL SSORT(EXCH, LAT, LLAT, INODE, I3, 0)
7174: DO 100 IA=1,I3
7175: I = INODE(IA)
7176: L = I + SYMLEN + 6
7177: IF (MOD(LAT(L),8).EQ.4) GO TO 100
7178: CALL S5UNPK(LAT(I), STACK(1), 6)
7179: WRITE (OUTUT,99999) (STACK(L),L=1,6)
7180: 99999 FORMAT (///1X, 6A1//)
7181: C
7182: C GET ARGS IF ANY
7183: C
7184: IS = 1
7185: K = SYMLEN + I
7186: L = LAT(K)
7187: IF (L) 70, 70, 20
7188: 20 K = K + 1
7189: K = LAT(K)
7190: IF (L*8.GT.LSTACK) GO TO 120
7191: DO 60 LL=1,L
7192: Q(1) = IGATT2(K,8)
7193: IF (Q(1).EQ.5 .OR. Q(1).EQ.6 .OR. Q(1).EQ.13) GO TO 30
7194: Q(1) = IGATT2(K,1)
7195: Q(2) = IGATT2(K,5)
7196: Q(3) = IGATT2(K,7)
7197: STACK(IS) = IBL
7198: STACK(IS+2) = IBL
7199: IF (Q(1).GE.8) STACK(IS) = C(1)
7200: L1 = MOD(Q(1),8) + 2
7201: STACK(IS+1) = C(L1)
7202: IF (Q(2).EQ.1) STACK(IS+2) = C(7)
7203: STACK(IS+3) = C(7)
7204: IF (Q(3).NE.0) STACK(IS+3) = C(8)
7205: GO TO 40
7206: 30 STACK(IS) = IP
7207: STACK(IS+1) = IBL
7208: STACK(IS+2) = IBL
7209: STACK(IS+3) = IBL
7210: 40 DO 50 LK=4,7
7211: L1 = LK + IS
7212: STACK(L1) = BL
7213: 50 CONTINUE
7214: IS = IS + 8
7215: K = LAT(K+3)
7216: 60 CONTINUE
7217: IS = IS - 1
7218: C PRINT ARGUMENTS
7219: K = 48
7220: IF (K.GT.IS) K = IS
7221: WRITE(OUTUT,99998)(STACK(LK), LK=1,K)
7222: 99998 FORMAT(20H ARGUMENT ATTRIBUTES ,5X,6(8A1,1X))
7223: IF( K.EQ.IS ) GOTO 70
7224: 65 LK = K + 1
7225: K = LK + 47
7226: IF(K.GT.IS) K = IS
7227: WRITE(OUTUT,99997) (STACK(L1),L1=LK,K)
7228: 99997 FORMAT(25X,6(8A1,1X))
7229: IF(K.LT.IS) GOTO 65
7230: C
7231: C GET COMMON NAMES
7232: C
7233: 70 K = I + SYMLEN + 2
7234: K = OUTCOM(LAT(K),IS)
7235: IF (SYSERR) GO TO 110
7236: IF (K.EQ.0) GO TO 80
7237: CALL OUT2A(14H COMMON BLOCKS, 14, IS, 2)
7238: C
7239: C FIND PARENTS
7240: C
7241: 80 K = I + SYMLEN + 3
7242: K = OUTLAT(LAT(K),IS,ISR)
7243: IF (SYSERR) GO TO 110
7244: IF (K.EQ.0) GO TO 90
7245: CALL OUT2A(22H CALLED BY SUBPROGRAMS, 22, IS, 1)
7246: C
7247: C FIND DESCENDENTS
7248: C
7249: 90 K = I + SYMLEN + 4
7250: K = OUTLAT(LAT(K),IS,ISR)
7251: IF (SYSERR) GO TO 110
7252: IF (K.EQ.0) GO TO 100
7253: CALL OUT2A(18H CALLS SUBPROGRAMS, 18, IS, 1)
7254: 100 CONTINUE
7255: 110 RETURN
7256: 120 SYSERR = .TRUE.
7257: CALL ERROR1(33H IN OUT2, TABLE OVERFLOW OF STACK, 33)
7258: GO TO 110
7259: END
7260: C XXXXXSETNOD.f
7261: SUBROUTINE SETNOD
7262: INTEGER PLAT, COM, PNODE, PDSA, DSA, SYMLEN, PP, SYMHD, PCOM,
7263: * SETARG, FINDND, FINDCM
7264: LOGICAL ERR, SYSERR, ABORT
7265: COMMON /COMS/ LCOM, PCOM, COM(300)
7266: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
7267: COMMON /HEAD/ LNODE, PNODE, NODE(500)
7268: COMMON /DETECT/ ERR, SYSERR, ABORT
7269: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
7270: COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
7271: COMMON /FACTS/ NAME, NOST, ITYP, IASF
7272: COMMON /TABL/ NEXT, LABHD, SYMHD, IBNEXT
7273: COMMON /SCR1/ LINODE, INODE(500)
7274: C
7275: C LAT-IS THE CALLING GRAPH PLUS AUXILIARY NODES
7276: C PLAT-IS NEXT FREE WORD IN LAT
7277: C LLAT-IS LENGTH OF LAT
7278: C NODE-IS LIST OF ALL CALLING NODES INDICES IN LAT
7279: C (WILL BE IN ALPHABETIC ORDER BEFORE CHECKING COMMENCES)
7280: C PNODE-IS NEXT FREE WORD IN NODE
7281: C LNODE-IS LENGTH OF NODE
7282: C
7283: C P.U. NODE IN LAT
7284: C WD 1.....PACKED CHARACTERS OF NAME OF SUBPGM
7285: C WD2.....NUMBER OF ARGS
7286: C WD3.....PTR TO HEAD OF LINEAR LINKED ORDERED LIST OF
7287: C ARGUMENT NODES IN LAT
7288: C WD4.....PTR TO HEAD OF LINEAR LINKED LIST OF COMMON NODES
7289: C IN LAT
7290: C WD5.....PTR TO HEAD OF LINEAR LINKED LIST OF INDICES IN
7291: C LAT OF ENTRIES FOR PARENT NODES
7292: C WD6.....PTR TO HEAD OF LINEAR LINKED LIST OF INDICES IN
7293: C LAT OF ENTRIES FOR DESCENDENT NODES
7294: C WD7.....PTR TO HEAD OF LINEAR LINKED LIST OF SEQUENCE NOS OF
7295: C BAD REFERENCES; INCONSISTANT TYPE OF FCN/SUBR REFERENCE, INCORR
7296: C NUMBER OF ARGS, AND RECURSIVE CALL OF SELF ARE THE THREE
7297: C TYPES OF BAD REFS
7298: C WD8.....BITS 0-2 TYPE OF SUBPGM: 0 SUBR, 1 FCN, 2 BLOCK DATA,
7299: C 3 MAIN, 4 ASF, 5 SUPEROOT
7300: C BITS 3-5 (IF FCN OR ASF) CONTAIN TYPE OF FCN: 0 DP, 1 RL,
7301: C 2 INT, 3 COMP, 4 LOG
7302: C
7303: C ARGUMENT NODE IN LAT
7304: C WD1.....ATTRIBUTES (SAME AS IN DSA, SEE LOOKUP)
7305: C WD2.....LENGTH (IN PROCEDURE ARGS THIS WORD POINTS TO
7306: C HEAD OF LINEAR LINKED LIST OF ACTUAL SUBPGM NAMES ASSOCIATED
7307: C WITH THIS ARG IN THE PROGRAM; ALSO HAVE INDEX IN LAT OF
7308: C SUBPRGM IN WHICH THE ASSOC OCCURS
7309: C WD 3.....PTR TO HEAD OF LINEAR LINKED LIST OF PARENT ARGS
7310: C (ARGS FROM PARENT RTNES SENT DOWN TO BE ASSOC. WITH THIS ARG)
7311: C WD 4.....PTR TO HEAD OF LINEAR LINKED LIST OF DESC. ARGS
7312: C (ARGS FROM DESC RTNES WHICH THIS ARG IS ASSOC. WITH)
7313: C WD 5.....PTR TO NEXT ARG NODE OR 0
7314: C
7315: C COMMON NODE IN LAT
7316: C WD 1.....INDEX OF ENTRY FOR THIS COMMON IN COM
7317: C WD 2.....1 IF COMMON STORED INTO BY THIS P.U. ELSE 0
7318: C WD 3.....PTR TO NEXT COMMON NODE
7319: C CREATE NODE PTR TO NEW NODE IN LAT
7320: C
7321: IF (PNODE.GT.LNODE) GO TO 170
7322: IF (PLAT+SYMLEN+7.GT.LLAT) GO TO 190
7323: C
7324: C CHECK IF SUBPROGRAM HAS NAME SAME AS ANOTHER SUBPROGRAM
7325: C OR A COMMON BLOCK
7326: C
7327: II = IGATT1(NAME,8)
7328: IF (II.EQ.11) GO TO 10
7329: IF (FINDND(DSA(NAME+4),IROOT)) 10, 10, 20
7330: 10 IF (FINDCM(DSA(NAME+4))) 40, 40, 30
7331: 20 ERR = .TRUE.
7332: 30 CALL ERROR2(45H SUBPROGRAM AND/OR COMMON BLOCK NAME CONFLICT, 45,
7333: * DSA(NAME+4), 1, 1, 1)
7334: IF (.NOT.ERR) GO TO 40
7335: ERR = .FALSE.
7336: ABORT = .TRUE.
7337: GO TO 160
7338: 40 NODE(PNODE) = PLAT
7339: IROOT = PNODE
7340: PNODE = PNODE + 1
7341: C
7342: C ENTER NAME INTO NODE
7343: C
7344: DO 50 I=1,SYMLEN
7345: L = NAME + 3 + I
7346: LL = PLAT - 1 + I
7347: LAT(LL) = DSA(L)
7348: 50 CONTINUE
7349: C
7350: C PP POINTS TO CURRENT RTNE NODE IN LAT
7351: C
7352: PP = PLAT
7353: PLAT = LL + 6
7354: LL = LL + 1
7355: DO 60 I=LL,PLAT
7356: LAT(I) = 0
7357: 60 CONTINUE
7358: C
7359: C 0 SUBR, 1 FCN, 2 BLOCK DATA, 3 MAIN, 4 ASF, 5 SUPEROOT
7360: C
7361: LAT(PLAT+1) = II/4
7362: C INITIALIZE LEVEL OF BLOCK DATA TO -2
7363: IF (LAT(PLAT+1).EQ.2) INODE(IROOT) = -2
7364: IF (LAT(PLAT+1).NE.1) GO TO 70
7365: L = IGATT1(NAME,1)
7366: LAT(PLAT+1) = LAT(PLAT+1) + 8*MOD(L,8)
7367: 70 PLAT = PLAT + 2
7368: C
7369: C HAVING INITIALIZED NODE TO 0, LOOK FOR ARGS
7370: C
7371: IF (DSA(NAME+2)) 80, 90, 80
7372: 80 L = PP + SYMLEN
7373: LAT(L) = SETARG(PP,NAME)
7374: IF (SYSERR) GO TO 160
7375: C
7376: C READ THROUGH SYMBOL TABLE FOR COMMON BLOCK DEFNS AND ASF DEFS
7377: C AND SETTING OF COMMON REGION
7378: C
7379: 90 K = SYMHD
7380: 100 IF (K) 110, 160, 110
7381: 110 LL = IGATT1(K,8)
7382: C
7383: C CHECK FOR ASF AND COMMON DEFNS OR COMMON
7384: C SETTING INFO
7385: C
7386: GO TO (140, 120, 140, 140, 140, 140, 130, 150, 140, 150, 140,
7387: * 140, 140, 140), LL
7388: C
7389: C CREATE ASF NODE
7390: C
7391: 120 CALL SETASF(PP, K)
7392: IF (SYSERR) GO TO 160
7393: GO TO 140
7394: C
7395: C CREATE COM ENTRY
7396: C
7397: 130 CALL SETCOM(PP, K)
7398: IF (SYSERR) GO TO 160
7399: 140 K = DSA(K+3)
7400: GO TO 100
7401: C
7402: C CHECK IF ELEMENT IN COMMON
7403: C
7404: 150 LL = IGATT1(K,2)
7405: L = IGATT1(K,5)
7406: IF (L.NE.1 .OR. LL.NE.1) GO TO 140
7407: L = DSA(K+2)
7408: L = DSA(L+1)
7409: CALL MKCOM(PP, L)
7410: IF (SYSERR) GO TO 160
7411: GO TO 140
7412: 160 RETURN
7413: 170 CALL ERROR1(34H IN SETNOD, TABLE OVERFLOW OF NODE, 34)
7414: 180 SYSERR = .TRUE.
7415: GO TO 160
7416: 190 CALL ERROR1(33H IN SETNOD, TABLE OVERFLOW OF LAT, 33)
7417: GO TO 180
7418: END
7419: C XXXXXCHK1.f
7420: INTEGER FUNCTION CHK1(IR, IE)
7421: C
7422: C PROGRAM UNIT AT LAT(IR) CALLS PROGRAM UNIT AT LAT(IE)
7423: C CHK1 RETURNS 1 IF REF OK ELSE 0
7424: C CHECKS FOR INCONSISTENT SYBPGM USAGE, CORRECT NO. OF
7425: C ARGS, CORRECT USAGE MATCH UP OF ARGS
7426: C
7427: INTEGER PREF, REF, PDSA, DSA, PLAT, SYMLEN, IBR(1)
7428: COMMON /CREF/ LREF, PREF, REF(100)
7429: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
7430: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
7431: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
7432: CHK1 = 0
7433: C CHECKS FOR SELF RECURSION
7434: IF (IE.NE.IR) GO TO 10
7435: CALL ERROR2(24H RECURSIVE CALL OF SELF , 24, REF(3), -1, 1, 1)
7436: GO TO 100
7437: C CHECKS FOR USAGE OF SUBPGM CONSISTENT WITH DEF
7438: 10 I = IE + SYMLEN + 6
7439: N = MOD(LAT(I),8)
7440: IF (N.EQ.REF(4) .OR. N.EQ.6 .AND. REF(4).EQ.1) GO TO 20
7441: CALL ERROR2(38H INCONSISTENT REFERENCE TO SUBPROGRAM , 38,
7442: * LAT(IE), 1, 1, 0)
7443: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
7444: GO TO 100
7445: C CHECKS FOR CORRECT NO. ARGS
7446: 20 I = IE + SYMLEN
7447: IF (LAT(I).EQ.REF(1)/2) GO TO 30
7448: CALL ERROR2(42H INCORRECT NUMBER OF ARGS IN REFERENCE TO , 42,
7449: * LAT(IE), 1, 1, 0)
7450: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
7451: GO TO 100
7452: C ARE DONE WITH REF IF IT HAS NO ARGS
7453: 30 CHK1 = 1
7454: IF(LAT(I)) 100, 100, 40
7455: C CHECK USAGES OF ARGS IN CALL VS USAGES OF ARGS IN DEF
7456: C N POINTS TO DUMMY ARG ENTRY
7457: 40 I = LAT(I)
7458: N = IE + SYMLEN + 1
7459: L = 5
7460: DO 80 K=1,I
7461: MD = IGATT2(LAT(N),8)
7462: IF (MD.NE.13 .AND. MD.NE.5 .AND. MD.NE.6) GO TO 60
7463: C HAVE A PROC ARG IN DEF
7464: C NEED A PROC ARG IN REF
7465: IF (REF(L).EQ.0) GO TO 50
7466: MR = IGATT1(REF(L),8)
7467: IF (MR.EQ.13 .OR. MR.EQ.6 .OR. MR.EQ.5) GO TO 70
7468: 50 IBR(1) = K
7469: CALL ERROR2(36H INCOMPATIBLE USAGE ASSOCIATED WITH ,36,IBR,-2,1,0)
7470: CALL ERROR2(17H IN REFERENCE TO ,17,LAT(IE), 1, 0, 0)
7471: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
7472: CHK1 = 0
7473: GOTO 70
7474: C HAVE VARIABLE OR ARRAY AS ARG IN DEF
7475: C NEED SAME IN REF
7476: 60 IF (REF(L).EQ.0) GO TO 70
7477: MR = IGATT1(REF(L),8)
7478: IF (MR.EQ.13 .OR. MR.EQ.5 .OR. MR.EQ.6) GO TO 50
7479: 70 N = LAT(N) + 3
7480: L = L + 2
7481: 80 CONTINUE
7482: 100 RETURN
7483: END
7484: C XXXXXCHK2.f
7485: INTEGER FUNCTION CHK2(IR, IE)
7486: C
7487: C PROGRAM UNIT AT LAT(IR) CALLS PROGRAM UNIT AT LAT(IE)
7488: C CHK2 RETURNS 1 IF REF IS OK, ELSE 0
7489: C CHECKS TYPE OF FCN IF FCN IS REFERENCED,
7490: C CHECKS PROC PARAMETERF FOR COMPATIBLE USAGE AND TYPE
7491: C TYPE AND STRUCTURE OF VARIABLE
7492: C AND ARRAY ARGS, BUILDS UPWARD LINKS BETWEEN
7493: C DUMMIES FOR SETTING INFO TRANSFER IN SCAN
7494: C BAD STRUCTURE MATCHING MAKES REF BAD
7495: C NO DUMMY LINKS CREATED IN THIS CASE
7496: C
7497: INTEGER REF, PREF, PDSA, DSA, PLAT, SYMLEN, FINDND, AER(1)
7498: LOGICAL ERR, SYSERR, ABORT
7499: COMMON /DETECT/ ERR, SYSERR, ABORT
7500: COMMON /CREF/ LREF, PREF, REF(100)
7501: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
7502: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
7503: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
7504: COMMON /FACTS/ NAME, NOST, ITYP, IASF
7505: CHK2 = 1
7506: C CHECK TYPE OF FCN CALLED IF A FCN
7507: IF (REF(4).NE.1) GO TO 10
7508: I = IE + SYMLEN + 6
7509: IF (MOD(IGATT1(REF(2),1),8).EQ.LAT(I)/8) GO TO 10
7510: IF (MOD(LAT(I),8).EQ.6 .AND. IGATT1(REF(2),1)/8.NE.1) GO TO 10
7511: CALL ERROR2(39H INCOMPATIBLE FCN TYPE IN REFERENCE TO , 39,
7512: * LAT(IE), 1, 1, 0)
7513: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
7514: C CYCLE THROUGH ARGS IF ANY
7515: 10 I = IE + SYMLEN
7516: IF (LAT(I).EQ.0) GO TO 170
7517: I = LAT(I)
7518: N = IE + SYMLEN + 1
7519: L = 5
7520: DO 160 K=1,I
7521: AER(1) = K
7522: L1 = IGATT2(LAT(N),8)
7523: IF (L1.EQ.13 .OR. L1.EQ.6 .OR. L1.EQ.5) GO TO 90
7524: C CHECK STRUCTURE AND TYPE OF VARIABLES
7525: C AND ARRAY ARGUMENTS
7526: K1 = MOD(IGATT2(LAT(N),1),8)
7527: K2 = IGATT2(LAT(N),7)
7528: IF (K2.GT.1) K2 = 1
7529: L1 = MOD(REF(L+1),8)
7530: L2 = MOD(REF(L+1),32)/8
7531: C
7532: C CHECK TYPE, CHECK HOLLERITH CONSTANTS MATCHED
7533: C ALWAYS TO INTEGER ARRAYS
7534: C
7535: IF (L1.NE.5 .OR. REF(L).NE.0) GO TO 20
7536: IF (REF(4).EQ.0 .AND. K2.NE.0 .AND. K1.EQ.2) GO TO 40
7537: CALL ERROR2(33H HOLLERITH CONST ASSOCIATED WITH ,33,AER,-2,1,0)
7538: CALL ERROR2(17H IN REFERENCE TO , 17,LAT(IE),1, 0, 0)
7539: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
7540: CHK2 = 0
7541: GO TO 150
7542: 20 IF (K1.EQ.L1 .OR. K1.EQ.2 .AND. L1.EQ.5) GO TO 30
7543: CALL ERROR2(33H MISMATCHED TYPE ASSOCIATED WITH ,33,AER,-2,1,0)
7544: CALL ERROR2(17H IN REFERENCE TO ,17,LAT(IE),1, 0, 0)
7545: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
7546: C
7547: C CHECK STRUCTURE L2 = 0 SCALAR, 1 ARRAY, 2 ARRAY ELE
7548: C
7549: 30 IF (K2.EQ.1 .AND. L2.GT.0 .OR. K2.EQ.0 .AND. (L2.EQ.2 .OR.
7550: * L2.EQ.0)) GO TO 40
7551: CALL ERROR2(38H MISMATCHED STRUCTURE ASSOCIATED WITH ,38,AER,-2,
7552: * 1, 0)
7553: CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE),1, 0, 0)
7554: CALL ERROR2(1H1, 0, REF(3), -1,0,1)
7555: CHK2 = 0
7556: GO TO 150
7557: C
7558: C CHECK IF ACTUAL ARG IS NON-PROC DUMMY ARG IN CURRENT PGM UNIT
7559: C IF SO CREATE ARGLINK.
7560: C NO ARGLINK CREATED IF FCN CALLED IS AN ASF
7561: C
7562: 40 IF (REF(L).LE.0 .OR. REF(4).EQ.4) GO TO 150
7563: K1 = IGATT1(REF(L),4)
7564: IF (K1.EQ.0) GO TO 150
7565: C
7566: C FIND REL. POSITION OF CALLING PGM
7567: C DUMMY , L1 PTS TO IT IN LAT
7568: L3 = DSA(NAME+2)
7569: KK = 0
7570: 50 KK = KK + 1
7571: IF (DSA(L3).EQ.REF(L)) GO TO 60
7572: L3 = DSA(L3+1)
7573: GO TO 50
7574: 60 K2 = 0
7575: L1 = IR + SYMLEN - 2
7576: 70 L1 = LAT(L1+3)
7577: K2 = K2 + 1
7578: IF (K2.LT.KK) GO TO 70
7579: C FIND REL POSITION OF CALLED DUMMY ARG
7580: C L2 PTS TO IT IN LAT
7581: K1 = 0
7582: L2 = IE + SYMLEN - 2
7583: 80 L2 = LAT(L2+3)
7584: K1 = K1 + 1
7585: IF (K1.LT.K) GO TO 80
7586: IF (MATCH(LAT(L2+2),1,L1).NE.0) GO TO 150
7587: IF (PLAT+2.GT.LLAT) GO TO 180
7588: LAT(PLAT) = L1
7589: LAT(PLAT+1) = LAT(L2+2)
7590: LAT(L2+2) = PLAT
7591: PLAT = PLAT + 2
7592: GO TO 150
7593: C CHECK PROC ARGUMENTS TO SEE THEY ARE CORRECT USAGE AND TYPE
7594: C LAT(N) PTS TO DUMMY ARG ENTRY IN LAT
7595: C REF(L) PTS TO CORRESP REF ARG IN DSA
7596: 90 IF (IGATT1(REF(L),4).EQ.1) GO TO 110
7597: C REFERENCE CONTAINS AN AACTUAL PROC NAME
7598: C CHECK FOR MISSING SUBPROGRAM
7599: L3 = REF(L)
7600: L2 = FINDND(DSA(L3+4),L3)
7601: IF (L2.NE.0) GO TO 100
7602: L3 = REF(L) + 4
7603: CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(L3), 1, 1, 0)
7604: CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE), 1, 0, 0)
7605: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
7606: GO TO 150
7607: C CALL CHK3 TO PREFORM CHECKS
7608: 100 L5 = L2 + SYMLEN + 6
7609: CALL CHK3(LAT(N), L2, L1, MOD(LAT(L5),8), IE, REF(3), AER)
7610: GO TO 150
7611: C REFERENCE CONTAINS A DUMMY ARGUMENT MUST CHECK ALL ACTUALS
7612: C WHICH CAN CORRESPOND TO THAT DUMMY
7613: C FIRST FIND ITS CORRESP ACTUAL, IF ANY
7614: 110 L2 = REF(L)
7615: L2 = DSA(L2+2)
7616: C L2 IS OFFSET AMONG ALL DUMMIES OF LAT(IR)
7617: C OF THE DUMMY ARG AT REF(L)
7618: L3 = IR + SYMLEN + 1
7619: L3 = LAT(L3)
7620: IF (L2.EQ.1) GO TO 130
7621: DO 120 L4=2,L2
7622: L3 = LAT(L3+3)
7623: 120 CONTINUE
7624: C L3 PTS TO DUMMY ARG IN CALLING RTNE
7625: 130 L3 = LAT(L3+1)
7626: C L3 CONTAINS OFFSET FOR PROC ACTUALS
7627: C MATCHED TO THIS DUMMY ARG
7628: C IN TEMPLATED OFF LAT(IR)
7629: L2 = IR + SYMLEN + 5
7630: IF (LAT(L2).NE.0) GO TO 140
7631: L3 = REF(L) + 4
7632: CALL ERROR2(35H NO ACTUAL PROCS SUBSTITUTABLE FOR , 35,
7633: * DSA(L3), 1, 1, 0)
7634: CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE), 1, 0, 0)
7635: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
7636: GO TO 150
7637: C L2 PTS TO ACTUALS TEMPLATE
7638: 140 L2 = LAT(L2)
7639: L4 = L2 + L3
7640: C LAT(L4) IS ACTUAL PAIRED TO REF(L)
7641: L5 = LAT(L4) + SYMLEN + 6
7642: CALL CHK3(LAT(N), LAT(L4), L1, MOD(LAT(L5),8), IE, REF(3), AER)
7643: C CYCLE TO NEXT ACTUAL
7644: L2 = LAT(L2) + L2
7645: IF (LAT(L2)) 150, 150, 140
7646: 150 L = L + 2
7647: N = LAT(N) + 3
7648: 160 CONTINUE
7649: 170 RETURN
7650: 180 SYSERR = .TRUE.
7651: CHK2 = 0
7652: CALL ERROR1(31H IN CHK2, TABLE OVERFLOW OF LAT, 31)
7653: GO TO 170
7654: END
7655: C XXXXXFIND.f
7656: INTEGER FUNCTION FIND(K)
7657: C
7658: C FIND HAS TO FIND THE INDEX IN NODE
7659: C OF THE LATTICE ENTRY AT K, DOES A
7660: C LINEAR SEARCH ON NODE ARRAY
7661: C P.U. ASSUMES NODE ARRAY SET UP PROPERLY
7662: C AND THAT NODES ITS ASKED TO FIND ARE ALWAYS IN THE
7663: C ARRAY SOMEWHERE. CAN BE ASKED TO FIND INDEX OF
7664: C ANY NODE IN LATTICE, EVEN ASFS
7665: C
7666: INTEGER PNODE
7667: COMMON /HEAD/ LNODE, PNODE, NODE(500)
7668: L = PNODE - 1
7669: DO 10 I=1,L
7670: IF (K.NE.IABS(NODE(I))) GO TO 10
7671: FIND = I
7672: GO TO 20
7673: 10 CONTINUE
7674: 20 RETURN
7675: END
7676: C XXXXXASLEV.f
7677: SUBROUTINE ASLEV(IPT)
7678: C
7679: C ASLEV TAKES A SUBLATTICE WITH ITS ROOT AT NODE(IABS(IPT)))
7680: C AND READJUSTS THE LEVELS IN THE SUBLATTICE
7681: C IN ACCORDANCE WITH NEW LEVEL AT ROOT
7682: C NOTE, IPT LT 0 FROM CALL IN SETREF (EXT) AND FROM ACTUALS
7683: C PASSED DOWN IN PROC
7684: C
7685: INTEGER PNODE, STACK, PLAT, FIND, SYMLEN
7686: INTEGER ZERO(1)
7687: LOGICAL SYSERR, ERR, ABORT, GR
7688: COMMON /DETECT/ ERR, SYSERR, ABORT
7689: COMMON /HEAD/ LNODE, PNODE, NODE(500)
7690: COMMON /SCR1/ LINODE, INODE(500)
7691: COMMON /SCR2/ LSTACK, STACK(500)
7692: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
7693: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
7694: DATA ZERO(1) /0/
7695: C
7696: C STACK (IS) IS SIGNED NODE INDEX OF SUBPGM
7697: C IF GT 0, NODE IS ALONG A RED LINK TO PARENT
7698: C IF LT 0, NODE IS ALONG A GREEN LINK TO PARENT
7699: C
7700: C STACK(IS+1) IS PTR TO TWO WORD DESC ENTRY FOR THIS
7701: C SUBPGM, OR 0 FOR END OF DESC LIST
7702: C
7703: K = IABS (IPT )
7704: K = SYMLEN + NODE(K) + 4
7705: STACK(2) = IPT
7706: STACK (1) = IABS ( LAT(K) )
7707: IS = 2
7708: C DOES TOP OF STACK ENTRY HAVE UNVISITED DESC
7709: 10 IF (STACK(IS-1).NE.0) GO TO 20
7710: C TEST IF ARE DONE WITH SUBLATTICE
7711: IF (IS.EQ.2) RETURN
7712: C POP UP A LEVEL IN PATH
7713: IS = IS - 2
7714: GO TO 10
7715: C UPDATE ENTRY OF NEXT DESCENDENT TO BE CHECKED ON STACK
7716: 20 K = STACK(IS-1)
7717: STACK(IS-1) = IABS (LAT(K+1))
7718: C LAT(K) CONTAINS SIGNED INDEX OF DESC BEING PROCESSED
7719: C SIGN INDICATES COLOR OF LINK TO PARENT, (I.E.
7720: C NODE AT TOP OF STACK)
7721: C LT 0 IS GREEN LINK, GT 0 IS RED LINK
7722: C L IS INDEX IN NODE(*) OF DESC BEING PROCESSED
7723: C KK IS INDEX IN LAT(*) OF DESC BEING PROCESSED
7724: LL = 1
7725: IF( LAT(K) .LT. 0) LL = -1
7726: KK = IABS(LAT(K))
7727: L = FIND(KK)
7728: C SKIP ALL DESC WITH NEGATIVE LEVELS
7729: IF (INODE(L).LT.0) GO TO 10
7730: C SEE IF STACK TOO SHORT FOR LOOPS
7731: IF( IS.LE.2) GOTO 40
7732: C CHECK FOR LOOPS IN PATH STACK DESC
7733: LOOP = 0
7734: GR = .FALSE.
7735: IF(LL.EQ.(-1)) GR = .TRUE.
7736: DO 60 I = 2,IS,2
7737: IF(LOOP) 70,70,90
7738: 90 IF(STACK(I).LT.0) GR = .TRUE.
7739: GOTO 60
7740: 70 IF(L.EQ.IABS(STACK(I))) LOOP = I
7741: 60 CONTINUE
7742: C NO LOOPS
7743: IF(LOOP.EQ.0) GOTO 40
7744: C LOOP OF MIXED COLORED LINKS
7745: C DO NOT STACK DESC
7746: IF(GR) GOTO 10
7747: C RECURSION
7748: ABORT = .TRUE.
7749: CALL ERROR2(19H RECURSIVE CALL OF ,19,LAT(KK), 1, 1, 0)
7750: DO 80 K=LOOP,IS,2
7751: KK = IABS(STACK(K))
7752: KK = NODE(KK)
7753: 80 CALL ERROR2(11H INVOLVING ,11,LAT(KK),1, 0, 0)
7754: CALL ERROR2(1H1, 0, ZERO, -3, 0, 1)
7755: 30 RETURN
7756: C TEST IF DESC LEVEL IS ALREADY GT LEVEL OF PAR
7757: C THEN NEEDNT CHECK PART OF SUBLATTICE UNDER THIS DESC
7758: 40 K = IABS (STACK(IS))
7759: IF (INODE(L).GT.INODE(K)) GO TO 10
7760: C PUSH DESC ONTO STACK AFTER FIXING HIS LEVEL
7761: INODE(L) = INODE(K) + 1
7762: C TEST AGAINST LNODE BECAUSE SCRATCH ARRAY
7763: C IS AS LONG AS NODE ARRAY
7764: IF (IS+2.GT.LNODE) GO TO 50
7765: STACK(IS+2) = LL * L
7766: K = NODE(L) + SYMLEN + 4
7767: STACK(IS+1) = IABS( LAT(K))
7768: IS = IS + 2
7769: GO TO 10
7770: 50 SYSERR = .TRUE.
7771: CALL ERROR1(43H IN ASLEV, PATH LONGER THAN NUMBER OF NODES, 43)
7772: GO TO 30
7773: END
7774: C XXXXXINVOKE.f
7775: SUBROUTINE INVOKE
7776: C
7777: C PGM UNIT STEPS THROUGH NODES IN INVOCATION ORDER
7778: C PUSHING ACTUAL PROC ARGS DOWN LATTICE WHERE NECESSARY
7779: C AND READJUSTING LEVEL IF NECESSARY
7780: C
7781: INTEGER PNODE, PLAT, PDSA, DSA, SYMLEN, PREF, REF, FIND, CHK1,
7782: * ZERO(1), FINDND
7783: LOGICAL ERR, SYSERR, ABORT, OK, AOK
7784: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
7785: COMMON /DETECT/ ERR, SYSERR, ABORT
7786: COMMON /HEAD/ LNODE, PNODE, NODE(500)
7787: COMMON /SCR1/ LINODE, INODE(500)
7788: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
7789: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
7790: COMMON /CREF/ LREF, PREF, REF(100)
7791: COMMON /FACTS/ NAME, NOST, ITYPE, IASF
7792: DATA ZERO(1)/0/
7793: C NC IS CURRENT NODE, NP IS PREVIOUS NODE PROCESSED
7794: NC = 0
7795: 10 NP = NC
7796: OK = .TRUE.
7797: AOK = .TRUE.
7798: C
7799: C SEARCH FOR NEXT NODE TO DO, NODE WITH LOWEST POSIT LEVEL IN INODE
7800: C UPON ENTRY TO INVOKE, SUPEROOT IS -1, ASFS AND BLOCK DATA
7801: C ARE -2. IF CANT FIND A POSITIVE LEVEL ARE DONE
7802: C
7803: L = PNODE - 1
7804: DO 20 I=1,L
7805: IF (INODE(I).LT.0) GO TO 20
7806: NC = I
7807: GO TO 40
7808: 20 CONTINUE
7809: 30 RETURN
7810: 40 J = NC
7811: DO 50 I=J,L
7812: IF (INODE(I).GE.0 .AND. INODE(I).LT.INODE(NC)) NC = I
7813: 50 CONTINUE
7814: C READ IN SYMBOL TABLE FOR NODE(NC) AND POSITION REFS CORRECTLY
7815: CALL RDSYM(NC, NP)
7816: 60 IF (INREF(I6)) 140, 140, 70
7817: C HAVE A REFERENCE TO PROCESS
7818: 70 IF (IGATT1(REF(2),4).EQ.1) GO TO 80
7819: C PROCESSING A DIRECT REFERENCE
7820: C NEED ONLY PROCESS REF TEMPLATE IF ANY PROC ACTUAL ARGS IN REF
7821: L = REF(2)
7822: L = FINDND(DSA(L+4),K)
7823: CALL PROC(NODE(NC), L, K, AOK)
7824: IF (SYSERR .OR. ABORT) GO TO 30
7825: GO TO 60
7826: C PROCESSING AN INDIRECT REF
7827: 80 K = NODE(NC) + SYMLEN + 5
7828: K = LAT(K)
7829: IF (K.EQ.0) GO TO 150
7830: C K PTS TO A TEMPLATE OF ACTUALS AT LAT(NODE(NC))
7831: C L GIVES REL POSIT AMONG PROC DUMMIES IN LAT(NODE(NC))
7832: C OF PROC DUMMY BEING CALLED
7833: L = REF(2)
7834: L = DSA(L+2)
7835: I = NODE(NC) + SYMLEN + 1
7836: I = LAT(I)
7837: IF (L.EQ.1) GO TO 100
7838: DO 90 M=2,L
7839: I = LAT(I+3)
7840: 90 CONTINUE
7841: C
7842: C I PTS TO DUMMY PROC ARG ENTRY IN LAT
7843: C
7844: 100 M = LAT(I+1) + K
7845: M = LAT(M)
7846: C M PTS TO ACTUAL SUBSTITUTABLE FOR I
7847: L = FIND(M)
7848: C RECURSION DUE TO INDIRECT REF COMPLETING THE LOOP
7849: IF (-1.NE.INODE(L)) GO TO 110
7850: ABORT = .TRUE.
7851: CALL ERROR2(26H RECURSIVE LOOP INVOLVING , 26, DSA(NAME+4), 1,1,0)
7852: CALL ERROR2(14H AND POSSIBLY , 14, LAT(M), 1, 0, 1)
7853: GO TO 30
7854: C NOTE NEED NOT WORRY ABOUT MISSING SUBPGM SINCE
7855: C THEN ITS LAT INDEX COULDNOT BE IN TEMPLATE
7856: 110 IF (CHK1(NODE(NC),M).EQ.0) GO TO 130
7857: C PROCESSED A LEGAL INDIRET REF
7858: CALL SETPD(M, NODE(NC))
7859: IF (SYSERR) GO TO 30
7860: IF (-2.EQ.INODE(L) .OR. INODE(NC).LT.INODE(L)) GO TO 120
7861: INODE(L) = INODE(NC) + 1
7862: CALL ASLEV(L)
7863: IF (ABORT .OR. SYSERR) GO TO 30
7864: C LOOK FOR MORE ACTUALS
7865: 120 CALL PROC(NODE(NC), M, L, AOK)
7866: IF (SYSERR .OR. ABORT) GO TO 30
7867: 130 K = LAT(K) + K
7868: K = LAT(K)
7869: IF (K) 60, 60, 100
7870: C MARK CURRENT NODE DONE
7871: 140 INODE(NC) = -1
7872: GO TO 10
7873: 150 IF (.NOT.OK) GO TO 60
7874: K = NODE(NC)
7875: CALL ERROR2(20H NO ACTUAL PROCS IN ,20, LAT(K), 1, 1, 0)
7876: CALL ERROR2(28H CANNOT PROCESS FORMAL REFS , 28,
7877: * ZERO, -3, 0, 1)
7878: OK = .FALSE.
7879: GO TO 60
7880: END
7881: C XXXXXRDSYM.f
7882: SUBROUTINE RDSYM(IC, IP)
7883: C
7884: C PGM UNIT RDSYM POSITIONS I4,I6 CORRECTLY AND INPUTS SYMBOL
7885: C TABLE OF PGM UNIT AT NODE(IC) WHEN LAST ONE READ WAS THAT OF NODE
7886: C
7887: INTEGER SYMLEN, PDSA, PLAT, FINDND, PNODE, DSA
7888: LOGICAL INSYM, L
7889: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
7890: COMMON /FACTS/ NAME, NOST, ITYP, IASF
7891: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
7892: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
7893: COMMON /HEAD/ LNODE, PNODE, NODE(500)
7894: IF (IP.LT.IC) GO TO 10
7895: REWIND I4
7896: REWIND I6
7897: 10 L = INSYM(I6,0)
7898: IF (FINDND(DSA(NAME+4),I).EQ.NODE(IC)) RETURN
7899: 20 IF (INREF(I6).EQ.1) GO TO 20
7900: GO TO 10
7901: END
7902: C XXXXXPROC.f
7903: SUBROUTINE PROC(IP, IM, IIM, OK)
7904: C
7905: C P.U. AT LAT(IP) CALLS P.U. AT LAT(IM) (NODE(IIM))
7906: C PROC COLLECTS ACTUAL PROC TEMPLATE(S) FROM THE CALL IF IT CAN
7907: C CHECKS FOR MISSING SUBPGMS AND STORES TEMPLATES OFF PGM UNIT
7908: C AT LAT(IM), THEM PROC CALLS ASLEV TO READJUST LEVELS OF ACTUALS
7909: C SENT TO LAT(IM) VS LEVEL (IM)
7910: C
7911: LOGICAL ERR, SYSERR, ABORT, OK
7912: INTEGER STACK, SYMLEN, PDSA, DSA, REF, PREF, PNODE, PLAT, FINDND,
7913: * FIND, SS(120), KBR(1)
7914: COMMON /CEXPRS/ LSTACK, STACK(620)
7915: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
7916: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
7917: COMMON /CREF/ LREF, PREF, REF(100)
7918: COMMON /HEAD/ LNODE, PNODE, NODE(500)
7919: COMMON /SCR1/ LINODE, INODE(500)
7920: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
7921: COMMON /DETECT/ ERR, SYSERR, ABORT
7922: EQUIVALENCE (SS(1),STACK(501))
7923: DATA KBR(1) /0/
7924: LSS = 501
7925: C ARE THERE ARGS IN THIS REF
7926: IF (REF(1).NE.0) GO TO 20
7927: 10 RETURN
7928: C CYCLE THROUGH REF ARGS
7929: C JJ IS LAST ENTRY IN REF FOR ARGS
7930: C IS PTS TO FIRST FREE WD IN STACK
7931: C MAX IS 1 IF NO DUMMY PROCS IN REF, ELSE IS EQUAL TO THE
7932: C NUMBER OF ACTUAL PROCS SUBSTITUTABLE FOR THE DUMMY PROCS
7933: 20 JJ = REF(1) + 4
7934: IS = 1
7935: MAX = 0
7936: DO 90 I=5,JJ,2
7937: C SKIP OVER EXPR AS ACTUAL ARGS AND ALL ACTUALS BUT PROC ARGS
7938: IF (REF(I).EQ.0) GO TO 90
7939: IF (REF(I+1).NE.6) GO TO 90
7940: C SEE IF ACTUAL ARG IS DUMMY PROC ARG AT LAT(IP)
7941: C OR ACTUAL PROCEDURE
7942: IF (IGATT1(REF(I),4).EQ.1) GO TO 40
7943: C HAVE AN ACTUAL PROCEDURE
7944: L = REF(I)
7945: L = FINDND(DSA(L+4),K)
7946: IF (L.NE.0) GO TO 30
7947: C IF, AS GATHERING ACTUAL PROCS MATCHED TO DUMMY PROC ARGS
7948: C PROC FINDS A MISSING SUBPROGM, PROCESSING OF THIS REF CEASES
7949: L = REF(I)
7950: CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(L+4), 1, 1, 0)
7951: CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
7952: GO TO 10
7953: 30 IF (IS+2.GT.LSS) GO TO 200
7954: C 2 WD STACK ENTRY FOR AN ACTUAL PROC AS AN ACTUAL ARG
7955: C IS FIRST WD - 1, 2ND WD - LAT INDEX OF ACTUAL PROC
7956: STACK(IS) = 1
7957: STACK(IS+1) = L
7958: IF (MAX.EQ.0) MAX = 1
7959: IS = IS + 2
7960: GO TO 90
7961: C HAVE A DUMMY PROC CHECK OUT NO OF ACTUALS
7962: C MATCHED TO IT AND STACK THOSE WITH COUNTER ON TOP
7963: 40 L = IP + SYMLEN + 5
7964: L = LAT(L)
7965: IF (L.NE.0) GO TO 50
7966: IF (.NOT.OK) GOTO 10
7967: CALL ERROR2(26H MISSING ACTUAL PROCEDURES ,26, KBR(1), -1,1,1)
7968: OK = .FALSE.
7969: GO TO 10
7970: C COLLECT ACTUALS CORRESPONDING TO THIS PROC ARG
7971: C K IS REL POSIT OF PROC ARG AMONG ALL ARGS AT LAT(IP)
7972: C L PTS TO TEMPLATE AT LAT(IP)
7973: 50 K = REF(I)
7974: K = DSA(K+2)
7975: C J POINTS TO FIRST ELEMENT ON ARGLIST
7976: J = IP + SYMLEN + 1
7977: J = LAT(J)
7978: IF (K.LE.1) GO TO 70
7979: DO 60 LL=2,K
7980: J = LAT(J+3)
7981: 60 CONTINUE
7982: C K IS REL POSIT OF PROC ARG AMONG PROC ARGS IN LAT(IP)
7983: C THAT IS IT IS OFFSET NECESS TO READ CORRESP ACTUAL
7984: C PROCS OFF TEMPLATES AT LAT(IP)
7985: C J POINTS TO DUMMY PROC ARG ENTRY IN LAT (IP)
7986: 70 K = LAT(J+1)
7987: IF (IS+1.GE.LSS) GO TO 200
7988: C J POINTS TO POSITION IN STACK OF COUNT OF HOW MANY
7989: C ACTUALS ARE MATCHED TO THIS DUMMY
7990: J = IS
7991: STACK(IS) = 0
7992: IS = IS + 1
7993: 80 IF (IS+1.GE.LSS) GO TO 200
7994: C N WD STACK ENTRY FOR DUMMY PROC ARGS USED AS ACTUAL ARGS IN REF
7995: C WD 1 CONTAINS NO OF ACTUAL PROCS MATCHED TO THE DUMMY
7996: C WDS 2 - N CONTAIN THE LAT INDICES OF EACH ACTUAL PROC
7997: STACK(J) = STACK(J) + 1
7998: LL = K + L
7999: STACK(IS) = LAT(LL)
8000: IS = IS + 1
8001: L = LAT(L) + L
8002: L = LAT(L)
8003: IF (L.NE.0) GO TO 80
8004: IF (STACK(J).GT.MAX) MAX = STACK(J)
8005: 90 CONTINUE
8006: C HAVE COLLECTED ALL PROC ACTUALS CORRESP TO THE PROC
8007: C ARGS IN THE REF, NOTE MAX IS NO OF TEMPLATES RESULTING FROM
8008: C THIS REF TO BE PASSED TO LAT(IM) AS LONG AS THEIR DUPS
8009: C ARE NOT THERE ALREADY
8010: C BUILD EACH TEMPLATE IN LOOP AND CHECK FOR DUPLICATION
8011: C IF NOT THERE COPY INTO LAT OFF LAT(IM) AND CHECK LEVEL OF ACTUALS
8012: C PASSED DOWN VS LEVEL OF LAT(IM)
8013: IF (MAX.EQ.0) GO TO 10
8014: DO 190 I=1,MAX
8015: C CREATE PROC INDICES PORTION OF TEMPLATE IN SS
8016: K = 1
8017: ISS = 1
8018: 100 IF (K.GE.IS) GO TO 110
8019: L = 1
8020: IF (STACK(K).GT.1) L = I
8021: IF (ISS+1.GE.120) GO TO 200
8022: J = K + L
8023: SS(ISS) = STACK(J)
8024: K = K + STACK(K) + 1
8025: ISS = ISS + 1
8026: GO TO 100
8027: C HAVE TEMPLATE IN SS(1) THROUGH SS(ISS-1)
8028: C SEE IF IT HAS A DUPLICATE AT LAT(IM)
8029: 110 K = IM + SYMLEN + 5
8030: K = LAT(K)
8031: IST = ISS - 1
8032: 120 IF (K.EQ.0) GO TO 150
8033: DO 130 L=1,IST
8034: J = K + L
8035: IF (LAT(J).NE.SS(L)) GO TO 140
8036: 130 CONTINUE
8037: C FOUND DUPLICATE
8038: GO TO 190
8039: C HAVENT FOUND A DUPLICATE YET
8040: C SEE IF THERE ARE MORE TEMPLATES TO COMPARE
8041: 140 K = LAT(K) + K
8042: K = LAT(K)
8043: GO TO 120
8044: C NOT A DUPLICATE WILL ADD IT ON
8045: 150 IF (PLAT+IST+2.LE.LLAT) GO TO 160
8046: CALL ERROR1(32H IN PROC, TABLE OVERFLOW OF LAT , 32)
8047: SYSERR = .TRUE.
8048: GO TO 10
8049: C MAKE AN ENTRY CONSISTING OF 1ST WORD - NO OF PROCS+1, SUBSEQUENT
8050: C WORDS - PROCS LAT INDICES, LAST WORD - PTR
8051: C TO NEXT SUCH TEMPLATE
8052: 160 DO 170 L=1,IST
8053: J = PLAT + L
8054: LAT(J) = SS(L)
8055: 170 CONTINUE
8056: LAT(PLAT) = IST + 1
8057: L = PLAT
8058: PLAT = PLAT + IST + 2
8059: J = IM + SYMLEN + 5
8060: LAT(PLAT-1) = LAT(J)
8061: LAT(J) = L
8062: C CHECK LEVELS
8063: DO 180 L=1,IST
8064: J = FIND(SS(L))
8065: C FIND HEAD OF GREEN LINKS LIST AT LAT(IM)
8066: JR = IM + SYMLEN + 3
8067: JLR = -SS(L)
8068: 210 IF(LAT(JR+1) .LE. 0) GOTO 220
8069: JR = LAT(JR+1)
8070: GOTO 210
8071: C HAVE TOP OF GREEN LINKS LIST AT LAT(JR)
8072: 220 IF(LAT(JR+1) .EQ. 0) GOTO 230
8073: JR = IABS( LAT(JR+1) )
8074: C LOOK FOR DUPLICATE ENTRY ON GREEN LINKS LIST
8075: IF(LAT(JR) .EQ. JLR) GOTO 240
8076: GOTO 220
8077: C ADD ON ENTRY TO GREEN LINKS LIST
8078: 230 IF(PLAT + 2 .GT. LLAT) GOTO 250
8079: LAT(PLAT) = JLR
8080: LAT(PLAT+1) = 0
8081: LAT(JR+1) = -PLAT
8082: PLAT = PLAT+2
8083: 240 IF((-1).EQ.INODE(J) .OR. (-2).EQ.INODE(J) .OR.
8084: * INODE(J).GT.INODE(IIM)) GOTO 180
8085: INODE(J) = INODE(IIM) + 1
8086: CALL ASLEV (-J)
8087: IF (SYSERR .OR. ABORT) GO TO 10
8088: 180 CONTINUE
8089: 190 CONTINUE
8090: GO TO 10
8091: 200 SYSERR = .TRUE.
8092: CALL ERROR1(33H IN PROC, TABLE OVERFLOW OF STACK, 33)
8093: GO TO 10
8094: 250 SYSERR = .TRUE.
8095: CALL ERROR1(31H IN PROC, TABLE OVERFLOW OF LAT,31)
8096: GOTO 10
8097: END
8098: C XXXXXCHKALL.f
8099: SUBROUTINE CHKALL
8100: C
8101: C CHKALL READS IN REFS FROM OUTUT4 AND CHECKS THEM
8102: C EXPANDS ALL INDIRECTS AND CHECKS THEM, IF ALL OK
8103: C WRITES THE EXPANDED VERSION OUT ON OUTUT3
8104: C TEMPLATE WRITTEN OUT CONSISTS OF
8105: C PREF - NO OF WORDS TO FOLLOW
8106: C IBR - CODE .LT.3 TO SHOW OK REF
8107: C REF(1) - 2*NO OF ARGS
8108: C IJR - LAT INDEX OF CALLED P.U.
8109: C REF(3) - STMT NO OF REF
8110: C REF(4) - CODE 0-SUBR, 1-FCN
8111: C REF(5 -) - ARG ENTRIES
8112: C FOR DIRECT REFS IF OK WRITES THE DIRECT REF OUT ON OUTUT3
8113: C CHKALL WRITES END OF REFS ON OUTUT3 BEFORE RETURNING
8114: C
8115: INTEGER OUTUT3, OUTUT4, DSA, PDSA, REF, PREF, PLAT, SYMLEN, FINDND
8116: INTEGER CHK1, CHK2
8117: LOGICAL ERR, SYSERR, ABORT, QP2, QBR
8118: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, OUTUT3, OUTUT4
8119: COMMON /CTABL/ LDSA, PDSA, DSA(5000)
8120: COMMON /CREF/ LREF, PREF, REF(100)
8121: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
8122: COMMON /DETECT/ ERR, SYSERR, ABORT
8123: COMMON /FACTS/ NAME, NOST, ITYP, IASF
8124: COMMON /PASS/ QP2, QBR
8125: DATA IBR /1/, JBR /3/
8126: C IJK IS CALLING PGM UNIT; IJR IS PGM UNIT CALLED
8127: IJK = FINDND(DSA(NAME+4),L1)
8128: 10 IF (INREF(OUTUT4)) 20, 20, 30
8129: C WRITE END OF REFS AND RETURN
8130: 20 WRITE (OUTUT3) IBR, JBR, IBR
8131: QBR = .FALSE.
8132: RETURN
8133: C CHECK IF REF INDIRECT OR DIRECT
8134: 30 IF (IGATT1(REF(2),4).EQ.1) GO TO 40
8135: C HAVE A DIRECT REF
8136: IJR = REF(2)
8137: IJR = FINDND(DSA(IJR+4),L1)
8138: IBAR = CHK2(IJK,IJR)
8139: IF (SYSERR) GO TO 20
8140: IF (IBAR.EQ.1) WRITE (OUTUT3) PREF, IBR, REF(1), IJR,
8141: * (REF(L),L=3,PREF)
8142: GO TO 10
8143: C HAVE AN INDIRECT REF
8144: 40 K = IJK + SYMLEN + 5
8145: K = LAT(K)
8146: C NOTE HAVE FLAGGED THIS ERROR OF NO ACTUALS AT LAT(IM)
8147: C BEFORE IN PROC SO NOW SKIP OVER REF
8148: IF (K.EQ.0) GO TO 10
8149: C K POINTS TO ACTUALS TEMPLATE AT CALLING PGM
8150: L = REF(2)
8151: L = DSA(L+2)
8152: J = IJK + SYMLEN + 1
8153: J = LAT(J)
8154: IF (L.LE.1) GO TO 60
8155: DO 50 LL=2,L
8156: J = LAT(J+3)
8157: 50 CONTINUE
8158: 60 L = LAT(J+1)
8159: C L IS OFFSET IN ACTUALS TEMPLATE OF ACTUALS
8160: C CORRESP TO THIS DUMMY
8161: 70 J = K + L
8162: IJR = LAT(J)
8163: QBR = .TRUE.
8164: IF (CHK1(IJK,IJR).NE.1) GO TO 80
8165: IBAR = CHK2(IJK,IJR)
8166: IF (SYSERR) GO TO 20
8167: IF (IBAR.EQ.1) WRITE (OUTUT3) PREF, IBR, REF(1), IJR,
8168: * (REF(L),L=3,PREF)
8169: 80 QBR = .FALSE.
8170: K = LAT(K) + K
8171: K = LAT(K)
8172: IF (K) 10, 10, 70
8173: END
8174: C XXXXXCHK3.f
8175: SUBROUTINE CHK3(IDUM, IACT, IDUM8, IACT8, IE, R, NO)
8176: C
8177: C CHECKS PROC ARGUMENTS FOR PROPER USAGE AND TYPE
8178: C IDUM LAT INDEX DUMY PROC ARG
8179: C IACT LAT INDEX ACTUAL PROC
8180: C IDUM8 USAGE DUMMY FROM DSA ATTRIBUTES
8181: C IACT8 USAGE ACTUAL FROM LAT ENTRY
8182: C IE CALLED RTNE
8183: C R STMT NO OF CALL
8184: C NO CONTAINS THE NUMBER OF PARAMETER BEING CHECKED BY THIS CALL
8185: C
8186: INTEGER PLAT, R(1), SYMLEN, NO(1)
8187: COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
8188: COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
8189: C SEPARATE OUT EXTERNAL ENTITIES
8190: IF (IDUM8.NE.13) GO TO 20
8191: L = IGATT2(IDUM,1)/8
8192: IF (L.NE.1) GO TO 50
8193: C FURTHER CHECK THAT EPLICITLY TYPED EXTERNAL ENTITIES
8194: C MATCH FCNS
8195: IF (IACT8.NE.1 .AND. IACT8.NE.6) GO TO 30
8196: C CHECK FCN HAS SAME TYPE ACROSS REF BNDRY
8197: 10 L = IACT + SYMLEN + 6
8198: IF (MOD(IGATT2(IDUM,1),8).EQ.LAT(L)/8) GO TO 50
8199: CALL ERROR2(40H INCONSISTENT FCN TYPES IN REFERENCE TO , 40,
8200: * LAT(IE), 1, 1, 0)
8201: CALL ERROR2(1H1, 0, R(1), -1, 0, 1)
8202: GO TO 50
8203: C CHECK SUBROUTINES
8204: 20 IF (IDUM8.EQ.6 .AND. IACT8.EQ.0) GO TO 50
8205: C CHECK OUT FCNS
8206: IF (IDUM8.EQ.5 .AND. IACT8.EQ.1) GO TO 10
8207: C SEPARATE OUT BASIC EXTERNALS BECAUSE THEY ARE CONSIDERED
8208: C TYPED BY THE FORTRAN.
8209: IF (IDUM8.EQ.5 .AND. IACT8.EQ.6) GO TO 40
8210: 30 CALL ERROR2(
8211: * 50H INCOMPATIBLE PROCEDURE PARAMETER ASSOCIATED WITH ,50,
8212: * NO, -2, 1, 0)
8213: CALL ERROR2(17H IN REFERENCE TO ,17, LAT(IE), 1, 0, 0)
8214: CALL ERROR2(1H1, 0, R(1), -1, 0, 1)
8215: GO TO 50
8216: C CHECK BASIC EXTER HAS NOT BEEN EXPLICITLY TYPED
8217: C OR ELSE IT HAS TO AGREE WITH THE ACTUAL TYPE
8218: 40 L = IACT + SYMLEN + 6
8219: IF (LAT(L)/8.EQ.1) GO TO 10
8220: 50 RETURN
8221: END
8222: combine done
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.