![[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 |
researchv10 Norman
C XXXXXBLOCKDATA0.f
BLOCK DATA
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C PFORT VERIFIER
C
C B. G. RYDER
C A. D. HALL
C
C BELL LABORATORIES, MURRAY HILL, NEW JERSEY 07974
C
C
C COPYRIGHT C 1978, BELL TELEPHONE LABORATORIES, INCOR-
C PORATED. GENERAL PERMISSION IS GRANTED TO MAKE AND
C DISTRIBUTE UNMODIFIED COMPLETE COPIES OF THIS COMPUTER
C PROGRAM, BUT NOT FOR PROFIT, PROVIDED THAT THIS COPYRIGHT
C NOTICE AND STATEMENT ARE INCLUDED.
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
C
INTEGER Z
COMMON /INTS/ Z(346)
DATA Z(1) /3/
DATA Z(2) /1HA/
DATA Z(3) /1HB/
DATA Z(4) /1HS/
DATA Z(5) /201/
DATA Z(6) /4/
DATA Z(7) /1HI/
DATA Z(8) /1HA/
DATA Z(9) /1HB/
DATA Z(10) /1HS/
DATA Z(11) /210/
DATA Z(12) /4/
DATA Z(13) /1HD/
DATA Z(14) /1HA/
DATA Z(15) /1HB/
DATA Z(16) /1HS/
DATA Z(17) /192/
DATA Z(18) /4/
DATA Z(19) /1HA/
DATA Z(20) /1HI/
DATA Z(21) /1HN/
DATA Z(22) /1HT/
DATA Z(23) /201/
DATA Z(24) /3/
DATA Z(25) /1HI/
DATA Z(26) /1HN/
DATA Z(27) /1HT/
DATA Z(28) /202/
DATA Z(29) /5/
DATA Z(30) /1HI/
DATA Z(31) /1HD/
DATA Z(32) /1HI/
DATA Z(33) /1HN/
DATA Z(34) /1HT/
DATA Z(35) /194/
DATA Z(36) /4/
DATA Z(37) /1HA/
DATA Z(38) /1HM/
DATA Z(39) /1HO/
DATA Z(40) /1HD/
DATA Z(41) /329/
DATA Z(42) /3/
DATA Z(43) /1HM/
DATA Z(44) /1HO/
DATA Z(45) /1HD/
DATA Z(46) /338/
DATA Z(47) /5/
DATA Z(48) /1HA/
DATA Z(49) /1HM/
DATA Z(50) /1HA/
DATA Z(51) /1HX/
DATA Z(52) /1H0/
DATA Z(53) /273/
DATA Z(54) /5/
DATA Z(55) /1HA/
DATA Z(56) /1HM/
DATA Z(57) /1HA/
DATA Z(58) /1HX/
DATA Z(59) /1H1/
DATA Z(60) /265/
DATA Z(61) /4/
DATA Z(62) /1HM/
DATA Z(63) /1HA/
DATA Z(64) /1HX/
DATA Z(65) /1H0/
DATA Z(66) /274/
DATA Z(67) /4/
DATA Z(68) /1HM/
DATA Z(69) /1HA/
DATA Z(70) /1HX/
DATA Z(71) /1H1/
DATA Z(72) /266/
DATA Z(73) /5/
DATA Z(74) /1HD/
DATA Z(75) /1HM/
DATA Z(76) /1HA/
DATA Z(77) /1HX/
DATA Z(78) /1H1/
DATA Z(79) /256/
DATA Z(80) /5/
DATA Z(81) /1HA/
DATA Z(82) /1HM/
DATA Z(83) /1HI/
DATA Z(84) /1HN/
DATA Z(85) /1H0/
DATA Z(86) /273/
DATA Z(87) /5/
DATA Z(88) /1HA/
DATA Z(89) /1HM/
DATA Z(90) /1HI/
DATA Z(91) /1HN/
DATA Z(92) /1H1/
DATA Z(93) /265/
DATA Z(94) /4/
DATA Z(95) /1HM/
DATA Z(96) /1HI/
DATA Z(97) /1HN/
DATA Z(98) /1H0/
DATA Z(99) /274/
DATA Z(100) /4/
DATA Z(101) /1HM/
DATA Z(102) /1HI/
DATA Z(103) /1HN/
DATA Z(104) /1H1/
DATA Z(105) /266/
DATA Z(106) /5/
DATA Z(107) /1HD/
DATA Z(108) /1HM/
DATA Z(109) /1HI/
DATA Z(110) /1HN/
DATA Z(111) /1H1/
DATA Z(112) /256/
DATA Z(113) /5/
DATA Z(114) /1HF/
DATA Z(115) /1HL/
DATA Z(116) /1HO/
DATA Z(117) /1HA/
DATA Z(118) /1HT/
DATA Z(119) /209/
DATA Z(120) /4/
DATA Z(121) /1HI/
DATA Z(122) /1HF/
DATA Z(123) /1HI/
DATA Z(124) /1HX/
DATA Z(125) /202/
DATA Z(126) /4/
DATA Z(127) /1HS/
DATA Z(128) /1HI/
DATA Z(129) /1HG/
DATA Z(130) /1HN/
DATA Z(131) /329/
DATA Z(132) /5/
DATA Z(133) /1HI/
DATA Z(134) /1HS/
DATA Z(135) /1HI/
DATA Z(136) /1HG/
DATA Z(137) /1HN/
DATA Z(138) /338/
DATA Z(139) /5/
DATA Z(140) /1HD/
DATA Z(141) /1HS/
DATA Z(142) /1HI/
DATA Z(143) /1HG/
DATA Z(144) /1HN/
DATA Z(145) /320/
DATA Z(146) /3/
DATA Z(147) /1HD/
DATA Z(148) /1HI/
DATA Z(149) /1HM/
DATA Z(150) /329/
DATA Z(151) /4/
DATA Z(152) /1HI/
DATA Z(153) /1HD/
DATA Z(154) /1HI/
DATA Z(155) /1HM/
DATA Z(156) /338/
DATA Z(157) /4/
DATA Z(158) /1HS/
DATA Z(159) /1HN/
DATA Z(160) /1HG/
DATA Z(161) /1HL/
DATA Z(162) /193/
DATA Z(163) /4/
DATA Z(164) /1HR/
DATA Z(165) /1HE/
DATA Z(166) /1HA/
DATA Z(167) /1HL/
DATA Z(168) /217/
DATA Z(169) /5/
DATA Z(170) /1HA/
DATA Z(171) /1HI/
DATA Z(172) /1HM/
DATA Z(173) /1HA/
DATA Z(174) /1HG/
DATA Z(175) /217/
DATA Z(176) /4/
DATA Z(177) /1HD/
DATA Z(178) /1HB/
DATA Z(179) /1HL/
DATA Z(180) /1HE/
DATA Z(181) /200/
DATA Z(182) /5/
DATA Z(183) /1HC/
DATA Z(184) /1HM/
DATA Z(185) /1HP/
DATA Z(186) /1HL/
DATA Z(187) /1HX/
DATA Z(188) /331/
DATA Z(189) /5/
DATA Z(190) /1HC/
DATA Z(191) /1HO/
DATA Z(192) /1HN/
DATA Z(193) /1HJ/
DATA Z(194) /1HG/
DATA Z(195) /219/
DATA Z(196) /3/
DATA Z(197) /1HE/
DATA Z(198) /1HX/
DATA Z(199) /1HP/
DATA Z(200) /713/
DATA Z(201) /4/
DATA Z(202) /1HD/
DATA Z(203) /1HE/
DATA Z(204) /1HX/
DATA Z(205) /1HP/
DATA Z(206) /704/
DATA Z(207) /4/
DATA Z(208) /1HC/
DATA Z(209) /1HE/
DATA Z(210) /1HX/
DATA Z(211) /1HP/
DATA Z(212) /731/
DATA Z(213) /4/
DATA Z(214) /1HA/
DATA Z(215) /1HL/
DATA Z(216) /1HO/
DATA Z(217) /1HG/
DATA Z(218) /713/
DATA Z(219) /4/
DATA Z(220) /1HD/
DATA Z(221) /1HL/
DATA Z(222) /1HO/
DATA Z(223) /1HG/
DATA Z(224) /704/
DATA Z(225) /4/
DATA Z(226) /1HC/
DATA Z(227) /1HL/
DATA Z(228) /1HO/
DATA Z(229) /1HG/
DATA Z(230) /731/
DATA Z(231) /6/
DATA Z(232) /1HA/
DATA Z(233) /1HL/
DATA Z(234) /1HO/
DATA Z(235) /1HG/
DATA Z(236) /1H1/
DATA Z(237) /1H0/
DATA Z(238) /713/
DATA Z(239) /6/
DATA Z(240) /1HD/
DATA Z(241) /1HL/
DATA Z(242) /1HO/
DATA Z(243) /1HG/
DATA Z(244) /1H1/
DATA Z(245) /1H0/
DATA Z(246) /704/
DATA Z(247) /3/
DATA Z(248) /1HS/
DATA Z(249) /1HI/
DATA Z(250) /1HN/
DATA Z(251) /713/
DATA Z(252) /4/
DATA Z(253) /1HD/
DATA Z(254) /1HS/
DATA Z(255) /1HI/
DATA Z(256) /1HN/
DATA Z(257) /704/
DATA Z(258) /4/
DATA Z(259) /1HC/
DATA Z(260) /1HS/
DATA Z(261) /1HI/
DATA Z(262) /1HN/
DATA Z(263) /731/
DATA Z(264) /3/
DATA Z(265) /1HC/
DATA Z(266) /1HO/
DATA Z(267) /1HS/
DATA Z(268) /713/
DATA Z(269) /4/
DATA Z(270) /1HD/
DATA Z(271) /1HC/
DATA Z(272) /1HO/
DATA Z(273) /1HS/
DATA Z(274) /704/
DATA Z(275) /4/
DATA Z(276) /1HC/
DATA Z(277) /1HC/
DATA Z(278) /1HO/
DATA Z(279) /1HS/
DATA Z(280) /731/
DATA Z(281) /4/
DATA Z(282) /1HT/
DATA Z(283) /1HA/
DATA Z(284) /1HN/
DATA Z(285) /1HH/
DATA Z(286) /713/
DATA Z(287) /4/
DATA Z(288) /1HS/
DATA Z(289) /1HQ/
DATA Z(290) /1HR/
DATA Z(291) /1HT/
DATA Z(292) /713/
DATA Z(293) /5/
DATA Z(294) /1HD/
DATA Z(295) /1HS/
DATA Z(296) /1HQ/
DATA Z(297) /1HR/
DATA Z(298) /1HT/
DATA Z(299) /704/
DATA Z(300) /5/
DATA Z(301) /1HC/
DATA Z(302) /1HS/
DATA Z(303) /1HQ/
DATA Z(304) /1HR/
DATA Z(305) /1HT/
DATA Z(306) /731/
DATA Z(307) /4/
DATA Z(308) /1HA/
DATA Z(309) /1HT/
DATA Z(310) /1HA/
DATA Z(311) /1HN/
DATA Z(312) /713/
DATA Z(313) /5/
DATA Z(314) /1HD/
DATA Z(315) /1HA/
DATA Z(316) /1HT/
DATA Z(317) /1HA/
DATA Z(318) /1HN/
DATA Z(319) /704/
DATA Z(320) /5/
DATA Z(321) /1HA/
DATA Z(322) /1HT/
DATA Z(323) /1HA/
DATA Z(324) /1HN/
DATA Z(325) /1H2/
DATA Z(326) /841/
DATA Z(327) /6/
DATA Z(328) /1HD/
DATA Z(329) /1HA/
DATA Z(330) /1HT/
DATA Z(331) /1HA/
DATA Z(332) /1HN/
DATA Z(333) /1H2/
DATA Z(334) /832/
DATA Z(335) /4/
DATA Z(336) /1HD/
DATA Z(337) /1HM/
DATA Z(338) /1HO/
DATA Z(339) /1HD/
DATA Z(340) /832/
DATA Z(341) /4/
DATA Z(342) /1HC/
DATA Z(343) /1HA/
DATA Z(344) /1HB/
DATA Z(345) /1HS/
DATA Z(346) /729/
END
C XXXXXBLOCKDATA1.f
BLOCK DATA
INTEGER EX(4,4), PT, PB, AO(4,4), RO(3,3)
COMMON /EXPRS/ PT, PB, AO, RO, EX
DATA AO(1,1), AO(1,2), AO(2,1) /3*0/, AO(1,3), AO(1,4), AO(3,1),
* AO(3,2), AO(4,1), AO(4,3) /6*-1/, AO(2,2) /1/, AO(3,3) /2/,
* AO(4,4), AO(2,4), AO(4,2) /3*3/, AO(3,4), AO(2,3) /2*-1/
DATA RO(1,1), RO(1,2), RO(2,1), RO(2,2), RO(3,3) /5*4/, RO(1,3),
* RO(2,3), RO(3,1), RO(3,2) /4*-1/
DATA EX(1,1) /0/, EX(1,2) /0/, EX(1,3) /0/, EX(1,4) /-1/, EX(2,1)
* /0/, EX(2,2) /1/, EX(2,3) /1/, EX(2,4) /-1/, EX(3,1) /-1/,
* EX(3,2) /-1/, EX(3,3) /2/, EX(3,4) /-1/, EX(4,1) /-1/,
* EX(4,2) /-1/, EX(4,3) /3/, EX(4,4) /-1/
END
C XXXXXBLOCKDATA2.f
BLOCK DATA
C
COMMON /TRANS/ Q(70)
INTEGER Q
C
DATA Q(1) /1H0/, Q(2) /1H1/, Q(3) /1H2/, Q(4) /1H3/, Q(5) /1H4/
DATA Q(6) /1H5/, Q(7) /1H6/, Q(8) /1H7/, Q(9) /1H8/, Q(10) /1H9/
C
DATA Q(31) /1HA/, Q(32) /1HB/, Q(33) /1HC/, Q(34) /1HD/, Q(35) /
* 1HE/
DATA Q(36) /1HF/, Q(37) /1HG/, Q(38) /1HH/, Q(39) /1HI/, Q(40) /
* 1HJ/
DATA Q(41) /1HK/, Q(42) /1HL/, Q(43) /1HM/, Q(44) /1HN/, Q(45) /
* 1HO/
DATA Q(46) /1HP/, Q(47) /1HQ/, Q(48) /1HR/, Q(49) /1HS/, Q(50) /
* 1HT/
DATA Q(51) /1HU/, Q(52) /1HV/, Q(53) /1HW/, Q(54) /1HX/, Q(55) /
* 1HY/
DATA Q(56) /1HZ/
C
DATA Q(61) /1H+/, Q(62) /1H-/, Q(63) /1H)/, Q(64) /1H=/, Q(65) /
* 1H./
DATA Q(66) /1H(/, Q(67) /1H*/, Q(68) /1H//, Q(69) /1H,/, Q(70) /
* 1H /
END
C XXXXXBLOCKDATA3.f
BLOCK DATA
INTEGER K(186), KI(30), KT(30)
COMMON /STS/ K, KI, KT
DATA K(1) /33/, K(2) /44/, K(3) /50/, K(4) /31/, K(5) /41/, K(6)
* /34/, K(7) /45/, K(8) /47/, K(9) /34/, K(10) /32/, K(11)
* /38/, K(12) /48/, K(13) /38/, K(14) /44/, K(15) /43/
DATA K(16) /47/, K(17) /34/, K(18) /30/, K(19) /41/
DATA K(20) /38/, K(21) /43/, K(22) /49/, K(23) /34/, K(24) /36/,
* K(25) /34/, K(26) /47/
DATA K(27) /32/, K(28) /44/, K(29) /42/, K(30) /45/, K(31) /41/,
* K(32) /34/, K(33) /53/, K(34) /41/, K(35) /44/, K(36) /36/,
* K(37) /38/, K(38) /32/, K(39) /30/, K(40) /41/
DATA K(41) /34/, K(42) /53/, K(43) /49/, K(44) /34/, K(45) /47/,
* K(46) /43/, K(47) /30/, K(48) /41/, K(49) /33/, K(50) /38/,
* K(51) /42/, K(52) /34/, K(53) /43/, K(54) /48/, K(55) /38/,
* K(56) /44/, K(57) /43/, K(58) /32/, K(59) /44/, K(60) /42/,
* K(61) /42/, K(62) /44/, K(63) /43/, K(64) /48/, K(65) /50/,
* K(66) /31/, K(67) /47/, K(68) /44/, K(69) /50/, K(70) /49/,
* K(71) /38/, K(72) /43/, K(73) /34/
DATA K(74) /35/, K(75) /50/, K(76) /43/, K(77) /32/, K(78) /49/,
* K(79) /38/, K(80) /44/, K(81) /43/, K(82) /31/, K(83) /41/,
* K(84) /44/, K(85) /32/, K(86) /40/, K(87) /33/, K(88) /30/,
* K(89) /49/, K(90) /30/, K(91) /34/, K(92) /46/, K(93) /50/,
* K(94) /38/, K(95) /51/, K(96) /30/, K(97) /41/, K(98) /34/,
* K(99) /43/, K(100) /32/, K(101) /34/, K(102) /33/, K(103)
* /30/, K(104) /49/, K(105) /30/
DATA K(106) /30/, K(107) /48/, K(108) /48/, K(109) /38/, K(110)
* /36/, K(111) /43/, K(112) /36/, K(113) /44/, K(114) /49/,
* K(115) /44/, K(116) /47/, K(117) /34/, K(118) /49/, K(119)
* /50/, K(120) /47/, K(121) /43/
DATA K(122) /32/, K(123) /44/, K(124) /43/, K(125) /49/, K(126)
* /38/, K(127) /43/, K(128) /50/, K(129) /34/, K(130) /32/,
* K(131) /30/, K(132) /41/, K(133) /41/, K(134) /48/, K(135)
* /49/, K(136) /44/, K(137) /45/, K(138) /38/, K(139) /35/,
* K(140) /33/, K(141) /44/, K(142) /45/, K(143) /30/, K(144)
* /50/, K(145) /48/, K(146) /34/
DATA K(147) /47/, K(148) /34/, K(149) /30/, K(150) /33/, K(151)
* /52/, K(152) /47/, K(153) /38/, K(154) /49/, K(155) /34/,
* K(156) /47/, K(157) /34/, K(158) /52/, K(159) /38/, K(160)
* /43/, K(161) /33/, K(162) /34/, K(163) /43/, K(164) /33/,
* K(165) /35/, K(166) /38/, K(167) /41/, K(168) /34/, K(169)
* /31/, K(170) /30/, K(171) /32/, K(172) /40/, K(173) /48/,
* K(174) /45/, K(175) /30/, K(176) /32/, K(177) /34/, K(178)
* /34/, K(179) /43/, K(180) /33/
DATA K(181) /35/, K(182) /44/, K(183) /47/, K(184) /42/, K(185)
* /30/, K(186) /49/
DATA KI(1) /15/, KI(2) /4/, KI(3) /7/, KI(4) /7/, KI(5) /7/,
* KI(6) /8/, KI(7) /9/, KI(8) /6/, KI(9) /10/, KI(10) /8/,
* KI(11) /9/, KI(12) /11/, KI(13) /4/, KI(14) /6/, KI(15) /4/,
* KI(16) /6/, KI(17) /8/, KI(18) /4/, KI(19) /4/, KI(20) /2/,
* KI(21) /2/, KI(22) /5/, KI(23) /4/, KI(24) /5/, KI(25) /6/,
* KI(26) /7/, KI(27) /9/, KI(28) /3/, KI(29) /6/, KI(30) /0/
DATA KT(1), KT(2), KT(3), KT(4), KT(5), KT(6), KT(7), KT(8)
* /8*1/, KT(9), KT(10), KT(11) /3*0/, KT(12) /2/, KT(13) /3/,
* KT(14), KT(15), KT(16), KT(17), KT(18), KT(19), KT(20),
* KT(21), KT(22), KT(23), KT(24), KT(25), KT(26), KT(27)
* /14*5/, KT(29), KT(30) /2*5/, KT(28) /6/
END
C XXXXXMAIN0.f
INTEGER STMT, PSTMT, SYMLEN, OUTUT, SYMHD, BNEXT, HASH, DSA,
* STACK, DOLIST, DOPT, OUTUT2, OUTUT3, PDSA, OUTUT4, REF, PREF,
* PNODE, PLAT, PCOM, COM
LOGICAL ERR, SYSERR, OPT, P1ERR, ABORT, P2
LOGICAL SW, QBR
COMMON /SWS/ SW(10)
C*****SWS
C SW(1) (LOG) IF TRUE, CAN USE END= OPTION IN READ STMTS
C
COMMON /OPTNS/ OPT(5), P1ERR
C
C*****OPTNS
C OPT(1) (LOG) IF TRUE, SYMBOL TABLE PRINTED FOR EACH P. U.
C OPT(2) (LOG) IF TRUE, CROSS REFERENCES PRINTED FOR EACH SYMBOL
C OPT(3) (LOG) IF TRUE, PASS 2 IS EXECUTED
C OPT(4) (LOG) IF TRUE, LISTING PRINTED FOR EACH P. U.
C OPT(5) (LOG) IF TRUE, FORTRAN PGM COMPILED AFTER VERIFIER
C RUN; IF ANY OF THESE ARE FALSE THE CORRESPONDING ACTION IS NOT TA
C P1ERR (LOG) SET TO TRUE IF INFO NORMALLY SAVED FOR PASS 2 IS
C SUPPRESSED FOR THIS P. U.
C
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
C
C*****INPUT
C NSTMT (INT) INDEX OF END-OF-INPUT-STMT CHARACTER IN STMT
C PSTMT (INT) POINTS TO CURRENT POSITION IN STMT (EXCEPT IN LEXICAL
C SUBPGMS WHERE IT IS UPDATED IN CALLING SUBPGM AFTER A TOKEN IS
C FOUND)
C STMT (INT) ENCODED FORM OF DEBLANKED INPUT STMT
C
COMMON /CEXPRS/ LSTACK, STACK(620)
C
C*****CEXPRS
C LSTACK (INT) LENGTH OF STACK
C STACK(*), (INT) ARRAY USED IN EXPR AS A STACK; ALSO FOR AUXILLARY
C STORAGE AND OUTPUT
C
COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
* OUTUT4
C
C*****PARAMS
C INUT (INT) LOGICAL INPUT NUMBER FOR THE HOST MACHINE
C OUTUT (INT) LOGICAL OUTPUT NUMBER FOR THE HOST MACHINE
C NOCHAR (INT) NUMBER OF CHARACTERS PER MACHINE WORD IN HOST
C SYMLEN (INT) NUMBER OF WORDS NECESSARY ON HOST TO STORE 6
C CHARACTERS (I.E. A FORTRAN SYMBOL)
C OUTUT2 (INT), OUTUT3(INT), OUTUT4(INT) LOGICAL OUTPUT NUMBERS
C FOR THE HOST MACHINE TO BE USED BY THE VERIFIER FOR INTERPASS
C COMMUNICATION
C
COMMON /FACTS/ NAME, NOST, ITYP, IASF
C
C*****FACTS
C NAME (INT) INDEX IN SYMBOL TABLE OF ENTRY FOR CURRENT P.U.
C NOST (INT) STMT NUMBER OF CURRENT STMT BEING PROCESSED
C ITYP (INT) TYPE OF STMT CURRENTLY BEING PROCESSED (SEE PU
C FOR FURTHER DOC)
C
COMMON /DETECT/ ERR, SYSERR, ABORT
C
C*****DETECT
C ERROR (LOG) SET TO TRUE IN VARIOUS SUBPGMS USUALLY TO CEASE PROCES
C OF CURRENT STMT
C SYSERR (LOG) IRRECOVERABLE ERROR IN SYSTEM; (E.G., TABLE OVERFLOW)
C IN PASS 1 CAUSES CURRENT P.U. TO HAVE AN END STMT SIMULATED AND
C EXECUTION PROCEDES TO NEXT P.U.; IN PASS 2 CAUSES PROCESSING
C OF PROGRAM TO CEASE.
C
COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
C
C*****TABL
C NEXT (INT) POINTS TO NEXT FREE WORD IN DSA (COUNTING FROM DSA(1))
C LABHD (INT) POINTS TO HEAD OF LINEAR LINKED LIST IN DSA OF ALL
C LABELS IN P.U.
C SYMHD (INT) POINTS TO HEAD OF LINEAR LINKED LIST IN DSA OF ALL
C SYMBOLS IN P.U.
C BNEXT (INT) POINTS TO NEXT FREE WORD IN DSA (COUNTING FROM
C DSA(LDSA))
C
COMMON /CHASH/ LHASH, HASH(401)
C
C*****CHASH
C LHASH (INT) LENGTH OF HASH ARRAY
C HASH (*) (INT) HASH TABLE USED TO INDEX INTO DSA
C
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
C
C*****CTABL
C LDSA (INT) LENGTH OF DSA
C DSA(*) (INT) SYMBOL TABLE (SEE LOOKUP FOR MORE EXPLICIT DOC)
C
COMMON /DOS/ DOPT, LDO, DOLIST(192)
C
C*****DOS
C DOPT (INT) POINTER TO FIRST FREE WORD IN DOLIST
C LDO (INT) LENGTH OF DOLIST
C DOLIST (*) (INT) ARRAY USED AS STACK FOR NESTING OF DOS (USED
C TO TEST FOR LEGAL BRANCHING WITHIN P.U. (SEE DOSPEC FOR FURTHER
C DOC)
C
COMMON /LISTDO/ LPT, LEN, LS(64)
C
C*****LISTDO
C LPT (INT) POINTER TO FIRST FREE WORD IN LS
C LEN (INT) LENGTH OF LS
C LS (*) (INT) ARRAY USED AS STACK FOR NESTING OF IMPLIED
C DO'S IN INPUT/OUTPUT STMTS (SEE DOSPEC FOR FURTHER DOC)
C
COMMON /PASS/ P2, QBR
C
C*****PASS
C P2 (LOG) IF TRUE, VERIFIER IS IN PASS 2; ELSE VERIFIER IS IN PASS
C QBR (LOG) IF TRUE, VERIFIER IS TO PRINT ERROR MESSAGES
C ELSE IS NOT
C
COMMON /CREF/ LREF, PREF, REF(100)
C
C*****CREF
C LREF (INT) TOTAL LENGTH OF ARRAY REF
C PREF (INT) CURRENT LENGTH OF REF
C REF (*) (INT) ARRAY CONTAINING INFORMATION CONCERNING A SUBR/FCN
C REF (SEE SETREF FOR FURTHER DOC)
C
COMMON /HEAD/ LNODE, PNODE, NODE(500)
C
C*****HEAD
C LNODE (INT) LENGTH OF NODE
C PNODE (INT) POINTER TO NEXT FREE WORD IN NODE
C NODE (*) (INT) ARRAY OF INDICES OF P.U. ENTRIES IN LAT
C
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
C
C*****GRAPH
C LLAT (INT) LENGTH OF LAT
C PLAT (INT) POINTER TO NEXT FREE WORD IN LAT
C LAT (*) (INT) ARRAY WHOSE ENTRIES DESCRIBE EACH P.U. IN PGM
C AND THEIR INTER-RELNS (SEE SETNOD FOR FURTHER DOC)
C
COMMON /COMS/ LCOM, PCOM, COM(300)
C
C*****COMS
C LCOM (INT) LENGTH OF COM
C PCOM (INT) POINTER TO NEXT FREE WORD IN COM
C COM (*) (INT) ARRAY WHOSE ENTRIES DESCRIBE EACH COMMON BLOCK
C IN PGM (SEE SETCOM FOR FURTHER DOC)
COMMON /SCR1/ LINODE, INODE(500)
COMMON /SCR2/ LNNODE, NNODE(500)
C
C***SCR1,SCR2,SCR3
C INODE(INT), NNODE(INT) SCRATCH ARRAYS KEYED ON LENGTH NODE(*)
C LINNODE = LNNODE .GE. MAX( LNODE, LCOM/(SYMLEN+5) )
C
C THREE MORE BLOCK COMMON REGIONS ARE USED : STS -SEE TYPST
C TRANS - SEE MAPCHR EXPRS - SEE EXPR FOR FURTHER DOC
C
QBR = .FALSE.
NOCHAR = 4
INUT = 5
OUTUT = 6
OUTUT2 = 7
OUTUT3 = 8
OUTUT4 = 9
C NOCHAR WAS &, OUT2-4 was 12,13,14 in distribution tape
REWIND INUT
REWIND OUTUT2
REWIND OUTUT3
REWIND OUTUT4
LEN = 64
SYMLEN = (5/NOCHAR) + 1
P2 = .FALSE.
ERR = .FALSE.
ABORT = .FALSE.
SYSERR = .FALSE.
SW(1) = .FALSE.
PDSA = 1
LDSA = 5000
LHASH = 401
DO 10 I=1,LHASH
HASH(I) = 0
10 CONTINUE
OPT(1) = .TRUE.
OPT(2) = .TRUE.
OPT(3) = .TRUE.
OPT(4) = .TRUE.
OPT(5) = .FALSE.
LSTACK = 620
LREF = 100
PREF = 1
LDO = 192
CALL OVRLAY(1)
CALL PU
IF (.NOT.OPT(3) .OR. SYSERR) GO TO 30
P2 = .TRUE.
IF (.NOT.OPT(4)) WRITE (OUTUT,99999)
99999 FORMAT (1H1)
CALL OVRLAY(2)
LLAT = 6000
PLAT = 1
BNEXT = LDSA
NEXT = 1
LNODE = 500
PNODE = 1
LCOM = 300
PCOM = 1
LINODE = LNODE
LNNODE = LNODE
C
C PASS 1 CAN SUPPRESS PASS 2 PROCESSING FOR SPECIFIC P.U.
C BUT NEVER SHUTS OFF PASS 2 COMPLETELY; PASS 2 CAN CEASE
C PROCESSING FOR VARIOUS REASONS:
C 1. 2 SUBPRGMS WITH SAME NAME(IN SETNOD)
C 2. NO PROGRAM UNIT SUCCESSFULLY PASSED TO PASS 2
C (IN CONSTR)
C 3. RECURSION (IN ASLEV AND INVOKE)
C IF MISSING SUBPRGMS ARE DISCOVERED, PASS 2 CAN
C PROCEDE WITH INCOMPLETE PROCESSING, A MESSAGE
C IS PRINTED TO INFORM THE USER
C
REWIND OUTUT2
REWIND OUTUT3
REWIND OUTUT4
CALL CONSTR(IROOT)
C CAN RETURN FROM CONSTR IN ERROR CONDITION WITH FILES LACKING
C VERIFIER SOFTWARE END OF FILE
IF (ABORT .OR. SYSERR) GO TO 30
REWIND OUTUT4
REWIND OUTUT3
REWIND OUTUT2
CALL CHECKS(IROOT)
20 REWIND INUT
CALL OVRLAY(3)
CALL COMPIL(.NOT.(ABORT.OR.SYSERR).AND.OPT(5))
STOP
30 WRITE (OUTUT,99998)
99998 FORMAT (47H1INTER-PROGRAM-UNIT COMMUNICATIONS NOT VERIFIED)
GO TO 20
END
C XXXXXCOMPIL.f
SUBROUTINE COMPIL(FLAG)
C
LOGICAL FLAG
C
RETURN
C
END
C XXXXXOVRLAY.f
SUBROUTINE OVRLAY(N)
C
RETURN
C
END
C XXXXXSATT1.f
SUBROUTINE SATT1(INDEX, FIELD, ATT)
C
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
C
INTEGER INDEX, FIELD, ATT
INTEGER LDSA, PDSA, DSA
INTEGER FWTH(8), FPOS(8)
C
DATA FWTH(1) /16/, FPOS(1) /1/
DATA FWTH(2) /2/, FPOS(2) /16/
DATA FWTH(3) /2/, FPOS(3) /32/
DATA FWTH(4) /2/, FPOS(4) /64/
DATA FWTH(5) /2/, FPOS(5) /128/
DATA FWTH(6) /2/, FPOS(6) /256/
DATA FWTH(7) /4/, FPOS(7) /512/
DATA FWTH(8) /32/, FPOS(8) /2048/
C
DSA(INDEX) = DSA(INDEX) + (ATT-MOD(DSA(INDEX)/FPOS(FIELD),
* FWTH(FIELD)))*FPOS(FIELD)
C
RETURN
C
END
C XXXXXIGATT1.f
INTEGER FUNCTION IGATT1(INDEX, FIELD)
C
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
C
INTEGER INDEX, FIELD
INTEGER LDSA, PDSA, DSA
INTEGER FWTH(8), FPOS(8)
C
DATA FWTH(1) /16/, FPOS(1) /1/
DATA FWTH(2) /2/, FPOS(2) /16/
DATA FWTH(3) /2/, FPOS(3) /32/
DATA FWTH(4) /2/, FPOS(4) /64/
DATA FWTH(5) /2/, FPOS(5) /128/
DATA FWTH(6) /2/, FPOS(6) /256/
DATA FWTH(7) /4/, FPOS(7) /512/
DATA FWTH(8) /32/, FPOS(8) /2048/
C
IGATT1 = MOD(DSA(INDEX)/FPOS(FIELD),FWTH(FIELD))
C
RETURN
C
END
C XXXXXEXCH.f
INTEGER FUNCTION EXCH(J1, J2, DSA, LDSA, HASH, LHASH, OFFSET)
INTEGER DSA(LDSA), HASH(LHASH), OFFSET
INTEGER OUTUT, SYMLEN, OUTUT2, OUTUT3, OUTUT4
COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
* OUTUT4
C
C DSA(HASH(J1)+OFFSET) CONTAINS ELE TO BE COMPARED
C DSA(HASH(J2)+OFFSET) CONTAINS ELE TO BE COMPARED
C
JJ1 = HASH(J1) + OFFSET
JJ2 = HASH(J2) + OFFSET
DO 40 I=1,SYMLEN
K1 = JJ1 + I - 1
K2 = JJ2 + I - 1
IF (DSA(K1)) 10, 20, 20
10 IF (DSA(K2)) 30, 50, 50
20 IF (DSA(K2)) 70, 30, 30
30 IF (DSA(K1)-DSA(K2)) 70, 40, 50
40 CONTINUE
C
C COMPARISON SHOWS ELEMENTS IN PROPER ORDER
C
50 EXCH = 0
60 RETURN
C
C COMPARISON SHOWS NEED FOR EXCHANGE
C
70 I = HASH(J1)
HASH(J1) = HASH(J2)
HASH(J2) = I
EXCH = -1
GO TO 60
END
C XXXXXSSORT.f
SUBROUTINE SSORT(EX, X, LX, Q, L, OFFSET)
INTEGER EX, X(LX), Q(L), OFFSET
EXTERNAL EX
C
C ENTRIES SPACED 1 APART IN HASH TABLE
C EX IS EXCHANGE ROUTINE--RETURNS<0 IF EXCHANGES ITEMS
C RETURNS >=0 IF DOESN'T
C L IS NUMBER OF THINGS TO BE SORTED, SPACING IS 1 HERE
C START SHELL SORT
C
M = 1
10 IF (M.GE.L) GO TO 20
M = M*2
GO TO 10
20 M = M/2
IF (M.LT.1) RETURN
K = L - M
C
C IN PASS1 ARE SORTING SYMBOL TABLE
C IN PASS 2 ARE SORTING LATTICE
C OR COMMON BLOCK DEFS
C
DO 50 J=1,K
I = J
30 IF (EX(I+M,I,X,LX,Q,L,OFFSET)) 40, 50, 50
C
C BUBBLE SORT W/I SUBLIST
C
40 I = I - M
IF (I.GE.1) GO TO 30
50 CONTINUE
GO TO 20
END
C XXXXXERROR1.f
SUBROUTINE ERROR1(MESS, LMESS)
C
INTEGER MESS(20), LMESS
INTEGER ZERO(1)
C
DATA ZERO(1) /0/
C
CALL ERROR2(MESS, LMESS, ZERO(1), ZERO(1), 1, 1)
C
RETURN
C
END
C XXXXXERROR2.f
SUBROUTINE ERROR2( I, JJ, K, NN, SPBEF, SPAFT )
C
C PRINTS ERROR MESSAGES AND SYMBOLIC NAME
C I IS PACKED HOLLERITH STRING
C JJ IS NUMBER OF CHARACTERS TO BE PRINTED ( N = JJ)
C K CONTAINS INTEGER OR HOLLERITH INFO TO FOLLOW MESSAGE
C NN CONTROLS TYPE OF LINE TO BE PRINTED
C
C NN = 0 MEANS PRINT MESSAGE
C
C NN < 0 MEANS IF JJ=0 NO MESSAGE, ELSE PRINT MESSAGE
C ON NEXT LINE IF NN = -1 PRINT PGM UNIT AND/OR STMT NO
C (CONTROLLED BY CONTENTS OF K).
C ON NEXT LINE IF NN = -2 PRINT PARAMETER NUMBER IN K
C NN = -3 USED FOR SPACING CONTROL IN LONG MESSAGES
C
C NN > 0 MEANS PRINT MESSAGE FOLLOWED BY IDENTIFIER IN K
C SPBEF, SPAFT CONTROL LINE SPACING BEFORE AND AFTER MESSAGE
C IF = 1, BLANK LINE EMMITTED
C
INTEGER I(1), J(80), OUTUT, PDSA, DSA, M(6), K(6), W
INTEGER SPBEF, SPAFT
LOGICAL OPT, P1ERR, P2, QBR
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /PARAMS/ INUT, OUTUT, NOCHAR, I1, I2, I3, I4
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /OPTNS/ OPT(5), P1ERR
COMMON /PASS/ P2, QBR
DATA W /1HW/, KK /1H-/
C
C ERROR IN P.U. DURING PROCESSING OF A HEADING STMT, SPECIFI STMT,
C EQUIV STMT, OR DATA STMT CAUSES PASS 2 TO BE SUPPRESSED FOR THAT
C P.U.
C
IF (QBR) GOTO 45
IF(SPBEF.EQ.1) WRITE(OUTUT, 99998)
N = JJ
IF (N.GT.72) N = 72
J(2) = KK
IF (N.GE.1) CALL S5UNPK(I, J, N)
IF (ITYP.LT.14 .AND. J(2).NE.W) P1ERR = .TRUE.
IF (NN) 50, 10, 30
C
C NN=0
C
10 CONTINUE
WRITE (OUTUT,99997) (J(L),L=1,N)
IF(P2 .OR. OPT(4)) GOTO 40
CALL S5UNPK(DSA(NAME+4), J(1), 6)
WRITE (OUTUT,99999) NOST, (J(L),L=1,6)
99999 FORMAT (16H *** AT STMT NO , I6, 13H IN PGM UNIT , 6A1)
99998 FORMAT(1H )
GO TO 40
C
C NN>0
C
30 CONTINUE
IF (N.GT.68) N = 68
CALL S5UNPK(K, J(73), 6)
WRITE (OUTUT,99997) (J(L),L=1,N), KK, KK, (J(L),L=73,78)
99997 FORMAT (4H ***, 76A1)
40 IF(SPAFT.EQ.1) WRITE(OUTUT, 99998)
45 RETURN
C
C NN<0
C
50 CONTINUE
IF (N.GE.1) WRITE (OUTUT,99997) (J(L),L=1,N)
IF( -2.EQ.NN ) GOTO 70
IF( -3.EQ.NN ) GOTO 40
CALL S5UNPK(DSA(NAME+4), M(1), 6)
C WRITE OUT STMT NO AND/OR PGM UNIT
IF (K(1).EQ.0) GO TO 60
WRITE (OUTUT,99996) K(1), (M(L),L=1,6)
99996 FORMAT (16H *** AT STMT NO , I6, 1X, 13H IN PGM UNIT , 6A1)
GO TO 40
60 WRITE (OUTUT,99995) (M(L),L=1,6)
99995 FORMAT (17H *** IN PGM UNIT , 6A1)
GO TO 40
C WRITE OUT PARAMETER NO FOR PARAMETERLIST ERRORS
70 WRITE(OUTUT,99994) K(1)
99994 FORMAT(22H *** PARAMETER NUMBER ,I6)
GOTO 40
END
C XXXXXARDECL.f
LOGICAL FUNCTION ARDECL(K2, KK)
C
C K2 IS INDEX OF END OF ARRAY DECLARATOR IN STMT
C KK IS SYMBOL TABLE INDEX FOR THIS ARRAY
C PROCESSES ARRAY DECLARATOR AND DECLARATOR CONSTRUCTS.
C CAN EXPECT ARRAY DECLARATOR, ARRAY ELEMENT; ARRAY, VARIABLE.
C ENTERS INTO SYMBOL TABLE AND TYPES ID; SETS USAGE ON ARRAY
C DECLARATOR
C CHECKS SYNTAX OF BOUNDS; IF VARIABLY DIMENSIONED, BOUNDS
C VARIABLE AND ARRAY ITSELF MUST BE DUMMY ARGUMENTS.
C ACCUMULATES TOTAL LENGTH OF ARRAY WITH CONSTANT BOUNDS AND STORES
C IT OFF ARRAY SYMBOL TABLE ENTRY. -1 LENGTH INDICATES VARIABLE
C DIMENSION
C CALLED BY DIMENSION, TYPE, COMMON, EQUIVALENCE, DATA STMT.
C
C ARRY IS TRUE FOR ARRAY ELEMENTS/ARRAY DECLARATORS
C FALSE FOR ARRAYS AND VARIABLES
C CORNER IS TRUE FOR ARRAY ELEMENTS WITH (1,1,1)--NEEDED IN EQUIV.
C STMT ; IF SUCH AN ELEMENT IS RECOGNIZED KK IS SENT AS ITS
C NEGATIVE.
C
LOGICAL ERR, SYSERR, ABORT, TOKPNO, VAR, CORNER, ARRY, FLUSH
INTEGER STMT, PSTMT, PDSA, BNEXT, SYMHD, DSA
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /DETECT/ ERR, SYSERR, ABORT
ERR = .FALSE.
FLUSH = .FALSE.
ARRY = .FALSE.
CORNER = .TRUE.
ARDECL = .FALSE.
C
C CHECK NAME; CAN'T HAVE BEEN USED PREVIOUSLY AS A NONVAR;
C CHECK TO SEE IF HAVE ARRAY ELEMENT/ARRAY DECLARATOR. IF SO
C ARRY=.TRUE.
C
ICNT = 0
CALL NEXTOK(PSTMT, K2, I1)
IF (I1.EQ.0) GO TO 10
CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
ERR = .TRUE.
GO TO 280
10 IF (STMT(K2).EQ.65) ARRY = .TRUE.
KK = LOOKUP(K2,.FALSE.)
IF (SYSERR) GO TO 70
ARDECL = .TRUE.
L = IGATT1(KK,8)
IF (L.EQ.0 .OR. L.EQ.10) GO TO 30
IF (ITYP.LT.6 .AND. L.EQ.13) GO TO 30
20 CALL ERROR1(45H ILLEGAL USE OF PREVIOUSLY DEFINED IDENTIFIER, 45)
ERR = .TRUE.
GO TO 280
C
C SET TYPE (EXPLICITLY FOR TYPE STMTS)
C
30 I1 = IGATT1(KK,1)
IF (ITYP.GE.6) GO TO 50
C
C TYPE EXPLICITLY
C
IF (I1.GE.8) GO TO 40
CALL SATT1(KK, 1, ITYP+7)
GO TO 60
40 CALL ERROR1(34H IDENTIFIER TYPED EXPLICITLY TWICE, 34)
GO TO 60
C
C TYPE IMPLICITLY
C
50 IF (I1.GT.0) GO TO 60
I1 = 1
IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
CALL SATT1(KK, 1, I1)
C
C IF NOT ARRAY ELEMENT/ARAY DECLARATOR--RECOGNITION COMPLETE
C
C CHECK NOT A DUMMY ARG IN COMMON, DATA, EQUIV STMT
C
60 IF (ARRY) GO TO 80
IF (IGATT1(KK,7).EQ.0) GO TO 65
IF (ITYP.EQ.12)
1 CALL ERROR1(46H WARNING - ILLEGAL USE OF ARRAY IN EQUIVALENCE
2 , 46)
IF (ITYP.EQ.13)
1 CALL ERROR1(39H WARNING - ILLEGAL USE OF ARRAY IN DATA, 39)
65 CONTINUE
I1 = IGATT1(KK,4)
IF (.NOT.(I1.EQ.1 .AND. (ITYP.EQ.8 .OR. ITYP.EQ.12 .OR.
* ITYP.EQ.13))) GO TO 70
ERR = .TRUE.
CALL ERROR1(32H ILLEGAL USAGE OF DUMMY ARGUMENT, 32)
70 RETURN
80 ISIZ = 1
VAR = .FALSE.
IF (L.EQ.0) CALL SATT1(KK, 8, 10)
C
C LOOP TO FIND BOUNDS; CHECK THAT VARIABLE BOUNDS ARE DUMMY ARGS
C SET ADJUSTIBLE DIMENSION VARIABLE BIT; SET TYPE IMPLICITLY IF NOT
C ALREADY SET
C ACCUMULATE LENGTH IF IN DIMENSION, COMMON, OR TYPE STMT.
C CHECK FOR REPEAT DIMENSIONING IN THOSE STMTS
C
L = IGATT1(KK,7)
IF (ITYP.EQ.13 .OR. ITYP.EQ.12) GO TO 90
IF (L.EQ.0) GO TO 100
CALL ERROR1(44H ILLEGAL USE OF PREVIOUSLY DIMENSIONED ARRAY, 44)
ERR = .TRUE.
GO TO 270
90 IF (L.EQ.0) CALL ERROR1(
* 44H ILLEGAL USE OF ARRAY NOT PREVIOUSLY DEFINED, 44)
100 IF (K2+1.LT.NSTMT) GO TO 120
110 CALL ERROR1(28H ILLEGAL ARRAY BOUNDS SYNTAX, 28)
GO TO 270
C
C CHECK FOR POSITIVE INTEGER BOUND
C
120 PSTMT = K2 + 1
IF (.NOT.TOKPNO(PSTMT,I1,LL)) GO TO 130
IF (ITYP.EQ.7 .OR. ITYP.EQ.8 .OR. ITYP.LT.6) ISIZ = ISIZ*LL
IF (ITYP.NE.12) GO TO 170
IF (I1-K2.NE.2 .OR. STMT(PSTMT).NE.1) CORNER = .FALSE.
GO TO 170
C
C SEEK A VARIABLE BOUND
C
130 CALL NEXTOK(PSTMT, I1, L)
IF (L.NE.0) GO TO 110
IF (ITYP.LT.6 .OR. ITYP.EQ.7) GO TO 140
CALL ERROR1(32H VARIABLE DIMENSION ILLEGAL HERE, 32)
ERR = .TRUE.
GO TO 270
140 VAR = .TRUE.
L = LOOKUP(I1,.FALSE.)
IF (SYSERR) GO TO 70
N = IGATT1(L,8)
IF (N.NE.0 .AND. N.NE.10) GO TO 20
I2 = IGATT1(L,4)
IF (I2.EQ.1) GO TO 150
CALL ERROR1(42H ILLEGAL USAGE OF VARIABLE IN ARRAY BOUNDS, 42)
ERR = .TRUE.
GO TO 270
150 I2 = IGATT1(KK,4)
IF (I2.EQ.1) GO TO 160
CALL ERROR1(50H VARIABLY DIMENSIONED ARRAY MUST BE DUMMY ARGUMENT,
* 50)
ERR = .TRUE.
GO TO 270
160 CALL SATT1(L, 6, 1)
CALL SATT1(L, 8, 10)
N = IGATT1(L,1)
IF (N.GT.0) GO TO 170
N = 1
IF (STMT(K2+1).GE.38 .AND. STMT(K2+1).LE.43) N = 2
CALL SATT1(L, 1, N)
GO TO 170
C
C FIND "," AND ACCUMULATE LENGTH
C
170 ICNT = ICNT + 1
IF (ICNT.LE.3) GO TO 180
ISIZ = ISIZ/LL
CALL ERROR1(30H WARNING - TOO MANY SUBSCRIPTS, 30)
ICNT = 3
FLUSH = .TRUE.
GO TO 190
180 K2 = I1
IF (STMT(K2).EQ.68) GO TO 100
C
C FIND ")" STORE LENGTH OR -1 INTO ARRAY SYMBOL TABLE ELEMENT
C
IF (STMT(K2).NE.62) GO TO 110
190 IF (ITYP.EQ.13 .OR. ITYP.EQ.12) GO TO 260
CALL SATT1(KK, 7, ICNT)
C
C STORE LENGTH OF ARRAY
C
IF (VAR) GO TO 240
IF (DSA(KK+2).EQ.0) GO TO 200
N = DSA(KK+2)
DSA(N) = ISIZ
GO TO 220
200 IF (NEXT+2.GE.BNEXT) GO TO 210
DSA(KK+2) = NEXT
DSA(NEXT) = ISIZ
DSA(NEXT+1) = 0
NEXT = NEXT + 2
GO TO 220
210 SYSERR = .TRUE.
CALL ERROR1(33H IN ARDECL, TABLE OVERFLOW OF DSA,33)
220 IF (FLUSH) GO TO 270
230 K2 = K2 + 1
GO TO 70
C
C FIXUP FOR VARIABLY DIMENSIONED ARRAYS
C
240 IF (DSA(KK+2).EQ.0) GO TO 250
N = DSA(KK+2)
DSA(N) = -1
GO TO 220
250 IF (NEXT+2.GE.BNEXT) GO TO 210
DSA(KK+2) = NEXT
DSA(NEXT) = -1
DSA(NEXT+1) = 0
NEXT = NEXT + 2
GO TO 220
C
C CHECK FORCORNER ELEMENT IN EQUIVALENCE STMT
C
260 IF (ITYP.NE.12) GO TO 220
IF (CORNER) KK = -KK
GO TO 220
C
C CODE TO FLUSH CONSTRUCT--TO NEXT ")"
C
270 IF (K2.EQ.NSTMT) GO TO 70
IF (STMT(K2).EQ.62) GO TO 230
K2 = K2 + 1
GO TO 270
C
C CODE TO FLUSH TO NEXT CONSTRUCT ")",",", "/"
C
280 K = 90
IF (ITYP.EQ.8 .OR. ITYP.EQ.13) K = 67
290 IF (K2.EQ.NSTMT) GO TO 70
L = STMT(K2)
IF (L.EQ.65) GO TO 270
IF (L.EQ.68 .OR. L.EQ.K) GO TO 70
K2 = K2 + 1
GO TO 290
END
C XXXXXASSASF.f
SUBROUTINE ASSASF(IGP)
INTEGER STMT, PSTMT, PDSA, EXPR, DSA, BNEXT, SYMHD
LOGICAL ERR, SYSERR, ABORT, ASF, DOVAR
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
C
C PROCESSES ARITHMETIC STMT FCNS AND ASSIGNMENT STMTS
C FIRST LOOKS FOR ELEMENT ON RHS. AND TYPES IT
C
CALL NEXTOK(PSTMT, K2, K)
ASF = .FALSE.
IF (K.NE.0) GO TO 180
K = LOOKUP(K2,.FALSE.)
IF (SYSERR) GO TO 190
I1 = IGATT1(K,1)
IF (I1.NE.0) GO TO 10
I1 = 1
IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I1 = 2
CALL SATT1(K, 1, I1)
C
C LOOK FOR A "(" ; FIND ARRAY = CASE AND SEND IT TO ERROR
C FIND ARRAY ELEMENT = , ID = CASES AND SEND THEM TO
C ASSIGNMENT CODE
C
10 I2 = IGATT1(K,7)
I1 = MOD(I1,8)
IF (STMT(K2).NE.65 .AND. I2.NE.0) GO TO 180
IF (STMT(K2).NE.65 .OR. I2.NE.0) GO TO 240
C
C ASF DEFN
C
ITYP = 31
ASF = .TRUE.
IGP = 4
NUM = 0
IASF = K
20 PSTMT = K2 + 1
IF (PSTMT.GE.NSTMT) GO TO 180
C
C ASF HAS LIST OF SCALAR VARIABLES; THEY ARE TYPED AND USAGE SET
C
CALL NEXTOK(PSTMT, K2, I)
IF (I.EQ.0) GO TO 30
CALL ERROR1(17H ILLEGAL ASF DEFN, 17)
GO TO 190
30 I = LOOKUP(K2,.FALSE.)
IF (SYSERR) GO TO 190
NUM = NUM + 1
I2 = IGATT1(I,1)
IF (I2.GT.0) GO TO 40
I2 = 1
IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I2 = 2
CALL SATT1(I, 1, I2)
40 I2 = IGATT1(I,8)
IF (I2.EQ.0) GO TO 50
IF (I2.EQ.1) GO TO 60
CALL ERROR1(29H ILLEGAL VARIABLE IN ASF DEFN, 29)
GO TO 210
50 CALL SATT1(I, 8, 1)
C STORE PTR TO CURRENT ASF-FCN ENTRY IN SYMBOL
C TABLE IN 3D WORD OF ASF-DUMMY ENTRY IN SYM TABLE
60 DSA(I+2) = K
C
C LIST OF INDICES OF ASF ARGS IS HUNG OFF OF ASF DEF IN DSA
C
IF (DSA(K+2).EQ.0) GO TO 120
L = DSA(K+2)
70 IF (DSA(L+1).EQ.0) GO TO 80
L = DSA(L+1)
GO TO 70
80 IF (NEXT+2.LT.BNEXT) GO TO 100
90 CALL ERROR1(33H IN ASSASF, TABLE OVERFLOW OF DSA, 33)
SYSERR = .TRUE.
GO TO 190
100 DSA(L+1) = NEXT
110 DSA(NEXT) = I
DSA(NEXT+1) = 0
NEXT = NEXT + 2
GO TO 130
120 IF (NEXT+2.GE.BNEXT) GO TO 90
DSA(K+2) = NEXT
GO TO 110
130 IF (STMT(K2).NE.62) GO TO 170
C
C CHECK FOR TWO ELEMENTS ONLIST BEING THE SAME ID
C
I2 = DSA(K+2)
DO 160 I=1,NUM
L = DSA(K+2)
DO 150 J=1,NUM
IF (I.EQ.J) GO TO 140
IF (DSA(L).NE.DSA(I2)) GO TO 140
CALL ERROR1(18H ILLEGAL ASF-DUMMY, 18)
CALL SATT1(K, 8, 0)
GO TO 190
140 L = DSA(L+1)
150 CONTINUE
I2 = DSA(I2+1)
160 CONTINUE
GO TO 200
170 IF (STMT(K2).EQ.68) GO TO 20
180 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
190 RETURN
C
C = AND EXPR CHECK
C
200 PSTMT = K2 + 1
210 IF (PSTMT.GE.NSTMT) GO TO 180
IF (STMT(PSTMT).NE.63) GO TO 180
PSTMT = PSTMT + 1
IF (PSTMT.GE.NSTMT) GO TO 180
L = EXPR(I)
IF (SYSERR) GO TO 190
C
C CHECK THAT ASF WAS NOT DEFINED RECURSIVELY, SET USAGE
C
IF (.NOT.ASF) GO TO 230
I2 = IGATT1(K,8)
IF (I2.EQ.0) GO TO 220
CALL ERROR1(17H ILLEGAL ASF NAME, 17)
GO TO 190
220 CALL SATT1(K, 8, 2)
230 IF (L/8.EQ.1) GO TO 280
L = MOD(L,8)
C
C COMPARE TYPES OF RHS AND LHS
C
IF ((L.EQ.3 .AND. I1.EQ.3) .OR. (L.EQ.4 .AND. I1.EQ.4) .OR.
* (L.LE.2 .AND. I1.LE.2) .OR. (L.EQ.5 .AND. I1.EQ.5)) GO TO 190
IF (.NOT.(L.EQ.2 .AND. I1.EQ.5 .OR. L.EQ.5 .AND. I1.EQ.2)) CALL
* ERROR1(38H INCOMPATIBLE DATA TYPES IN ASSIGNMENT, 38)
GO TO 190
C
C PROCESSING FOR ASSIGNMENT STMT
C
240 I = IGATT1(K,8)
IF (I.NE.0) GO TO 250
I = 10
CALL SATT1(K, 8, 10)
250 IF (I.EQ.10 .OR. (I.EQ.4 .AND. K.EQ.NAME)) GO TO 260
CALL ERROR1(31H CANNOT ASSIGN VALUE TO THIS ID, 31)
GO TO 190
260 CALL SATT1(K, 5, 1)
IF (STMT(K2).EQ.65) GO TO 270
IF (DOVAR(K)) CALL ERROR1(
* 57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS,
* 57)
PSTMT = K2
GO TO 210
270 PSTMT = K2 + 1
IF (PSTMT.GE.NSTMT) GO TO 180
CALL SUBS(I, I2)
C
C PEEL SUBSCRIPTS OFF
C
IF (SYSERR .OR. ERR) GO TO 190
PSTMT = I
GO TO 210
280 CALL ERROR1(30H ILLEGAL USE OF ARRAY VARIABLE, 30)
GO TO 190
END
C XXXXXASSIGN.f
SUBROUTINE ASSIGN
INTEGER PSTMT, STMT
LOGICAL TOKLAB, ERR, SYSERR, ABORT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /DETECT/ ERR, SYSERR, ABORT
C
C PROCESSES AN ASSIGN STMT: ASSIGN <LABEL> TO <VAR>
C
IF (PSTMT.GE.NSTMT) GO TO 10
IF (.NOT.TOKLAB(1,K2,KK,.FALSE.)) GO TO 80
IF (SYSERR) GO TO 20
PSTMT = K2
IF (PSTMT+2.GE.NSTMT) GO TO 10
IF (STMT(PSTMT).EQ.49 .AND. STMT(PSTMT+1).EQ.44) GO TO 30
10 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
20 RETURN
30 PSTMT = PSTMT + 2
IF (PSTMT.GE.NSTMT) GO TO 10
CALL NEXTOK(PSTMT, K2, K)
IF (K.NE.0) GO TO 10
K = LOOKUP(K2,.FALSE.)
IF (SYSERR) GO TO 20
I1 = IGATT1(K,1)
I2 = IGATT1(K,7)
I3 = IGATT1(K,8)
IF (I3.EQ.0) GO TO 40
IF (I3.NE.8) GO TO 90
GO TO 50
40 CALL SATT1(K, 8, 8)
50 IF (I1.NE.0) GO TO 60
I1 = 1
IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
CALL SATT1(K, 1, I1)
60 IF (MOD(I1,8).EQ.2 .AND. I2.EQ.0) GO TO 70
CALL ERROR1(35H ASSIGN VARIABLE NOT INTEGER SCALAR, 35)
GO TO 20
70 IF (K2.NE.NSTMT) GO TO 10
GO TO 20
80 CALL ERROR1(14H MISSING LABEL, 14)
GO TO 20
90 CALL ERROR1(23H ILLEGAL VARIABLE USAGE, 23)
GO TO 20
END
C XXXXXCOMMON.f
SUBROUTINE COMMON
INTEGER PSTMT, PDSA, STMT, DSA, BNEXT, SYMHD, S(4)
LOGICAL ERR, SYSERR, ABORT, ARDECL
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /FACTS/ NAME, NOST, ITYP, IASF
DATA S(1) /66/, S(2) /32/, S(3) /44/, S(4) /42/
C
C PROCESSES A COMMON STMT
C FIRST, PEEL OFF NAME OF COMMON AND SET SYMBOL TABLE ENTRY USAGE
C CHECK NAME HAS NOT APPEARED BEFORE IN PGM UNIT
C
IF (STMT(PSTMT).EQ.67) GO TO 30
C
C SET SYMBOL TABLE ENTRY FOR BLANK COMMON
C
10 I1 = IGATT1(NAME,8)
IF (I1.EQ.11) GO TO 170
IF (PSTMT.GE.NSTMT) GO TO 200
L = PSTMT
DO 20 I1=1,4
STMT(I1) = S(I1)
20 CONTINUE
PSTMT = 1
KK = LOOKUP(5,.FALSE.)
IF (SYSERR) GO TO 190
PSTMT = L
CALL SATT1(KK, 8, 7)
GO TO 60
30 PSTMT = PSTMT + 1
IF (STMT(PSTMT).NE.67) GO TO 40
PSTMT = PSTMT + 1
GO TO 10
40 IF (PSTMT.GE.NSTMT) GO TO 200
CALL NEXTOK(PSTMT, K2, L)
IF (L.NE.0) GO TO 200
KK = LOOKUP(K2,.FALSE.)
IF (SYSERR) GO TO 190
I1 = IGATT1(KK,1)
N = IGATT1(KK,8)
IF (I1.EQ.0 .AND. (N.EQ.0 .OR. N.EQ.7)) GO TO 50
CALL ERROR1(20H ILLEGAL COMMON NAME, 20)
GO TO 190
50 CALL SATT1(KK, 8, 7)
I1 = IGATT1(NAME,8)
IF (I1.EQ.11) CALL SATT1(KK, 2, 1)
PSTMT = K2 + 1
IF (PSTMT.GE.NSTMT .OR. STMT(K2).NE.67) GO TO 200
C
C ELEMENTS IN COMMON: ARRAYS,VARIABLES,DECLARATIONS OF ARRAYS( NOT
C VARIABLY DIMENSIONED). IMPLICITLY TYPE THEM
C
60 IF (ARDECL(K2,N)) GO TO 70
CALL ERROR1(47H COMMON ELEMENT NOT VARIABLE, ARRAY, DECLARATOR,
* 47)
GO TO 190
70 IF (SYSERR .OR. ERR) GO TO 190
C
C SET SYMBOL TABLE ENTRY OF ELEMENT TO SHOW ITS IN COMMON
C PUT POINTER TO COMMON NAME INTO 3D WORD OF ENTRY (OR OFF 3D
C WORD--FOR ARRAYS
C
I1 = IGATT1(N,2)
IF (I1.NE.0) GO TO 160
CALL SATT1(N, 2, 1)
I1 = IGATT1(N,7)
IF (I1.EQ.0) GO TO 80
L = DSA(N+2)
DSA(L+1) = KK
GO TO 90
80 CALL SATT1(N, 8, 10)
IF (NEXT+2.GE.BNEXT) GO TO 180
DSA(N+2) = NEXT
DSA(NEXT) = 0
DSA(NEXT+1) = KK
NEXT = NEXT + 2
C
C SETUP CHAIN OF ELEMENTS OF COMMON HANGING OFF SYMBOL TABLE
C ENTRY OF COMMON NAME
C
90 IF (DSA(KK+2).EQ.0) GO TO 130
L = DSA(KK+2)
100 IF (DSA(L+1).EQ.0) GO TO 110
L = DSA(L+1)
GO TO 100
110 IF (NEXT+2.GE.BNEXT) GO TO 180
DSA(L+1) = NEXT
120 DSA(NEXT) = N
DSA(NEXT+1) = 0
NEXT = NEXT + 2
GO TO 140
130 IF (NEXT+2.GE.BNEXT) GO TO 180
DSA(KK+2) = NEXT
GO TO 120
C
C CHECK FOR END OF STMT
C
140 IF (K2.EQ.NSTMT) GO TO 190
IF (STMT(K2).NE.68) GO TO 150
PSTMT = K2 + 1
GO TO 60
150 IF (STMT(K2).NE.67) GO TO 200
PSTMT = K2
GO TO 30
160 CALL ERROR1(23H ELEMENT IN TWO COMMONS, 23)
GO TO 140
170 CALL ERROR1(
* 51H BLANK COMMON NOT ALLOWED IN BLOCK DATA SUBPROGRAMS, 51)
GO TO 190
180 SYSERR = .TRUE.
CALL ERROR1(33H IN COMMON, TABLE OVERFLOW OF DSA,33)
190 RETURN
200 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
GO TO 190
END
C XXXXXDIMENS.f
SUBROUTINE DIMENS
C
C PROCESSES DIMENSION STMT, RECORDING OF ARRAY BOUNDS, LENGTH
C ETC. DONE IN ORDER
C
INTEGER STMT, PSTMT
LOGICAL ERR, SYSERR, ABORT, ARDECL
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
10 IF (ARDECL(K2,K3)) GO TO 20
CALL ERROR1(35H ILLEGAL SYNTAX OF ARRAY DECLARATOR, 35)
GO TO 40
20 IF (SYSERR) RETURN
IF (K2.EQ.NSTMT) GO TO 40
IF (STMT(K2).EQ.68 .AND. K2+1.NE.NSTMT) GO TO 30
CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
GO TO 40
30 PSTMT = K2 + 1
GO TO 10
40 RETURN
END
C XXXXXDOCHK.f
SUBROUTINE DOCHK(KK)
INTEGER DOLIST, DOPT, OUTUT, SYMLEN, OUTUT2, DSA, PDSA, OUTUT3,
* STACK, OUTUT4
COMMON /DOS/ DOPT, LDO, DOLIST(192)
COMMON /CEXPRS/ LSTACK, STACK(620)
COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
* OUTUT4
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
C
C KK IS SYMBOL TABLE ENTRY OF LABEL
C ROUTINE CHECKS ALL LABELS FOR BEING END OF DO-STMTS; IF LABEL IS
C END-OF-DO, ALL LABELS WITHIN THAT DO, HAVE END-OF-DEFN STMT NO
C RECORDED IN THEM; DOPT IS DECREMENTED, A MOCK END-OF-DO IS
C CREATED BY THE END STMT IN THE PGM UNIT; DOLIST MUST BE EMPTY
C AFTER THIS PROCESSING OF AN END,
C PERFORMS FIXUP ON SCOPE OF LABELS ENDING MULTIPLE NESTED DO'S
C
IF (ITYP.EQ.28) GO TO 50
IF (DOLIST(DOPT+1).NE.KK) GO TO 40
10 CALL FIXLAB(.FALSE.)
DOPT = DOPT - 6
IF (ITYP.EQ.15 .OR. ITYP.EQ.16 .OR. (ITYP.GE.19 .AND.
* ITYP.LE.22)) CALL ERROR1(26H ILLEGAL ENDING STMT ON DO, 26)
IF (DOLIST(DOPT+1).NE.KK) GO TO 40
C
C GET REFERENCE TO NESTED DO ENDING AND MAKE REFERENCE
C TO DO STATEMENT A NEGATIVE NUMBER
C SO IT WON'T BE AN ILLEGAL BRANCH
C
K = DSA(KK+1)
L = DOLIST(DOPT)
20 IF (DSA(K).EQ.L) GO TO 30
K = DSA(K+1)
GO TO 20
30 DSA(K) = -DSA(K)
GO TO 10
40 RETURN
50 CALL FIXLAB(.TRUE.)
IF (DOPT-6.LE.0) GO TO 40
LL = 1
L = DOPT/6
DO 60 I=1,L
J = DOPT + 7 - 6*I
K = DOLIST(J)
CALL S5UNPK(DSA(K+4), STACK(LL), 6)
LL = LL + 6
60 CONTINUE
LL = LL - 1
IF (LL.LE.55) GO TO 70
99999 FORMAT (/25H MISSING DO ENDING LABEL , 55A1)
WRITE (OUTUT,99999) (STACK(L),L=1,55)
WRITE (OUTUT,99998) (STACK(L),L=56,LL)
GO TO 40
99998 FORMAT (25X, 55A1)
70 WRITE (OUTUT,99999) (STACK(L),L=1,LL)
GO TO 40
END
C XXXXXDOSPEC.f
SUBROUTINE DOSPEC(KK, K2, LOG)
INTEGER STMT, PSTMT, DOPT, DOLIST, LOOKUP
LOGICAL SYSERR, ABORT, DOVAR, ERR, TOKPNO, LOG
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /LISTDO/ LPT, LEN, LS(64)
COMMON /DOS/ DOPT, LDO, DOLIST(192)
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /DETECT/ ERR, SYSERR, ABORT
C
C ROUTINE RECOGNIZES DO-SPECIFICATION CONSTRUCT
C DOLIST ARRAY IS DO STACK USED TO CHECK NESTING; 6 WORD ENTRY
C WORD 1-CURRENT STMT NO
C WORD 2-INDEX OF LABEL IN DSA
C WORD 3-INDEX OF DO CONTROL VARIABLE IN DSA
C WORD 4-6,-INDICES OF LIMITS IN DSA OR 0 FOR CONSTANT LIMITS
C LS ARRAY IS IMPLICIT DO STACK- IN EACH ENTRY IS SAME DATA
C AS WORDS 3-6 OF DOLIST ENTRIES.
C
IF (.NOT.LOG) GO TO 10
IF (LPT.LE.1) GO TO 20
LPT = LPT - 4
LS(LPT) = 0
LS(LPT+1) = 0
LS(LPT+2) = 0
LS(LPT+3) = 0
GO TO 40
10 IF (DOPT.LE.LDO-11) GO TO 30
20 CALL ERROR1(20H DO NESTING TOO DEEP, 20)
GO TO 190
30 DOPT = DOPT + 6
DOLIST(DOPT) = NOST
DOLIST(DOPT+1) = KK
DOLIST(DOPT+2) = 0
DOLIST(DOPT+3) = 0
DOLIST(DOPT+4) = 0
DOLIST(DOPT+5) = 0
C
C DO CONTROL VARIABLE MUST BE INTEGER, SCALAR VARIABLE
C
40 IF (PSTMT.LT.NSTMT) GO TO 60
50 CALL ERROR1(35H ILLEGAL SYNTAX IN DO SPECIFICATION, 35)
GO TO 190
60 CALL NEXTOK(PSTMT, K2, K)
IF (K.NE.0) GO TO 50
K = LOOKUP(K2,.FALSE.)
IF (SYSERR) GO TO 180
I1 = IGATT1(K,1)
IF (I1.GT.0) GO TO 70
I1 = 1
IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
CALL SATT1(K, 1, I1)
70 I2 = IGATT1(K,7)
I3 = IGATT1(K,8)
IF (MOD(I1,8).NE.2 .OR. I2.NE.0) GO TO 220
IF (I3.NE.0) GO TO 80
I3 = 10
CALL SATT1(K, 8, 10)
80 IF (I3.NE.10) GO TO 220
CALL SATT1(K, 5, 1)
IF (DOVAR(K)) CALL ERROR1(
* 57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS,
* 57)
I3 = IGATT1(K,2)
IF (I3.EQ.1) CALL ERROR1(37H WARNING - CONTROL VARIABLE IN COMMON,
* 37)
IF (K.EQ.NAME) CALL ERROR1(
* 49H WARNING - FUNCTION NAME USED AS CONTROL VARIABLE, 49)
IF (.NOT.LOG) GO TO 90
LS(LPT) = K
GO TO 100
90 DOLIST(DOPT+2) = K
C
C FIND AN =
C
100 IF (STMT(K2).NE.63) GO TO 50
C
C DO-LIMITS LIMS COUNTS NUMBER OF LIMITS; THESE MUST BE INTEGER
C SCALAR VARIABLES OR POSITIVE INTEGER CONSTANTS
C
LIMS = 0
110 PSTMT = K2 + 1
IF (PSTMT.GE.NSTMT) GO TO 50
IF (.NOT.TOKPNO(PSTMT,K2,K)) GO TO 120
LIMS = LIMS + 1
GO TO 170
120 CALL NEXTOK(PSTMT, K2, K)
IF (K.NE.0) GO TO 210
K = LOOKUP(K2,.FALSE.)
IF (SYSERR) GO TO 180
LIMS = LIMS + 1
IF (.NOT.LOG) GO TO 130
IF (LS(LPT).EQ.K) CALL ERROR1(17H ILLEGAL DO LIMIT, 17)
I1 = LPT + LIMS
LS(I1) = K
GO TO 140
130 IF (DOLIST(DOPT+2).EQ.K) CALL ERROR1(17H ILLEGAL DO LIMIT, 17)
I1 = DOPT + 2 + LIMS
DOLIST(I1) = K
140 I1 = IGATT1(K,1)
I2 = IGATT1(K,7)
I3 = IGATT1(K,8)
IF (I3.NE.0) GO TO 150
CALL SATT1(K, 8, 10)
I3 = 10
150 IF (I3.NE.10) GO TO 50
IF (I1.GT.0) GO TO 160
I1 = 1
IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
CALL SATT1(K, 1, I1)
160 IF (MOD(I1,8).NE.2 .OR. I2.NE.0) GO TO 210
C
C CHECK FOR END OF STMT
C
170 IF (K2.LT.NSTMT .AND. STMT(K2).NE.62) GO TO 200
C
C IF THERE ARE NO MORE CHARS, WE ARE DONE WITH THIS STMT;
C THERE MUST BE AT LEAST 2 AND NO MORE THAN 3 LIMITS IN DO
C
IF (LIMS.LE.1) GO TO 230
180 RETURN
190 ERR = .TRUE.
GO TO 180
C
C CHECK FOR A "," MUST FIND HERE
C
200 IF (STMT(K2).NE.68) GO TO 50
IF (LIMS.GE.3) GO TO 230
GO TO 110
210 CALL ERROR1(47H DO LIMIT NOT INTEGER SCALAR VAR OR POS INTEGER,
* 47)
GO TO 190
220 CALL ERROR1(36H CONTROL VARIABLE NOT INTEGER SCALAR, 36)
GO TO 190
230 CALL ERROR1(18H ILLEGAL DO LIMITS, 18)
GO TO 190
END
C XXXXXDOVAR.f
LOGICAL FUNCTION DOVAR(INDX)
INTEGER DOPT, DOLIST
COMMON /DOS/ DOPT, LDO, DOLIST(192)
C
C CHECKS VAR AT DSA(INDX) NOT IN DOSTACK ALREADY
C AS A LIMIT OR INDEX OF PREVIOUSLY DEFINED AND CURRENTLY
C DEFINED DO
C
DOVAR = .FALSE.
IF (DOPT) 40, 40, 10
10 DO 30 I=1,DOPT,6
L1 = I + 2
L2 = L1 + 3
DO 20 K=L1,L2
IF (DOLIST(K).EQ.INDX) GO TO 50
20 CONTINUE
30 CONTINUE
40 RETURN
50 DOVAR = .TRUE.
GO TO 40
END
C XXXXXEQUIV.f
SUBROUTINE EQUIV
INTEGER STMT, PSTMT, PDSA, DSA, TYPE, STACK, BNEXT, SYMHD
LOGICAL ARDECL, CORNR, SAME, ERR, SYSERR, ABORT
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /CEXPRS/ LSTACK, STACK(620)
C
C PROCESSES AN EQUIVALENCE STMT-FINDS DECLARATORS SEPARATED BY ,
C IF DIFFERENT TYPE VARIABLES INVOLVED, CHECKS FOR USE OF CORNER
C ELEMENTS; ARDECL CALLED TO PROCESS DECLARATORS
C SAME IS .TRUE. IF ALL ITEMS EQUIVALENCED IN ONE (--) ARE SAME TYPE
C CORNR IS .TRUE. IF ALL ITEMS EQUIV. IN ONE (--) ARE CORNER ELES.
C E.G. A(1,1,1)
C
10 IF (STMT(PSTMT).EQ.65) GO TO 30
20 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
GO TO 150
30 TYPE = -1
IPT = 1
CORNR = .TRUE.
SAME = .TRUE.
40 PSTMT = PSTMT + 1
IF (PSTMT.GE.NSTMT) GO TO 20
IF (.NOT.ARDECL(K2,KK)) GO TO 150
IF (SYSERR .OR. ERR) GO TO 150
C
C KK>= 0 FOR AN ARRAY ELEMENT MEANS IT WASN'T A CORNER ELEMENT
C
L = IGATT1(IABS(KK),7)
IF (KK.GT.0 .AND. L.GT.0) CORNR = .FALSE.
KK = IABS(KK)
C
C SET USAGE, IF UNSET
C
L = IGATT1(KK,8)
IF (L.EQ.0) CALL SATT1(KK, 8, 10)
C
C STORE VARIABLE IN STACK, CHECK VARIABLE TYPE
C
STACK(IPT) = KK
IPT = IPT + 1
CALL SATT1(KK, 3, 1)
I = IGATT1(KK,1)
I = MOD(I,8)
IF (-1.EQ.TYPE) TYPE = I
IF (TYPE.EQ.I) GO TO 50
SAME = .FALSE.
C
C END OF DELARATOR CHECKS; NEED , OR )
C
50 IF (STMT(K2).NE.68) GO TO 60
PSTMT = K2
GO TO 40
60 IF (STMT(K2).NE.62) GO TO 20
C
C CHECK FOR CORNER ELEMENTS IF ARRAY ELEMENTS WERE USED
C
IF (.NOT.SAME .AND. .NOT.CORNR) CALL ERROR1(
* 53H WARNING - USE CORNER ELEMENTS WHEN MIXING DATA TYPES, 53)
C
C CHECK FOR ELEMENTS IN COMMON; MAKE SURE ONLY ONE COMMON
C REGION APPEARS
C
KK = IPT - 1
C
C PUT COMMON REGIONS OF EACH DECLARATOR (IF ANY) ON STACK
C
DO 80 I=1,KK
L = IGATT1(STACK(I),2)
IF (L) 80, 80, 70
70 IF(IPT+1.GT.LSTACK) GOTO 160
L = STACK(I)
L = DSA(L+2)
STACK(IPT) = DSA(L+1)
IPT = IPT + 1
80 CONTINUE
IF (KK+2.GE.IPT) GO TO 90
CALL ERROR1(40H EQUIVALENCE CONFLICTS WITH COMMON DEFNS, 40)
GO TO 130
90 IF (KK+1.EQ.IPT) GO TO 130
C
C MARK ALL DECLARATORS IN EQUIV (--) AS IF IN COMMON BLOCK
C THAT ANY ONE OF THEM IS ACTUALLY IN
C
DO 120 I=1,KK
L = IGATT1(STACK(I),2)
IF (L.EQ.1) GO TO 120
CALL SATT1(STACK(I), 2, 1)
L = STACK(I)
IF (DSA(L+2)) 100, 100, 110
100 IF(NEXT+2.GE.BNEXT) GOTO 170
DSA(L+2) = NEXT
DSA(NEXT) = 0
DSA(NEXT+1) = STACK(IPT-1)
NEXT = NEXT + 2
GO TO 120
110 L = DSA(L+2)
DSA(L+1) = STACK(IPT-1)
120 CONTINUE
130 IF (K2+1.EQ.NSTMT) GO TO 150
IF (STMT(K2+1).NE.68) GO TO 20
PSTMT = K2 + 2
GO TO 10
150 RETURN
160 CALL ERROR1(34H IN EQUIV, TABLE OVERFLOW OF STACK,34)
180 SYSERR = .TRUE.
GOTO 150
170 CALL ERROR1(32H IN EQUIV, TABLE OVERFLOW OF DSA, 32)
GOTO 180
END
C XXXXXEXTERN.f
SUBROUTINE EXTERN
LOGICAL ERR, SYSERR, ABORT
LOGICAL BR, INTEXT
INTEGER STMT, PSTMT
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /DETECT/ ERR, SYSERR, ABORT
C
C PROCESS AN EXTERNAL STMT. CAUSES IDS TO BE MARKED AS EXTERNAL
C PROCEDURES. ERROR OCCURS IF ID HAS PREVIOUSLY DEFINED INCONSISTANT
C USAGE. EXTERNAL CAN'T APPEAR IN BLOCK DATA PGM UNIT.
C
L = IGATT1(NAME,8)
IF (L.EQ.11) GO TO 60
10 CALL NEXTOK(PSTMT, K2, KK)
IF (KK.EQ.0) GO TO 20
CALL ERROR1(19H ILLEGAL IDENTIFIER, 19)
GO TO 70
20 KK = LOOKUP(K2,.FALSE.)
IF (SYSERR) RETURN
L = IGATT1(KK,8)
IF (L.EQ.0) GO TO 30
CALL ERROR1(26H ILLEGAL USE OF IDENTIFIER, 26)
GO TO 40
30 CALL SATT1(KK, 8, 13)
C
C CAUSE EXTERNAL BIT TO BE SET IF POSSIBLE BASIC EXTERNAL
C
40 BR = INTEXT(KK,0,0,.FALSE.)
IF (K2.EQ.NSTMT) GO TO 70
IF (STMT(K2).NE.68) GO TO 50
PSTMT = K2 + 1
GO TO 10
50 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
GO TO 70
60 CALL ERROR1(
*60H ILLEGAL USAGE OF EXTERNAL STMT WITHIN BLOCK DATA SUBPROGRAM,
* 60)
70 RETURN
END
C XXXXXFIXLAB.f
SUBROUTINE FIXLAB(ND)
C
C ROUTINE SETS END-OF-DEF-STMT NO FOR LABELS
C WHEN CALLED BY END STMT, FIXES ALL LABEL DEFS YET UNBOUND
C TO THE END OF PGM STMT NO. WHEN CALLED BY DO STMT
C FIXES UP ALL LABELS AT THE LEVEL OF THE CURRENT
C DO TO END-OF-DO STMT NO; ND TRUE MEANS AN END STMT CALLED FIXLAB
C
LOGICAL ND
INTEGER DOLIST, DOPT, BNEXT, SYMHD, DSA, PDSA
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /DOS/ DOPT, LDO, DOLIST(192)
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
LEV = -DOPT/6
I = LABHD
10 IF (I.EQ.0) RETURN
K = IGATT1(I,2)
IF (K.NE.1) GO TO 30
K = IGATT1(I,1)
IF (K.NE.1) GO TO 30
K = DSA(I+2)
IF (ND) GO TO 20
IF (DSA(K+1).EQ.LEV) DSA(K+1) = NOST
GO TO 30
20 IF (DSA(K+1).LE.0) DSA(K+1) = NOST
30 I = DSA(I+3)
GO TO 10
END
C XXXXXFORMAT.f
SUBROUTINE FORMAT
INTEGER STMT, PSTMT
LOGICAL TOKPNO, SIGN, ERROR
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
C
C ROUTINE PROCESSES FORMAT STMT
C FORMAT (Q1 T1 Z1 T2 Z2 ... TN Q2)
C Q1,Q2 ARE EMPTY OR ARE SEPARARTERS
C T1,T2 ETC. ARE FORMAT-ITEMS
C Z1,Z2, ETC. ARE SEPARATERS
C CHECKS FOR <= 2 LEVELS OF PARENTHESES
C
ERROR = .FALSE.
ICNT = 0
C
C "("
C
IF (STMT(PSTMT).EQ.65) GO TO 30
10 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
C
C SEARCH FOR FORMAT ITEMS
C
20 RETURN
30 ICNT = ICNT + 1
IF (ICNT.GT.2) CALL ERROR1(28H TOO MANY PARENTHESES LEVELS, 28)
PSTMT = PSTMT + 1
C
C LOOK FOR Q1
C
CALL SEPAR(I)
C TAKES CARE OF FORMAT()
IF (STMT(PSTMT).EQ.62) GO TO 180
IF (STMT(PSTMT-1).EQ.68) CALL ERROR1(25H ILLEGAL PUNCTUATION (, ,
* 25)
40 IF (STMT(PSTMT).EQ.65) GO TO 30
IF (PSTMT.GE.NSTMT) GO TO 10
SIGN = .FALSE.
C
C SEARCH FOR REPEAT FACTER (POSITIVE INTEGER)
C
IF (TOKPNO(PSTMT,K2,N)) GO TO 70
C
C HOLLERITH STRINGS
C
IF (STMT(PSTMT).LT.0) GO TO 120
C
C "-" IN P SCALING FORMAT-ITEM
C
IF (STMT(PSTMT).NE.61) GO TO 50
SIGN = .TRUE.
PSTMT = PSTMT + 1
50 IF (PSTMT.GE.NSTMT) GO TO 10
C
C LOOK FOR <INT> IN PSCALING FORMAT-ITEM
C P SCALING FORMAT-ITEM
C ( - ) <INTEGER> P REPEAT (A,I,L) <WIDTH> . <INT>
C
CALL NEXTOK(PSTMT, K2, K)
C
C CHECK FOR USE OF "-" WITH NON P-SCALING CONSTRUCTS
C
IF (K.NE.1 .AND. SIGN) GO TO 100
IF (K.EQ.1) GO TO 60
N = STMT(PSTMT)
GO TO 90
60 SIGN = .TRUE.
PSTMT = K2
N = STMT(PSTMT)
GO TO 80
C
C LOOK FOR PART OF FORMAT-ITEM AFTER REPEAT FACTOR
C
70 PSTMT = K2
N = STMT(PSTMT)
C
C "("
C
IF (N.EQ.65) GO TO 30
C
C "X"
C
IF (N.EQ.53) GO TO 120
C
C "P"
C
80 IF (N.EQ.45) GO TO 130
IF (SIGN) GO TO 100
C
C A,I,L
C
90 IF (N.EQ.30 .OR. N.EQ.38 .OR. N.EQ.41) GO TO 110
C
C D,E,F,G
C
IF (N.GE.33 .AND. N.LE.36) GO TO 150
100 CALL ERROR1(20H ILLEGAL FORMAT ITEM, 20)
GO TO 20
C
C A,I,L FOUND. LOOK FOR <WIDTH>
C
110 IF (PSTMT+1.GE.NSTMT) GO TO 10
PSTMT = PSTMT + 1
IF (.NOT.TOKPNO(PSTMT,K2,I)) GO TO 100
IF (N.NE.30 .OR. I.EQ.1 .OR. ERROR) GO TO 160
CALL ERROR1(48H WARNING - A FORMAT ITEM NOT PORTABLE FOR N.GT.1,
* 48)
ERROR = .TRUE.
GO TO 160
C
C SKIP TO NEXT CHAR IN X OR HOLLERITH
C
120 PSTMT = PSTMT + 1
GO TO 170
C
C LOOK FOR CONSTRUCT FOLLOWING THE P. CAN BE A REPEAT
C
130 IF (PSTMT+1.GE.NSTMT) GO TO 10
PSTMT = PSTMT + 1
IF (STMT(PSTMT).GT.9 .OR. STMT(PSTMT).LT.0) GO TO 140
CALL NEXTOK(PSTMT, K2, K)
IF (K.NE.1) GO TO 10
PSTMT = K2
C
C AFTER D,E,F,G FIND <WIDTH> . <INT>
C
140 IF (STMT(PSTMT).LT.33 .OR. STMT(PSTMT).GT.36) GO TO 10
150 IF (PSTMT+1.GE.NSTMT) GO TO 10
PSTMT = PSTMT + 1
IF (.NOT.TOKPNO(PSTMT,K2,N)) GO TO 100
IF (STMT(K2).NE.64) GO TO 100
IF (K2+1.GE.NSTMT) GO TO 10
PSTMT = K2 + 1
CALL NEXTOK(PSTMT, K2, K)
IF (K.NE.1) GO TO 100
160 PSTMT = K2
C
C FINISHED A FORMAT-ITEM
C LOOK FOR SEPARATER OR ")"
C
170 IF (STMT(PSTMT).NE.62) GO TO 210
180 ICNT = ICNT - 1
IF (ICNT.LT.0) GO TO 190
IF (PSTMT+1.LT.NSTMT) GO TO 200
IF (ICNT.EQ.0) GO TO 20
190 CALL ERROR1(28H ILLEGAL PARENTHESES NESTING, 28)
GO TO 20
200 PSTMT = PSTMT + 1
GO TO 170
210 CALL SEPAR(I)
IF (I.EQ.0) CALL ERROR1(24H MISSING FIELD SEPARATOR, 24)
IF (STMT(PSTMT).NE.62) GO TO 40
IF (STMT(PSTMT-1).EQ.68) CALL ERROR1(25H ILLEGAL PUNCTUATION ,) ,
* 25)
GO TO 180
END
C XXXXXGETTOK.f
INTEGER FUNCTION GETTOK(K1, K2)
C
C GETTOK FINDS NEXT TOKEN IN STMT(K1)-STMT(K2-1)
C AND RETURNS A VALUE:
C 0= DOUBLE PRECISION CONSTANT-
C 2= INTEGER CONSTANT
C 1= REAL CONSTANT-
C 3= COMPLEX CONSTANT
C 4= LOGICAL CONSTANT
C 5= HOLLERITH CONSTANT
C 6= ID
C >10=OPERATOR (10+CODE FOR OPERATOR;HERE ARRAY AND FCN REFS ARE 16
C
INTEGER PSTMT, STMT
LOGICAL ERR, SYSERR, ABORT, TOKLOP, TOKRL, TOKCOM, TOKLOG
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /DETECT/ ERR, SYSERR, ABORT
10 GETTOK = -1
IF (.NOT.TOKRL(K1,K2,K)) GO TO 20
GETTOK = 1
IF (K.EQ.0) GETTOK = 0
GO TO 40
20 CALL NEXTOK(K1, K2, K)
K = K + 1
GO TO (50, 30, 60, 70), K
30 GETTOK = 2
40 RETURN
C
C PROCESS ID, SEE IF ITS A FCN CALL OR ARRAY NAME
C
50 GETTOK = 6
IF (STMT(K2).NE.65) GO TO 40
GETTOK = 16
K2 = K2 + 1
GO TO 40
60 GETTOK = 5
GO TO 40
70 K = STMT(K1)
IF (K.EQ.64) GO TO 100
IF (K.EQ.65) GO TO 80
IF (K.EQ.62) GETTOK = 12
IF (K.EQ.68) GETTOK = 18
IF (K.EQ.60 .OR. K.EQ.61) GETTOK = 11
IF (K.EQ.66 .OR. K.EQ.67) GETTOK = 17
IF (K2.EQ.K1+2) GETTOK = 13
IF (GETTOK+1) 40, 120, 40
80 GETTOK = 15
IF (TOKCOM(K1,K)) GO TO 90
GO TO 40
90 GETTOK = 3
K2 = K
GO TO 40
C
C CHECK FOR LOGICAL CONSTANTS,OPERATORS
C
100 IF (.NOT.TOKLOG(K1,K2)) GO TO 110
GETTOK = 4
GO TO 40
110 IF (.NOT.TOKLOP(K1,K2,K)) GO TO 120
GETTOK = K
GO TO 40
120 CALL ERROR1(26H ILLEGAL CHARACTER IGNORED, 26)
IF (K1+1.GE.NSTMT) GO TO 130
K1 = K1 + 1
GO TO 10
130 ERR = .TRUE.
RETURN
END
C XXXXXGOTO.f
SUBROUTINE GOTO
INTEGER STMT, PSTMT
LOGICAL TOKLAB, DONE, ERR, SYSERR, ABORT
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
C
C PROCESSES UNCONDITIONAL, ASSIGNED, AND COMPUTED GOTO STMTS
C
IF (PSTMT.GE.NSTMT) GO TO 100
DONE = .FALSE.
C
C UNCONDITIONAL GOTO
C
IF (TOKLAB(1,K2,K,.FALSE.)) GO TO 110
C
C COMPUTED GOTO
C
IF (SYSERR) GO TO 110
IF (STMT(PSTMT).EQ.65) GO TO 70
C
C ASSIGNED GOTO: GOTO <VAR> , ( <LAB> , ETC. )
C
10 CALL NEXTOK(PSTMT, K2, K)
IF (K.NE.0) GO TO 100
K = LOOKUP(K2,.FALSE.)
IF (SYSERR) GO TO 110
I1 = IGATT1(K,1)
IF (I1.NE.0) GO TO 20
I1 = 1
IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
CALL SATT1(K, 1, I1)
20 I2 = IGATT1(K,7)
IF (MOD(I1,8).NE.2 .OR. I2.NE.0) CALL ERROR1(
* 31H NOT AN INTEGER SCALAR VARIABLE, 31)
I1 = IGATT1(K,8)
IF (DONE) GO TO 40
C
C CHECK FOR ASSIGN VARIABLE IN USAGE
C
IF (I1.EQ.0) GO TO 30
IF (I1.NE.8) CALL ERROR1(26H ID NOT AN ASSIGN VARIABLE, 26)
GO TO 60
30 CALL SATT1(K, 8, 8)
GO TO 60
C
C CHECK FOR VARIABLE IN USAGE
C
40 IF (I1.EQ.0) GO TO 50
IF (I1.NE.10) CALL ERROR1(19H ILLEGAL ID IN GOTO, 19)
GO TO 130
50 CALL SATT1(K, 8, 10)
GO TO 130
C
C LOOK FOR ","
C
60 IF (STMT(K2).NE.68) GO TO 100
K2 = K2 + 1
DONE = .TRUE.
IF (STMT(K2).NE.65) GO TO 100
GO TO 80
70 PSTMT = PSTMT + 1
GO TO 90
80 PSTMT = K2 + 1
C
C LOOK FOR ( <LAB> , ETC.)
C
90 IF (PSTMT.GE.NSTMT) GO TO 100
IF (.NOT.TOKLAB(1,K2,K,.FALSE.)) GO TO 100
IF(SYSERR) GOTO 110
IF (STMT(K2).EQ.68) GO TO 80
IF (STMT(K2).NE.62) GO TO 100
IF (DONE) GO TO 120
DONE = .TRUE.
IF (STMT(K2+1).NE.68) GO TO 100
PSTMT = K2 + 2
IF (PSTMT.LT.NSTMT) GO TO 10
100 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
110 RETURN
C
C CHECK END OF STMT IS REACHED
C
120 K2 = K2 + 1
130 IF (K2.NE.NSTMT) CALL ERROR1(
* 34H EXTRANEOUS INFO AFTER END OF STMT, 34)
GO TO 110
END
C XXXXXID.f
SUBROUTINE ID(K2)
INTEGER STMT, PSTMT
LOGICAL ERR, SYSERR, ABORT, DOVAR
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /FACTS/ NAME, NOST, ITYP, IASF
C
C ROUTINE CHECKS IDENTIFIERS IN <LIST> FOR BEING ARRAY,ARRAY ELEMENT
C OR VARIABLE.- RETURNS ERR=.TRUE. IF MUST CEASE PROCESSING
C FIRST CHECK USAGE
C
K = LOOKUP(K2,.FALSE.)
IF (SYSERR) GO TO 50
C
C CHECK USAGE
C
I3 = IGATT1(K,8)
IF (I3.NE.0) GO TO 10
CALL SATT1(K, 8, 10)
GO TO 20
10 IF (I3.NE.10) CALL ERROR1(27H ILLEGAL IDENTIFIER IN LIST, 27)
C
C SET TYPE
C
20 I3 = IGATT1(K,1)
IF (I3.NE.0) GO TO 30
I3 = 1
IF (STMT(PSTMT).LE.43 .AND. STMT(PSTMT).GE.38) I3 = 2
CALL SATT1(K, 1, I3)
C
C CHECK FOR READING INTO DO CONTROL VARIABLE OR LIMIT
C
30 IF (ITYP.NE.23) GO TO 40
IF (DOVAR(K)) CALL ERROR1(
* 57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS,
* 57)
C
C MARK VARIABLES AS SET IF VALUES READ IN
C
CALL SATT1(K, 5, 1)
C
C SEPARATE OUT ARRAY ELEMENTS AND CHECK SUBSCRIPTS
C
40 IF (STMT(K2).NE.65) GO TO 50
I3 = IGATT1(K,7)
IF (I3.EQ.0) GO TO 60
PSTMT = K2 + 1
IF (PSTMT.GE.NSTMT) GO TO 80
CALL SUBS(K2, I3)
ERR = .FALSE.
50 RETURN
60 CALL ERROR1(40H ILLEGAL SUBSCRIPTING OF SCALAR VARIABLE, 40)
70 ERR = .TRUE.
GO TO 50
80 CALL ERROR1(19H SUBSCRIPTING ERROR, 19)
GO TO 70
END
C XXXXXIDLIST.f
LOGICAL FUNCTION IDLIST(IDO)
INTEGER PSTMT, STMT
LOGICAL ERR, SYSERR, ABORT, IDO
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /DETECT/ ERR, SYSERR, ABORT
C
C RECOGNIZES IDLIST=<ID> �, <ID>! ;LAST <ID> CANNOT BE FOLLOWED BY
C A '='; IDLIST MUST CONTAIN AT LEAST ONE ID. IDLIST=.FALSE. WILL
C BE RETURNED FOR AN IRRECOVERABLE SYNTAX ERROR.
C IDO SET TO .TRUE. WHEN <IDLIST> IS FOLLOWED BY <DOSPEC>
C
IDO = .FALSE.
IDLIST = .TRUE.
IF (PSTMT.GE.NSTMT) GO TO 60
CALL NEXTOK(PSTMT, K2, K)
IF (K.NE.0) GO TO 60
IF (STMT(K2).EQ.63) GO TO 20
CALL ID(K2)
IF (ERR .OR. SYSERR) GO TO 20
10 PSTMT = K2
IF (STMT(PSTMT).EQ.68 .AND. STMT(PSTMT+1).EQ.65 .OR.
* STMT(PSTMT).EQ.62 .OR. PSTMT.EQ.NSTMT) GO TO 30
IF (STMT(PSTMT).EQ.68) GO TO 50
CALL ERROR1(35H ILLEGAL TOKEN FOLLOWING IDENTIFIER, 35)
20 IDLIST = .FALSE.
ERR = .FALSE.
30 RETURN
40 IDO = .TRUE.
GO TO 30
C
C MAKE SURE <ID> = ISN'T NEXT CONSTRUCT
C
50 K2 = K2 + 1
IF (K2.GE.NSTMT) GO TO 60
CALL NEXTOK(K2, K3, K)
IF (STMT(K3).EQ.63) GO TO 40
PSTMT = K2
K2 = K3
CALL ID(K2)
IF (ERR .OR. SYSERR) GO TO 20
GO TO 10
60 CALL ERROR1(23H ILLEGAL SYNTAX IN LIST, 23)
GO TO 20
END
C XXXXXIFS.f
SUBROUTINE IFS(LOG)
LOGICAL TOKLAB, ERR, SYSERR, ABORT, LOG
INTEGER STMT, PSTMT, EXPR
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /DETECT/ ERR, SYSERR, ABORT
C
C ROUTINE PROCESSES ARITHMETIC AND LOGICAL IF STMTS
C LOG RETURNED AS TRUE IF LOGICAL-IF IS ENCOUNTERED;PU CHECKS FOR
C ACCEPTIBLE EXECUTABLE STMT AFTER LOGICAL EXPRESSION
C
LOG = .FALSE.
L = MOD(EXPR(I),8)
IF (-1.EQ.L .OR. SYSERR) GO TO 30
LOG = L.EQ.4
IF (LOG) GO TO 30
C
C ARITHMETIC IF--SEARCH FOR <LAB>,<LAB>,<LAB>
C
IF (L.GT.2) GO TO 50
I = 0
IF (PSTMT.GE.NSTMT) GO TO 20
10 IF (.NOT.TOKLAB(1,K2,L,.FALSE.)) GO TO 40
IF (SYSERR) GO TO 30
I = I + 1
IF (I.EQ.3) GO TO 60
IF (STMT(K2).NE.68) GO TO 20
PSTMT = K2 + 1
IF (PSTMT.LT.NSTMT) GO TO 10
20 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
30 RETURN
40 CALL ERROR1(14H MISSING LABEL, 14)
GO TO 30
50 CALL ERROR1(39H COMPLEX EXPRESSION ILLEGAL IN ARITH-IF, 39)
GO TO 30
60 IF (K2.EQ.NSTMT) GO TO 30
CALL ERROR1(34H EXTRANEOUS INFO AFTER END OF STMT, 34)
GO TO 30
END
C XXXXXINTEXT.f
LOGICAL FUNCTION INTEXT(LL, L1, L2, BR)
C
C LL POINTS TO DSA ENTRY OF FCN NAME
C L1 POINTS INTO STACK TO BEGINNING OF ARGS
C L2 POINTS INTO STACK TO LAST ARG ENTRY
C BR .TRUE. MEANS LOOK FOR BOTH EXTERNALS ND INTRINS
C BR FALSE MEANS JUST LOOK FOR EXTERNALS
C ROUTINE CHECKS FOR REFERENCES TO INTRINSIC OR BASIC EXTERNAL
C FCNS; RETURNS TRUE IF FINDS INTRINSIC FCN. CHECKS INTRINSICS
C ARGS FOR USAGE, TYPE AND NUMBER. MARKS POSSIBLE BASIC EXTDRNAL
C FCNS SENT DOWN TO IT
C
INTEGER STACK, BL, PDSA, DSA, FCN(6), Z
LOGICAL BR
COMMON /CEXPRS/ LSTACK, STACK(620)
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /INTS/ Z(346)
COMMON /FACTS/ NAME, NOST, ITYP, IASF
DATA BL /1H /
INTEXT = .FALSE.
CALL S5UNPK(DSA(LL+4), FCN(1), 6)
K = 1
DO 40 I=1,55
K1 = K + 1
K2 = K1 + Z(K) - 1
L = 0
DO 10 J=K1,K2
L = L + 1
IF (FCN(L).NE.Z(J)) GO TO 30
10 CONTINUE
IF (L.EQ.6) GO TO 60
L = L + 1
DO 20 J=L,6
IF (FCN(J).NE.BL) GO TO 30
20 CONTINUE
GO TO 60
30 K = K2 + 2
40 CONTINUE
50 RETURN
C
C DIFFERENTIATES BETWEEN A POSSIBLE BASIC EXTERNAL AND POSSIBLE
C INTRINSIC FCN
C
60 L = MOD(Z(K2+1),1024)/512
C
C IF POSSIBLE BASIC EXTERNAL CHECK TYPE AND SET IT IF NOT ALREADY
C EXPLICITLY SET
C
IF (L.NE.1) GO TO 70
L = IGATT1(LL,1)
IF (L/8.GE.1) GO TO 190
L = MOD(Z(K2+1),8)
IF (BR) L = L + 8
CALL SATT1(LL, 1, L)
C
C MARK AS USED IN PASS 1
C
GO TO 190
C
C CHEKC IF IN EXTERNAL STMT IF SO NOT AN INTRINSIC
C
70 IF (.NOT.BR) GO TO 50
L = IGATT1(LL,8)
IF (L.EQ.13) GO TO 50
C
C CHECK IF EXPLICITLY TYPES DIFFERENTLY THAN EXPECTED
C
L = IGATT1(LL,1)
J = MOD(Z(K2+1),8)
IF (L.GE.8) GO TO 80
CALL SATT1(LL, 1, J+8)
GO TO 90
80 IF (J.NE.MOD(L,8)) GO TO 50
C
C K POINTS TO THE FUNCTION ENTRY IN Z
C K1 POINTS TO FIRST LETTER IN FCN-NAME; K2 TO LAST LETTER
C FIELDS IN ATTRIBUTE WORD ARE AS FOLLOWS:
C BITS 0-2 TYPE FCN
C BITS 3-5 TYPE ARGS
C BIT 6 IF 1, FIXED NO ARGS; IF 0 VARIABLE NO OF ARGS
C BITS 7-8 MINIMUM NUMBER OF ARGS
C BITS 9 IF 0, INTRINSIC; IF 1 BASIC EXTERNAL
C BITS 10 IF 1 USED IN PASS 1; ELSE NOT REFERENCED
C
C FCN IS INTRINSIC
C CHECK NUMBER OF ARGS
C
90 I = MOD(Z(K2+1),128)/64
J = MOD(Z(K2+1),512)/128
IF (I) 100, 100, 120
C
C VARIABLE NUMBER OF ARGS ALLOWED
C MUST BE AT LEAST J
C
100 IF ((L2-L1+1)/2.GE.J) GO TO 130
110 CALL ERROR2(29H INCORRECT NUMBER OF ARGS IN , 29, DSA(LL+4),
* 1, 1, 1)
GO TO 180
C
C FIXED NUMBER OF ARGS
C
120 IF ((L2-L1+1)/2.NE.J) GO TO 110
C
C CHECK THRU ARG LIST OR PROPER TYPE ID AS AN ARG;
C CHECK TYPE AND THAT ARGS ARE SCALARS
C
130 L = MOD(Z(K2+1),64)/8
DO 170 N=L1,L2,2
C
C CHECK FOR EXPRESSION AS ARG
C
IF (STACK(N).EQ.0) GO TO 160
C
C CHECK USAGE
C
I = IGATT1(STACK(N),8)
IF (I.EQ.10 .OR. ((I.EQ.2 .OR. I.EQ.5 .OR. I.EQ.14) .AND.
* STACK(N+1).NE.6)) GO TO 160
IF (I.NE.0) GO TO 140
CALL SATT1(STACK(N), 8, 10)
GO TO 160
140 IF (I.EQ.1 .AND. ITYP.NE.31) GO TO 150
I = STACK(N)
IF (DSA(I+2).EQ.IASF) GO TO 160
150 CALL ERROR2(40H ILLEGAL ARGUMENT IN INTRINSIC REFERENCE, 40,
* DSA(LL+4), 1, 1, 1)
GO TO 170
C
C CHECK STRUCTURE
C
160 IF (STACK(N+1)/8.EQ.1) CALL ERROR2(
* 48H ILLEGAL STRUCTURE OF ARG IN INTRINSIC REFERENCE, 48,
* DSA(LL+4), 1, 1, 1)
C
C CHECK TYPE
C
IF (MOD(STACK(N+1),8).NE.L) CALL ERROR2(
* 43H ILLEGAL TYPE OF ARG IN INTRINSIC REFERENCE, 43,
* DSA(LL+4), 1, 1, 1)
170 CONTINUE
180 INTEXT = .TRUE.
I = IGATT1(LL,8)
IF (I.NE.0) GO TO 190
CALL SATT1(LL, 8, 14)
C
C MARK FCN AS USED
C
190 K = Z(K2+1)/1024
IF (K.EQ.0) Z(K2+1) = Z(K2+1) + 1024
GO TO 50
END
C XXXXXIO.f
SUBROUTINE IO
LOGICAL ERR, SYSERR, TOKPNO, OK, ABORT, TOKLAB
INTEGER STMT, PSTMT
INTEGER EN(4)
LOGICAL SW
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /SWS/ SW(10)
DATA EN(1), EN(2), EN(3), EN(4) /34,43,33,63/
C
C ROUTINE RECOGNIZES READ,WRITE,REWIND,BACKSPACE,ENDFILE,PAUSE STMTS
C
OK = .TRUE.
ASSIGN 160 TO IFORM
IF (ITYP.NE.23 .AND. ITYP.NE.24) GO TO 240
C
C SYNTAX OF READ, WRITE STMTS IS THE SAME EXCEPT A BINARY WRITE
C NEEDS A <LIST>. (SEE USE OF OK)
C "READ" (�<UNIT> / <UNIT> , <FORM>!) �<LIST>!
C <UNIT> IS INTEGER SCALAR VARIABLE OR POSITIVE INTEGER CONST
C <FORM> IS <LABEL> OR <ARRAY NAME>.
C
IF (STMT(PSTMT).NE.65) GO TO 230
PSTMT = PSTMT + 1
IF (PSTMT.GE.NSTMT) GO TO 120
10 IF (TOKPNO(PSTMT,K2,K)) GO TO 60
CALL NEXTOK(PSTMT, K2, K)
IF (K.EQ.0) GO TO 20
CALL ERROR1(13H ILLEGAL UNIT, 13)
GO TO 110
20 K = LOOKUP(K2,.FALSE.)
IF (SYSERR) GO TO 110
I1 = IGATT1(K,1)
I2 = IGATT1(K,7)
I3 = IGATT1(K,8)
IF (I3.NE.0) GO TO 30
CALL SATT1(K, 8, 10)
GO TO 40
30 IF (I3.EQ.10) GO TO 40
CALL ERROR1(13H ILLEGAL UNIT, 13)
40 IF (I1.NE.0) GO TO 50
I1 = 1
IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
CALL SATT1(K, 1, I1)
50 IF (MOD(I1,8).NE.2 .OR. I2.NE.0) CALL ERROR1(13H ILLEGAL UNIT, 13)
60 PSTMT = K2
C
C DISTINGUISH ( <UNIT> ) FROM ( <UNIT>,<FORM> )
C
IF (ITYP.NE.23 .AND. ITYP.NE.24) GO TO 100
IF (STMT(PSTMT).EQ.68) GO TO 130
IF (STMT(PSTMT).EQ.62 .AND. ITYP.EQ.24) OK = .FALSE.
C
C CODE FINDS ")" AND TRIES TO FIND LIST
C
70 IF (STMT(PSTMT).NE.62) GO TO 230
PSTMT = PSTMT + 1
IF (PSTMT.GE.NSTMT) GO TO 90
CALL LIST
GO TO 110
80 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
PSTMT = PSTMT + 1
GO TO 70
90 IF (OK) GO TO 110
CALL ERROR1(13H MISSING LIST, 13)
100 IF (PSTMT.LT.NSTMT) CALL ERROR1(
* 34H EXTRANEOUS INFO AFTER END OF STMT, 34)
110 RETURN
120 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
GO TO 110
C
C IDENTIFY END= IF THERE
C
130 IF (ITYP.NE.23) GO TO IFORM, (160, 80)
I1 = PSTMT + 1
DO 140 K=1,4
IF (STMT(I1).NE.EN(K)) GO TO IFORM, (160, 80)
I1 = I1 + 1
140 CONTINUE
IF (.NOT.SW(1)) CALL ERROR1(
* 37H WARNING - NON-PORTABLE EOF CONSTRUCT, 37)
C
C HAVE FOUND END=, TRY FOR LABEL
C
PSTMT = I1
IF(.NOT.TOKLAB(1,K2,K,.FALSE.))
1CALL ERROR1(44H MISSING LABEL IN NON-PORTABLE EOF CONSTRUCT ,44)
IF(SYSERR) GOTO 110
150 PSTMT = K2
GO TO 70
C
C SEARCH FOR FORM
C
160 PSTMT = PSTMT + 1
IF (PSTMT.GE.NSTMT) GO TO 230
IF (TOKLAB(3,K2,K,.FALSE.)) GO TO 220
IF(SYSERR) GOTO 110
CALL NEXTOK(PSTMT, K2, K)
IF (K.EQ.0) GO TO 180
170 CALL ERROR1(13H ILLEGAL FORM, 13)
GO TO 110
180 K = LOOKUP(K2,.FALSE.)
IF (SYSERR) GO TO 110
I1 = IGATT1(K,1)
I2 = IGATT1(K,7)
I3 = IGATT1(K,8)
IF (I3.NE.0) GO TO 190
CALL SATT1(K, 8, 10)
GO TO 200
190 IF (I3.EQ.10) GO TO 200
CALL ERROR1(13H ILLEGAL FORM, 13)
200 IF (I1.NE.0) GO TO 210
I1 = 2
IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
CALL SATT1(K, 1, I1)
210 IF((MOD(I1,8).NE.2.AND.MOD(I1,8).NE.5).OR.I2.EQ.0) GOTO 170
C
C HAVE SUCCESSFULLY FOUND A FORM
C
220 IF (SYSERR) GO TO 110
PSTMT = K2
ASSIGN 80 TO IFORM
IF (STMT(PSTMT).EQ.68) GO TO 130
GO TO 70
230 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
GO TO 110
C
C LAST 4 I-O STMTS
C
240 IF (ITYP.EQ.27 .OR. ITYP.EQ.22) CALL ERROR1(
* 39H WARNING - USE OF NON-PORTABLE I/O STMT, 39)
IF (ITYP.EQ.22) GO TO 100
IF (PSTMT.LT.NSTMT) GO TO 10
CALL ERROR1(13H MISSING UNIT, 13)
GO TO 110
END
C XXXXXLDOVAR.f
SUBROUTINE LDOVAR
COMMON /LISTDO/ LPT, LEN, LS(64)
C
C CHECKS PROPER NESTING OF DOS WITHIN LIST CONSTRUCT
C
IF (LPT.GE.61) GO TO 50
DO 40 KQ=LPT,60,4
KK = KQ + 4
DO 30 L=1,4
LL = L + KQ - 1
IF (LS(LL)) 10, 30, 10
10 DO 20 K=KK,61,4
IF (LS(K).EQ.LS(LL)) CALL ERROR1(
*57H ILLEGAL TO CHANGE VALUE OF CONTROL VARIABLE OR DO LIMITS, 57)
20 CONTINUE
30 CONTINUE
40 CONTINUE
50 RETURN
END
C XXXXXNEXTOK.f
SUBROUTINE NEXTOK(K1, K2, CODE)
INTEGER STMT, CODE, PSTMT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
C
C NEXT TOKEN IN STMT(K1)-STMT(K2-1). CODES ARE:
C DIGIT STRING(1)
C HOLLERITH(2)
C IDENTIFIER(0)
C SPECIAL CHARACTER(3)
C
IF (STMT(K1).LT.0) GO TO 50
IF (STMT(K1).GT.9) GO TO 20
C
C DIGIT STRING
C
CODE = 1
K2 = K1 + 1
10 IF (K2.EQ.NSTMT) GO TO 60
IF ((STMT(K2).GT.9) .OR. (STMT(K2).LT.0)) GO TO 60
K2 = K2 + 1
GO TO 10
20 IF (STMT(K1).GT.55) GO TO 40
C
C IDENTIFIER
C
CODE = 0
K4 = K1 + 1
K2 = K4
DO 30 I=K4,NSTMT
IF (STMT(I).GT.55 .OR. STMT(I).LT.0) GO TO 60
K2 = K2 + 1
30 CONTINUE
C
C
C SPECIAL CHARACTER
C
40 K2 = K1 + 1
CODE = 3
IF (STMT(K1).NE.66) GO TO 60
IF (STMT(K2).EQ.66) K2 = K2 + 1
GO TO 60
C
C HOLLERITH
C
50 CODE = 2
K2 = K1 + 1
60 RETURN
END
C XXXXXOUTSYM.f
SUBROUTINE OUTSYM
INTEGER HASH, STACK, BL, DSA, OUTUT, SYMHD, BNEXT, SYMLEN, ATT(8)
INTEGER CODE(11), CC(30), C(4), Q(70), SYM, PDSA
INTEGER OUTUT2, OUTUT3, OUTUT4
LOGICAL OK
LOGICAL OPT, P1ERR, COMM
COMMON /CHASH/ LHASH, HASH(401)
COMMON /OPTNS/ OPT(5), P1ERR
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
* OUTUT4
COMMON /TABL/ NEXT, LAB, SYM, BNEXT
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /CEXPRS/ LSTACK, STACK(620)
COMMON /TRANS/ Q
DATA BL /1H /
DATA CODE(1) /1HD/, CODE(2) /1HR/, CODE(3) /1HI/, CODE(4) /1HC/,
* CODE(5) /1HL/, CODE(11) /1HE/, CODE(7) /1HA/, CODE(8) /1HS/,
* CODE(9) /1HF/, CODE(10) /1HN/, CODE(6) /1HH/, C(1) /4/, C(2)
* /11/, C(3) /7/, C(4) /8/
DATA CC(2), CC(16), CC(20), CC(22), CC(26), CC(28) /6*1H /,
* CC(3), CC(5), CC(9), CC(11) /1HF,1HS,1HF,1HF/, CC(1), CC(4) /
* 1HU,1HA/, CC(6), CC(8), CC(10), CC(12), CC(14) /1HF,4*1HN/,
* CC(7), CC(13) /2*1HS/, CC(15) /1HC/, CC(17) /1HG/, CC(18) /
* 1HT/, CC(19) /1HL/, CC(21) /1HV/, CC(25) /1HM/, CC(23) /1HB/,
* CC(24) /1HD/, CC(27) /1HE/
DATA CC(29) /1HI/, CC(30) /1HF/
C
C ROUTINE PRINTS OUT SYMBOL TABLE FOR A PROGRAM UNIT
C
IF (NAME.EQ.0 .OR. .NOT.OPT(1)) RETURN
II = IGATT1(NAME,8)
CALL S5UNPK(DSA(NAME+4), STACK(1), 6)
WRITE (OUTUT,99999) (STACK(I),I=1,6)
99999 FORMAT (14H1PROGRAM UNIT , 5X, 6A1)
IF (II.EQ.11 .OR. II.EQ.12 .OR. DSA(NAME+2).EQ.0) GO TO 60
C
C PRINT FCN/SUBROUTINE ARGS
C
KK = DSA(NAME+2)
I = 0
10 L = 20
CALL RDLIST(KK, 9, M, 0)
IF (M) 20, 60, 20
20 DO 30 I1=1,M
J = STACK(I1) + 4
CALL S5UNPK(DSA(J), STACK(L), 6)
L = L + 7
STACK(L-1) = BL
30 CONTINUE
MM = M*7 + 19
IF (I) 40, 40, 50
40 WRITE (OUTUT,99998) (STACK(L),L=20,MM)
99998 FORMAT (//10H ARGUMENTS, 9X, 63A1)
I = 1
GO TO 10
50 WRITE (OUTUT,99997) (STACK(L),L=20,MM)
99997 FORMAT (19X, 63A1)
GO TO 10
C
C PRINT SYMBOLS FOR PROGRAM UNIT
C
60 CALL SORT(SYM, LBR)
COMM = .FALSE.
WRITE (OUTUT,99996)
99996 FORMAT (//1X, 4HNAME, 5X, 4HTYPE, 2X, 3HUSE, 1X, 10HATTRIBUTES,
* 1X, 10HREFERENCES//)
DO 230 JBR=1,LBR
SYMHD = HASH(JBR)
DO 70 I=20,35
STACK(I) = BL
70 CONTINUE
DO 80 I=1,8
ATT(I) = IGATT1(SYMHD,I)
80 CONTINUE
C SKIPS OVER SYMBOL TABLE ENTRY FOR MAIN, BLOCK DATA,
C AND CURRENT SUBROUTINE NAME
IF (SYMHD.EQ.NAME .AND. ATT(8).NE.4) GO TO 230
IF (ATT(8).NE.7) GO TO 90
COMM = .TRUE.
GO TO 230
90 CALL S5UNPK(DSA(SYMHD+4), STACK(20), 6)
I1 = ATT(8)
L = 2*(I1+1) - 1
STACK(28) = CC(L)
STACK(29) = CC(L+1)
C LEAVE BLANK IRRELEVANT TYPE INFO FOR EXT SUBR, COMMON, EXT ENTS
IF(ATT(8).EQ.6 .OR. ATT(8).EQ.7 .OR. ATT(8).EQ.13)
1 GOTO 100
I1 = MOD(ATT(1),8)
IF (ATT(1).GE.8) STACK(26)=CODE(11)
STACK(27) = CODE(I1 + 1)
100 DO 110 I=1,4
L = I + 29
J = C(I)
IF (ATT(I+1).EQ.1) STACK(L) = CODE(J)
110 CONTINUE
IF (ATT(8).EQ.7) STACK(30) = BL
IF (ATT(8).NE.10 .AND. ATT(8).NE.8) GO TO 140
IF (ATT(7)) 120, 130, 120
120 STACK(34) = CODE(7)
J = ATT(7) + 1
STACK(35) = Q(J)
GO TO 140
130 STACK(34) = CODE(8)
C
C XREF LIST
C
140 IF (OPT(2)) GO TO 160
150 WRITE (OUTUT,99995) (STACK(L),L=20,35)
GO TO 230
160 OK = .FALSE.
N = DSA(SYMHD+1)
IF (N.LE.0) GO TO 150
N = DSA( N+1 )
170 CALL RFLIST( N, M, J, DSA(SYMHD+1) )
C
C FIRST TIME PRINT WHOLE LINE
C
K = M
IF (M.GE.57) K = 57
WRITE (OUTUT,99995) (STACK(L),L=20,35), (STACK(L),L=50,K)
99995 FORMAT (1X, 6A1, 5X, 2A1, 3X, 2A1, 3X, 6A1, 2X, 8(I5, 1X))
IF (M-57) 220, 220, 180
180 L = (M-57)/8
LL = 58
IF (L) 220, 210, 190
190 DO 200 K=1,L
LK = LL + 7
WRITE (OUTUT,99994) (STACK(I),I=LL,LK)
LL = LK + 1
200 CONTINUE
IF (LK.EQ.M) GO TO 220
210 WRITE (OUTUT,99994) (STACK(I),I=LL,M)
99994 FORMAT (30X, 8(I5, 1X))
C
C MAY HAVE TO CALL REFLIST AGAIN
C
220 IF (J) 230, 230, 170
230 CONTINUE
C
C PRINT LABELS
C
IF (LAB.EQ.0) GO TO 320
CALL SORT(LAB, LBR)
DO 310 JBR=1,LBR
LABHD = HASH(JBR)
CALL S5UNPK(DSA(LABHD+4), STACK(20), 6)
OK = .FALSE.
IF (OPT(2)) GO TO 240
WRITE (OUTUT,99993) (STACK(L),L=20,25)
GO TO 310
240 II = DSA(LABHD+1)
II = DSA(II+1)
250 CALL RFLIST(II, M, J, DSA(LABHD+1) )
K = M
IF (M.GE.57) K = 57
WRITE (OUTUT,99993) (STACK(I),I=20,25), (STACK(I),I=50,K)
99993 FORMAT (1X, 6A1, 23X, 8(I5, 1X))
IF (M-57) 300, 300, 260
260 L = (M-57)/8
LL = 58
IF (L) 300, 290, 270
270 DO 280 K=1,L
LK = LL + 7
WRITE (OUTUT,99992) (STACK(I),I=LL,LK)
LL = LK + 1
280 CONTINUE
IF (LK.EQ.M) GO TO 300
290 WRITE (OUTUT,99992) (STACK(I),I=LL,M)
99992 FORMAT (30X, 8(I5, 1X))
300 IF (J) 310, 310, 250
310 CONTINUE
320 IF (.NOT.COMM) GO TO 390
CALL SORT(SYM, LBR)
WRITE (OUTUT,99991)
99991 FORMAT (//14H COMMON BLOCKS//)
DO 380 JBR=1,LBR
SYMHD = HASH(JBR)
I = IGATT1(SYMHD,8)
IF (I.NE.7) GO TO 380
CALL S5UNPK(DSA(SYMHD+4), STACK(100), 6)
N = 0
II = DSA(SYMHD+2)
330 L = 11
CALL RDLIST(II, 10, M, 0)
IF (M) 340, 380, 340
340 DO 350 I=1,M
J = STACK(I) + 4
CALL S5UNPK(DSA(J), STACK(L), 6)
L = L + 7
STACK(L-1) = BL
350 CONTINUE
L = L - 1
IF (N) 360, 360, 370
360 WRITE (OUTUT,99990) (STACK(I),I=100,105), (STACK(I),I=11,L)
99990 FORMAT (1X, 6A1, 3X, 70A1)
N = 1
GO TO 330
370 WRITE (OUTUT,99989) (STACK(K),K=11,L)
99989 FORMAT (10X, 70A1)
GO TO 330
380 CONTINUE
390 RETURN
END
C XXXXXPOP.f
SUBROUTINE POP
LOGICAL ERR, SYSERR, ABORT
INTEGER PB, PT, STACK, OP(12), EX(4,4), AO(4,4), RO(3,3)
COMMON /CEXPRS/ LSTACK, STACK(620)
COMMON /EXPRS/ PT, PB, AO, RO, EX
COMMON /DETECT/ ERR, SYSERR, ABORT
DATA OP(1), OP(3), OP(7), OP(9), OP(10), OP(11) /6*2/, OP(4) /1/,
* OP(5) /0/, OP(6), OP(8), OP(2) /3*-1/, OP(12) /1/
C
C JOB OF SUBROUTINE IS TO POP THE STACK; DOES ALL POPS
C EXCEPT REMOVAL OF "FCN(" CONSTRUCTION
C OP(I) CONTAINS NUM OF ARGS OF OPERATER I PB CHECKED BEFORE
C CALLING POP; POP CHECKS PT; ERROR RETURNS FROM THIS ROUTINE STOP
C EXPRESSION PROCESSING (I.E. ERR=.TRUE.)
C
ERR = .FALSE.
I = STACK(PB+1)
K = OP(I-10)
IF (K) 190, 180, 10
10 L = PT - 1
KQ = K
20 IF (K) 80, 80, 30
30 IF (STACK(L)/8.EQ.1) GO TO 220
IF (STACK(L).GE.8 .OR. STACK(L-1).EQ.0) GO TO 40
J = IGATT1(STACK(L-1),8)
IF (J.EQ.0) CALL SATT1(STACK(L-1), 8, 10)
40 GO TO (60, 50), K
50 K1 = MOD(STACK(L),8) + 1
GO TO 70
60 K2 = MOD(STACK(L),8) + 1
70 L = L - 2
K = K - 1
GO TO 20
C
C 11 +,- 12 ) 13 ** 14 .NOT. 15 ( 16 FCN( 17 *,/ 18 ,
C 19 .AND. 20 .OR. 21 .EQ. 22 UNARY +,-
C
80 L = I - 10
GO TO (90, 190, 120, 150, 190, 190, 90, 190, 130, 130, 100, 140),
* L
90 IF (K1.GT.4 .OR. K2.GT.4) GO TO 210
KK = AO(K1,K2)
GO TO 160
100 IF (K1.GT.3 .OR. K2.GT.3) GO TO 110
KK = RO(K1,K2)
GO TO 160
110 IF ((K1.NE.6 .OR. K2.NE.6) .AND. (K1.NE.6 .OR. K2.NE.3) .AND.
* (K1.NE.3 .OR. K2.NE.6) ) GO TO 210
KK = 4
GO TO 160
120 IF (K1.GT.4 .OR. K2.GT.4) GO TO 210
KK = EX(K2,K1)
GO TO 160
130 KK = 4
IF (K1.NE.5 .OR. K2.NE.5) GO TO 210
GO TO 160
140 KK = K2 - 1
IF (KK.LT.0 .OR. KK.GT.3) GO TO 210
GO TO 160
150 IF (K2.NE.5) GO TO 210
KK = 4
160 IF (-1.EQ.KK) GO TO 210
C
C STORE ON STACK 0 TO SHOW EXPRESSION RESULT(NO DSA INDEX)
C ALSO STORE TYPE OF RESULTING OPERAND
C
PT = PT - 2*KQ
STACK(PT) = 0
STACK(PT+1) = KK
PT = PT + 2
PB = PB + 1
170 RETURN
C
C POPPING "("
C
180 PB = PB + 1
GO TO 170
190 CALL ERROR1(25H ILLEGAL ELEMENT ON STACK, 25)
200 ERR = .TRUE.
RETURN
210 CALL ERROR1(34H ILLEGAL COMBINATION OF DATA TYPES, 34)
GO TO 200
220 CALL ERROR1(21H ILLEGAL USE OF ARRAY, 21)
GO TO 200
END
C XXXXXRDLIST.f
SUBROUTINE RDLIST(HEAD, L, N, M)
C
C HEAD IS THE HEAD OF A LINEAR LINKED LIST IN DSA
C L IS MAX NUMBER OF ITEMS DESIRED
C N IS NUMBER OF ITEMS RETURNED
C M IS END OF LIST MARKER
C
INTEGER HEAD, STACK, DSA, PDSA
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /CEXPRS/ LSTACK, STACK(620)
N = 0
10 IF (HEAD.EQ.M .OR. N.GE.L) GO TO 20
N = N + 1
STACK(N) = DSA(HEAD)
HEAD = DSA(HEAD+1)
GO TO 10
20 RETURN
END
C XXXXXRFLIST.f
SUBROUTINE RFLIST( I1, I2, I4, I3 )
C
C I1 IS POINTER TO FIRST ELEMENT ON XREF LIST IN DSA
C I2 IS COUNT OF HOW MANY REFS ARE RETURNED IN STACK
C I4 IS 1 IF RFLIST MUST BE CALLED AGAIN; ELSE IS 0
C I3 IS LAST OF LIST ELEMENTS
C
INTEGER DSA, PDSA, STACK
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /CEXPRS/ LSTACK, STACK(620)
I4 = 0
I2 = 49
10 IF ( I2+1.GE.LSTACK ) GOTO 30
I2 = I2 + 1
STACK(I2) = DSA(I1)
IF( I1.EQ.I3 ) GOTO 20
I1 = DSA(I1+1)
GOTO 10
20 RETURN
30 I4 = 1
GO TO 20
END
C XXXXXSEPAR.f
SUBROUTINE SEPAR(ICHAR)
C
C FINDS SEPARATER CONSTRUCT IN FORMAT STMTS
C SEPARATER IS A COMBINATION OF "/" AND ","
C ",," IS ALWAYS ILLEGAL IN A SEPARATER
C MIXING OF "/" AND "," IS WARNED AGAINST
C
C ICHAR CONTAINS LENGTH OF SEPARATOR FOUND
INTEGER PSTMT, STMT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
ICHAR = PSTMT
ICOM = 0
C
C " , "
C
10 IF (STMT(PSTMT).NE.68) GO TO 20
ICOM = ICOM + 1
C
C CHECK FOR ",,"
C
PSTMT = PSTMT + 1
IF (STMT(PSTMT).EQ.68) GO TO 30
20 IF (STMT(PSTMT).NE.67) GO TO 50
PSTMT = PSTMT + 1
GO TO 10
30 CALL ERROR1(19H ILLEGAL ADJACENT ,, 19)
C
C FLUSH TO NEXT NON-SEPARATER
C
40 PSTMT = PSTMT + 1
IF (STMT(PSTMT).EQ.67 .OR. STMT(PSTMT).EQ.68) GO TO 40
50 ICHAR = PSTMT - ICHAR
IF (ICOM.GT.0 .AND. ICHAR.GT.1) CALL ERROR1(
* 36H ILLEGAL MIXING OF / AND , IN FORMAT, 36)
RETURN
END
C XXXXXSETNAM.f
SUBROUTINE SETNAM(KK)
LOGICAL ERR, SYSERR, ABORT
INTEGER STMT, PSTMT, S(5)
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
DATA S(1) /66/, S(2) /42/, S(3) /30/, S(4) /38/, S(5) /43/
C
C KK=11 FOR BLOCK DATA PGM; KK=12 FOR MAIN PGM
C NAME POINTS TO SYMBOL TABLE ENTRY FOR NEW PGM
C
IF (KK.EQ.11) GO TO 30
PSTMT = 1
DO 10 I=1,5
STMT(I) = S(I)
10 CONTINUE
NAME = LOOKUP(6,.FALSE.)
IF (SYSERR) RETURN
CALL SATT1(NAME, 8, 12)
20 RETURN
30 PSTMT = 5
STMT(PSTMT) = S(1)
NAME = LOOKUP(11,.FALSE.)
IF (SYSERR) RETURN
CALL SATT1(NAME, 8, 11)
GO TO 20
END
C XXXXXSORT.f
SUBROUTINE SORT(IPT, L)
EXTERNAL EXCH
INTEGER HASH, PDSA, DSA
COMMON /CHASH/ LHASH, HASH(401)
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
C
C PUT ALL SUMBOL INDICES IN HASH TABLE TO SORT THEM
C
L = 0
I = IPT
10 IF (I.EQ.0) GO TO 20
L = L + 1
HASH(L) = I
I = DSA(I+3)
GO TO 10
C
C CALL SORT ROUTINE
C UPON RETURN HASH CONTAINS INDICES OF ALL SYMBOLS OR LABELS IN
C DSA IN LEXICOGRAPHIC ORDER
C
20 CALL SSORT(EXCH, DSA, LDSA, HASH, L, 4)
RETURN
END
C XXXXXSUBS.f
SUBROUTINE SUBS(K2, NO)
INTEGER STMT, PSTMT
LOGICAL ERR, SYSERR, ABORT, TOKPNO
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
C
C STMT(PSTMT)-STMT(K2-1) CONTAIN SUBSCRIPT CONSTRUCT
C NO IS NUMBER OF SUBSCRIPTS EXPECTED
C ROUTINE CHECKS SYNTAX AND NUMBER OF SUBSCRIPTS
C IF FLUSH OF CONSTRUCT IS NECESSARY, AND NSTMT IS REACHED
C ERR=.TRUE.
C
ICNT = 0
10 CALL NEXTOK(PSTMT, K2, K)
IF (K.EQ.0) GO TO 70
IF (TOKPNO(PSTMT,K2,LL)) GO TO 60
20 CALL ERROR1(28H ILLEGAL SYNTAX OF SUBSCRIPT, 28)
C
C FLUSH TO END OF SUBSCRIPT CONSTRUCTION
C
30 IF (STMT(K2).EQ.62) GO TO 40
K2 = K2 + 1
IF (K2.LT.NSTMT) GO TO 30
ERR = .TRUE.
GO TO 50
40 K2 = K2 + 1
50 RETURN
60 IF (STMT(K2).NE.66) GO TO 130
PSTMT = K2 + 1
IF (PSTMT.GE.NSTMT) GO TO 20
CALL NEXTOK(PSTMT, K2, K)
IF (K.NE.0) GO TO 20
C
C ACESS SYMBOL TABLE ENTRY FOR VARIABLE TO DETERMINE
C USAGE AND TYPE
C
70 KQ = LOOKUP(K2,.FALSE.)
IF (SYSERR) GO TO 30
I1 = IGATT1(KQ,1)
I1 = MOD(I1,8)
I2 = IGATT1(KQ,7)
I3 = IGATT1(KQ,8)
IF (I3.EQ.0) GO TO 90
IF (I3.EQ.10) GO TO 100
80 CALL ERROR1(43H ILLEGAL VARIABLE IN SUBSCRIPT CONSTRUCTION, 43)
GO TO 120
90 CALL SATT1(KQ, 8, 10)
C
C IMPLICITLY TYPE VARIABLES FIRST ENCOUNTERED IN SUBSCRIPT
C CONSTRUCT
C
100 IF (I1.GT.0) GO TO 110
I1 = 1
IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
CALL SATT1(KQ, 1, I1)
110 IF (I2.NE.0 .OR. I1.NE.2) GO TO 80
120 IF (STMT(K2).NE.60 .AND. STMT(K2).NE.61) GO TO 130
CALL NEXTOK(K2+1, K3, K)
IF (K.NE.1) GO TO 20
K2 = K3
130 ICNT = ICNT + 1
IF (STMT(K2).EQ.68) GO TO 140
IF (STMT(K2).NE.62) GO TO 20
IF (NO.NE.ICNT) CALL ERROR1(34H INCOMPATIBLE NUMBER OF SUBSCRIPTS,
* 34)
IF (ICNT.GT.3) CALL ERROR1(20H TOO MANY SUBSCRIPTS, 20)
GO TO 40
140 PSTMT = K2 + 1
IF (PSTMT.GE.NSTMT) GO TO 20
GO TO 10
END
C XXXXXSUBFCN.f
SUBROUTINE SUBFCN(TYPE)
C
C TYPE IS EXPLICIT TYPE OF FUNCTION, ELSE IS -1
C ALL FCNS GIVEN EXPLICIT TYPE SINCE FCN NAME CANNOT APPEAR IN
C NONEXECUTABLE STMT WITHIN FCN SUBPRGM EXCEPT HEAD STMT
C ROUTINES DEFINES SUBROUTINE AND FUNCTION NAMES AND CREATES
C LINKED LISTS OF POINTERS TO THEIR ARGUMENTS IN DSA.
C SETS NAME TO POINT TO CURRENT FUNCN OR SUBRTNE. IN CASE
C OF BAD SYNTAX IN NAME CONSTRUCT OR FCN WITHOUT PARAMS.,
C PROGRAM UNIT BECOMES MAIN PGM BY DEFAULT
C
INTEGER STMT, PSTMT, DSA, SYMHD, TYPE, BNEXT, S(5), PDSA
LOGICAL ERR, SYSERR, ABORT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /DETECT/ ERR, SYSERR, ABORT
DATA S(1) /66/, S(2) /42/, S(3) /30/, S(4) /38/, S(5) /43/
KCELL = 0
CALL NEXTOK(PSTMT, K2, I1)
IF (I1.NE.0) GO TO 120
C
C SET FCN OR SUBR USE IN SYMBOL TABLE. TYPE FCN AND RECORD EXPLICIT
C OR IMPLICIT TYPE
C
K = LOOKUP(K2,.FALSE.)
IF (SYSERR) GO TO 90
NAME = K
L = ITYP - 8
GO TO (10, 20), L
10 CALL SATT1(K, 8, 3)
GO TO 40
20 CALL SATT1(K, 8, 4)
IF (TYPE.LT.0) GO TO 30
CALL SATT1(K, 1, TYPE+8)
GO TO 40
30 L = 1
IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) L = 2
CALL SATT1(K, 1, L)
40 IF (STMT(K2).NE.65) GO TO 140
50 PSTMT = K2 + 1
IF (PSTMT.GE.NSTMT) GO TO 120
CALL NEXTOK(PSTMT, K2, L)
IF (L.NE.0) GO TO 80
C
C ENTER PARAMETER IN SYMBOL TABLE; TYPE IMPLICITLY; ADD ONTO PARAM
C LIST HANGING OFF SUBR/FCN NAME; SET DUMMYARG BIT ON; DO NOT SET
C USAGE
C
N = LOOKUP(K2,.FALSE.)
IF (SYSERR) GO TO 90
I2 = IGATT1(N,4)
I1 = IGATT1(N,8)
IF (I1.NE.0 .OR. I2.NE.0) GO TO 80
L = 1
IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) L = 2
CALL SATT1(N, 1, L)
L = IGATT1(N,4)
IF (L.EQ.1) GO TO 80
CALL SATT1(N, 4, 1)
IF (NEXT+2.GE.BNEXT) GO TO 150
IF (KCELL.EQ.0) GO TO 60
DSA(KCELL+1) = NEXT
GO TO 70
C
C START PARAM LIST
C
60 DSA(K+2) = NEXT
70 KCELL = NEXT
DSA(NEXT) = N
DSA(NEXT+1) = 0
NEXT = NEXT + 2
C
C SEARCH FOR ")" OR ","
C
IF (STMT(K2).EQ.62) GO TO 100
IF (STMT(K2).EQ.68) GO TO 50
80 CALL ERROR1(33H ILLEGAL SYNTAX IN PARAMETER LIST, 33)
90 RETURN
100 K2 = K2 + 1
110 IF (K2.EQ.NSTMT) GO TO 90
CALL ERROR1(39H ILLEGAL CHARACTERS AFTER SUBR/FCN HEAD, 39)
GO TO 90
120 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
PSTMT = 6
DO 130 I1=1,5
STMT(I1+5) = S(I1)
130 CONTINUE
NAME = LOOKUP(11,.FALSE.)
IF (SYSERR) GO TO 90
CALL SATT1(NAME, 8, 11)
GO TO 90
140 IF (ITYP.EQ.9) GO TO 110
CALL ERROR1(20H NO PARAMS SPECIFIED, 20)
GO TO 120
150 SYSERR = .TRUE.
CALL ERROR1(33H IN SUBFCN, TABLE OVERFLOW OF DSA,33)
GO TO 90
END
C XXXXXTOKCOM.f
LOGICAL FUNCTION TOKCOM(K1, K2)
C
C TOKCOM RETURNS TRUE IS FINDS CONST IN STMT(K1)-STMT(K2-1)
C ( (OPTIONAL SIGN) REAL CONST, (OPTIONAL SIGN) REAL CONST ) IS
C COMPLEX CONSTRUCT; TOKCOM RESETS K2
C
LOGICAL TOKRL
INTEGER STMT, PSTMT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
TOKCOM = .FALSE.
IF (STMT(K1).NE.65) GO TO 10
K3 = K1 + 1
IF (STMT(K3).EQ.60 .OR. STMT(K3).EQ.61) K3 = K3 + 1
IF (TOKRL(K3,K2,K)) IF (K-1) 10, 20, 10
10 RETURN
20 IF (STMT(K2).NE.68) GO TO 10
K3 = K2 + 1
IF (STMT(K3).EQ.60 .OR. STMT(K3).EQ.61) K3 = K3 + 1
IF (TOKRL(K3,K2,K)) IF (K-1) 10, 30, 10
GO TO 10
30 IF (STMT(K2).NE.62) GO TO 10
K2 = K2 + 1
TOKCOM = .TRUE.
GO TO 10
END
C XXXXXTOKLAB.f
LOGICAL FUNCTION TOKLAB(K1, K2, KK, DEF)
INTEGER STMT, PSTMT, SYMHD, DSA, PDSA, BNEXT, DOPT, DOLIST
LOGICAL DEF, NON0, SYSERR, ABORT, ERR
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /DOS/ DOPT, LDO, DOLIST(192)
COMMON /FACTS/ NAME, NOST, ITYPE, IASF
C
C LOOKS FOR DEFNS OF LABEL IF DEF = .TRUE., ELSE LOOKS FOR
C REFS. IF IT FINDS A LABEL TOKLAB=.TRUE.
C IN REFERENCE LABEL IS IN STMT(PSTMT)-STMT(K2-1)
C IN DEFN LABEL IS IN STMT(1)-STMT(K2-1)
C KK IS SYMBOL TABLE INDEX OF LABEL
C K1 IS TYPE OF LABEL EXPECTED OR DEFINED--1-EXECUTABLE
C 2-NONEXECUTABLE, 3-FORMAT
C IN REF, ROUTINE SETS USAGE OF SYMBOL AND CHECKS FOR
C COMPATIBLE REFERENCES(I.E. GOTO 5 AND WRITE(6,5) ARE INCOMPAT.)
C IN DEF, ROUTINE SETS USAGE OF SYMBOL, CHECKS FOR DUPLICATE
C DEFNS, CHECKS FOR COMPATIBLITY BETWEEN DEFN AND PREVIOUS
C REFS, CREATES SCOPE AREA FOR LABEL INITIALIZING WORD1 TO
C CURRENT HEADING STMT NO ON DOLIST AND WORD2 TO CURRENT LEVEL
C IN REFS AND DEFS LABELS MUST BE POSITIVE NUMBERS
C
TOKLAB = .FALSE.
IF (DEF) GO TO 80
NON0 = .FALSE.
J = PSTMT + 4
IF (J.GT.NSTMT) J = NSTMT
K3 = PSTMT
DO 10 K2 = PSTMT,J
IF(STMT(K2).GT.9 .OR. STMT(K2).LT.0) GOTO 60
IF(STMT(K2) .GT. 0) NON0 = .TRUE.
IF(.NOT.NON0) K3 = K3+1
10 CONTINUE
K2 = J+1
IF(.NOT.NON0) GOTO 70
C NOTE CAN CHANGE PSTMT HERE BECAUSE WE KNOW WE HAVE A LAB
20 PSTMT = K3
KK = LOOKUP(K2,.TRUE.)
IF (SYSERR) GO TO 50
IF (ITYPE.EQ.14) DSA(BNEXT+1) = -DSA(BNEXT+1)
I = IGATT1(KK,8)
IF (I.EQ.0) CALL SATT1(KK, 8, 9)
I1 = IGATT1(KK,1)
IF (I1.NE.0) GO TO 30
CALL SATT1(KK, 1, K1)
GO TO 40
30 IF (K1.NE.I1) CALL ERROR1(30H INCOMPATIBLE LABEL REFERENCES, 30)
40 TOKLAB = .TRUE.
50 RETURN
60 IF (K2.EQ.PSTMT) GO TO 50
IF (NON0) GO TO 20
70 CALL ERROR1(30H LABEL MUST BE POSITIVE NUMBER, 30)
GO TO 50
C
C TAKES DEF OF LABEL; CHECKS FOR DUPLICATE DEFS.; SETS DEFINED
C BIT IN SYMBOL TABLE; STORES BEGINNING BINDING STMT NO
C
80 K2 = 0
NON0 = .FALSE.
DO 90 I=1,5
IF (STMT(I).EQ.69) GO TO 90
IF ((STMT(I).GT.9) .OR. (STMT(I).LT.0)) GO TO 140
IF (STMT(I).GT.0) NON0 = .TRUE.
IF (.NOT.NON0) GO TO 90
K2 = K2 + 1
STMT(K2) = STMT(I)
90 CONTINUE
IF (K2.EQ.0) GO TO 50
IF (.NOT.NON0) GO TO 70
K2 = K2 + 1
KK = LOOKUP(K2,.TRUE.)
IF (SYSERR) GO TO 50
I = IGATT1(KK,2)
IF (I.EQ.1) GO TO 120
CALL SATT1(KK, 2, 1)
CALL SATT1(KK, 8, 9)
I1 = IGATT1(KK,1)
IF (I1.EQ.0) GO TO 100
IF (I1.EQ.K1) GO TO 110
CALL ERROR1(44H ILLEGAL REFERENCE TO LABEL IN PREVIOUS CODE, 44)
100 CALL SATT1(KK, 1, K1)
110 IF (K1.NE.1) GO TO 40
IF (NEXT+2.GE.BNEXT) GO TO 130
DSA(KK+2) = NEXT
DSA(NEXT) = DOLIST(DOPT)
DSA(NEXT+1) = -DOPT/6
NEXT = NEXT + 2
GO TO 40
120 CALL ERROR1(16H DUPLICATE LABEL, 16)
GO TO 50
130 CALL ERROR1(33H IN TOKLAB, TABLE OVERFLOW OF DSA, 33)
SYSERR = .TRUE.
GO TO 50
140 CALL ERROR1(24H ILLEGAL SYMBOL IN LABEL, 24)
GO TO 50
END
C XXXXXTOKLOG.f
LOGICAL FUNCTION TOKLOG(K1, K2)
C
C ROUTINE RETURNS TRUE IF FINDS .TRUE. OR .FALSE.
C IN STMT(K1)-STMT(K2-1)
C
INTEGER STMT, CONS(13), PSTMT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
DATA CONS(1) /64/, CONS(2) /35/, CONS(3) /30/, CONS(4) /41/,
* CONS(5) /48/, CONS(6) /34/, CONS(7) /64/, CONS(8) /64/,
* CONS(9) /49/, CONS(10) /47/, CONS(11) /50/, CONS(12) /34/,
* CONS(13) /64/
TOKLOG = .FALSE.
KCNT = 1
L1 = 1
L2 = 7
K2 = K1
10 DO 20 I=L1,L2
IF (STMT(K2).NE.CONS(I)) GO TO 30
K2 = K2 + 1
20 CONTINUE
TOKLOG = .TRUE.
RETURN
30 KCNT = KCNT + 1
IF (KCNT.GE.3) RETURN
K2 = K1
L1 = 8
L2 = 13
GO TO 10
END
C XXXXXTOKLOP.f
LOGICAL FUNCTION TOKLOP(K1, K2, KCODE)
C
C ROUTINE RETURNS TRUE IF FINDS LOGICAL OR RELATIONAL
C OPERATORS IN STMT(K1)-STMT(K2-1); RETURNS OPERATOR CODE
C IN KCODE (SEE EXPR FOR CODES)
C
INTEGER C(20), CC(9), CODE(9), PSTMT, STMT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
DATA C(1) /30/, C(2) /43/, C(3) /33/, C(4) /43/, C(5) /44/, C(6)
* /49/, C(7) /44/, C(8) /47/, C(9) /34/, C(10) /46/, C(11)
* /43/, C(12) /34/, C(13) /36/, C(14) /49/, C(15) /36/, C(16)
* /34/, C(17) /41/, C(18) /49/, C(19) /41/, C(20) /34/
DATA CC(1), CC(2) /2*3/, CC(3), CC(4), CC(5), CC(6), CC(7),
* CC(8), CC(9) /7*2/, CODE(1) /19/, CODE(2) /14/, CODE(3) /20/,
* CODE(4), CODE(5), CODE(6), CODE(7), CODE(8), CODE(9) /6*21/
TOKLOP = .FALSE.
IF (STMT(K1).NE.64) RETURN
J = 1
DO 30 I=1,9
KK = J + CC(I) - 1
K2 = K1 + 1
DO 10 L=J,KK
IF (STMT(K2).NE.C(L)) GO TO 20
K2 = K2 + 1
10 CONTINUE
KCODE = CODE(I)
IF (STMT(K2).NE.64) RETURN
K2 = K2 + 1
TOKLOP = .TRUE.
RETURN
20 J = J + CC(I)
30 CONTINUE
RETURN
END
C XXXXXTOKPNO.f
LOGICAL FUNCTION TOKPNO(K1, K2, LL)
C
C ROUTINE RECOGNIZES A POSITIVE INTEGER CONSTANT
C IN STMT(K1)-STMT(K2-1), AND RETURNS ITS VALUE IN LL
C
INTEGER STMT, PSTMT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
TOKPNO = .FALSE.
CALL NEXTOK(K1, K2, K)
IF (K.NE.1) RETURN
K=K2-1
LL = 0
DO 10 KK=K1,K
LL = 10 * LL + STMT(KK)
10 CONTINUE
IF (LL.GT.0) TOKPNO = .TRUE.
RETURN
END
C XXXXXTOKRL.f
LOGICAL FUNCTION TOKRL(K1, K2, CODE)
INTEGER STMT, CODE, PSTMT
LOGICAL TOKLOP
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
C
C ROUTINE RETURNS TRUE IF FINDS A REAL CONSTANT IN
C STMT(K1)-STMT(K2-1) . ELSE IT RETURNS FALSE.
C BASIC CONSTRUCT IS: <INT> . <INT>
C <INT> .
C . <INT>
C EACH OF THESE MAY BE FOLLOWED BY <D,E> <+,-> <INT>
C ALSO LEGAL IS IN-CONST FOLLOWED BY EXPONENT CONSTRUCT
C
TOKRL = .FALSE.
CALL NEXTOK(K1, K2, K)
IF (K.EQ.3 .AND. STMT(K1).EQ.64) GO TO 10
IF (K.EQ.1 .AND. STMT(K2).EQ.64) GO TO 40
C IF HAVE INT-CONST NEED EXPONENT FOR THIS TO BE A REAL-CONST
IF (K-1) 80, 50, 80
C
C FIND BASIC REAL CONSTANT
C
C (. INT-CONST) CONSTRUCT
10 CALL NEXTOK(K2, K3, K)
IF (K.NE.1) GO TO 80
20 K2 = K3
30 TOKRL = .TRUE.
CODE = 1
GO TO 50
C (INT-CONST .) CONSTRUCT; CHECK FOR (INT . INT )
40 K2 = K2 + 1
CALL NEXTOK(K2, K3, K)
IF (K.EQ.1) GO TO 20
IF (TOKLOP(K2-1,K4,K)) GO TO 80
GO TO 30
C
C CHECK FOR EXPONENT
C
50 IF (STMT(K2).NE.33) GO TO 60
CODE = 0
GO TO 70
60 IF (STMT(K2).NE.34) GO TO 80
CODE = 1
70 K3 = K2 + 1
IF (K3.EQ.NSTMT) GO TO 80
IF ((STMT(K3).EQ.60) .OR. (STMT(K3).EQ.61)) K3 = K3 + 1
CALL NEXTOK(K3, K4, K)
IF (K.NE.1) GO TO 80
K2 = K4
TOKRL = .TRUE.
80 RETURN
END
C XXXXXTYPE.f
SUBROUTINE TYPE
LOGICAL ERR, SYSERR, ARDECL, ABORT
INTEGER STMT, PSTMT, DSA, PDSA
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
C
C PROCESSES TYPE STMT BY FINDING IDS OR ARRAY DECLS
C THEY ARE ENTERED INTO SYMBOL TABLE AND TYPED EXPLICITLY
C NO USAGE IS SET.
C
10 IF (.NOT.ARDECL(K2,INDX)) GO TO 20
IF (SYSERR) GO TO 30
L = IGATT1(INDX,6)
IF(L.EQ.1) CALL ERROR1(63
1H WARNING - SHOULD TYPE ADJUSTABLE DIMENSION VARIABLE BEFORE USE
2, 63)
IF (K2.EQ.NSTMT) GO TO 30
IF (STMT(K2).EQ.68 .AND. K2+1.NE.NSTMT) GO TO 40
20 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
30 RETURN
40 PSTMT = K2 + 1
GO TO 10
END
C XXXXXTYPST.f
SUBROUTINE TYPST(ITYP, KK, KL)
INTEGER PSTMT, K(186), KI(30), STMT, CODE, KT(30)
LOGICAL ERR, SYSERR, ASSMT, ABORT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /STS/ K, KI, KT
C
C*****STS
C K(*) (INT) ARRAY CONTAINS A TABLE OF INTERNAL CODES FOR EACH
C "KEYWORD" IN FORTRAN STMTS
C KI(*) (INT) ARRAY CONTAINING NUMBER OF CHARACTERS IN EACH
C KEYWORD IN K
C KT(*) (INT) ARRAY CONTAINING CLASS OF EACH STMT IN K
C (SEE PU FOR FURTHER DOC OF IGP -CLASS)
C TEST IF ITS AN ASSIGNMENT; IF SO ITYP = 30
C ELSE SEARCH K ARRAY FOR STMT; ITYP CONTAINS CODED
C TYPE OF STMT; KK CONTAINS GENERAL CLASS OF STMTS IT FALLS IN
C KL IS COUNT OF NUMBER OF LETTERS IN FIRST WORD OF STMT
C
CALL TYPST2(ASSMT)
IF (ASSMT) GO TO 40
J = 1
CODE = 0
10 I = PSTMT
CODE = CODE + 1
L = J + KI(CODE) - 1
DO 20 LL=J,L
IF (STMT(I).NE.K(LL)) GO TO 30
I = I + 1
20 CONTINUE
ITYP = CODE
KK = KT(CODE)
KL = KI(CODE)
RETURN
30 J = L + 1
IF (CODE.LT.29) GO TO 10
ERR = .TRUE.
RETURN
40 ITYP = 30
KK = KT(30)
KL = 0
RETURN
END
C XXXXXTYPST2.f
SUBROUTINE TYPST2(ASSMT)
INTEGER PSTMT, STMT
LOGICAL EQUALS, ASSMT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
C
C ALGORITHM FOR IDENTIFYING ASSIGNMENT STMTS:
C
EQUALS = .FALSE.
LEVEL = 0
IGP = 0
C
C 62.....) 63.....= 65.....( 68.....,
C
DO 40 I=PSTMT,NSTMT
IF (STMT(I).EQ.65) LEVEL = LEVEL + 1
IF (STMT(I).NE.62) GO TO 10
LEVEL = LEVEL - 1
IF (EQUALS) GO TO 40
IF (LEVEL.EQ.0) IGP = IGP + 1
IF (IGP.EQ.1 .AND. LEVEL.EQ.0 .AND. STMT(I+1).NE.63) GO TO 60
GO TO 40
10 IF (LEVEL) 50, 20, 30
20 IF (STMT(I).EQ.68) GO TO 60
IF (STMT(I).EQ.63) EQUALS = .TRUE.
GO TO 40
30 IF (STMT(I).EQ.63) GO TO 60
40 CONTINUE
IF (.NOT.EQUALS) GO TO 60
ASSMT = .TRUE.
50 RETURN
60 ASSMT = .FALSE.
GO TO 50
END
C XXXXXSATT2.f
SUBROUTINE SATT2(INDEX, FIELD, ATT)
C
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
C
INTEGER INDEX, FIELD, ATT
INTEGER LLAT, PLAT, LAT
INTEGER FWTH(8), FPOS(8)
C
DATA FWTH(1) /16/, FPOS(1) /1/
DATA FWTH(2) /2/, FPOS(2) /16/
DATA FWTH(3) /2/, FPOS(3) /32/
DATA FWTH(4) /2/, FPOS(4) /64/
DATA FWTH(5) /2/, FPOS(5) /128/
DATA FWTH(6) /2/, FPOS(6) /256/
DATA FWTH(7) /4/, FPOS(7) /512/
DATA FWTH(8) /32/, FPOS(8) /2048/
C
LAT(INDEX) = LAT(INDEX) + (ATT-MOD(LAT(INDEX)/FPOS(FIELD),
* FWTH(FIELD)))*FPOS(FIELD)
C
RETURN
C
END
C XXXXXIGATT2.f
INTEGER FUNCTION IGATT2(INDEX, FIELD)
C
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
C
INTEGER INDEX, FIELD
INTEGER LLAT, PLAT, LAT
INTEGER FWTH(8), FPOS(8)
C
DATA FWTH(1) /16/, FPOS(1) /1/
DATA FWTH(2) /2/, FPOS(2) /16/
DATA FWTH(3) /2/, FPOS(3) /32/
DATA FWTH(4) /2/, FPOS(4) /64/
DATA FWTH(5) /2/, FPOS(5) /128/
DATA FWTH(6) /2/, FPOS(6) /256/
DATA FWTH(7) /4/, FPOS(7) /512/
DATA FWTH(8) /32/, FPOS(8) /2048/
C
IGATT2 = MOD(LAT(INDEX)/FPOS(FIELD),FWTH(FIELD))
C
RETURN
C
END
C XXXXXCALLS.f
SUBROUTINE CALLS
INTEGER STMT, PSTMT, EXPR, M(3), OUTUT3, OUTUT4
LOGICAL ERR, SYSERR, ABORT
LOGICAL OPT, P1ERR
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /PARAMS/ I1, I2, I6, I4, I5, OUTUT3, OUTUT4
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /OPTNS/ OPT(5), P1ERR
DATA M(1) /4/, M(2) /2/, M(3) /0/
C
C CHECK FOR LEGAL SUBROUTINE NAME BEFORE CALLING EXPR
C TO PROCESS ARGUMENTS
C IF NO ARGS, CALLS SAVES PASS 2 DATA ITSELF WITHOUT
C CALLING EXPR
C
IF (PSTMT.GE.NSTMT) GO TO 10
CALL NEXTOK(PSTMT, K2, K)
IF (K.NE.0) GO TO 10
IF (K2.EQ.NSTMT) GO TO 40
IF (STMT(K2).EQ.65) GO TO 30
10 CALL ERROR1(26H MISSING ROUTINE NAME OR (, 26)
20 RETURN
C
C BY A CALL TO EXPR
C
30 I3 = EXPR(K)
IF (SYSERR) GO TO 20
IF (PSTMT.NE.NSTMT) CALL ERROR1(18H ILLEGAL CALL STMT, 18)
GO TO 20
C
C SAVE SUBROUTINE CALL W/O ARGS
C
40 K = LOOKUP(K2,.FALSE.)
IF (SYSERR) GO TO 20
I3 = IGATT1(K,8)
IF (I3.NE.13 .AND. I3.NE.0) GO TO 50
CALL SATT1(K, 8, 6)
GO TO 60
C
C MAKE SURE EXTERNAL REFERENCED ID IS NOT USED AS ANYTHING
C OTHER AS A SUBROUTINE ELSEWHERE IN THIS P-U
C
50 IF (I3.EQ.6) GO TO 60
CALL ERROR1(24H ILLEGAL SUBROUTINE NAME, 24)
GO TO 20
60 IF (OPT(3) .AND. .NOT.P1ERR) WRITE (OUTUT3) M, K, NOST, M(3)
GO TO 20
END
C XXXXXDATA.f
SUBROUTINE DATA
LOGICAL ERR, SYSERR, ABORT, REPL, ARDECL, SIGN, TOKPNO, ERROR
INTEGER DECNT, DATCNT, STMT, PSTMT, GETTOK, STACK, S(10), DSA,
* PDSA
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /CEXPRS/ LSTACK, STACK(620)
DATA IS /1H*/
C
C ROUTINE PROCESSES A DATA STMT
C
10 DECNT = 0
20 IF (ARDECL(K2,KK)) GO TO 30
IF (.NOT.ERR) GO TO 30
CALL ERROR1(19H ILLEGAL DECLARATOR, 19)
IF(.NOT.SYSERR) GOTO 260
30 IF (SYSERR) RETURN
C
C SET DECLARATOR USAGE AS VARIABLE; CHECK ITS NOT IN BLANK COMMON
C CANNOT BE INLABELLED COMMON IF THIS STMT NOT IN BLOCK DATA PGM
C FOUND A DECLARATOR ADD IT TO LIST OF ALL DECLS SO CAN CHECK
C TYPE OF ITS CORRESPONDING DATA-ITEM; ADD IN COUNT SO CAN
C CHECK NUMBER OF DECLS VS. NUMBER OF DATA-ITEMS
C KEEP TYPE INFO ON STACK; DECNT IS LENGTH OF STACK
C
I = IGATT1(KK,8)
IF (I.EQ.0) CALL SATT1(KK, 8, 10)
I = IGATT1(KK,2)
NN = IGATT1(NAME,8)
IF (I) 60, 60, 40
C
C IF VARIABLE IN COMMON, CHECK TO SEE IF CAN LEGALLY APPEAR
C IN DATA STMT
C
40 I = DSA(KK+2)
I = DSA(I+1)
CALL S5UNPK(DSA(I+4), S(1), 6)
IF (S(1).EQ.IS) GO TO 50
C
C FOUND NO "*" SO ARE IN LABELLED COMMON
C
IF (NN.EQ.11) GO TO 70
CALL ERROR1(
* 55H ILLEGAL TO INITIALIZE VARIABLE IN LABELLED COMMON HERE,
* 55)
GO TO 260
C
C FOUND BLANK COMMON
C
50 CALL ERROR1(48H ILLEGAL TO INITIALIZE VARIABLES IN BLANK COMMON,
* 48)
GO TO 260
60 IF (NN.NE.11) GO TO 70
CALL ERROR1(33H DATA-ITEM NOT IN LABELLED COMMON, 33)
GO TO 260
70 I = IGATT1(KK,1)
CALL SATT1(KK, 5, 1)
NN = 1
IF (IGATT1(KK,7).EQ.0) GO TO 75
IF (STMT(K2-1).EQ.62) GO TO 75
N = DSA(KK+2)
NN = DSA(N)
75 CONTINUE
IF (DECNT+3.LE.LSTACK) GO TO 76
CALL ERROR1(33H IN DATA, TABLE OVERFLOW OF STACK , 33 )
GO TO 260
76 CONTINUE
STACK(DECNT+1) = MOD(I,8)
STACK(DECNT+2) = KK
STACK(DECNT+3) = NN
DECNT = DECNT + 3
IF (STMT(K2).EQ.67) GO TO 100
IF (STMT(K2).NE.68) GO TO 90
PSTMT = K2 + 1
IF (PSTMT.LT.NSTMT) GO TO 20
80 CALL ERROR1(15H ILLEGAL SYNTAX, 15)
RETURN
90 CALL ERROR1(33H ILLEGAL PUNCTUATION IN DATA STMT, 33)
GO TO 260
C
C FIND DATA-ITEMS; CHECK ITS TYPE VS. CORRESPONDING DECLARATOR
C SIGN .TRUE. IF DATA-ITEM PRECEEDED BY A SIGN
C REPL .TRUE. IF A REPLICATION FACTOR HAS ALREADY BEEN FOUND
C
100 DATCNT = 0
ERROR = .FALSE.
PSTMT = K2 + 1
110 IF (PSTMT.EQ.NSTMT) GO TO 80
SIGN = .FALSE.
REPL = .FALSE.
NN = 1
120 IF (STMT(PSTMT).NE.60 .AND. STMT(PSTMT).NE.61) GO TO 130
PSTMT = PSTMT + 1
SIGN = .TRUE.
130 IF (PSTMT.EQ.NSTMT) GO TO 80
KK = GETTOK(PSTMT,K2)
IF (ERR) GO TO 80
IF (KK.LT.6) GO TO 150
140 CALL ERROR1(18H ILLEGAL DATA-ITEM, 18)
GO TO 260
150 KK = KK + 1
GO TO (200, 200, 160, 190, 190, 180), KK
C
C MUST MAKE SURE THAN AN INTEGER DATA-ITEM ISN'T A REPLICATION FACTO
C
160 IF (REPL) GO TO 200
IF(SIGN .OR. STMT(K2).NE.66) GOTO 200
IF(TOKPNO(PSTMT,K2,NN)) GOTO 170
CALL ERROR1(27H ILLEGAL REPLICATION FACTOR ,27)
NN = 1
170 REPL = .TRUE.
PSTMT = K2 + 1
GO TO 120
C
C CHECK LENGTH OF HOLLERITH DATA-ITEM; MUST FIT INTO INTEGER WORD
C
180 IF (STMT(PSTMT)+2048.EQ.1 .OR. ERROR) GO TO 190
CALL ERROR1(
* 53H WARNING - NH WITH N.GT.1 IS NOT A PORTABLE CONSTRUCT, 53)
ERROR = .TRUE.
C
C CHECK COMPLEX, HOLLERITH, AND LOGICAL DATA-ITEMS ARE UNSIGNED
C
190 IF (SIGN) GO TO 140
C
C CHECK COMPATIBLITY OF DATA-ITEMS WITH DECLARATORS
C NN IS REPLICATION FACTOR;
C
200 IBR=0
DO 220 I = 1,NN
IF (STACK(DATCNT+3).EQ.0) DATCNT = DATCNT + 3
IF (DATCNT .GE. DECNT) GO TO 240
STACK(DATCNT+3) = STACK(DATCNT+3) - 1
IF (STACK(DATCNT+1).EQ.KK-1) GO TO 220
IF ((STACK(DATCNT+1).NE.2 .OR. KK.NE.6) .AND.
* (STACK(DATCNT+1).NE.5 .OR. KK.NE.3)) GO TO 210
CALL SATT1(STACK(DATCNT+2), 1, 5)
GO TO 220
210 IBR = 1
220 CONTINUE
IF(IBR .EQ. 1) CALL ERROR1(52
1H WARNING - DATA-ITEM IS INCOMPATIBLE WITH DECLARATOR ,52)
C
C CHECK FOR "," BETWEEN DATA-ITEMS
C
IF (STMT(K2).NE.68) GO TO 230
PSTMT = K2 + 1
GO TO 110
C
C CHECK FOR ANOTHER SET OF DECLARATORS/DATA-ITEMS
C
230 IF (STMT(K2).NE.67) GO TO 90
IF (STACK(DATCNT+3).EQ.0) DATCNT = DATCNT + 3
IF (DATCNT.EQ.DECNT) GO TO 250
240 CALL ERROR1(34H MISSING DECLARATORS OR DATA-ITEMS, 34)
IF (DATCNT.GE.DECNT) GO TO 260
250 PSTMT = K2 + 1
IF (PSTMT.EQ.NSTMT) RETURN
IF (STMT(PSTMT).NE.68) GO TO 90
PSTMT = PSTMT + 1
IF (PSTMT.NE.NSTMT) GO TO 10
GO TO 80
C
C FLUSH TO "/," CONSTRUCT OR END OF STATEMEMT
C
260 IF (PSTMT+1.GE.NSTMT) RETURN
IF (STMT(PSTMT).EQ.67 .AND. STMT(PSTMT+1).EQ.68) GO TO 270
PSTMT = PSTMT + 1
GO TO 260
270 PSTMT = PSTMT + 2
IF (PSTMT.GE.NSTMT) RETURN
GO TO 10
END
C XXXXXDOSTMT.f
SUBROUTINE DOSTMT
LOGICAL TOKLAB, ERR, SYSERR, ABORT
INTEGER STMT, PSTMT
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /DETECT/ ERR, SYSERR, ABORT
C
C ROUTINE PROCESSES A DO STMT. DOSTMT PEELS OFF THE
C LABEL. CALLS DOSPEC TO GET THE <DO-SPECIFICATION>
C
IF (TOKLAB(1,K2,KK,.FALSE.)) GO TO 10
CALL ERROR1(23H MISSING LABEL AFTER DO, 23)
GO TO 20
10 IF (SYSERR) GO TO 20
PSTMT = K2
CALL DOSPEC(KK, K2, .FALSE.)
20 RETURN
END
C XXXXXEND.f
SUBROUTINE END
C
C ROUTINE SAVES SYMBOL TABLE FOR 2ND PASS
C CHECKS VARIABLE DIMENSIONING IN FCN/SUBR PU'S
C CANNOT RESET DUMMY ARGS USED IN VARIABLE DIMENSIONING;
C CHECKS SUCH BOUNDS FOR TYPE INTEGER
C CALLS OUTSYM TO PRINT SYMBOL TABLE
C CHECKS FOR UNDEFINED LABELS,MISSING DO ENDINGS,
C PROPER BRANCHING THROUGHOUT PGM,
C FIXES UP ALL LABELS WHOSE SCOPE IS NOT YET LIMITED
C SETS USAGE OF ALL IDS TO VARIABLE IF USAGE NOT YET SET
C RESETS FCN USAGE IN FCN SUBPROGRAM
C
INTEGER OUTUT, OUTUT2, OUTUT3, OUTUT4
INTEGER PDSA, SYMLEN, BNEXT, SYMHD, STACK, DSA
LOGICAL OPT, P1ERR
COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
* OUTUT4
COMMON /OPTNS/ OPT(5), P1ERR
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /CEXPRS/ LSTACK, STACK(620)
I = IGATT1(NAME,8)
IF((I.NE.3 .AND. I.NE.10) .OR. DSA(NAME+2).EQ.0) GOTO 40
C
C ARGUMENT CHECKING- FOR USE IN VARIABLE DIMENSIONING OF ARRAYS
C
LL = 1
L = DSA(NAME+2)
NPAR = 0
10 IF (L.EQ.0) GO TO 40
NPAR = NPAR + 1
C CHECK FOR PROC ARGS TO ENTER THEIR RELATIVE POSIT
C IN ARGLIST IN WD 3 OF THEIR SYMBOL TABLE ENTRY
I = IGATT1(DSA(L),8)
IF (I.NE.5 .AND. I.NE.6 .AND. I.NE.13) GO TO 20
I = DSA(L)
DSA(I+2) = NPAR
GO TO 30
20 I = IGATT1(DSA(L),6)
IF (I.EQ.0) GO TO 30
I = IGATT1(DSA(L),7)
IF (I.NE.0) GO TO 30
I = IGATT1(DSA(L),5)
K = DSA(L)
IF (I.GT.0) CALL ERROR2(
* 57H ILLEGALLY RESET DUMMY ARG USED IN VARIABLE DIMENSIONING ,
* 57, DSA(K+4), 1, 1, 1)
I = IGATT1(K,1)
IF (MOD(I,8).NE.2) CALL ERROR2(
* 47H ILLEGAL DATA TYPE USED IN ADJUSTIBLE DIMENSION, 47
* , DSA(K+4), 1, 1, 1)
30 L = DSA(L+1)
GO TO 10
C
C OUTPUT TABLE
C
40 CALL DOCHK(1)
C
C CHECK LABELS DEFINED AND WITHIN SCOPE
C
I = LABHD
50 IF (I.EQ.0) GO TO 110
L = IGATT1(I,2)
IF (L.EQ.1) GO TO 60
CALL ERROR2(17H UNDEFINED LABEL , 17, DSA(I+4), 1, 1, 1)
GO TO 100
60 L = IGATT1(I,1)
IF (L.NE.1) GO TO 100
L = DSA(I+2)
L1 = DSA(L)
KK = DSA(L+1)
L2 = DSA(I+1)
C
C L3 POINTS TO LAST ELEMENT ON CIRCULAR LIST
C
L3 = L2
70 IF (DSA(L2).LE.KK .AND. DSA(L2).GE.L1) GO TO 90
IF (DSA(L2).LT.0) GO TO 80
CALL ERROR2(15H ILLEGAL BRANCH, 15, DSA(L2), -1, 1, 1)
GO TO 90
80 DSA(L2) = IABS(DSA(L2))
90 L2 = DSA(L2+1)
IF (L2.NE.L3) GO TO 70
100 I = DSA(I+3)
GO TO 50
C
C SET <ID> USAGE IF NOT YET SET
C
110 I = SYMHD
120 IF (I.EQ.0) GO TO 150
K = IGATT1(I,8)
IF (K.NE.0) GO TO 130
CALL SATT1(I, 8, 10)
GO TO 140
130 IF (K.NE.6) GO TO 140
IF (IGATT1(I,1)/8.NE.1) GO TO 140
CALL ERROR2(33H SUBROUTINE NAME CANNOT BE TYPED , 33, DSA(I+4),
* 1, 1, 1)
140 I = DSA(I+3)
GO TO 120
C
C RESET FCN USAGE IN FCN PROGRAM UNIT
C
150 I = IGATT1(NAME,8)
IF (I.NE.10) GO TO 160
CALL SATT1(NAME, 8, 4)
I = IGATT1(NAME,5)
IF (I.EQ.0) CALL ERROR1(23H FUNCTION VALUE NOT SET, 23)
C
C SAVE BINARY COPY OF SYMBOL TABLE
C
160 IF (OPT(3) .AND. .NOT.P1ERR) GO TO 170
CALL ERROR1(36H P-U NOT SAVED FOR PASS2 PROCESSING , 36)
K = 3
L = 1
WRITE(OUTUT2) L,K,L
WRITE(OUTUT3) L,K,L
GOTO 180
170 K = 1
L = NEXT - 1
I = L + 3
WRITE (OUTUT2) I, K, (DSA(I),I=1,L), NAME, SYMHD, LABHD
L = 3
WRITE (OUTUT3) K, L, K
180 CALL OUTSYM
RETURN
END
C XXXXXEXPR.f
INTEGER FUNCTION EXPR(LOGEX)
C
C LOGEX IS A DUMMY ARG , NEVER USED
C FALSE IF AN ARITHMETIC EXPRESSION WAS FOUND
C PRE IS PRECEDENCE TABLE, PRE(I,J) GIVES ACTION TAKEN WHEN OP I
C IS ON THE STACK, OP J IN THE INPUT
C CUROP IS CURRENT TOKEN TYPE
C PREVOP IS PREVIOUS TOKEN TYPE (LAST ONE PROCESSED BEFORE CUROP)
C STACK IS OPERAND STACK GROWING FROM TOP (1,2 ETC)
C OPERATER STACK GROWING FROM BOTTOM UP(100,99 ETC)
C PARENS COUNTS NESTING LEVEL OF PARENTHESES AND FUNCTION CALLS
C
C*****EXPRS
C PT (INT) POINTER TO NEXT FREE WORD ON OPERAND STACK (GROWS
C FROM STACK(1))
C PB (INT) POINTER TO NEXT FREE WORD ON OPERATOR STACK (GROWS
C FROM STACK(LSTACK))
C AO(*,*) (INT) ARRAY GIVES TYPES OF ARITH OPERATIONS
C AO(I,J) = TYPE OF (TYPE I <ARITH-OP> TYPE J)
C RO(*,*) (INT) ARRAY TELLS LEGALITY OF RELATIONAL OPERATIONS
C RO(I,J) = 1 IF TYPE I <RELOP> TYPEJ IS LEGAL; ELSE IS 0
C EX(*,*) (INT) ARRAY GIVES TYPES OF ** OPERATION
C EX(I,J) = TYPE OF (TYPE I <**> TYPE J)
C
INTEGER PRE(12,12), EX(4,4), AO(4,4), CUROP, PREVOP, RO(3,3),
* STACK, PARENS, STMT, PSTMT, PT, PB, SYMLEN, PDSA, OUTUT,
* GETTOK, IBR(14), JBR(13), ADJ(5,4), OUTUT2, DSA, OUTUT3,
* OUTUT4, PREF, REF
LOGICAL FLUSH, ERR, SYSERR, CALLST, DOVAR, OPT, ABORT, P1ERR
LOGICAL INTEXT
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /EXPRS/ PT, PB, AO, RO, EX
COMMON /CEXPRS/ LSTACK, STACK(620)
COMMON /CREF/ LREF, PREF, REF(100)
COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
* OUTUT4
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /OPTNS/ OPT(5), P1ERR
COMMON /FACTS/ NAME, NOST, ITYP, IASF
DATA K /0/
DATA PRE(1,1) /6/, PRE(1,2) /6/, PRE(1,3) /4/, PRE(1,5) /4/,
* PRE(1,6) /2/, PRE(1,7) /4/, PRE(1,8) /6/, PRE(1,9) /6/,
* PRE(1,10) /6/, PRE(1,4) /-1/, PRE(1,11) /6/, PRE(2,1) /-1/,
* PRE(2,2) /-1/, PRE(2,3) /-1/, PRE(2,5) /-1/, PRE(2,6) /-1/,
* PRE(2,7) /-1/, PRE(2,8) /-1/, PRE(2,9) /-1/, PRE(2,10) /-1/,
* PRE(2,4) /-1/, PRE(2,11) /-1/, PRE(3,1) /6/, PRE(3,2) /6/,
* PRE(3,3) /-1/, PRE(3,5) /4/, PRE(3,6) /2/, PRE(3,7) /6/,
* PRE(3,8) /6/, PRE(3,9) /6/, PRE(3,10) /6/, PRE(3,4) /-1/,
* PRE(3,11) /6/, PRE(5,1) /5/, PRE(5,2) /7/, PRE(5,3) /4/,
* PRE(5,5) /4/, PRE(5,6) /2/, PRE(5,7) /4/, PRE(5,8) /-1/,
* PRE(5,9) /4/, PRE(5,10) /4/, PRE(5,4) /4/, PRE(5,11) /4/,
* PRE(6,1) /5/, PRE(6,2) /1/, PRE(6,3) /4/, PRE(6,5) /4/,
* PRE(6,6) /2/, PRE(6,7) /4/, PRE(6,8) /3/, PRE(6,9) /4/,
* PRE(6,10) /4/, PRE(6,4) /4/, PRE(6,11) /4/
DATA PRE(7,1) /6/, PRE(7,2) /6/, PRE(7,3) /4/, PRE(7,5) /4/,
* PRE(7,6) /2/, PRE(7,7) /6/, PRE(7,8) /6/, PRE(7,9) /6/,
* PRE(7,10) /6/, PRE(7,4) /-1/, PRE(7,11) /6/, PRE(8,1) /-1/,
* PRE(8,2) /-1/, PRE(8,3) /-1/, PRE(8,5) /-1/, PRE(8,6) /-1/,
* PRE(8,7) /-1/, PRE(8,8) /-1/, PRE(8,9) /-1/, PRE(8,10) /-1/,
* PRE(8,4) /-1/, PRE(8,11) /-1/, PRE(9,1) /5/, PRE(9,2) /6/,
* PRE(9,3) /4/, PRE(9,5) /4/, PRE(9,6) /2/, PRE(9,7) /4/,
* PRE(9,8) /6/, PRE(9,9) /6/, PRE(9,10) /6/, PRE(9,4) /4/,
* PRE(9,11) /4/, PRE(10,1) /5/, PRE(10,2) /6/, PRE(10,3) /4/,
* PRE(10,5) /4/, PRE(10,6) /2/, PRE(10,7) /4/, PRE(10,8) /6/,
* PRE(10,9) /4/, PRE(10,10) /6/, PRE(10,4) /4/, PRE(10,11) /4/,
* PRE(4,1) /5/, PRE(4,2) /6/, PRE(4,3) /4/, PRE(4,5) /4/,
* PRE(4,6) /2/, PRE(4,7) /4/, PRE(4,8) /6/, PRE(4,9) /6/,
* PRE(4,10) /6/, PRE(4,4) /-1/, PRE(4,11) /4/, PRE(11,1) /5/,
* PRE(11,2) /6/, PRE(11,3) /4/, PRE(11,5) /4/, PRE(11,6) /2/,
* PRE(11,7) /4/, PRE(11,8) /6/, PRE(11,9) /6/, PRE(11,10) /6/,
* PRE(11,4) /-1/, PRE(11,11) /6/
DATA PRE(12,1), PRE(12,3), PRE(12,7), PRE(12,11) /4*6/, PRE(12,2)
* /6/, PRE(12,5) /4/, PRE(12,6) /2/, PRE(12,8) /6/, PRE(12,4),
* PRE(12,9), PRE(12,10) /3*6/, PRE(1,12), PRE(2,12), PRE(3,12),
* PRE(7,12), PRE(12,12) /5*-1/, PRE(5,12), PRE(6,12),
* PRE(8,12), PRE(9,12), PRE(10,12), PRE(4,12), PRE(11,12) /7*4/
DATA IBR(1), IBR(3), IBR(7), IBR(12) /4*1/, IBR(2) /2/, IBR(4),
* IBR(11) /2*3/, IBR(9), IBR(10) /2*5/, IBR(8), IBR(5), IBR(6)
* /3*4/, IBR(13) /2/, IBR(14) /4/, JBR(1), JBR(12) /2*1/,
* JBR(2), JBR(3), JBR(7), JBR(9), JBR(10), JBR(11), JBR(8)
* /7*2/, JBR(4) /3/, JBR(5), JBR(6) /2*4/, JBR(13) /4/
DATA ADJ(1,1), ADJ(1,2), ADJ(1,3) /3*-1/, ADJ(1,4) /0/, ADJ(2,1),
* ADJ(2,2) /2*0/, ADJ(2,3), ADJ(2,4) /2*-1/, ADJ(3,1) /1/,
* ADJ(3,4) /0/, ADJ(3,2), ADJ(3,3) /2*-1/, ADJ(5,1) /1/,
* ADJ(5,3), ADJ(5,4) /2*0/, ADJ(5,2) /-1/, ADJ(4,1), ADJ(4,3),
* ADJ(4,4) /3*0/, ADJ(4,2) /-1/
C
C CODES IN OPERAND STACK
C 0....DOUBLE PRECISION 1....REAL 2....INTEGER
C 3....COMPLEX 4....LOGICAL 5....HOLLERITH
C 6....PROCEDURE NAME
C CODES FOR OPERATORS
C 11 +,- 12 ) 13 ** 14 .NOT. 15 ( 16 FCN(
C 17 /,* 18 , 19 .AND. 20 .OR. 21 .EQ. 22 UNARY -,+
C
PB = LSTACK
PT = 1
CALLST = .FALSE.
PREVOP = -1
CUROP = 0
PARENS = 0
FLUSH = .FALSE.
EXPR = -1
10 IF (PSTMT.LT.NSTMT .AND. .NOT.CALLST) GO TO 110
C
C FINISH RECOGNITION OF EXPRESSION; POP OPERAND STACK AND RETURN
C TYPE OF EXPRESSION
C
20 IF (PARENS.EQ.0) GO TO 40
30 CALL ERROR1(37H UNBALANCED PARENTHESES IN EXPRESSION, 37)
IF (FLUSH) GO TO 530
GO TO 80
40 IF (PB.EQ.LSTACK .OR. CALLST) GO TO 60
50 CALL POP
IF (ERR) GO TO 530
IF (PB.LT.LSTACK) GO TO 50
60 IF (PT.NE.3) GO TO 90
IF (STACK(1).EQ.0) GO TO 70
I = IGATT1(STACK(1),8)
IF (I.EQ.0) CALL SATT1(STACK(1), 8, 10)
70 EXPR = STACK(2)
80 PSTMT = K2
ERR = .FALSE.
RETURN
90 CALL ERROR1(29H INVALID SYNTAX IN EXPRESSION, 29)
IF (FLUSH) GO TO 530
GO TO 80
100 CALL ERROR1(31H EXPRESSION TOO LONG TO PROCESS, 31)
GO TO 530
C
C CONTINUING PROCESSING THE EXPRESSION, IDENTIFY NEXT TOKEN,
C
110 CUROP = GETTOK(PSTMT,K2)
IF (ERR) GO TO 80
C
C SEE END OF EXPRESSION: ")" <ID> OR <LABEL>; GETTOK RETURNS
C SAME CODES AS THOSE ABOVE EXCEPT 6 IS ID, 16 IS FCN( OR ARRAY ELE
C
IF (CUROP.NE.6 .AND. CUROP.NE.2 .AND. CUROP.NE.16 .OR.
* PREVOP.NE.12) GO TO 120
K2 = PSTMT
GO TO 20
C
C CHECK FOR ADJACENT OPERATORS OR OPERANDS.
C
120 IF (PREVOP.LE.6) GO TO 130
I = IBR(PREVOP-10)
GO TO 140
130 I = IBR(13)
IF(PREVOP.EQ.(-1)) I = IBR(14)
140 IF (CUROP.LE.6) GO TO 150
I2 = JBR(CUROP-10)
GO TO 160
150 I2 = JBR(13)
160 IF (I.GE.3 .AND. I2.EQ.1) CUROP = 22
IF (ADJ(I,I2)) 170, 190, 180
170 CALL ERROR1(44H ADJACENT PLACEMENT OF OPERATORS OR OPERANDS, 44)
GO TO 530
180 CALL ERROR1(
* 54H WARNING - ADJACENT PLACEMENT OF OPERATOR AND UNARY -+, 54)
190 IF (CUROP.GT.6 .AND. CUROP.NE.16) GO TO 290
IF (CUROP.LT.6) GO TO 280
C
C PROCESS ID OR FCN( OR ARRAY ELEMENT OR ARRAY
C LOOKUP SYMBOL TABLE ENTRY TO IDENTIFY ARRAYS AND TO IMPLICITLY
C TYPE IDENTIFIERS IF NECESSARY.
C
IF (CUROP.EQ.6) GO TO 200
K = LOOKUP(K2-1,.FALSE.)
GO TO 210
200 K = LOOKUP(K2,.FALSE.)
210 IF (SYSERR) GO TO 530
I1 = IGATT1(K,1)
I2 = IGATT1(K,7)
I3 = IGATT1(K,8)
C
C IMPLICITLY TYPE IDENTIFIERS AND FCNS
C
IF (I1.GT.0) GO TO 220
I1 = 1
IF (STMT(PSTMT).GE.38 .AND. STMT(PSTMT).LE.43) I1 = 2
CALL SATT1(K, 1, I1)
C
C SEPARATE ARRAY ELEMENT, FCN REFERENCE,ASF REF.
C
220 I1 = MOD(I1,8)
IF (CUROP.NE.16) GO TO 250
IF (I2.EQ.0) GO TO 240
C
C ARRAY ELEMENT--CHECK FOR BEING IN ASF DEF AND PEEL OFF
C SUBSCRIPTS, CHECKING THEIR NUMBER
C
IF (ITYP.NE.31) GO TO 230
CALL ERROR1(39H ILLEGAL USE OF ARRAY IN ASF DEFINITION, 39)
230 CUROP = I1
I1 = CUROP + 16
PSTMT = K2
CALL SUBS(K2, I2)
IF (ERR .OR. SYSERR) GO TO 80
GO TO 270
C
C PROCESS FCN( OR ASF( REFERENCE; CHECK USAGE TO SEE
C IF IS A LEGAL FCN OR ASF NAME I.E. IF WAS USED
C AS A FCN, SUBR, ASF, OR WAS IN AN EXTERNAL STMT.
C
240 IF (I3.EQ.0 .OR. I3.EQ.2 .OR. I3.EQ.5 .OR. I3.EQ.6 .OR. I3.EQ.13
* .OR. I3.EQ.14) GO TO 290
C
C ACTUAL USAGE WILL BE DETERMINED BY CODE WHICH
C STORES CALL TEMPLATE
C
CALL ERROR1(18H ILLEGAL USE OF ID, 18)
GO TO 530
C
C VARIABLE, ARRAY, PROCEDURE NAME
C
250 IF (I2.EQ.0) GO TO 260
C
C ARRAY
C
CUROP = I1
I1 = CUROP + 8
IF (I3.EQ.0) CALL SATT1(K, 8, 10)
GO TO 270
C
C VARIABLE OR PROCEDURE
C LEAVE IDS USAGE UNSET
C THEY WILL BE SET LATER BY APPEARING AS OPERANDS OR BY BEING
C DEFINED AS FCN OR SUBROUTINE REFS BY FOLLOWING PGMS
C
260 IF (I3.EQ.0) GO TO 270
IF (I3.EQ.5 .OR. I3.EQ.6 .OR. I3.EQ.13) I1 = 6
IF (I3.EQ.10 .OR. I1.EQ.6) GO TO 270
IF (ITYP.EQ.31 .AND. I3.EQ.1 .AND. DSA(K+2).EQ.IASF) GO TO 270
CALL ERROR1(36H ILLEGAL VARIABLE USED IN EXPRESSION, 36)
GO TO 530
C
C ENTER ARRAY,ID, PROCEDURE NAME, ARRAY ELEMENT INTO OPERAND STACK
C UPDATE PREVOP,PSTMT. ALSO ENTER SYMBOL TABLE INDEX FOR THESE
C PREVOP = 0,1,...6 FOR OPERANDS
C 11,12,...22 FOR OPERATORS
C
270 IF (PT+2.GE.PB) GO TO 100
STACK(PT) = K
STACK(PT+1) = I1
PT = PT + 2
PREVOP = CUROP
PSTMT = K2
GO TO 10
C
C ARE PROCESSING A CONSTANT
C
280 I1 = CUROP
K = 0
GO TO 270
C
C ARE PROCESSING AN OPERATER
C PRE(I,J) CONTAINS ACTION TAKEN GIVEN OPERATOR I ON STACK
C AND OPERATOR J IN INPUT
C
290 KNAME = K
IF (CUROP.EQ.15 .OR. CUROP.EQ.16) PARENS = PARENS + 1
IF (CUROP.EQ.12) PARENS = PARENS - 1
IF (PARENS.GE.0) GO TO 300
FLUSH = .TRUE.
GO TO 30
C
C CHECKS FOR LEADING UNARY +,- IN EXPRESSIONS
C
300 IF (PB.EQ.LSTACK) GO TO 460
I = STACK(PB+1) - 10
I2 = CUROP - 10
K = PRE(I,I2)
310 IF (-1.NE.K) GO TO 320
FLUSH = .TRUE.
GO TO 90
320 GO TO (330, 470, 520, 480, 480, 490, 510), K
C
C CREATE TEMPLATE FROM FCN CALL
C
330 IF (ITYP.EQ.18 .AND. PARENS.EQ.0) CALLST = .TRUE.
L1 = STACK(PB+2)
L2 = PT - 1
C
C CHECK FOR NO ARGS
C
IF (L2.GT.L1) GO TO 340
CALL ERROR1(18H MISSING ARGUMENTS, 18)
GO TO 450
C
C CHECK FOR NOT CHANGING THROUGH SUBROUTINE CALL THE DO CONTROL
C VARIABLE OF A CURRENT LOOP OR ANY ADJUSTIBLE DIMENSION DUMMY ARG
C
340 DO 380 I=L1,L2,2
IF (STACK(I)) 350, 380, 350
350 IF (DOVAR(STACK(I))) STACK(I+1) = STACK(I+1) + 32
I1 = IGATT1(STACK(I),4)
IF (I1) 380, 380, 360
360 I1 = IGATT1(STACK(I),6)
IF (I1) 380, 380, 370
370 STACK(I+1) = STACK(I+1) + 64
380 CONTINUE
C
C CHECK FOR USE OF ID AS FCN ONCE AND AS SUBROUTINE LATER
C OR VICE VERSA
C
I = STACK(PB+3)
L = IGATT1(I,8)
IF (L.EQ.2 .OR. L.EQ.5 .OR. L.EQ.6) GO TO 410
IF (.NOT.INTEXT(I,L1,L2,.TRUE.)) GO TO 390
C
C FOUND AN INTRINSIC FCN
C CHECK NOT IN A CALL STMT USED AS A SUBROUTINE
C
IF (CALLST) GO TO 420
GO TO 450
C
C DEFINE FCN( USAGE IF UNSET
C SET USAGE OF ID USED AS A PROC
C
390 IF (CALLST) GO TO 400
CALL SATT1(I, 8, 5)
GO TO 430
400 CALL SATT1(I, 8, 6)
GO TO 430
C
C CHECK USAGE OF PROC ALREADY USED IN PROGRAM UNIT
C
410 IF (CALLST .AND. L.EQ.6 .OR. .NOT.CALLST .AND. (L.EQ.5 .OR.
* L.EQ.2)) GO TO 430
420 CALL ERROR1(18H ILLEGAL REFERENCE, 18)
GO TO 450
430 IF (.NOT.OPT(3) .OR. P1ERR) GO TO 450
C
C LOAD INTO STACK COUNT OF WORDS IN DESCRIPTOR, INDEX OF FCN
C IN SYMBOL TABLE, STMT NO OF REFERENCE
C
IF (PT+3.GE.PB) GO TO 100
STACK(PT) = PT - STACK(PB+2)
STACK(PT+1) = STACK(PB+3)
STACK(PT+2) = NOST
STACK(PT+3) = 6 - IGATT1(STACK(PB+3),8)
L3 = PT + 3
ICOD = 2
L = L2 - L1 + 5
IF (L.LE.LREF) GO TO 440
CALL ERROR1(44H IN EXPR, TABLE OVERFLOW OF REF, REF IGNORED, 44)
GO TO 450
440 WRITE (OUTUT3) L, ICOD, (STACK(I),I=PT,L3), (STACK(I),I=L1,L2)
C
C FCN REF POPPED AND PROPER TYPE PUT ON OPERAND STACK
C
450 PT = STACK(PB+2)
I1 = IGATT1(STACK(PB+3),1)
STACK(PT) = 0
STACK(PT+1) = MOD(I1,8)
PT = PT + 2
PB = PB + 3
GO TO 520
C
C HANDLES FIRST OPERATOR IN EXPRESSION--WILL ALWAYS BE PUSHED ONTO
C OPERATOR STACK. FCN( HAS SPECIAL PUSH.
C
460 IF (CUROP.NE.16) GO TO 480
C
C FOUND "FCN(" CONSTRUCT ; STORE 3 THINGS IN STACK
C PTR TO FCN NAME IN SYMBOL TABLE; PTR TO 1ST ARGE IN STACK ;
C OPERAND CODE FOR FCN(
C
470 IF (PB-3.LE.PT) GO TO 100
STACK(PB) = KNAME
STACK(PB-1) = PT
STACK(PB-2) = CUROP
PB = PB - 3
GO TO 520
C
C SIMPLE PUSH ONTO OPERATOR STACK
C
480 IF (PB-1.EQ.PT) GO TO 100
STACK(PB) = CUROP
PB = PB - 1
GO TO 520
C
C POP OPERATOR FROM STACK. IF STACK EMPTY, PUSH CUROP ONTO
C STACK. ELSE TAKE ACTION SPECIFIED BY PRE(TOP OPERATOR,CUROP).
C
490 CALL POP
IF (ERR) GO TO 530
IF (PB.LT.LSTACK) GO TO 500
GO TO 480
500 I = STACK(PB+1) - 10
K = PRE(I,CUROP-10)
GO TO 310
C
C POP "(" WHEN HAVE FINISHED A PARENTHESIZED EXPRESSION
C
510 CALL POP
IF (ERR) GO TO 530
C
C UPDATE PREVOP,PSTMT AFTER FINISHING PROCESSING AN OPERATOR
C
520 PREVOP = CUROP
PSTMT = K2
GO TO 10
C
C JOB OF THIS CODE IS TO FLISH TO END OF UNRECOGNIZABLE
C EXPRESSION
C
530 K2 = PSTMT
ERR = .FALSE.
540 IF (K2.GE.NSTMT) GO TO 80
IF (STMT(K2).EQ.65) PARENS = PARENS + 1
IF (STMT(K2).NE.62) GO TO 550
PARENS = PARENS - 1
IF (PARENS.EQ.0) GO TO 560
550 K2 = K2 + 1
GO TO 540
560 I = GETTOK(K2,I2)
K2 = I2
IF ((I.EQ.1 .OR. I.EQ.6) .OR. ERR) GO TO 80
GO TO 540
END
C XXXXXINSTMT.f
SUBROUTINE INSTMT(EOF, NCARD)
LOGICAL ILLEG, ILHOL, ILCONT
LOGICAL NEWRD, EOF, CONT, OPT, P1ERR
INTEGER PSTMT, CARD(80), OUTUT, BLK, STATE, HCOUNT, STMT
INTEGER SYMLEN, OUTUT2, OUTUT3, OUTUT4
DIMENSION IBR(5)
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /OPTNS/ OPT(5), P1ERR
COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
* OUTUT4
COMMON /FACTS/ NAME, NOST, ITYP, IASF
DATA NEWRD /.TRUE./
DATA IBR(1), IBR(2), IBR(3), IBR(4), IBR(5) /1H*,1HC,1H.,1H0,1H /
DATA CARD(1) /1H /
C
C ROUTINE INPUTS AN ENTIRE FORTRAN STATEMENT. IT IS PASSED 1 CHAR
C PER ELEMENT IN THE ARRAY STMT.
C IN SHOULD BE CALLED AGAIN IF ERR IS TRUE.
C EACH CARD IS WRITTEN OUT BEFORE BEING PARSED.
C IN DEBLANKS CARDS USES THE VARIABLE STATE TO FIND
C HOLLERITHS:
C STATE = 0.....LOOK FOR BREAK CHAR
C 1.....HAVE BREAK CHAR AND NEED DIGIT
C 2.....HAVE DIGIT AND NEED DIGIT OR "H"
C 3....NEED TO SKIP OVER THESE CHARS, PART OF HOLLERITH
C NOTE: USE "90" AS AN END OF STMT MARKER
C
C NEWRD IS TRUE IF A NEW CARD IS NECESSARY; ELSE CARD IN BUFFER
C IS USED. EOF IS TRUE WHEN END-OF-FILE CARD ("." IN COL 1)
C IS READ NCARD GIVES # OF CARDS READ FOR THIS STMT
C
10 NOST = NOST + 1
STATE = 0
NSTMT = 0
ILLEG = .FALSE.
ILCONT = .FALSE.
ILHOL = .FALSE.
NCARD = 0
CONT = .FALSE.
20 IF (NEWRD) CALL IN(CARD, INUT)
IF (CARD(1).NE.IBR(2) .OR. CARD(2).NE.IBR(1)) GO TO 40
C
C DEAL WITH OPTIONS CARD
C
IF (CONT) GO TO 50
CALL INOPT(CARD)
30 IF (OPT(4)) WRITE (OUTUT,99999) CARD
99999 FORMAT (11X, 80A1)
NEWRD = .TRUE.
GO TO 20
40 IF (CARD(1).NE.IBR(2)) GO TO 70
C
C DEAL WITH COMMENT CARD
C
IF (.NOT.CONT) GO TO 30
C
C HAVE COMPLETED STMT
C
50 NEWRD = .FALSE.
NSTMT = NSTMT + 1
STMT(NSTMT) = 90
60 IF (ILLEG) CALL ERROR1(
* 40H WARNING - NON-FORTRAN CHARACTER IGNORED, 40)
IF (ILHOL) CALL ERROR1(
* 46H WARNING - NON-FORTRAN CHARACTER IN HOLLERITH , 46)
IF (ILCONT) CALL ERROR1(
* 45H WARNING - NON-FORTRAN CONTINUATION CHARACTER, 45)
RETURN
70 IF (CARD(1).NE.IBR(3)) GO TO 80
C
C HAVE EOF
C
IF (CONT) GO TO 50
EOF = .TRUE.
GO TO 60
80 IF (CARD(6).EQ.IBR(4) .OR. CARD(6).EQ.IBR(5)) GO TO 100
C
C DEAL WITH CONTINUATION CARD
C
II = MAPCHR(CARD(6),ILCONT)
IF (CONT) GO TO 110
CALL ERROR1(40H WARNING - CONTINUATION NOT ALLOWED HERE, 40)
C
C FLUSH TO NEXT NONCONTINUATION CARD
C
90 IF (OPT(4)) WRITE (OUTUT,99998) NOST, CARD
99998 FORMAT (1H , I5, 5X, 80A1)
CALL IN(CARD, INUT)
IF (CARD(1).NE.IBR(1) .AND. CARD(1).NE.IBR(2) .AND.
* CARD(1).NE.IBR(3) .AND. CARD(6).NE.IBR(4) .AND.
* CARD(6).NE.IBR(5)) GO TO 90
NEWRD = .FALSE.
GO TO 10
C
C DEAL WITH A NON-CONTINUATION CARD
C
100 IF (CONT) GO TO 50
C DEAL WITH A LEGAL CONTIN OR NONCONTIN CARD
110 NCARD = NCARD + 1
IF (NCARD.LT.21) GO TO 120
CALL ERROR1(33H WARNING - TOO MANY CONTINUATIONS, 33)
GO TO 90
120 IF (OPT(4)) WRITE (OUTUT,99998) NOST, CARD
NEWRD = .TRUE.
BLK = 0
IF (NSTMT.NE.0) GO TO 150
DO 130 I=1,5
NSTMT = NSTMT + 1
STMT(NSTMT) = MAPCHR(CARD(I),ILLEG)
130 CONTINUE
140 I = 7
GO TO 180
150 DO 160 I=1,5
IF (MAPCHR(CARD(I),ILLEG).NE.69) GO TO 170
160 CONTINUE
GO TO 140
170 CALL ERROR1(40H WARNING - ILLEGAL LABEL WILL BE IGNORED, 40)
GO TO 140
180 IF (I.LE.72) GO TO 200
C
C AFTER TRANSLATE CARD CHECK FOR BLANK CARD
C AND GO BACK FOR A CONTINUATION CARD
C
IF (BLK.NE.66) GO TO 190
CALL ERROR1(33H WARNING - BLANK CARD ENCOUNTERED, 33)
GO TO 90
190 CONT = .TRUE.
GO TO 20
200 IF (STATE.NE.3) GO TO 210
C
C STATE 3 --ARE PROCESSING A HOLLERITH
C
HCOUNT = HCOUNT - 1
KK = MAPCHR(CARD(I),ILHOL)
IF (HCOUNT.EQ.0) STATE = 0
GO TO 290
210 NSTMT = NSTMT + 1
STMT(NSTMT) = MAPCHR(CARD(I),ILLEG)
IF (STMT(NSTMT).NE.69) GO TO 220
C
C BLANK ENCOUNTERED AND DELETED
C
BLK = BLK + 1
NSTMT = NSTMT - 1
GO TO 290
220 KK = STATE + 1
GO TO (280, 260, 230), KK
C
C STATE 2--SKIP OVER LEADING DIGIT STRING; LOOK FOR H
C
230 IF (STMT(NSTMT).LE.9) GO TO 290
IF (STMT(NSTMT).NE.37) GO TO 270
C
C PROCESS HOLLERITH COUNT
C
STMT(NSTMT) = -STMT(NSTMT)
STATE = 3
KK = NSTMT - KST
I10 = 1
HCOUNT = 0
DO 240 K=1,KK
JJ = NSTMT - K
HCOUNT = HCOUNT + I10*STMT(JJ)
I10 = I10*10
240 CONTINUE
STMT(KST) = HCOUNT - 2048
NSTMT = KST
IF (HCOUNT.LE.0) GO TO 250
GO TO 290
C
C AVOID THE 0H CONSTRUCTION
C
250 CALL ERROR1(44H WARNING - 0H ILLEGAL HOLLERITH CONSTRUCTION, 44)
STATE = 0
GO TO 290
C
C STATE 1--LOOK FOR START OF DIGIT STRING BEFORE H
C
260 IF (STMT(NSTMT).GT.9) GO TO 270
STATE = 2
KST = NSTMT
GO TO 290
C
C CHECK FOR NESTED SPECIAL HEADING CHARS
C
270 STATE = 0
280 IF ((STMT(NSTMT).LT.65) .OR. (STMT(NSTMT).GT.68)) GO TO 290
STATE = 1
290 I = I + 1
GO TO 180
END
C XXXXXIN.f
SUBROUTINE IN(CARD, INUT)
C
INTEGER CARD(80)
LOGICAL EOF
C
DATA EOF /.FALSE./
DATA IDOT /1H./
C
IF (EOF) RETURN
C
C READ A CARD. PHYSICAL EOF SHOULD TRANSFER TO 100
C
READ (INUT,99999) CARD
99999 FORMAT (80A1)
IF (CARD(1).NE.IDOT) RETURN
C
C HERE FOR EOF
C
100 CARD(1) = IDOT
EOF = .TRUE.
C
RETURN
END
C XXXXXINOPT.f
SUBROUTINE INOPT(CARD)
INTEGER S(8), CARD(80), J(5)
LOGICAL OPT, P1ERR
COMMON /OPTNS/ OPT(5), P1ERR
DATA S(1), S(2), S(3), S(4), S(5), S(6), S(7) /1HS,1HR,1HP,1HL,
* 1HC,1H,,1HN/, S(8) /1H /
C
C OPT(1) IF TRUE, PRINT SYMBOL TABLE
C IF FALSE, NOSYMBOL TABLE PRINTED
C OPT(2) IF TRUE, PRINT CROSS REFERENCES
C IF FALSE, NO REFS PRINTED
C OPT(3) IF TRUE, DO PASS 2; ELSE DO NOT
C OPT(4) IF TRUE GET LISTING OF PGM; ELSE DO NOT
C OPT(5) IF TRUE, COMPILE PGM AFTER PROCESSING; ELSE DO NOT
C SET OPTIONS FROM CARD READ IN BY "IN"
C P2 IS TURNED OFF ONLY ONCE A RUN; IT CANNOT BE TURNED ON AGAIN
C OPTIONS CARD IS ONLY ACCEPTED IF SYNTAX ON CARD IS OK
C SYNTAX IS C* FOLLOWED BY AT LEAST ONE OPTION OF THEFORM
C OPT BLANKS, OPT N, AT LEAST ONE OF (S,R,P,L,C), OPT BLANKS
C WHERE OPTIONS ARE SEPARATEDBY COMMAS
C
DO 10 I=1,5
J(I) = 0
10 CONTINUE
IP = 2
20 IP = IP + 1
IF (IP.GE.73) GO TO 60
C DEBLANK LEADING BLANKS
IF (CARD(IP).EQ.S(8)) GO TO 20
L = 1
C
C CHECK FOR NEGATIVE
C
IF (CARD(IP).NE.S(7)) GO TO 30
L = -1
IP = IP + 1
IF (IP.GE.73) GO TO 60
30 DO 40 I=1,5
IF (S(I).NE.CARD(IP)) GO TO 40
J(I) = J(I) + L
GO TO 50
40 CONTINUE
GOTO 100
C
C FLUSH BLANKS TO NEXT COMMA
C
50 IP = IP + 1
IF (IP.GE.73) GO TO 60
IF (CARD(IP).EQ.S(6)) GO TO 20
IF(CARD(IP).NE.S(8)) GOTO 100
GO TO 50
60 DO 90 K=1,5
IF (J(K)) 70, 90, 80
70 OPT(K) = .FALSE.
GO TO 90
C DO NOT LET USER TURN ON PASS2 AFTER WE TURN IT OFF
80 IF (K.EQ.3 .AND. .NOT.OPT(3)) GO TO 90
OPT(K) = .TRUE.
90 CONTINUE
100 RETURN
END
C XXXXXLIST.f
SUBROUTINE LIST
INTEGER STMT, PSTMT
LOGICAL ERR, SYSERR, ABORT, IDLIST, IDO, FINDO
LOGICAL SIO
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /LISTDO/ LPT, LEN, LS(64)
C
C ROUTINE PROCESSES THE LIST CONSTRUCT, USED IN I-O STMTS
C LEV USED TO COUNT PARENTHESES LEVELS
C
SIO = .FALSE.
LPT = LEN + 1
FINDO = .FALSE.
ICNT = 0
LEV = 0
10 IF (STMT(PSTMT).NE.65) GO TO 20
LEV = LEV + 1
IF (LEV.GT.ICNT) ICNT = ICNT + 1
PSTMT = PSTMT + 1
GO TO 10
20 IF (PSTMT.GE.NSTMT) GO TO 120
C
C ALLOW <ID>=ARRAY,ARRAY ELE., VARIABLE
C
IF (.NOT.IDLIST(IDO)) GO TO 130
C
C FALSE RETURN SIGNIFIES ERROR IN IDLIST
C TRUE RETURN SIGNIFIES NO ERROR IN IDLIST
C IDO = .TRUE. MEANS , <DOSPEC> IS NEXT
C IDO = .FALSE. MEANS AT END-OF-STMT, ", (" , OR ")"
C
C FOUND <DOSPEC> )
C
IF (SYSERR) GO TO 130
IF (.NOT.IDO) GO TO 30
PSTMT = PSTMT + 1
GO TO 100
C
C FOUND END OF SIMPLE LIST "( <IDLIST> )"
C
30 IF (STMT(PSTMT).EQ.62) GO TO 60
40 IF (PSTMT.NE.NSTMT) GO TO 50
C
C AT END OF STMT
C
IF (FINDO) CALL LDOVAR
IF (LEV.NE.0) GO TO 120
GO TO 130
C
C NEED "," AND NEW <LIST> CONSTRUCT
C
50 IF (STMT(PSTMT).NE.68) GO TO 120
PSTMT = PSTMT + 1
GO TO 10
C
C MUST CHECK FOR ILLEGALLY NESTED SIMPLE LISTS
C SIMPLE LIST= ( <IDLIST> )
C ICNT COUNTAINS LEVEL OF LAST SIMPLE LIST WITHIN A
C PARENTHESIZED EXPRESSION
C
60 SIO = .TRUE.
IF (LEV.EQ.0) GO TO 120
PSTMT = PSTMT + 1
IF (ICNT.LE.LEV) GO TO 80
70 CALL ERROR1(28H ILLEGAL PARENTHESES NESTING, 28)
GO TO 130
80 LEV = LEV - 1
IF (LEV) 120, 110, 90
C
C CHECK FOR CONSTRUCT FOLLOWING <DOSPEC>
C
90 IF (STMT(PSTMT).EQ.62) GO TO 70
IF (STMT(PSTMT).NE.68) GO TO 120
CALL NEXTOK(PSTMT+1, K2, K)
IF (K.NE.0 .OR. STMT(K2).NE.63) GO TO 40
PSTMT = PSTMT + 1
C
C LOOK FOR DOSPEC
C
100 CALL DOSPEC(0, K2, .TRUE.)
IF (SYSERR .OR. ERR) GO TO 130
FINDO = .TRUE.
IF (STMT(K2).NE.62) GO TO 120
PSTMT = K2 + 1
IF (ICNT.GT.LEV) ICNT = ICNT - 1
GO TO 80
C
C CHECK NESTED DOSPECS IN LIST
C
110 IF (LEV.NE.0 .OR. .NOT.FINDO) GO TO 40
FINDO = .FALSE.
CALL LDOVAR
LPT = LEN + 1
GO TO 40
120 CALL ERROR1(20H ILLEGAL PUNCTUATION, 20)
IF (FINDO) CALL LDOVAR
130 IF (SIO) CALL ERROR1(34H REDUNDANT PARENTHESES ARE ILLEGAL, 34)
RETURN
END
C XXXXXLOOKUP.f
INTEGER FUNCTION LOOKUP(K1, LABEL)
C
C STMT(PSTMT)-STMT(K2-1) TO BE ENTERED IN DSA
C LABEL IS TRUE IF SYMBOL IS A LABEL. ROUTINE
C RETURNS VALUE OF INDEX OF SYMBOL IN DSA, CREATING
C A NEW ENTRY ID NESESSARY. IT ENTERS SYMBOL INTO
C SYMBOL OR LABEL CHAIN AND CREATES A CROSSREFERENCE
C ENTRY FOR THE CURRENT STATMT NUMBER
C
INTEGER PSTMT, SYMLEN, DSA, HASH, L(6), LL(6)
INTEGER BLANK, SYMHD, STMT, OUTUT, BNEXT, Q(70)
INTEGER PDSA, OUTUT2, OUTUT3, OUTUT4
LOGICAL LABEL, ERR, P1ERR, OPT, SYSERR, ABORT
COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
* OUTUT4
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /CHASH/ LHASH, HASH(401)
COMMON /TRANS/ Q
COMMON /OPTNS/ OPT(5), P1ERR
DATA BLANK /1H /
K = K1 - PSTMT
IF (K.LE.6) GO TO 10
CALL ERROR1(39H IDENTIFIER TOO LONG, WILL BE TRUNCATED, 39)
K = 6
10 KK = K
DO 20 I=1,K
II = PSTMT + I - 1
J = STMT(II) + 1
LL(I) = Q(J)
20 CONTINUE
DO 30 I=1,SYMLEN
L(I) = BLANK
30 CONTINUE
CALL S5PACK(LL, L, K)
C
C HAVE PACKED SYMBOL;NOW CALCULATE HASH
C HASH IS(PRODUCT OF FIRST AND THIRD LETTERS PLUS SECOND) MOD 257
C
IF (KK.LT.3) GO TO 50
IHASHS = STMT(PSTMT)*STMT(PSTMT+2) + STMT(PSTMT+1)
40 IHASHS = MOD(IHASHS,LHASH)
ISAVE = IHASHS
IHASH = IHASHS + 1
GO TO 80
50 IHASHS = STMT(PSTMT)
GO TO (60, 70), KK
60 IHASHS = IHASHS*69 + 69
GO TO 40
70 IHASHS = IHASHS*69 + STMT(PSTMT+1)
GO TO 40
80 IF (HASH(IHASH).EQ.0) GO TO 140
C
C IF TABLE EMPTY, CREATE ENTRY, SEND BACK INDEX OF FIRST WORD IN DSA
C ELSE COMPARE SYMBOL TO ID AND RETURN INDEX OF PROPER ENTRY IN HASH
C TABLE AFTER RESOLVING COLLISION
C
DO 90 J=1,SYMLEN
II = HASH(IHASH) + 3 + J
IF (L(J).NE.DSA(II)) GO TO 100
90 CONTINUE
LOOKUP = HASH(IHASH)
IF (DSA(LOOKUP+1)) 190, 190, 200
C
C RESOLVE CONFLICTS BY LINEAR CONGRUENCE
C
100 IHASHS = MOD(IHASHS+1,LHASH)
IF (IHASHS.EQ.ISAVE) GO TO 110
IHASH = IHASHS + 1
GO TO 80
110 CALL ERROR1(34H IN LOOKUP, TABLE OVERFLOW OF HASH, 34)
120 SYSERR = .TRUE.
RETURN
130 CALL ERROR1(33H IN LOOKUP, TABLE OVERFLOW OF DSA, 33)
GO TO 120
C
C CREATE NEW SYMBOL TABLE ENTRY; ZERO ITS CROSSREF TAIL PTR
C
140 HASH(IHASH) = NEXT
IF (NEXT+6+SYMLEN.GE.BNEXT) GO TO 130
LOOKUP = NEXT
C
C*****DSA
C 1ST WORD..... ATTRIBUTE WORD
C FIELD 1
C
C BITS 0-2*TYPE (FOR SYMBOL) 0 DOUBLE PRECISION, 1 REAL, 2 INT,
C 3 COMPLEX,4 LOGICAL, 5 HOLLERITH
C TYPE (FOR LABEL) 1 EXECUTABLE STMT, 2 NONEXEC. STMT,
C 3 FORMAT STMT
C BIT 3****EXPLICITLY TYPED 1, IMPLICITLY 0
C FIELD 2
C BIT 4****(FOR SYMBOL) IN COMMON 1, NOT IN COMMON 0
C (FOR LABEL) DEFINED 1, REFERENCED 0
C (FOR COMMON-NAME) INITIALIZED IN BLOCK DATA SUBPGM
C FIELD 3
C BIT 5****EQUIVALENCED 1
C FIELD 4
C BIT 6****DUMMY SUBROUTINE/FUNCTION ARGUMENT 1
C FIELD 5
C BIT 7****VALUE SET BY P.U. 1
C FIELD 6
C BIT 8****VARIABLE USED AS DIMENSION IN VARIABLY DIMENSIONED ARRAY
C FIELD 7
C BIT 9-10*SCALAR 0, NUMBER OF ARRAY BOUNDS 1,2,3
C FIELD 8
C BITS 11-15**USAGE--UNSET 0, ASF ARG 1, ASF FCN 2, CURRENT P. U.=
C SUBR 3, CURRENT P.U.=FCN 4, EXTERNAL FCN 5, EXTERNAL SUBR 6,
C COMMON-NAME 7, ASSIGN/GOTO VARIABLE 8,LABEL 9, VARIABLE 10,
C CURRENT P.U.=BLOCK DATA 11, CURRENT P.U.=MAIN 12, EXTERNAL ENTITY
C 13, INTRINSIC FCN 14
C BITS 5-8 ARE 0 IF ENTRY CORRESPONDS TO ENTITY WITHOUT THE
C ATTRIBUTE MENTIONED
C
C 2ND WD..... XREF LIST TAIL POINTER
C 3D WORD.....EXTRA INFO POINTER
C
C FOR A VARIABLE, 3D WORD POINTS TO A 2 WORD BLOCK, FIRST WORD
C CONTAINING STORAGE UNIT LENGTH OF THE VARIABLE (-1 IF VARIABLY
C DIMENSIONED ARRAY); SECOND WORD CONTAINING INDEX OF COMMON
C ENTRY IN DSA;
C FOR A LABEL, 3D WORD CONTAINS POINTER TO 2 WORD BLOCK ; AFTER
C LABEL DEFINED, FIRST WORD CONTAINS STMT NUMBER OF FIRST STMT
C IN CURRENT DO NESTING LEVEL; SECOND WORD CONTAINS NEGATIVE THE
C NESTING LEVEL; WHEN END OF THIS NESTING LEVEL IS ENCOUNTERED
C ALL 2ND WORDS FOR THAT LEVEL ARE UPDATED TO CONTAIN STMT NUMBER
C OF LAST STMT AT THAT NESTING LEVEL;
C FOR A COMMON-NAME, 3D WORD POINTS TO HEAD OF LINEAR LINKED LIST
C OF INDICES OF DSA ENTRIES FOR ORDERED ELEMENTS IN THAT COMMON;
C FOR THE CURRENT P.U. IF ITS A SUBR OR FCN, 3D WORD CONTAINS
C A LINEAR LINKED LIST OF INDICES IN DSA OF ENTRIES FOR ORDERED
C DUMMIES OF THAT SUBPGM;
C
C 4TH WORD..... CHAIN POINTER TO ENTRY IN DSA FOR LAST SYMBOL
C OR LABEL FOR WHICH A NEW ENTRY WAS CREATED
C 5-7TH WORD.....PACKED CHARACTERS OF SYMBOL OR LABEL
C
J = NEXT + 2
DO 150 I=NEXT,J
DSA(I) = 0
150 CONTINUE
J = J + 1
DO 160 I=1,SYMLEN
II = I + J
DSA(II) = L(I)
160 CONTINUE
C
C SETONE OF THE CHAIN POINTERS TO PUT THIS SYMBOL ON CHAIN
C
IF (LABEL) GO TO 170
DSA(J) = SYMHD
SYMHD = NEXT
GO TO 180
170 DSA(J) = LABHD
LABHD = NEXT
180 NEXT = 4 + SYMLEN + NEXT
C
C BEGINNEW XREF LIST
C
190 IF (.NOT.LABEL .AND. .NOT.OPT(2)) GO TO 210
IF (NEXT+2.GE.BNEXT) GO TO 130
DSA(BNEXT-1) = NOST
DSA(LOOKUP+1) = BNEXT - 1
DSA(BNEXT) = BNEXT - 1
BNEXT = BNEXT - 2
GO TO 210
C
C XREF LIST UPDATE; CHECK TO SEE IF STATEMENT NUMBER IS ALREADY
C THERE
C
200 IF (.NOT.LABEL .AND. .NOT.OPT(2)) GO TO 210
IF (NEXT+2.GE.BNEXT) GO TO 130
J = DSA(LOOKUP+1)
IF (DSA(J).EQ.NOST) GO TO 210
DSA(BNEXT) = DSA(J+1)
DSA(J+1) = BNEXT - 1
DSA(LOOKUP+1) = BNEXT - 1
DSA(BNEXT-1) = NOST
BNEXT = BNEXT - 2
210 RETURN
END
C XXXXXMAPCHR.f
INTEGER FUNCTION MAPCHR(CHAR, ERR)
C
C MAPCHR RETURNS THE INTERNAL CODE OF THE CHARACTER CHAR
C
INTEGER CHAR
INTEGER LET(46), ICODE(46)
LOGICAL ERR
C
DATA LET(7), ICODE(7) /1H0,0/
DATA LET(16), ICODE(16) /1H1,1/
DATA LET(22), ICODE(22) /1H2,2/
DATA LET(24), ICODE(24) /1H3,3/
DATA LET(26), ICODE(26) /1H4,4/
DATA LET(28), ICODE(28) /1H5,5/
DATA LET(25), ICODE(25) /1H6,6/
DATA LET(38), ICODE(38) /1H7,7/
DATA LET(34), ICODE(34) /1H8,8/
DATA LET(32), ICODE(32) /1H9,9/
DATA LET(3), ICODE(3) /1HA,30/
DATA LET(36), ICODE(36) /1HB,31/
DATA LET(14), ICODE(14) /1HC,32/
DATA LET(6), ICODE(6) /1HD,33/
DATA LET(5), ICODE(5) /1HE,34/
DATA LET(33), ICODE(33) /1HF,35/
DATA LET(27), ICODE(27) /1HG,36/
DATA LET(37), ICODE(37) /1HH,37/
DATA LET(8), ICODE(8) /1HI,38/
DATA LET(44), ICODE(44) /1HJ,39/
DATA LET(46), ICODE(46) /1HK,40/
DATA LET(13), ICODE(13) /1HL,41/
DATA LET(12), ICODE(12) /1HM,42/
DATA LET(4), ICODE(4) /1HN,43/
DATA LET(2), ICODE(2) /1HO,44/
DATA LET(18), ICODE(18) /1HP,45/
DATA LET(43), ICODE(43) /1HQ,46/
DATA LET(11), ICODE(11) /1HR,47/
DATA LET(15), ICODE(15) /1HS,48/
DATA LET(10), ICODE(10) /1HT,49/
DATA LET(30), ICODE(30) /1HU,50/
DATA LET(42), ICODE(42) /1HV,51/
DATA LET(45), ICODE(45) /1HW,52/
DATA LET(39), ICODE(39) /1HX,53/
DATA LET(35), ICODE(35) /1HY,54/
DATA LET(41), ICODE(41) /1HZ,55/
DATA LET(31), ICODE(31) /1H+,60/
DATA LET(29), ICODE(29) /1H-,61/
DATA LET(19), ICODE(19) /1H),62/
DATA LET(23), ICODE(23) /1H=,63/
DATA LET(17), ICODE(17) /1H.,64/
DATA LET(20), ICODE(20) /1H(,65/
DATA LET(21), ICODE(21) /1H*,66/
DATA LET(40), ICODE(40) /1H/,67/
DATA LET(9), ICODE(9) /1H,,68/
DATA LET(1), ICODE(1) /1H ,69/
C
DO 10 I=1,46
IF (CHAR.EQ.LET(I)) GO TO 20
10 CONTINUE
C
C UNKNOWN, RETURN BLANK AND SET ERR = .TRUE.
C
MAPCHR = 69
ERR = .TRUE.
RETURN
C
C KNOWN, RETURN INTERNAL CODE, LEAVE ERR ALONE
C
20 MAPCHR = ICODE(I)
RETURN
END
C XXXXXPU.f
SUBROUTINE PU
INTEGER STMT, PSTMT, SYMLEN, OUTUT, SYMHD, BNEXT, HASH, DSA
INTEGER STACK, DOPT, DOLIST, PDSA, OUTUT2, OUTUT3, OUTUT4
INTEGER Q(70)
LOGICAL ERR, BLKD, SYSERR, LOGIF1, LOGIF2, LAB, EOF
LOGICAL NEW, TOKLAB, EXECUT, P1ERR, OPT, RET, ABORT
LOGICAL P2, QBR
COMMON /OPTNS/ OPT(5), P1ERR
COMMON /INPUT/ NSTMT, PSTMT, STMT(1327)
COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3,
* OUTUT4
COMMON /CEXPRS/ LSTACK, STACK(620)
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
COMMON /CHASH/ LHASH, HASH(401)
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /DOS/ DOPT, LDO, DOLIST(192)
COMMON /TRANS/ Q
COMMON /PASS/ P2, QBR
C
C ROUTINE HANDLES CYCLING THROUGH STMTS OF A PGM UNIT. NEW IS
C USED TO HANDLE P.U.'S WITHOUT END STMTS. FLUSHING OF STMTS
C TO NEXT END OR HEADING STMT IS PROVIDED FOR ILLEGAL SEQUENCING
C LOGIF1,LOGIF2 ARE USED TO CYCLE THROUGH LOGICAL IF STMTS
C EOF OF INPUT FILE
C ERR USED AS ERROR DIAGNOSTIC INDICATOR
C NEWRD, NEW USED TO CONTROL INPUT
C
EOF = .FALSE.
NEW = .FALSE.
C
C INTER-PROGRAM INITIALIZATION
C NOST CONTAINS CURRENT STATEMENT NUMBER
C ITYP CONTAINS TYPE OF STMT
C BLKD IS TRUE FOR BLOCK DATA PGM UNIT, ELSE FALSE
C EXECUT IS TRUE FOR AT LEAST ONE EXECUTABLE STMT IN
C PROGRAM UNIT EXISTING
C NAME CONTAINS INDEX IN DSA OF PGM UNIT NAME
C P1ERR USED TO CONTROL WRITING OF SYMBOL TABLE FOR
C PASS 2
C RET IS TRUE IF RETURN STMT OCCURS IN P.U. ELSE FALSE
C NEXT, BNEXT POINT INTO DSA
C LABHD POINTS TO HEAD OF LABELS LIST IN DSA
C SYMHD POINTS TO HEAD OF SYMBOLS LIST IN DSA
C KGP, IGP USED TO CHECK STMT SEQUENCING
C DOPT,DOLIST USED TO CHECK DO LOOP NESTING
C
10 NOST = 0
ITYP = 0
LTYP = 0
BLKD = .FALSE.
EXECUT = .FALSE.
NAME = 0
P1ERR = .FALSE.
RET = .FALSE.
NEXT = 1
BNEXT = LDSA
LABHD = 0
SYMHD = 0
KGP = 0
DOPT = 1
DOLIST(1) = 1
DO 20 I=2,6
DOLIST(I) = 0
20 CONTINUE
DO 30 I=1,LHASH
HASH(I) = 0
30 CONTINUE
C
C DONT GOTO NEW PAGE IF NOT PRODUCING LISTING
C
IF (.NOT.OPT(4)) GO TO 40
WRITE (OUTUT,99999)
99999 FORMAT (32H1PFORT VERIFIER 1/12/79 VERSION //)
C
C INPUT NEW STMT; RETURN WHEN HIT EOF STMT
C FIND LABELS
C
C HEADING STMT INADVERTENTLY READ BECAUSE OF MISSING END
C
40 IF (.NOT.NEW) GO TO 70
NEW = .FALSE.
NOST = 1
IF (.NOT.OPT(4)) GO TO 80
K = NSTMT - 1
DO 50 I=1,K
II = STMT(I) + 1
STACK(I) = Q(II)
50 CONTINUE
WRITE (OUTUT,99998) NOST, (STACK(I),I=1,K)
99998 FORMAT (1H , I5, 5X, 80A1)
GO TO 80
60 CALL ERROR1(20H UNRECOGNIZABLE STMT, 20)
ERR = .FALSE.
70 CALL INSTMT(EOF, NCARD)
IF (EOF) GO TO 400
80 LAB = .FALSE.
C
C TYPST TYPES THE CURRENT STAMT
C ITYP IS NO 1-30 TELLING STMT WE HAVE
C KGP IS LEVEL NO 0-6 OF STMT.
C ICNT IS NO OF CHARACTERS IN STMT IE KI(ITYP)
C
PSTMT = 6
CALL TYPST(ITYP, IGP, ICNT)
IF (ERR) GO TO 60
PSTMT = 6 + ICNT
IF (ITYP.GE.6) GO TO 100
I = ITYP - 1
CALL TYPST(ITYP, II, K2)
IF (ITYP.NE.10) GO TO 90
PSTMT = PSTMT + K2
IGP = II
GO TO 110
90 ITYP = I + 1
100 I = -1
110 II = 1
IF (ITYP.LT.14 .OR. ITYP.EQ.28 .OR. ITYP.EQ.31) II = 2
IF (ITYP.EQ.29) II = 3
KEEP = PSTMT
PSTMT = 1
IF (TOKLAB(II,K2,KK,.TRUE.)) LAB = .TRUE.
IF (SYSERR) GO TO 450
C
C CHECK FOR MAIN PROGRAM OR OTHER HEADING STMTS
C
IF (NAME) 140, 120, 140
120 IF (IGP) 130, 150, 130
130 CALL SETNAM(12)
GO TO 150
140 IF (IGP.EQ.0) GO TO 490
C
C CHECK SEQUENCING OF STMTS
C
150 IF (BLKD .AND. IGP.GT.3 .AND. ITYP.NE.28) GO TO 160
IF (IGP.GE.KGP) GO TO 170
CALL ERROR1(24H ILLEGAL STMT SEQUENCING, 24)
GO TO 450
160 CALL ERROR1(32H ILLEGAL STMTS IN BLOCK DATA PGM, 32)
GO TO 450
C
C CHECK FOR FIRST ASF DEFN OR EXECUTABLE STMT.
C TO RESET USAGE OF FCN SUBPGM NAME IN SYMBOL TABLE
C
170 IF (EXECUT .OR. IGP.LT.4) GO TO 180
EXECUT = .TRUE.
K = IGATT1(NAME,8)
IF (K.EQ.4) CALL SATT1(NAME, 8, 10)
180 PSTMT = KEEP
LOGIF2 = .FALSE.
C
C VALUES OF ITYP
C 1-5 TYPE STMTS: 1 DP, 2 REAL, 3 INT, 4 COMP, 5 LOG
C 6-8 OTHER SPECIFICATION STMTS: 6 EXTERNAL, 7 DIMENSION
C 8 COMMON
C 9-11 HEADING STMTS: 9 SUBROUTINE, 10 FUNCTION, 11 BLOCK DATA
C 12 EQUIVALENCE
C 13 DATA
C 14-27,30,32 EXECUTABLE STMTS: 14 ASSIGN, 15 GOTO, 16 RETURN,
C 17 CONTINUE, 18 CALL, 19 STOP, 20 IF, 21 DO, 22 PAUSE,
C 23 READ, 24 WRITE, 25 REWIND, 26 ENDFILE, 27 BACKSPACE, 30
C ASSIGNMENT, 32 LOGICAL IF
C 28 END
C 29 FORMAT
C 31 ASF DEFN
C CLASS CODES
C 0-HEADING STMTS
C 1-SPECIFICATION STMTS (INCLUDING TYPE STMTS)
C 2-EQUIVALENCE
C 3-DATA
C 4-ASF DEF
C 5-EXECUTABLE STMTS AND FORMAT STMTS
C 6-END STMT
C
190 GO TO (200, 200, 200, 200, 200, 210, 220, 250, 230, 230, 240,
* 270, 260, 350, 330, 360, 380, 370, 380, 300, 280, 340, 340,
* 340, 340, 340, 340, 410, 390, 290), ITYP
C
C TYPE STMTS (SYSERR)
C
200 CALL TYPE
GO TO 430
C
C EXTERNAL STMT (SYSERR)
C
210 CALL EXTERN
GO TO 430
C
C DIMENSION STMT(SYSERR)
C
220 CALL DIMENS
GO TO 430
C
C SUBR/FCN DEFNS (SYSERR)
C
230 CALL SUBFCN(I)
GO TO 430
C
C BLOCK DATA STMT (SYSERR)
C
240 CALL SETNAM(11)
BLKD = .TRUE.
GO TO 430
C
C COMMON STMT
C
250 CALL COMMON
GO TO 430
260 CALL DATA
GO TO 430
270 CALL EQUIV
GO TO 430
280 CALL DOSTMT
GO TO 430
290 CALL ASSASF(IGP)
IF (IGP.EQ.4 .AND. LOGIF2) GO TO 320
GO TO 430
C
C IF STMTS
C
300 CALL IFS(LOGIF1)
C
C FOUND AN ARITH. IF
C
IF (.NOT.LOGIF1) GO TO 430
C
C FOUND LOGICAL IF WITHIN LOGICAL IF
C
IF (LOGIF1 .AND. LOGIF2) GO TO 320
C
C FOUND A LOGICAL IF; MUS PROCESS REST OFSTMT
C
LOGIF2 = .TRUE.
CALL TYPST(ITYP, K, K2)
IF (.NOT.ERR) GO TO 310
CALL ERROR1(20H UNRECOGNIZABLE STMT, 20)
GO TO 430
310 IF (K.NE.4 .AND. K.NE.5 .OR. ITYP.EQ.21 .OR. ITYP.EQ.29) GO TO 320
PSTMT = PSTMT + K2
GO TO 190
320 CALL ERROR1(27H ILLEGAL STMT IN LOGICAL IF, 27)
GO TO 430
C
C GOTO STMTS
C
330 CALL GOTO
GO TO 430
C
C I-O STMTS
C
340 CALL IO
GO TO 430
C
C ASSIGN STMT
C
350 CALL ASSIGN
GO TO 430
C
C RETURN CANNOT APPEAR IN MAIN PGM
C
360 I = IGATT1(NAME,8)
IF (I.EQ.12) CALL ERROR1(
* 44H RETURN STATEMENT MAY NOT APPEAR IN MAIN PGM, 44)
RET = .TRUE.
GO TO 380
C
C CALL STMT
C
370 CALL CALLS
GO TO 430
C
C CHECK FOR EXTRANEOUS INFO AFTER STOP AND CONTINUE STMTS
C
380 IF (PSTMT.NE.NSTMT) CALL ERROR1(
* 34H EXTRANEOUS INFO AFTER END OF STMT, 34)
GO TO 430
C
C FORMAT
C
390 IF (.NOT.LAB) CALL ERROR1(26H MISSING FORMAT STMT LABEL, 26)
CALL FORMAT
GO TO 430
C
C CODE TO HANDLE END-OF-FILE WITHOUT AN END STMT
C
400 IF (ITYP.EQ.28 .OR. ITYP.EQ.0) GO TO 500
CALL ERROR1(37H WARNING - MISSING END STMT SIMULATED, 37)
LAB = .FALSE.
ITYP = 28
410 CALL END
C
C CHECK FOR NO CONTINUATION
C
IF (NCARD.GT.1) CALL ERROR1(34H END LINE CANNOT HAVE CONTINUATION,
* 34)
C
C CHECK FOR ENDING ON A GOTO,ARITH IF, STOP OR RETURN
C
IF ((LTYP.EQ.16 .OR. LTYP.EQ.15 .OR. LTYP.EQ.19 .OR. LTYP.EQ.20)
* .OR. BLKD) GO TO 420
CALL ERROR1(29H ILLEGAL LAST EXECUTABLE STMT, 29)
C
C CHECK THERE HAVE BEEN EXECUTABLE STMTS
C CHECK FOR A RETURN STMT IF NECESSARY
C
420 IF (KGP.NE.5 .AND. .NOT.BLKD) CALL ERROR1(
* 42H ILLEGAL PROGRAM UNIT, NO EXECUTABLE STMTS, 42)
I = IGATT1(NAME,8)
IF (I.EQ.11 .OR. I.EQ.12 .OR. RET) GO TO 430
CALL ERROR1(36H MISSING RETURN STMT IN PROGRAM UNIT, 36)
C
C CHECK STMT LABELS FOR DOENDINGS, UPDATE KGP, CHECK TABLE SIZE
C CHECK FOR CANCELLING SAVING OF SYMBOL TABLE FOR PASS2
C DUE TO ERRORS IN THIS PGM UNIT
C
430 KGP = IGP
IF (ITYP.NE.29) LTYP = ITYP
IF (LOGIF2) LTYP = 32
IF (SYSERR) GO TO 450
IF (.NOT.LAB) GO TO 440
CALL DOCHK(KK)
IF (ITYP.LT.14 .OR. ITYP.EQ.28 .OR. ITYP.EQ.31) CALL ERROR1(
* 37H WARNING - LABELED NONEXECUTABLE STMT, 37)
440 IF (EOF) GO TO 500
ERR = .FALSE.
IF (ITYP.EQ.28) GO TO 10
GO TO 70
C
C FLUSH CODE TO NEXT HEADR OR END SMT
C
450 CALL ERROR1(44H CODE FLUSHED UNTIL NEXT END OR HEADING STMT, 44)
P1ERR = .TRUE.
IF (SYSERR) SYSERR = .FALSE.
LAB = .FALSE.
460 CALL INSTMT(EOF, NCARD)
IF (EOF) GO TO 500
PSTMT = 6
CALL TYPST(ITYP, IGP, ICNT)
IF (.NOT.ERR) GO TO 470
ERR = .FALSE.
GO TO 460
470 IF (ITYP.EQ.28) GO TO 410
IF (ITYP.GT.5) GO TO 480
PSTMT = PSTMT + ICNT
CALL TYPST(ITYP, IGP, ICNT)
IF (ERR) ERR = .FALSE.
IF (ITYP.EQ.10) GO TO 490
GO TO 460
480 IF (ITYP.LT.9 .OR. ITYP.GT.11) GO TO 460
C
C HAVE FOUND A HEADER STMT; SIMULATE AN END STMT
C
490 NEW = .TRUE.
CALL ERROR1(37H WARNING - MISSING END STMT SIMULATED, 37)
ITYP = 28
LAB = .FALSE.
GO TO 410
C
C PUT ENDING MARKER ON THE DATA FOR PASS2
C
500 I = 1
II = 4
WRITE (OUTUT3) I, II, I
WRITE (OUTUT2) I, II, I
RETURN
END
C XXXXXCOMCHK.f
SUBROUTINE COMCHK(MAIN)
INTEGER TEMP(1), PLAT, STAR, PCOM, COM, PNODE, SYMLEN
INTEGER ZERO(1)
COMMON /COMS/ LCOM, PCOM, COM(300)
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
COMMON /HEAD/ LNODE, PNODE, NODE(500)
COMMON /SCR2/ LNN, NN(500)
DATA STAR /1H*/
DATA ZERO(1) /0/
C
C ALGORITHM TO CHECK FOR LEGAL USE OF COMMON IN PGM UNITS
C NODE(MAIN) POINTS TO SUPEROOT ENTRY IN LAT
C
IF (PCOM.LE.0) GO TO 130
LK = 1
10 IF (LK.GE.PCOM-1) GO TO 130
C
C CHECK COMMON ISNT BLANK COMMON
C
CALL S5UNPK(COM(LK), TEMP, 1)
IF (TEMP(1).EQ.STAR) GO TO 120
C
C CHECK THAT COMMON BLOCK NOT IN BLOCK DATA PGM
C NEED NOT CHECK THE COMMON
C
K = LK + SYMLEN + 1
IF (COM(K).EQ.1) GO TO 120
C
C NEED ALGORITHM TO CHECK OUT THIS COMMON
C
L = PNODE - 1
DO 20 K=1,L
NN(K) = 0
IF (NODE(K).LT.0) NN(K) = 1
20 CONTINUE
ICNT = 0
NN(MAIN) = 2
C
C SEARCH FOR A 2 NODE
C
30 L = PNODE - 1
DO 40 K=1,L
IF (NN(K).EQ.2) GO TO 50
40 CONTINUE
GO TO 120
C
C FOUND A 2 NODE; CHANGE TO 1 TO SHOW HAVE VISITED IT;
C IF SUBPGM CONTAINS COMMON IN QUESTION INCREMENT COUNT;
C IF COUNT> 1 ERROR IN USAGE
C IF SUBPGM DOESN'T CONTAIN COMMON, MARK HIS DESC 2 IF THEY ARE 0.
C
50 NN(K) = 1
LBR = NODE(K)
L = NODE(K) + SYMLEN + 2
L = LAT(L)
60 IF (L.EQ.0) GO TO 90
IF (LAT(L).NE.LK) GO TO 80
C
C FOUND COMMON LK AT THIS NODE
C MARK NODE TO A 3
C
NN(K) = 3
ICNT = ICNT + 1
IF (ICNT.LE.1) GO TO 30
CALL ERROR2(31H ILLEGAL USAGE OF COMMON BLOCK , 31, COM(LK),
* 1, 1, 0)
K = PNODE - 1
DO 70 I=1,K
L = NODE(I)
IF (NN(I).EQ.3) CALL ERROR2(19H WHICH APPEARED IN , 19, LAT(L),
* 1, 0, 0)
70 CONTINUE
CALL ERROR2( 1H1, 0, ZERO(1), -3, 0, 1)
GO TO 120
80 L = LAT(L+2)
GO TO 60
C
C ARE DONE SEARCHING FOR COMMON LK AT THIS NODE
C ADD DESCENDENTS ONTO LIST TO BE VISITED
C
90 L = NODE(K) + SYMLEN + 4
L = LAT(L)
100 IF (L.EQ.0) GO TO 30
K = PNODE - 1
C
C FIND DESC OF NODE AND IF NOT VISITED SET TO 2
C
DO 110 I=1,K
IF (NODE(I).NE.LAT(L)) GO TO 110
IF (NN(I).EQ.0) NN(I) = 2
110 CONTINUE
L = LAT(L+1)
GO TO 100
120 LK = LK + SYMLEN + 5
GO TO 10
130 RETURN
END
C XXXXXCOMPAR.f
LOGICAL FUNCTION COMPAR(A, B)
INTEGER SYMLEN, A(2), B(2)
COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
C
C ROUTINE TESTS TWO IDENTIFIERS FOR SAMENESS; RETURNS TRUE IF
C SAME, ELSE FALSE
C
DO 10 I=1,SYMLEN
IF (A(I).NE.B(I)) GO TO 30
10 CONTINUE
COMPAR = .TRUE.
20 RETURN
30 COMPAR = .FALSE.
GO TO 20
END
C XXXXXFINDND.f
INTEGER FUNCTION FINDND(K1, K2)
INTEGER K1(2)
INTEGER PLAT, PNODE
LOGICAL COMPAR
COMMON /HEAD/ LNODE, PNODE, NODE(500)
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
C
C FINDS SUBPROGRAM WHOSE PACKED NAME IS IN K1(2) AND
C RETURNS INDEX OF ITS LAT ENTRY AS VALUE OF FINFND
C RETURNS IN K2 INDEX IN NODE OF LAT INDEX
C IGNORES ASF NODES IN LAT BY IGNORING NEGATIVE NODE
C ENTRIES
C
IF (PNODE-1) 40, 40, 10
10 K = PNODE - 1
DO 30 I=1,K
IF (NODE(I)) 30, 30, 20
20 FINDND = NODE(I)
K2 = I
IF (COMPAR(LAT(FINDND),K1)) GO TO 50
30 CONTINUE
40 FINDND = 0
50 RETURN
END
C XXXXXFINDCM.f
INTEGER FUNCTION FINDCM(K1)
INTEGER K1(2)
INTEGER PCOM, COM, SYMLEN
LOGICAL COMPAR
COMMON /COMS/ LCOM, PCOM, COM(300)
COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
C
C ROUTINE FINDS COMMON BLOCK WHOSE NAME IS AT K1 IN COM
C RETURNS INDEX IN COM OR 0 IF CANNOT FIND IT
C
IF (PCOM-1) 30, 30, 10
10 K = PCOM - 1
KK = SYMLEN + 5
DO 20 I=1,K,KK
FINDCM = I
IF (COMPAR(COM(I),K1)) GO TO 40
20 CONTINUE
30 FINDCM = 0
40 RETURN
END
C XXXXXINREF.f
INTEGER FUNCTION INREF(IDUM)
INTEGER REF, PREF
COMMON /CREF/ LREF, PREF, REF(100)
C
C ROUTINE TO INPUT CALL TEMPLATES, RETURNS -1 FOR EOF, 0 FOR END
C OF REFS FOR THIS PGM UNIT, AND 1 FOR REF RETRIEVED
C
READ (IDUM) PREF, K, (REF(L),L=1,PREF)
IF (K-3) 10, 30, 40
10 INREF = 1
20 RETURN
30 INREF = 0
GO TO 20
40 INREF = -1
GO TO 20
END
C XXXXXINSYM.f
LOGICAL FUNCTION INSYM(IDUM,II)
INTEGER OUTUT, OUTUT2, OUTUT3, SYMHD, PDSA, SYMLEN, DSA, BNEXT
COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, OUTUT2, OUTUT3, I1
COMMON /TABL/ NEXT, LABHD, SYMHD, BNEXT
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
C
C ROUTINE TO INPUT SYMBOL TABLE; RETURNS TRUE FOR SUCCESSFUL, ELSE
C FALSE. KCODE=1 FOR TABLE, 3 FOR DUMMY TABLE, 4 FOR EOF
C DUMMY TABLE CAUSES REFS FOR THIS PU TO BE FLUSHED IF
C IDUM NE 0
C
5 READ(OUTUT2) PDSA, KCODE, (DSA(I),I=1,PDSA)
IF (KCODE-3) 10, 40, 30
10 NAME = DSA(PDSA-2)
SYMHD = DSA(PDSA-1)
LABHD = DSA(PDSA)
PDSA = PDSA - 3
INSYM = .TRUE.
20 RETURN
30 INSYM = .FALSE.
GO TO 20
C FLUSH REFS FOR DUMMY TABLE IF IDUM NONZERO
40 IF(IDUM.EQ.0) GOTO 5
50 IF(INREF(IDUM)) 60, 60, 50
C WRITE END OF REFS FOR DUMMY REFS IF II NE 0; ELSE GOT TO
C NEXT SYMBOL TABLE
60 IF(II.EQ.0) GOTO 5
L = 1
K = 3
WRITE(II) L,K,L
GOTO 5
END
C XXXXXMATCH.f
INTEGER FUNCTION MATCH(HEAD, INCR, N)
INTEGER PLAT, HEAD
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
C
C ROUTINE READS DOEN A LINEAR LINKED LIST IN LAT TO FIND ENTRY
C WHOSE FIRST WORD CONTAINS N; EACH LIST ELEMENT IS INCR+1 LONG;
C HEAD IS POINTER TO FIRST LIST ELEMENT
C RETURNS 0 FOR NO MATCH ON LIST OR THE EMPTY LIST
C
IF (HEAD) 40, 40, 10
10 MATCH = HEAD
20 IF (LAT(MATCH).EQ.N) GO TO 50
MATCH = MATCH + INCR
IF (LAT(MATCH)) 40, 40, 30
30 MATCH = LAT(MATCH)
GO TO 20
40 MATCH = 0
50 RETURN
END
C XXXXXMKCOM.f
SUBROUTINE MKCOM(PP, K)
INTEGER PLAT, PDSA, FINDCM, DSA, SYMLEN, PP, PCOM, COM
LOGICAL SYSERR, ERR, ABORT
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /COMS/ LCOM, PCOM, COM(300)
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
C
C WANT TO MARK COMMONLIST ENTRY SET FOR SUBPGM PP; MAY HAVE TO
C CREATE ENTRY
C
N = FINDCM(DSA(K+4))
L = SYMLEN + 2 + PP
KK = -K
IF (N.NE.0) KK = N
C
C LOOK FOR DSA ENTRY ON LIST
C
I = MATCH(LAT(L),2,KK)
IF (I) 30, 30, 10
10 LAT(I+1) = 1
20 RETURN
C
C CREATE NEW ENTRY
C
30 IF (PLAT+3.GT.LLAT) GO TO 40
LAT(PLAT+1) = 1
LAT(PLAT+2) = LAT(L)
LAT(L) = PLAT
LAT(PLAT) = KK
PLAT = PLAT + 3
GO TO 20
40 SYSERR = .TRUE.
CALL ERROR1(32H IN MKCOM, TABLE OVERFLOW OF LAT, 32)
GO TO 20
END
C XXXXXOUTCOM.f
INTEGER FUNCTION OUTCOM(IH, L)
INTEGER STACK,PLAT
LOGICAL ERR, SYSERR, ABORT
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /CEXPRS/ LSTACK, STACK(620)
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
C
C READS DOWN COM LIST OF PU NODE, PUTS INDICES OF ENTRIES
C IN STACK. IH IS HEAD OF LIST, L RETURNS NO OF ENTRIES
C
OUTCOM = 0
IF (IH) 40, 40, 10
10 L = 1
K = IH
20 IF (L+1.GT.LSTACK) GOTO 50
STACK(L) = LAT(K)
IF (LAT(K+1).EQ.1) STACK(L) = -STACK(L)
L = L + 1
K = LAT(K+2)
IF (K) 30, 30, 20
30 L = L - 1
IF(L.GT.0) OUTCOM=1
40 RETURN
50 SYSERR = .TRUE.
CALL ERROR1(35H IN OUTCOM, TABLE OVERFLOW OF STACK, 35)
GO TO 40
END
C XXXXXOUTLAT.f
INTEGER FUNCTION OUTLAT(IH, L, ISR)
INTEGER STACK, PLAT
LOGICAL ERR, SYSERR, ABORT
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /CEXPRS/ LSTACK, STACK(620)
INTEGER SYMLEN
COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
C
C IH POINTS TO A PARENTS OR DESCS LIST IN LAT; L IS NUM
C OF ELEMENTS FOUND ON LIST; ISR IS ENTRY IN LAT OF
C SUPERROOT
C
C
OUTLAT = 0
IF (IH) 50, 50, 10
10 K = IH
L = 1
20 M = LAT(K)
C SKIP OVER CALLS TO ASFS AND OVER SUPEROOT
IF(MOD(IGATT2(M+SYMLEN+6,1),8).EQ.4 .OR. M.EQ.ISR) GOTO 30
IF(L+1.GT.LSTACK) GOTO 60
STACK(L) = M
L = L + 1
30 K = LAT(K+1)
IF (K) 40, 40, 20
40 L = L - 1
IF (L.GT.0) OUTLAT = 1
50 RETURN
60 CALL ERROR1(35H IN OUTLAT, TABLE OVERFLOW OF STACK, 35)
SYSERR = .TRUE.
GO TO 50
END
C XXXXXOUT2A.f
SUBROUTINE OUT2A( IT, JJ, N, ISW )
C
C IT CONTINAS TITLE FOR FIRST LINE OF OUTPUT
C JJ CONTAINS NUMBER OF CHARS IN TITLE, J<=25
C N CONTAINS NUMBER OF ELEMENTS TO BE PRINTED
C ISW TELLS IF THESE ARE COMMON NAMES OR PROC NAMES
C
INTEGER IT(25), II(25), BL, PLAT, PCOM, COM, STACK, OUTUT, S
INTEGER BUF(54)
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /PARAMS/ II1, OUTUT, II2, II3, II4, II5, II6
COMMON /CEXPRS/ LSTACK, STACK(620)
COMMON /COMS/ LCOM, PCOM, COM(300)
DATA BL/1H /,S/1HS/
C
C UNPACK TITLE
C
NN = JJ
IF(JJ.GT.25) NN=25
CALL S5UNPK( IT(1), II(1), NN)
K1 = NN + 1
IF(K1.GT.25) GOTO 15
DO 10 K =K1, 25
II(K) = BL
10 CONTINUE
C
C SETUP FIRST LINE OF ELEMENTS
C
15 K = 6
IF (K.GT.N) K = N
IB = 1
DO 50 I = 1, K
IL = STACK(I)
GOTO (20, 30),ISW
C FOR PARE OR DESC LISTS
20 CALL S5UNPK( LAT(IL), BUF(IB), 6 )
BUF(IB + 7) = BL
GOTO 40
C FOR COMMON LISTS- INDEX TO ELEMENTS IS NEGATIVE
C IF COMMON IS SET BY PGM UNIT
30 BUF(IB + 7) = BL
IF(IL.LT.0) BUF(IB + 7) = S
IL = IABS(IL)
CALL S5UNPK( COM(IL), BUF(IB), 6 )
40 BUF(IB + 6) = BL
BUF(IB + 8) = BL
IB = IB + 9
50 CONTINUE
IB = IB - 1
WRITE(OUTUT,99999) (II(L),L=1,25), (BUF(I),I=1,IB)
99999 FORMAT(80A1)
IF(K.EQ.N) GOTO 110
C WRITE SUBSEQUENT LINES
60 IB = 1
K1 = K + 1
K = K + 6
IF (K.GT.N) K = N
DO 100 I = K1, K
IL = STACK(I)
GOTO (70, 80), ISW
C FOR PAR OR DESC LISTS
70 CALL S5UNPK( LAT(IL), BUF(IB), 6 )
BUF(IB + 7) = BL
GOTO 90
C FOR COMMON LISTS
80 BUF(IB + 7) = BL
IF(IL.LT.0) BUF(IB + 7) = S
IL = IABS(IL)
CALL S5UNPK( COM(IL), BUF(IB), 6 )
90 BUF(IB + 6) = BL
BUF(IB +8) = BL
IB = IB + 9
100 CONTINUE
IB = IB - 1
WRITE(OUTUT,99998) (BUF(I),I =1,IB)
99998 FORMAT(25X,55A1)
IF(K.LT.N) GOTO 60
110 RETURN
END
C XXXXXOUT2C.f
SUBROUTINE OUT2C
INTEGER COM, PCOM, STACK, BL, SYMLEN, OUTUT, S, PLAT
EXTERNAL EXCH
COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, I1, I2, I3
COMMON /COMS/ LCOM, PCOM, COM(300)
COMMON /CEXPRS/ LSTACK, STACK(620)
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /SCR2/ LICOM, ICOM(500)
DATA BL /1H /, S /1HS/
C
C PRINTS COM ARRAY
C
IF (PCOM-1) 80, 80, 10
10 K1 = SYMLEN + 5
K = 1
LCOMS = (PCOM-1)/(SYMLEN+5)
DO 20 I=1,LCOMS
ICOM(I) = K
K = K + K1
20 CONTINUE
CALL SSORT(EXCH, COM, LCOM, ICOM, LCOMS, 0)
WRITE (OUTUT,99999)
99999 FORMAT (///14H1COMMON BLOCKS///1X, 4HNAME, 3X, 3HSET, 1X,
* 18H DP,COM INT,RL,LOG//)
DO 70 IBR=1,LCOMS
I = ICOM(IBR)
CALL S5UNPK(COM(I), STACK(1), 6)
DO 30 L=1,3
II = I + SYMLEN + L
KK = 7 + L
STACK(KK) = COM(II)
30 CONTINUE
IF (STACK(8)) 40, 40, 50
40 STACK(8) = BL
GO TO 60
50 STACK(8) = S
60 WRITE (OUTUT,99998) (STACK(II),II=1,6), STACK(8),
* (STACK(II),II=9,10)
99998 FORMAT (1X, 6A1, 3X, A1, I8, 3X, I8)
70 CONTINUE
80 RETURN
END
C XXXXXSCAN.f
SUBROUTINE SCAN(MAINND)
INTEGER PLAT, SYMLEN, PNODE, STACK
LOGICAL ERR, SYSERR, ABORT
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
COMMON /CEXPRS/ LSTACK, STACK(620)
COMMON /HEAD/ LNODE, PNODE, NODE(500)
COMMON/ SCR1/ LINODE, INODE(500)
COMMON /SCR2/ LICOM, ICOM(500)
C
C SUBROUTINE PERCOLATES SETTING INFO ABOUT ARGUMENTS AND COMMON
C UP THE LATTICE---IN ORDER THAT UNSAFE REFS CAN BE CHECKED
C
C
C STACK(1)-(LSTACK) KEEPS TRACK OF PATH FROM CURRENT TERMINAL NODE
C TO SUPEROOT NODE
C INODE(J) IS 0 IF A NODE IS UNVISITED SO FAR ON ALL PATHS
C 1 IF A NODE HAS BEEN VISITED ON AT LEAST ONE PATH
C SYSERR IS SET BY SCAN
C
DO 10 I=1,PNODE
INODE(I) = 0
10 CONTINUE
INODE(MAINND) = 1
MAIN = NODE(MAINND)
NUM = 0
C
C CYCLE THROUGH ALL TERMINAL NODES
C
20 NUM = NUM + 1
IF (NUM.GT.PNODE-1) GO TO 240
C
C CHECK IF AN NODE IS ASF OR IF IT HAS DESC
C OR IF IT HAS NO PARENTS
C
IF (NODE(NUM).LE.0) GO TO 20
I = NODE(NUM) + SYMLEN + 4
C
C NO PARENTS
C
IF (LAT(I-1).EQ.0) GO TO 20
C
C TEST DESC FOR BEING ALL ASFS
C
IF (LAT(I).EQ.0) GO TO 40
L = LAT(I)
30 K = LAT(L) + SYMLEN + 6
IF (MOD(LAT(K),8).NE.4) GO TO 20
L = LAT(I+1)
IF (L) 40, 40, 30
C
C HAVE A TERMINAL NODE;NOW CAN START RECURSIVE TRAVERSE OF ALL
C PATHS UPWARDS FROM IT TO ROOT
C ILEN--POINTER TO TOP OF CURRENT PATH
C JNODE--CURRENT NODE
C
40 INODE(NUM) = 1
ILEN = 2
STACK(2) = NODE(NUM)
STACK(1) = 0
C
C STACK ENTRY IS 1ST WORD-POINTER TO NODE ON LIST OF PARS OFPREV
C NODE; 2ND WORD-NODE INDEX
C PROCESS NODE
C 1. CHECK EACH ARG. IF NOT SET OR IF PARENTS ARGLINKS NONEXISTANT
C SKIP TO NEXT ARG (IF NO ARGS GOTO 2); ELSE MARK EACH PARENT
C ARGLIST ENTRY AS SET FOR A SET ARG.
C 2. ADD EACH COMMON REGION TO PARENTS' LIST OF COMMON REGIONS
C 3. GET NEW NODE
C
50 J = STACK(ILEN) + SYMLEN + 1
C
C ARG PROCESSING
C
J = LAT(J)
60 IF (J.EQ.0) GO TO 90
I = IGATT2(J,5)
IF (I.NE.1 .OR. LAT(J+2).EQ.0) GO TO 80
L = LAT(J+2)
70 IF (L.EQ.0) GO TO 80
C
C SET PARENT ARGS
C
CALL SATT2(LAT(L), 5, 1)
L = LAT(L+1)
GO TO 70
C
C GO ON TO NEXT ARG
C
80 J = LAT(J+3)
GO TO 60
C
C COMMON PROCESSING
C
90 J = STACK(ILEN) + SYMLEN + 2
II = 0
J = LAT(J)
C
C ACCUMULATE COMMON REGIONS
C
100 IF (J.EQ.0) GO TO 110
ICOM(II+1) = LAT(J)
IF (LAT(J+1).NE.0) ICOM(II+1) = -ICOM(II+1)
II = II + 1
J = LAT(J+2)
GO TO 100
110 IF (II.EQ.0) GO TO 150
C
C GET PARENT NODE AND ADD COMMON REGIONS TO IT
C
K = STACK(ILEN) + SYMLEN + 3
K = LAT(K)
120 L = LAT(K) + SYMLEN + 2
DO 140 I=1,II
LL = MATCH(LAT(L),2,IABS(ICOM(I)))
IF (LL.EQ.0) GO TO 130
IF (ICOM(I).LT.0) LAT(LL+1) = 1
GO TO 140
C
C COPY COMMONNODE ENTRIES ONTO PARENTS LIST
C
130 IF (PLAT+3.GT.LLAT) GO TO 270
LAT(PLAT+2) = LAT(L)
LAT(PLAT+1) = 0
LAT(PLAT) = IABS(ICOM(I))
IF (ICOM(I).LT.0) LAT(PLAT+1) = 1
LAT(L) = PLAT
PLAT = PLAT + 3
140 CONTINUE
C
C GOONTO NEW PARENT
C
K = LAT(K+1)
IF (K.NE.0) GO TO 120
C
C FIND A PARENT OF THIS NODE AND TRY TO VISIT IT NEXT
C I CONTAINS POINTER TO PARENT LIST POSITION OF THE PARENT;
C J CONTAINS PARENTS INDEX IN LAT
C IF NO MORE PARENTS, MUST BACKUP A LEVEL
C
150 I = STACK(ILEN) + SYMLEN + 3
160 IF (LAT(I).EQ.0) GO TO 200
I = LAT(I)
170 J = LAT(I)
C
C CHECK THAT NEW ENTRY HAS PARENTS
C AND THAT IT IS NOT THE SUPEROOT
C
K = J + SYMLEN + 3
IF (LAT(K).GT.0) GO TO 210
C
C IF THIS PARENT UNACCEPTIBLE GO ONTO NEXT PARENT
C MARK UNACCEPTIBLE AS VISITED SO WONT BE RECURSIVE
C
LL = PNODE - 1
DO 180 L=1,LL
IF (J.NE.NODE(L)) GO TO 180
INODE(L) = 1
GO TO 190
180 CONTINUE
190 I = I + 1
GO TO 160
C
C MUST BACK DOWN THE PATH TO THE NEXT JUNCTURE WITH
C AN UNTRIED PATH; CHECK FIRST FOR DONE WITH ENTIRE PATH
C
200 IF (STACK(ILEN-1).EQ.0) GO TO 20
ILEN = ILEN - 2
J = STACK(ILEN+1)
IF (LAT(J+1).EQ.0) GO TO 200
C
C FOUND AN UNTRIED PATH ON THE STACK
C
I = LAT(J+1)
GO TO 170
C
C MARK ENTRY AS VISITED
C
210 LL = PNODE - 1
DO 220 L=1,LL
IF (J.NE.NODE(L)) GO TO 220
INODE(L) = 1
GO TO 230
220 CONTINUE
C
C ENTER ON STACK
C
230 IF (ILEN+2.GT.LSTACK) GO TO 260
STACK(ILEN+1) = I
STACK(ILEN+2) = J
ILEN = ILEN + 2
GO TO 50
240 RETURN
250 SYSERR = .TRUE.
GO TO 240
260 CALL ERROR1(33H IN SCAN, TABLE OVERFLOW OF STACK, 33)
GO TO 250
270 CALL ERROR1(31H IN SCAN, TABLE OVERFLOW OF LAT, 31)
GO TO 250
END
C XXXXXSETARG.f
INTEGER FUNCTION SETARG(PP, N)
INTEGER PLAT, DSA, PP, SYMLEN, PDSA
LOGICAL ERR, SYSERR, ABORT
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
C
C SETS UP LIST OF ARGUMENTS , HANGING OFF NODE AT LAT(PP)
C ARGES ARE KEPT IN ORDERED LINEAR LINKED LIST
C ORDERING CORRESPONDS TO LEFT TO RIGHT APPEARENCE IN DEFN
C N-SUBPRGM ENTRY IN DSA
C PP- CURRENT RTNE NODE IN LAT
C ARGUMENT NODE
C WD 1 ATTRIBUTES
C WD2 LENGTH WITH -1 FOR VARIABLEY DIMENSIONED ARRAYS
C WD3 HEAD OF PARENT REFS LIST
C WD4 HEAD OF DESCENDENTS REFS LIST
C WD5 PTR TO NEXT ARG
C
C FIND FIRST ARGUMENT & ZERO COUNT
C
J = DSA(N+2)
SETARG = 0
IPROC = 0
C
C FIND FIRST ENTRY ON DSA ARGLIST;
C KK HEAD OF TO BE CREATED ARGLIST IN LAT
C
I = DSA(J)
KK = PP + SYMLEN + 1
C
C SETUP STORAGE FOR ARG ENTRY
C
10 IF (PLAT+4.GE.LLAT) GO TO 80
C
C ENTER ATTRIBUTE WORD AND ZERO REST OF ENTRY
C
LAT(PLAT) = DSA(I)
LAT(KK) = PLAT
KK = PLAT + 3
DO 20 IA=1,3
L = IA + PLAT
LAT(L) = 0
20 CONTINUE
K = IGATT1(I,8)
IF (K.NE.10) GO TO 50
C
C GET STRUCTURE OF ARG
C
K = IGATT1(I,7)
IF (K) 40, 40, 30
C
C ARRAY
C
30 K = DSA(I+2)
LAT(PLAT+1) = DSA(K)
GO TO 60
C
C SCALAR
C
40 LAT(PLAT+1) = 1
GO TO 60
C SET RELATIVE ORDER OF PROC ARGS IN ITS 2ND WORD
50 IPROC = IPROC + 1
LAT(PLAT+1) = IPROC
C
C CHECK FOR MORE ARGS; ADVANCE PLAT
C
60 PLAT = PLAT + 4
SETARG = SETARG + 1
IF (DSA(J+1)) 90, 90, 70
70 J = DSA(J+1)
I = DSA(J)
GO TO 10
80 SYSERR = .TRUE.
CALL ERROR1(33H IN SETARG, TABLE OVERFLOW OF LAT, 33)
90 RETURN
END
C XXXXXSETASF.f
SUBROUTINE SETASF(PP, K)
INTEGER PP, SYMLEN, PLAT, PDSA, SETARG, PNODE, DSA
LOGICAL ERR, SYSERR, ABORT
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /HEAD/ LNODE, PNODE, NODE(500)
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
COMMON /DETECT/ ERR, SYSERR, ABORT
C
C SETUP ASF NODE; IT HAS A NODE JUST LIKE A RTNE
C EXCEPT ITS INDEX IN NODE IS NEGATIVE
C PP-COM ADDRESS OF PARENT SUBPGM
C K-DSA ADDRESS OF ASF ENTRY
C
IF (PNODE+1.GT.LNODE) GO TO 40
IF (PLAT+SYMLEN+11.GT.LLAT) GO TO 60
C
C CREATE NEW NODE ENTRY
C
NODE(PNODE) = -PLAT
PNODE = PNODE + 1
C
C ENTER NAME AND ZERO REST OF NODE
C
DO 10 I=1,SYMLEN
L = K + 3 + I
LL = PLAT + I - 1
LAT(LL) = DSA(L)
10 CONTINUE
DO 20 I=1,6
L = LL + I
LAT(L) = 0
20 CONTINUE
C
C SET LAST ELEMENT TO TYPE OF PGM UNIT
C STORE IN SAME WORD ASF TYPE
C
I = IGATT1(K,1)
LAT(L+1) = 4 + 8*MOD(I,8)
C
C SETUP PARENT'S LIST TO POINT TO PP IN ASF NODE
C
L = PLAT + SYMLEN + 3
LAT(L) = L + 4
LAT(L+4) = PP
LAT(L+5) = 0
KQ = PLAT
PLAT = L + 6
C
C SETUP REFERENCE IN PP'S DESCENDENTS LIST
C
II = PP + SYMLEN + 4
LAT(PLAT) = KQ
LAT(PLAT+1) = LAT(II)
LAT(II) = PLAT
PLAT = PLAT + 2
C
C SETUP ARGUMENTS
C
L = KQ + SYMLEN
LAT(L) = SETARG(KQ,K)
30 RETURN
40 CALL ERROR1(34H IN SETASF, TABLE OVERFLOW OF NODE, 34)
50 SYSERR = .TRUE.
GO TO 30
60 CALL ERROR1(33H IN SETASF, TABLE OVERFLOW OF LAT, 33)
GO TO 50
END
C XXXXXSETCOM.f
SUBROUTINE SETCOM(PP, K)
LOGICAL SYSERR, ERR, ABORT, BLANK
INTEGER PLAT, DSA, SYMLEN, PP, PDSA, COM, PCOM, R(5), S(3),
* FINDND, ST, SS(1), FINDCM
INTEGER ZERO(1)
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
COMMON /COMS/ LCOM, PCOM, COM(300)
C
C COM ENTRY
C WORD 1.....PACKED CHARACTERS OF COMMON-NAME
C WORD 2....TOTAL LENGTH OF COMMON BLOCK
C WORD 3.....1 IF COMMON INITIALIZED BY BLOCK DATA SUBPGM
C 0 IF NOT
C WORDS 4-8...TOTAL LENGTHS OF COMPLEX, DOUBLE PRECIS,
C REAL, INTEGER, LOGICAL DATA TYPES RESPECTIVELY
C WORD 9.....INDEX IN LAT OF ENTRY OF P.U. WHICH CONTAINS
C THIS DEFN OF THE COMMON BLOCK
C
C FINDS COMMON BLOCK ENTRY IN COM- ELSE CREATES AND INITIALIZES NEW
C ENTRY. CHECKS NEW ENTRY BLOCK NOT ALREADY A SUBPGM NAME.
C GATHERS INFO ON ORDER, TYPE, LENGTH OF ENTRIES IN THE COMMON-
C CHECKS FOR VARIABLY DIMENSIONED ARRAYS.
C FORMS COMMONLIST ENTRY FOR BLOCK OFF SUBPGM AT LAT(PP)
C IF FOUND COMMON IN COM, COMPARES OLD DEFN TO NEW FOR ORDER, LEN,
C TYPE OF ENTRIES; FLAGS INCONSISTENCIES; NOTES IF COMMON IN
C TWO BLOCK DATA PGMS. COMMON IS AT DSA(K)
C
DATA R(1), R(4) /2*1/, R(2), R(3), R(5) /3*2/, ST /1H*/
DATA ZERO(1) /0/
C
C CHECK ISNT IN NODE AS PROCEDURE NAME
C
IF (FINDND(DSA(K+4),KK)) 20, 20, 10
10 CALL ERROR2(41H COMMON BLOCK HAS SAME NAME AS SUBPROGRAM, 41,
* DSA(K+4), 1, 1, 1)
C
C CHECK IF IN COM ALREADY
C
20 KK = FINDCM(DSA(K+4))
IF (KK) 30, 30, 60
C
C CREATE NEW ENTRY
C
30 IF (PCOM+SYMLEN+5.GT.LCOM) GO TO 260
DO 40 I=1,SYMLEN
L = PCOM + I - 1
LL = K + I + 3
COM(L) = DSA(LL)
40 CONTINUE
C
C MARK COMMON SET WHEN IT IS CREATED BY A BLOCK-DATA
C SUBPROGRAM WHICH SET IT
C
DO 50 I=1,4
LL = L + I
COM(LL) = 0
50 CONTINUE
COM(LL+1) = PP
IF (IGATT1(NAME,8).EQ.11 .AND. IGATT1(K,2).EQ.1) COM(L+2) = 1
KK = PCOM
PCOM = PCOM + SYMLEN + 5
C
C GATHER INFO ABT LENGTH,TYPE,ORDER OF ELEMENTS
C
60 L = 0
S(1) = 0
S(2) = 0
S(3) = 0
I = DSA(K+2)
70 IF (I) 130, 130, 80
C
C READING LIST OF ELEMENTS IN COMMON-CHECK TYPE,STRUCTURE
C
80 K1 = IGATT1(DSA(I),1)
K2 = IGATT1(DSA(I),7)
K1 = MOD(K1,8)
IF (K1.EQ.5) K1 = 2
C
C R(I) CONTAINS PROPER ORDER OF TYPE I IN DEFN OF COMMON
C
LL = R(K1+1)
IF (LL.LT.L) GO TO 120
IF (K2) 90, 90, 100
90 S(LL) = S(LL) + 1
GO TO 110
100 K2 = DSA(I)
K2 = DSA(K2+2)
S(LL) = S(LL) + DSA(K2)
110 I = DSA(I+1)
L = LL
GO TO 70
C
C ACCUMULATE COUNTS OF TYPES-NOTE TYPES OUT OF ORDER CAUSES
C TRUNCATION OF THE DEFINITION
C
120 CALL ERROR2(41H ILLEGAL ORDERING OF DATA-TYPES IN COMMON, 41,
* COM(KK), 1, 1, 0)
CALL ERROR2(1H1, 0, ZERO(1), -1, 0, 1)
130 S(3) = S(1) + S(2)
C
C HANG COMMONLIST ENTRY OFF PP NODE, IF NOT ALREADY THERE FROM SET
C
L = PP + SYMLEN + 2
I = MATCH(LAT(L),2,-K)
IF (I.GT.0) GO TO 140
I = MATCH(LAT(L),2,KK)
IF (I.LE.0) GO TO 150
140 LAT(I) = KK
GO TO 160
C
C CREATE NEW ENTRY
C
150 IF (PLAT+3.GT.LLAT) GO TO 280
LAT(PLAT) = KK
LAT(PLAT+1) = 0
LAT(PLAT+2) = LAT(L)
LAT(L) = PLAT
PLAT = PLAT + 3
160 I = KK + SYMLEN
IF (COM(I)) 170, 170, 190
C
C NEW DEFN
C
170 COM(I) = S(3)
COM(I+2) = S(1)
COM(I+3) = S(2)
180 RETURN
C
C COMPARE LENGTHS OF EACH TYPE
C
190 L = KK + SYMLEN + 2
BLANK = .FALSE.
CALL S5UNPK(COM(KK), SS(1), 1)
IF (SS(1).EQ.ST) BLANK = .TRUE.
IBR = 0
IF (COM(L+1).NE.S(2)) IBR = 1
IF (COM(L).NE.S(1)) IBR = -1
C BLANK COMMON DEFNS MATCH
IF (IBR.EQ.0 .AND. BLANK) GO TO 180
C NAMED COMMON DEFNS MATCH
IF (IBR.EQ.0 .AND. .NOT.BLANK) GO TO 210
C BLANK COMMON DONT MATCH
IF (IBR.NE.0 .AND. BLANK) GO TO 230
C NAMED COMMONS DONT MATCH -- ERROR
200 CALL ERROR2(25H INCOMPATIBLE COMMON DEFN, 25, COM(KK), 1, 1,
* 0)
K1 = KK + SYMLEN + 4
K1 = COM(K1)
CALL ERROR2(3H IN, 3, LAT(K1), 1, 0, 0)
CALL ERROR2(4H AND, 4, LAT(PP), 1, 0, 1)
IF (BLANK) GO TO 180
C
C CHECK DOUBLE SETTING OF BLOCK
C
210 IF (IGATT1(K,2).NE.1 .OR. IGATT1(NAME,8).NE.11) GO TO 180
IF (COM(L-1).NE.1) GO TO 220
CALL ERROR2(
* 53H COMMON BLOCK INITIALIZED IN TWO BLOCK DATA SUBPGMS , 53,
* COM(KK), 1, 1, 1)
GO TO 180
220 COM(L-1) = 1
GO TO 180
C
C CHECK ARE LENGTHENING BLANK COMMON OFF THE END
C
230 IF(IBR.EQ.(-1)) GOTO 250
C ARE LENGTHENING OFF END
C KEEP LONGEST DEFN
IF (COM(L+1).GT.S(2)) GO TO 180
240 COM(L+1) = S(2)
LL = SYMLEN + KK
COM(LL) = S(3)
COM(LL+4) = PP
GO TO 180
C SEE ARE REALLY LENGTHENING OFF END IF
C DEFNS DIFFER IN FIRST DATA TYPE AREAS
250 IF (S(1).LT.COM(L) .AND. S(2).EQ.0) GO TO 180
IF (.NOT.(S(1).GT.COM(L) .AND. COM(L+1).EQ.0)) GO TO 200
COM(L) = S(1)
GO TO 240
260 CALL ERROR1(33H IN SETCOM, TABLE OVERFLOW OF COM, 33)
270 SYSERR = .TRUE.
GO TO 180
280 CALL ERROR1(33H IN SETCOM, TABLE OVERFLOW OF LAT, 33)
GO TO 270
END
C XXXXXSETEXT.f
SUBROUTINE SETEXT
INTEGER Z, FINDND, PLAT, PNODE, PP, SS(3), SYMLEN
INTEGER BLANK
LOGICAL ERR, SYSERR, ABORT
COMMON /SCR1/ LINODE, INODE(500)
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /INTS/ Z(346)
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /HEAD/ LNODE, PNODE, NODE(500)
COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
DATA BLANK /1H /
C
C SUBROUTINE SETS UP DEFNS FOR BASIC EXTERNAL FCNS USED IN PASS 1
C FLUSH PAST INTRINSICS IN TABLE
C
K = 1
DO 10 I=1,31
K = K + Z(K) + 2
10 CONTINUE
C
C SEARCH EXTERNAL ENTRIES IN TABLE TO SEE WHICH HAVE BEEN USED
C
DO 90 I=1,24
N = K + Z(K) + 1
L = Z(N)/1024
IF (L) 80, 80, 20
C
C SEE IF THIS EXTERNAL FCN HAS BEEN USER DEFINED
C
20 L = Z(K)
DO 30 J=1,SYMLEN
SS(J) = BLANK
30 CONTINUE
CALL S5PACK(Z(K+1), SS, L)
LL = FINDND(SS(1),J)
IF (LL.NE.0) GO TO 80
C
C SETUP LATTICE ENTRY FOR THIS EXERNAL FCN
C
IF (PNODE+1.GE.LNODE) GO TO 120
IF (PLAT+SYMLEN+8.GE.LLAT) GO TO 110
C SET LEVEL OF BASIC EXTERNAL FUNCTION TO -2
INODE(PNODE) = -2
NODE(PNODE) = PLAT
PNODE = PNODE + 1
DO 40 J=1,SYMLEN
L = PLAT + J - 1
LAT(L) = SS(J)
40 CONTINUE
PP = PLAT
PLAT = PLAT + SYMLEN
LAT(PLAT) = MOD(Z(N),512)/128
L = PLAT + 1
LL = PLAT + 5
DO 50 NN=L,LL
LAT(NN) = 0
50 CONTINUE
LAT(PLAT+6) = 6 + 8*MOD(Z(N),8)
NO = LAT(PLAT)
PLAT = PLAT + 7
C
C FILL IN ARG ENTRIES
C NO CONTAINS NUMBER OF ARGS
C
IF ((PLAT+4)*NO.GE.LLAT) GO TO 110
L = PP + SYMLEN + 1
60 LL = PLAT + 3
DO 70 NN=PLAT,LL
LAT(NN) = 0
70 CONTINUE
CALL SATT2(PLAT, 1, MOD(Z(N),64)/8)
CALL SATT2(PLAT, 4, 1)
CALL SATT2(PLAT, 8, 10)
LAT(L) = PLAT
LAT(PLAT+1) = 1
L = PLAT + 3
PLAT = PLAT + 4
IF (NO.EQ.1) GO TO 80
NO = NO - 1
GO TO 60
80 K = N + 1
90 CONTINUE
100 RETURN
110 CALL ERROR1(33H IN SETEXT, TABLE OVERFLOW OF LAT, 33)
GO TO 130
120 CALL ERROR1(34H IN SETEXT, TABLE OVERFLOW OF NODE, 34)
130 SYSERR = .TRUE.
GO TO 100
END
C XXXXXSETPD.f
SUBROUTINE SETPD(I, K2)
INTEGER PDSA, DSA, PLAT, SYMLEN
LOGICAL ERR, SYSERR, ABORT
COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
C
C SUBROUTINE ADDS PGM UNIT AT LAT(I) ONTO K2 DESC-LIST
C ADDS K2 ONTO I PARENTS LIST
C
IF (PLAT+4.GT.LLAT) GO TO 20
C
C SEE THAT K2 IS NOT ALREADY ON I PARENTS LIST
C 0 RETURN INDICATES EMPTY LIST OR NO MATCH
C
J = I + SYMLEN + 3
IF (MATCH(LAT(J),1,K2).NE.0) GO TO 10
LAT(PLAT+1) = LAT(J)
LAT(PLAT) = K2
LAT(J) = PLAT
J = K2 + SYMLEN + 4
LAT(PLAT+3) = LAT(J)
LAT(PLAT+2) = I
LAT(J) = PLAT + 2
PLAT = PLAT + 4
10 RETURN
C
C ERROR RETURNS
C
20 SYSERR = .TRUE.
CALL ERROR1(32H IN SETPD, TABLE OVERFLOW OF LAT, 32)
GO TO 10
END
C XXXXXSETREF.f
SUBROUTINE SETREF(GREEN,INDIR)
INTEGER CHK1, KBR(1)
INTEGER REF, PREF, PDSA, DSA, PLAT, PNODE, FINDND, SYMLEN
LOGICAL ERR, SYSERR, ABORT, COMPAR, GREEN, INDIR
COMMON /HEAD/ LNODE, PNODE, NODE(500)
COMMON/ SCR1/ LINODE, INODE(500)
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /CREF/ LREF, PREF, REF(100)
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
COMMON /TABL/ NEXT, LABHD, ISYM, IBNEXT
DATA IBR /1/, JBR /3/, KBR(1) /0/
C
C GREEN = T IF ENCOUNTER EXTERNAL ENTITIES AT ALL
C INDIR = T IF ENCOUNTER ANY INDIRECT REFS
C READS IN ALL REFS FOR A PROGRAM UNIT; FINDS MISSING
C SUBPROGRAM REFS AND DISCARDS THEM; CHECKS ASF REFS AND
C DISCARDS THEM; WRITES INDIRECT REFS OUT ON I6 WITHOUT
C PROCESSING; DOES MINIMAL CHECKING OF DIRECT REFS
C CREATING PAR/DESC LINKS AND WRITING GOOD
C REFS OUT ON I6, AFTER DONE WITH REFS, SEARCHES
C FOR EXTERNAL ENTITIES (USAGE 13) TO FIX UP LEVELS
C
IJK = FINDND(DSA(NAME+4),IIJK)
C READ IN A NEW REF; IF HIT END OF REFS RECORD
C END OF REFS ON I6 AND RETURN
10 IF (INREF(I5)) 20, 20, 80
C WRITE END OF REFS
20 WRITE (I6) IBR, JBR, IBR
C CHECK FOR NON DUMMY EXTERNALS IN SYMBOL TABLE WHICH
C C AUSE CHANGES IN LEVEL CALCS
K = ISYM
30 IF (K) 40, 40, 50
150 SYSERR=.TRUE.
CALL ERROR1(33H IN SETREF, TABLE OVERFLOW OF LAT,33)
40 RETURN
50 IF (IGATT1(K,8).NE.13 .OR. IGATT1(K,4).EQ.1) GO TO 70
L = FINDND(DSA(K+4),IL)
IF (L.NE.0) GO TO 60
CALL ERROR2(18H MISSING EXTERNAL , 18, DSA(K+4), 1, 1, 0)
CALL ERROR2(1H1,0,KBR(1),-1, 0, 1)
GO TO 70
C FOUND AN EXTERNAL ENTITY
60 GREEN = .TRUE.
C ENTER ONTO GREEN LINKS LIST AT NODE
N = IJK + SYMLEN + 3
C J IS HEAD OF GREEN LINKS LIST (SEE SETPD)
160 IF(LAT(N+1).LE.0) GOTO 170
N = LAT(N+1)
GOTO 160
170 J = N+1
IF(PLAT+2.GT.LLAT) GOTO 150
LAT(PLAT) = -L
LAT(PLAT+1) = LAT(J)
LAT(J) = -PLAT
PLAT = PLAT+2
IF(-2.EQ.INODE(IL).OR.INODE(IL).GT.INODE(IIJK)) GOTO 70
INODE(IL) = INODE(IIJK) + 1
CALL ASLEV(-IL)
IF (ABORT .OR. SYSERR) GO TO 40
70 K = DSA(K+3)
GO TO 30
C
C REF IS WD1--NUMBER OF ARGS(2 WD ENTRIES)
C WD2--PTR TO PGM UNIT CALLED IN DSA
C WD3--STMT NO OF CALL
C WD4--CODE, 0 FOR SUBR REFS; 1 FOR FCN REFS
C WD5+-ARG ENTRIES (WD1-SYMBOL TABLE INDEX OR 0
C WD2-TYPE/STRUCTURE INFO)
C
80 IF (REF(4).LT.4) GO TO 100
C
C ASF REFERENCE; CHECKED AND THEN DISCARDED
C
K1 = PNODE - 1
DO 90 I=1,K1
IF (NODE(I).GE.0) GO TO 90
IJR = IABS(NODE(I))
L = IJR + SYMLEN + 3
L = LAT(L)
K = REF(2)
C
C IF HAVE ASF REF, FIND ASF BY NAME AND PAR CHECKS
C
IF (COMPAR(DSA(K+4),LAT(IJR)) .AND. LAT(L).EQ.IJK) GO TO 110
90 CONTINUE
L = REF(2) + 4
CALL ERROR2(18H MISSING ASF DEFN , 18, DSA(L), 1, 1, 0)
CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
GO TO 10
C
C WRITE INDIRECT REF OUT ON I6
C
100 K2 = IGATT1(REF(2),4)
IF(K2.EQ.0) GOTO 140
INDIR = .TRUE.
GOTO 130
C CHECK FOR MISSING SUBPROGRAM
140 K1 = REF(2)
IJR = FINDND(DSA(K1+4),IIJR)
IF (IJR.NE.0) GO TO 110
CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(K1+4), 1
* ,1, 0)
CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
GO TO 10
C CHECK DIRECT REFS AND ASF REFS
C 1 MEANS OK 0 MEANS N.G.
110 IF (CHK1(IJK,IJR)) 10, 10, 120
120 IF (REF(4).EQ.4) GO TO 10
C GOOD DIRECT REF; CREATE PAR/DES LINKS
CALL SETPD(IJR, IJK)
IF (SYSERR) GO TO 40
IF (-2.EQ.INODE(IIJR) .OR. INODE(IIJR).GT.INODE(IIJK)) GO TO 130
C FIX UP LEVELS
INODE(IIJR) = INODE(IIJK) + 1
CALL ASLEV(IIJR)
IF (SYSERR .OR. ABORT) GO TO 40
130 WRITE (I6) PREF, IBR, (REF(L),L=1,PREF)
GO TO 10
END
C XXXXXUNSAFE.f
SUBROUTINE UNSAFE
C
C ROUTINE READS IN ALL DIRECT AND INDIRECT REFS FOR THE CURRENT
C PGM-UNIT; CHECKS FOR THE 3 UNSAFE REFS
C
LOGICAL IBR
INTEGER PLAT, PDSA, DSA, SYMLEN, PREF, REF, INREF, FINDCM
COMMON /CREF/ LREF, PREF, REF(100)
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /FACTS/ NAME, I1, I2, IASF
COMMON /PARAMS/ I3, I4, I5, SYMLEN, I6, I7, I8
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
10 IF (INREF(I7).LE.0) RETURN
C CHECK FOR REF WITHOUT ARGS
I = REF(1)
IF (I.EQ.0) GO TO 10
LL = REF(2)
L = LL + SYMLEN + 1
L = LAT(L)
C
C LPOINTS TO DUMMY ARGUMENT IN LAT
C
DO 70 K=1,I,2
J = 4 + K
IF (REF(J).EQ.0) GO TO 20
N = IGATT1(REF(J),8)
IF (N.EQ.10 .OR. N.EQ.4) GO TO 30
GO TO 60
C
C LOOK FOR EXPRESSION BEING MATCHED TO AN ARG WHICH
C IS SET; TYPE 1 UNSAFE REF
C
20 IF (IGATT2(L,5).EQ.0) GO TO 60
CALL ERROR2(
* 56H EXPRESSION MATCHED TO POSSIBLY SET ARG IN REFERENCE TO ,
* 56, LAT(LL), 1, 1, 0)
CALL ERROR2(24H TYPE 1 UNSAFE REFERENCE, 24, REF(3), -1, 0, 1)
GO TO 60
C
C CHECK FOR ACTUAL ARG IN COMMON BEING SENT DOWN WHERE RTNE
C BENEATH CHANGES ARG OR COMMON REGION
C TYPE 3 UNSAFE REFERENCE
C
30 N = IGATT1(REF(J),2)
IF (N.NE.1) GO TO 40
C
C SEE IF ACTUAL IS AN ARRAY
C
N = IGATT2(L,7)
IF (N.NE.0) GO TO 40
N = REF(J) + 2
N = DSA(N)
N = DSA(N+1) + 4
N = FINDCM(DSA(N))
NN = LL + SYMLEN + 2
NN = MATCH(LAT(NN),2,N)
IF (NN.EQ.0) GO TO 40
N = IGATT2(L,5)
IF (N.EQ.0 .AND. LAT(NN+1).EQ.0) GO TO 40
CALL ERROR2(42H ARG OR COMMON MAY BE SET BY REFERENCE TO , 42,
* LAT(LL), 1, 1, 0)
CALL ERROR2(24H TYPE 3 UNSAFE REFERENCE, 24, REF(3), -1, 0, 1)
C
C CHECK FOR DO CONTROL VAR OR LIMIT MATCHED
C TO DUMMY ARG POSSIBLY SET
C
40 NN = IGATT2(L,5)
IF (NN.EQ.0) GO TO 60
NN = REF(J+1)/32
IF (NN.NE.1) GO TO 50
CALL ERROR2(
* 51H DO CONTROL VARIABLE OR LIMIT CAN BE SET IN REF TO , 51,
* LAT(LL), 1, 1, 0)
CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
C
C CHECK FOR ADJUSTIBLE DIMENSION VARIABLE MATCHED TO DUMMY
C ARG POSSIBLY SET
C
50 NN = REF(J+1)/64
IF (NN.NE.1) GO TO 60
CALL ERROR2(
* 52H ADJUSTIBLE DIMENSION VARIABLE CAN BE SET IN REF TO ,
* 52, LAT(LL), 1, 1, 0)
CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
60 L = LAT(L+3)
70 CONTINUE
C
C CHECK FOR SAME ACTUAL ARG SENT DOWN FOR DIFFERENT DUMMY-ARGS
C AND ONE OF DUMMIES MAY BE SET
C
C TYPE 2 UNSAFE REFERENCE
IF (REF(1).LE.2) GO TO 130
LR = LL + SYMLEN + 1
LR = LAT(LR)
C
C OUTER LOOP GOES TO NEXT TO LAST ARG
C
I = REF(1) + 3
II = I - 2
DO 120 K=5,II,2
J = REF(K)
IF (J.EQ.0) GO TO 110
JBR = IGATT1(J,8)
IF (JBR.NE.10 .AND. JBR.NE.4) GO TO 110
L = LAT(LR+3)
MM = K + 2
DO 100 M=MM,I,2
IF (REF(M).NE.J) GO TO 90
C
C HAVE TWO ACTUALS MAPPED ONTO DIFFERENT DUMMIES
C
C IF BOTH DUMMIES ARE ARRAYS OR BOTH ARE UNSET, NO UNSAFE
IF( IGATT2(L,7).NE.0 .AND. IGATT2(LR,7).NE.0 ) GOTO 90
IF( IGATT2(L,5).EQ.0 .AND. IGATT2(LR,5).EQ.0 ) GOTO 90
80 CALL ERROR2(64
*H ACTUAL ARG ASSOCIATED WITH 2 DUMMY ARGS POSSIBLY SET IN REF TO
*, 64, LAT(LL), 1, 1, 0)
CALL ERROR2(24H TYPE 2 UNSAFE REFERENCE, 24, REF(3), -1, 0, 1)
90 L = LAT(L+3)
100 CONTINUE
110 LR = LAT(LR+3)
120 CONTINUE
C
C CHECK FOR EXTERNAL FCNS WITHIN ASF-DEFS WHICH CONTAIN
C ASF-DUMMIES AND WHICH SET THEIR ARGS
C
130 IF (REF(4).NE.1) GO TO 10
II = REF(1) + 3
IBR = .FALSE.
DO 140 K=5,II,2
J = REF(K)
IF (J.EQ.0) GO TO 140
IF (IGATT1(J,8).EQ.1) IBR = .TRUE.
140 CONTINUE
IF (.NOT.IBR) GO TO 10
C
C SEE IF EXTERNAL FCN SETS ANY OF ITS ARGS
C
K = LL + SYMLEN + 1
K = LAT(K)
II = REF(1)/2
DO 150 L=1,II
IF (IGATT2(K,8).EQ.10 .AND. IGATT2(K,5).EQ.1) IBR = .FALSE.
150 CONTINUE
IF (IBR) GO TO 10
CALL ERROR2(37H ILLEGAL USAGE OF ASF-DUMMY IN REF TO, 37,
* LAT(LL), 1, 1, 0)
CALL ERROR2(1H , 0, REF(3), -1 ,0, 1)
GO TO 10
END
C XXXXXCHECKS.f
SUBROUTINE CHECKS(IROOT)
C
C MAIN IS INDEX IN NODE OF SUPEROOT IN LAT
C
LOGICAL ERR, SYSERR, ABORT, INSYM
COMMON /PARAMS/ I1, I2, I3, I4, I5, I6, I7
COMMON /DETECT/ ERR, SYSERR, ABORT
CALL COMCHK(IROOT)
CALL SCAN(IROOT)
IF (SYSERR) GO TO 20
10 IF(.NOT.INSYM(I6,0)) GOTO 30
CALL UNSAFE
GO TO 10
20 WRITE (I2,99999)
99999 FORMAT (31H1UNSAFE REFERENCES NOT VERIFIED)
30 RETURN
END
C XXXXXCONSTR.f
SUBROUTINE CONSTR(MAINND)
LOGICAL SYSERR, ERR, ABORT, INSYM, GREEN, INDIR
LOGICAL OVER
C NOTE SETNOD SETS ABORT FOR 2 P.U. WITH SAME NAME
C CONSTR SETS ABORT IF IT FINDS NO SYMBOL TABLES FROM PASS1
C ASLEV SETS ABORT IF IT FINDS RECURSION IN CALLING GRAPH
INTEGER OUTUT2, OUTUT3, OUTUT4, SYMLEN
INTEGER PNODE, PLAT, LS(2)
COMMON /HEAD/ LNODE, PNODE, NODE(500)
COMMON /SCR1/ LINODE, INODE(500)
COMMON /PARAMS/ I1, I2, I3, SYMLEN, OUTUT2, OUTUT3, OUTUT4
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /DETECT/ ERR, SYSERR, ABORT
DATA IBR /1/, JBR /4/
DATA LS(1) /1H,/, LS(2) /1H /
C
C CONSTR DIRECTS THE FIRST PORTION OF PASS2
C CALLS SETNOD TO CONSTRUCT THE LAT NODES FOR EACH P.U..
C CALLS SETEXT TO SETUP BASIC EXERNALS NODES
C AS NEEDED.
C CALLS SETREF TO MAKE CONNECTS BETWEEN THE NODES
C CALLS INVOKE TO CALCULATE LEVELS AND ASSIMILATE
C ALL PROC INFO NECESSARY
C CALLS ERASE TO GET RID OF NON-REFERENCE LINKS IN
C CALLING GRAPH
C CALLS CHKALL TO DO FINAL CHECKS OF ALL REFS AND TO
C WRITE ALL GOOD REFS OUT FOR FUTURE PROCESSING
C FORMS SUPERROOT IN GRAPH
C CALLS OUTPUT ROUTINES WHENEVER CAN, TO GIVE PARTIAL
C LISTINGS OF CURRENT DATA STRUCTURE
C
C USE INSYM TO POSSIBLY SKIP OVER BAD REFS WITH DUMMY SYM TBL
C SETREF READS REFS FROM OUTUT3, WRITES ON OUTUT4
C INVOKE READS FROM OUTUT4
C CHKALL READS FROM OUTUT4, WRITES OUTUT3
C UNSAFE READS FROM OUTUT3
C INITIALIZE LEVEL ARRAY AND ISR
ISR = 0
DO 10 I=1,LNODE
INODE(I) = 0
10 CONTINUE
C INITIALIZE LOGICAL FLAGS FOR DETECTION OF PRESENCE OF
C EXTERNAL ENTITIES (GREEN) AND INDIRECT REFS(INDIR)
GREEN = .FALSE.
INDIR = .FALSE.
20 IF(.NOT.INSYM(0,0)) GOTO 30
C
C SUCCESSFULLY READ SYMBOL TABLE
C
CALL SETNOD
IF (SYSERR .OR. ABORT) GO TO 130
GO TO 20
30 REWIND OUTUT2
IF (PNODE.EQ.1) GO TO 150
C CHANGE LEVEL ON ASFS SO DONT PROCESS THEM
L = PNODE - 1
DO 40 I=1,L
IF (NODE(I).LT.0) INODE(I) = -2
40 CONTINUE
C
C SETUP BASIC EXTERNAL DEFNS AS NEEDED
C
CALL SETEXT
IF (SYSERR) GO TO 130
C
C READ IN SYMBOL TABLES
C SETREF WILL READ IN REFS
C
50 IF(.NOT.INSYM(OUTUT3, OUTUT4)) GOTO 60
CALL SETREF ( GREEN, INDIR )
IF (SYSERR .OR. ABORT) GO TO 130
GO TO 50
60 REWIND OUTUT2
REWIND OUTUT3
WRITE (OUTUT4) IBR, JBR, IBR
REWIND OUTUT4
IF(.NOT.INDIR) GOTO 70
C
C CALL LEVEL ALG
C
CALL INVOKE
IF (ABORT .OR. SYSERR) GO TO 130
REWIND OUTUT2
REWIND OUTUT4
C
C CHECK AND EXPAND REFS AND SAVE ALL GOOD ONES FOR LATER
C
70 IF(.NOT.INSYM(OUTUT4,OUTUT3)) GOTO 80
CALL CHKALL
IF (SYSERR) GO TO 130
GO TO 70
80 WRITE (OUTUT3) IBR, JBR, IBR
C
C CONSTRUCT SUPEROOT IN LAT
C
IF (PNODE+1.GT.LNODE) GO TO 180
IF (PLAT+SYMLEN+7.GT.LLAT) GO TO 160
NODE(PNODE) = PLAT
C MAINND IS SUPEROOT INDEX IN NODE
C ISR IS SUPEROOT INDEX IN LAT
MAINND = PNODE
ISR = PLAT
PNODE = PNODE + 1
LAT(PLAT) = LS(1)
PLAT = PLAT + 1
IF (SYMLEN.EQ.1) GO TO 100
DO 90 I=2,SYMLEN
L = PLAT + I - 2
LAT(L) = LS(2)
90 CONTINUE
PLAT = L + 1
100 L = PLAT + 5
DO 110 I=PLAT,L
LAT(I) = 0
110 CONTINUE
LAT(L+1) = 5
PLAT = L + 2
C
C LOOK FOR CALLABLE PGM UNITS WITHOUT PARENTS
C
L = PNODE - 2
DO 120 I=1,L
K = SYMLEN + 3 + IABS(NODE(I))
IF (LAT(K).EQ.0) CALL SETPD(IABS(NODE(I)), ISR)
IF (SYSERR) GO TO 130
120 CONTINUE
130 IF(.NOT.GREEN) GOTO 190
C ERASE GREEN LINKS
L = PNODE - 2
DO 210 I = 1,L
C SKIP ASF NODES
IF(NODE(I) .LT. 0) GOTO 210
C FIND HEAD OF GREEN LINKS
N = NODE(I) + SYMLEN + 3
220 IF(LAT(N+1) .LE. 0) GOTO 230
N = LAT(N+1)
GOTO 220
230 LAT(N+1) = 0
210 CONTINUE
190 OVER = SYSERR
SYSERR = .FALSE.
CALL OUT2 (ISR)
SYSERR = SYSERR.OR.OVER
IF(SYSERR) CALL ERROR1(
* 56H ILLEGAL COMMON USAGE AND UNSAFE REFERENCES NOT VERIFIED,
* 56)
CALL OUT2C
140 RETURN
150 ABORT = .TRUE.
GO TO 140
160 CALL ERROR1(33H IN CONSTR, TABLE OVERFLOW OF LAT, 33)
170 SYSERR = .TRUE.
GO TO 130
180 CALL ERROR1(34H IN CONSTR, TABLE OVERFLOW OF NODE, 34)
GO TO 170
END
C XXXXXOUT2.f
SUBROUTINE OUT2(ISR)
INTEGER SYMLEN, PNODE, BL, PLAT, STACK, Q(3), C(12),
* OUTLAT, OUTCOM, OUTUT
LOGICAL ERR, SYSERR, ABORT
EXTERNAL EXCH
COMMON /PARAMS/ INUT, OUTUT, NOCHAR, SYMLEN, I1, I2, II1
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /CEXPRS/ LSTACK, STACK(620)
COMMON /HEAD/ LNODE, PNODE, NODE(500)
COMMON /SCR1/ LINODE, INODE(500)
DATA C(1) /1HE/, C(2) /1HD/, C(3) /1HR/, C(4) /1HI/, C(5) /1HC/,
* C(6) /1HL/, C(7) /1HS/, C(8) /1HA/, C(9) /1HF/, IP /1HP/, IBL
* /1H-/, C(12) /1HU/, C(10) /1HB/, C(11) /1HN/
DATA BL /1H /
C
C ROUTINE PRINTS CALLING GRAPH
C
IF (PNODE.LE.2) GO TO 110
C
C GRAPH
C
I3 = PNODE - 1
IF (ISR.NE.0) I3 = I3 - 1
C
C SORT LATTICE
C
DO 10 I=1,I3
INODE(I) = IABS(NODE(I))
10 CONTINUE
CALL SSORT(EXCH, LAT, LLAT, INODE, I3, 0)
DO 100 IA=1,I3
I = INODE(IA)
L = I + SYMLEN + 6
IF (MOD(LAT(L),8).EQ.4) GO TO 100
CALL S5UNPK(LAT(I), STACK(1), 6)
WRITE (OUTUT,99999) (STACK(L),L=1,6)
99999 FORMAT (///1X, 6A1//)
C
C GET ARGS IF ANY
C
IS = 1
K = SYMLEN + I
L = LAT(K)
IF (L) 70, 70, 20
20 K = K + 1
K = LAT(K)
IF (L*8.GT.LSTACK) GO TO 120
DO 60 LL=1,L
Q(1) = IGATT2(K,8)
IF (Q(1).EQ.5 .OR. Q(1).EQ.6 .OR. Q(1).EQ.13) GO TO 30
Q(1) = IGATT2(K,1)
Q(2) = IGATT2(K,5)
Q(3) = IGATT2(K,7)
STACK(IS) = IBL
STACK(IS+2) = IBL
IF (Q(1).GE.8) STACK(IS) = C(1)
L1 = MOD(Q(1),8) + 2
STACK(IS+1) = C(L1)
IF (Q(2).EQ.1) STACK(IS+2) = C(7)
STACK(IS+3) = C(7)
IF (Q(3).NE.0) STACK(IS+3) = C(8)
GO TO 40
30 STACK(IS) = IP
STACK(IS+1) = IBL
STACK(IS+2) = IBL
STACK(IS+3) = IBL
40 DO 50 LK=4,7
L1 = LK + IS
STACK(L1) = BL
50 CONTINUE
IS = IS + 8
K = LAT(K+3)
60 CONTINUE
IS = IS - 1
C PRINT ARGUMENTS
K = 48
IF (K.GT.IS) K = IS
WRITE(OUTUT,99998)(STACK(LK), LK=1,K)
99998 FORMAT(20H ARGUMENT ATTRIBUTES ,5X,6(8A1,1X))
IF( K.EQ.IS ) GOTO 70
65 LK = K + 1
K = LK + 47
IF(K.GT.IS) K = IS
WRITE(OUTUT,99997) (STACK(L1),L1=LK,K)
99997 FORMAT(25X,6(8A1,1X))
IF(K.LT.IS) GOTO 65
C
C GET COMMON NAMES
C
70 K = I + SYMLEN + 2
K = OUTCOM(LAT(K),IS)
IF (SYSERR) GO TO 110
IF (K.EQ.0) GO TO 80
CALL OUT2A(14H COMMON BLOCKS, 14, IS, 2)
C
C FIND PARENTS
C
80 K = I + SYMLEN + 3
K = OUTLAT(LAT(K),IS,ISR)
IF (SYSERR) GO TO 110
IF (K.EQ.0) GO TO 90
CALL OUT2A(22H CALLED BY SUBPROGRAMS, 22, IS, 1)
C
C FIND DESCENDENTS
C
90 K = I + SYMLEN + 4
K = OUTLAT(LAT(K),IS,ISR)
IF (SYSERR) GO TO 110
IF (K.EQ.0) GO TO 100
CALL OUT2A(18H CALLS SUBPROGRAMS, 18, IS, 1)
100 CONTINUE
110 RETURN
120 SYSERR = .TRUE.
CALL ERROR1(33H IN OUT2, TABLE OVERFLOW OF STACK, 33)
GO TO 110
END
C XXXXXSETNOD.f
SUBROUTINE SETNOD
INTEGER PLAT, COM, PNODE, PDSA, DSA, SYMLEN, PP, SYMHD, PCOM,
* SETARG, FINDND, FINDCM
LOGICAL ERR, SYSERR, ABORT
COMMON /COMS/ LCOM, PCOM, COM(300)
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /HEAD/ LNODE, PNODE, NODE(500)
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /PARAMS/ INUT, I1, NOCHAR, SYMLEN, I2, I3, I4
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /TABL/ NEXT, LABHD, SYMHD, IBNEXT
COMMON /SCR1/ LINODE, INODE(500)
C
C LAT-IS THE CALLING GRAPH PLUS AUXILIARY NODES
C PLAT-IS NEXT FREE WORD IN LAT
C LLAT-IS LENGTH OF LAT
C NODE-IS LIST OF ALL CALLING NODES INDICES IN LAT
C (WILL BE IN ALPHABETIC ORDER BEFORE CHECKING COMMENCES)
C PNODE-IS NEXT FREE WORD IN NODE
C LNODE-IS LENGTH OF NODE
C
C P.U. NODE IN LAT
C WD 1.....PACKED CHARACTERS OF NAME OF SUBPGM
C WD2.....NUMBER OF ARGS
C WD3.....PTR TO HEAD OF LINEAR LINKED ORDERED LIST OF
C ARGUMENT NODES IN LAT
C WD4.....PTR TO HEAD OF LINEAR LINKED LIST OF COMMON NODES
C IN LAT
C WD5.....PTR TO HEAD OF LINEAR LINKED LIST OF INDICES IN
C LAT OF ENTRIES FOR PARENT NODES
C WD6.....PTR TO HEAD OF LINEAR LINKED LIST OF INDICES IN
C LAT OF ENTRIES FOR DESCENDENT NODES
C WD7.....PTR TO HEAD OF LINEAR LINKED LIST OF SEQUENCE NOS OF
C BAD REFERENCES; INCONSISTANT TYPE OF FCN/SUBR REFERENCE, INCORR
C NUMBER OF ARGS, AND RECURSIVE CALL OF SELF ARE THE THREE
C TYPES OF BAD REFS
C WD8.....BITS 0-2 TYPE OF SUBPGM: 0 SUBR, 1 FCN, 2 BLOCK DATA,
C 3 MAIN, 4 ASF, 5 SUPEROOT
C BITS 3-5 (IF FCN OR ASF) CONTAIN TYPE OF FCN: 0 DP, 1 RL,
C 2 INT, 3 COMP, 4 LOG
C
C ARGUMENT NODE IN LAT
C WD1.....ATTRIBUTES (SAME AS IN DSA, SEE LOOKUP)
C WD2.....LENGTH (IN PROCEDURE ARGS THIS WORD POINTS TO
C HEAD OF LINEAR LINKED LIST OF ACTUAL SUBPGM NAMES ASSOCIATED
C WITH THIS ARG IN THE PROGRAM; ALSO HAVE INDEX IN LAT OF
C SUBPRGM IN WHICH THE ASSOC OCCURS
C WD 3.....PTR TO HEAD OF LINEAR LINKED LIST OF PARENT ARGS
C (ARGS FROM PARENT RTNES SENT DOWN TO BE ASSOC. WITH THIS ARG)
C WD 4.....PTR TO HEAD OF LINEAR LINKED LIST OF DESC. ARGS
C (ARGS FROM DESC RTNES WHICH THIS ARG IS ASSOC. WITH)
C WD 5.....PTR TO NEXT ARG NODE OR 0
C
C COMMON NODE IN LAT
C WD 1.....INDEX OF ENTRY FOR THIS COMMON IN COM
C WD 2.....1 IF COMMON STORED INTO BY THIS P.U. ELSE 0
C WD 3.....PTR TO NEXT COMMON NODE
C CREATE NODE PTR TO NEW NODE IN LAT
C
IF (PNODE.GT.LNODE) GO TO 170
IF (PLAT+SYMLEN+7.GT.LLAT) GO TO 190
C
C CHECK IF SUBPROGRAM HAS NAME SAME AS ANOTHER SUBPROGRAM
C OR A COMMON BLOCK
C
II = IGATT1(NAME,8)
IF (II.EQ.11) GO TO 10
IF (FINDND(DSA(NAME+4),IROOT)) 10, 10, 20
10 IF (FINDCM(DSA(NAME+4))) 40, 40, 30
20 ERR = .TRUE.
30 CALL ERROR2(45H SUBPROGRAM AND/OR COMMON BLOCK NAME CONFLICT, 45,
* DSA(NAME+4), 1, 1, 1)
IF (.NOT.ERR) GO TO 40
ERR = .FALSE.
ABORT = .TRUE.
GO TO 160
40 NODE(PNODE) = PLAT
IROOT = PNODE
PNODE = PNODE + 1
C
C ENTER NAME INTO NODE
C
DO 50 I=1,SYMLEN
L = NAME + 3 + I
LL = PLAT - 1 + I
LAT(LL) = DSA(L)
50 CONTINUE
C
C PP POINTS TO CURRENT RTNE NODE IN LAT
C
PP = PLAT
PLAT = LL + 6
LL = LL + 1
DO 60 I=LL,PLAT
LAT(I) = 0
60 CONTINUE
C
C 0 SUBR, 1 FCN, 2 BLOCK DATA, 3 MAIN, 4 ASF, 5 SUPEROOT
C
LAT(PLAT+1) = II/4
C INITIALIZE LEVEL OF BLOCK DATA TO -2
IF (LAT(PLAT+1).EQ.2) INODE(IROOT) = -2
IF (LAT(PLAT+1).NE.1) GO TO 70
L = IGATT1(NAME,1)
LAT(PLAT+1) = LAT(PLAT+1) + 8*MOD(L,8)
70 PLAT = PLAT + 2
C
C HAVING INITIALIZED NODE TO 0, LOOK FOR ARGS
C
IF (DSA(NAME+2)) 80, 90, 80
80 L = PP + SYMLEN
LAT(L) = SETARG(PP,NAME)
IF (SYSERR) GO TO 160
C
C READ THROUGH SYMBOL TABLE FOR COMMON BLOCK DEFNS AND ASF DEFS
C AND SETTING OF COMMON REGION
C
90 K = SYMHD
100 IF (K) 110, 160, 110
110 LL = IGATT1(K,8)
C
C CHECK FOR ASF AND COMMON DEFNS OR COMMON
C SETTING INFO
C
GO TO (140, 120, 140, 140, 140, 140, 130, 150, 140, 150, 140,
* 140, 140, 140), LL
C
C CREATE ASF NODE
C
120 CALL SETASF(PP, K)
IF (SYSERR) GO TO 160
GO TO 140
C
C CREATE COM ENTRY
C
130 CALL SETCOM(PP, K)
IF (SYSERR) GO TO 160
140 K = DSA(K+3)
GO TO 100
C
C CHECK IF ELEMENT IN COMMON
C
150 LL = IGATT1(K,2)
L = IGATT1(K,5)
IF (L.NE.1 .OR. LL.NE.1) GO TO 140
L = DSA(K+2)
L = DSA(L+1)
CALL MKCOM(PP, L)
IF (SYSERR) GO TO 160
GO TO 140
160 RETURN
170 CALL ERROR1(34H IN SETNOD, TABLE OVERFLOW OF NODE, 34)
180 SYSERR = .TRUE.
GO TO 160
190 CALL ERROR1(33H IN SETNOD, TABLE OVERFLOW OF LAT, 33)
GO TO 180
END
C XXXXXCHK1.f
INTEGER FUNCTION CHK1(IR, IE)
C
C PROGRAM UNIT AT LAT(IR) CALLS PROGRAM UNIT AT LAT(IE)
C CHK1 RETURNS 1 IF REF OK ELSE 0
C CHECKS FOR INCONSISTENT SYBPGM USAGE, CORRECT NO. OF
C ARGS, CORRECT USAGE MATCH UP OF ARGS
C
INTEGER PREF, REF, PDSA, DSA, PLAT, SYMLEN, IBR(1)
COMMON /CREF/ LREF, PREF, REF(100)
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
CHK1 = 0
C CHECKS FOR SELF RECURSION
IF (IE.NE.IR) GO TO 10
CALL ERROR2(24H RECURSIVE CALL OF SELF , 24, REF(3), -1, 1, 1)
GO TO 100
C CHECKS FOR USAGE OF SUBPGM CONSISTENT WITH DEF
10 I = IE + SYMLEN + 6
N = MOD(LAT(I),8)
IF (N.EQ.REF(4) .OR. N.EQ.6 .AND. REF(4).EQ.1) GO TO 20
CALL ERROR2(38H INCONSISTENT REFERENCE TO SUBPROGRAM , 38,
* LAT(IE), 1, 1, 0)
CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
GO TO 100
C CHECKS FOR CORRECT NO. ARGS
20 I = IE + SYMLEN
IF (LAT(I).EQ.REF(1)/2) GO TO 30
CALL ERROR2(42H INCORRECT NUMBER OF ARGS IN REFERENCE TO , 42,
* LAT(IE), 1, 1, 0)
CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
GO TO 100
C ARE DONE WITH REF IF IT HAS NO ARGS
30 CHK1 = 1
IF(LAT(I)) 100, 100, 40
C CHECK USAGES OF ARGS IN CALL VS USAGES OF ARGS IN DEF
C N POINTS TO DUMMY ARG ENTRY
40 I = LAT(I)
N = IE + SYMLEN + 1
L = 5
DO 80 K=1,I
MD = IGATT2(LAT(N),8)
IF (MD.NE.13 .AND. MD.NE.5 .AND. MD.NE.6) GO TO 60
C HAVE A PROC ARG IN DEF
C NEED A PROC ARG IN REF
IF (REF(L).EQ.0) GO TO 50
MR = IGATT1(REF(L),8)
IF (MR.EQ.13 .OR. MR.EQ.6 .OR. MR.EQ.5) GO TO 70
50 IBR(1) = K
CALL ERROR2(36H INCOMPATIBLE USAGE ASSOCIATED WITH ,36,IBR,-2,1,0)
CALL ERROR2(17H IN REFERENCE TO ,17,LAT(IE), 1, 0, 0)
CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
CHK1 = 0
GOTO 70
C HAVE VARIABLE OR ARRAY AS ARG IN DEF
C NEED SAME IN REF
60 IF (REF(L).EQ.0) GO TO 70
MR = IGATT1(REF(L),8)
IF (MR.EQ.13 .OR. MR.EQ.5 .OR. MR.EQ.6) GO TO 50
70 N = LAT(N) + 3
L = L + 2
80 CONTINUE
100 RETURN
END
C XXXXXCHK2.f
INTEGER FUNCTION CHK2(IR, IE)
C
C PROGRAM UNIT AT LAT(IR) CALLS PROGRAM UNIT AT LAT(IE)
C CHK2 RETURNS 1 IF REF IS OK, ELSE 0
C CHECKS TYPE OF FCN IF FCN IS REFERENCED,
C CHECKS PROC PARAMETERF FOR COMPATIBLE USAGE AND TYPE
C TYPE AND STRUCTURE OF VARIABLE
C AND ARRAY ARGS, BUILDS UPWARD LINKS BETWEEN
C DUMMIES FOR SETTING INFO TRANSFER IN SCAN
C BAD STRUCTURE MATCHING MAKES REF BAD
C NO DUMMY LINKS CREATED IN THIS CASE
C
INTEGER REF, PREF, PDSA, DSA, PLAT, SYMLEN, FINDND, AER(1)
LOGICAL ERR, SYSERR, ABORT
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /CREF/ LREF, PREF, REF(100)
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
COMMON /FACTS/ NAME, NOST, ITYP, IASF
CHK2 = 1
C CHECK TYPE OF FCN CALLED IF A FCN
IF (REF(4).NE.1) GO TO 10
I = IE + SYMLEN + 6
IF (MOD(IGATT1(REF(2),1),8).EQ.LAT(I)/8) GO TO 10
IF (MOD(LAT(I),8).EQ.6 .AND. IGATT1(REF(2),1)/8.NE.1) GO TO 10
CALL ERROR2(39H INCOMPATIBLE FCN TYPE IN REFERENCE TO , 39,
* LAT(IE), 1, 1, 0)
CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
C CYCLE THROUGH ARGS IF ANY
10 I = IE + SYMLEN
IF (LAT(I).EQ.0) GO TO 170
I = LAT(I)
N = IE + SYMLEN + 1
L = 5
DO 160 K=1,I
AER(1) = K
L1 = IGATT2(LAT(N),8)
IF (L1.EQ.13 .OR. L1.EQ.6 .OR. L1.EQ.5) GO TO 90
C CHECK STRUCTURE AND TYPE OF VARIABLES
C AND ARRAY ARGUMENTS
K1 = MOD(IGATT2(LAT(N),1),8)
K2 = IGATT2(LAT(N),7)
IF (K2.GT.1) K2 = 1
L1 = MOD(REF(L+1),8)
L2 = MOD(REF(L+1),32)/8
C
C CHECK TYPE, CHECK HOLLERITH CONSTANTS MATCHED
C ALWAYS TO INTEGER ARRAYS
C
IF (L1.NE.5 .OR. REF(L).NE.0) GO TO 20
IF (REF(4).EQ.0 .AND. K2.NE.0 .AND. K1.EQ.2) GO TO 40
CALL ERROR2(33H HOLLERITH CONST ASSOCIATED WITH ,33,AER,-2,1,0)
CALL ERROR2(17H IN REFERENCE TO , 17,LAT(IE),1, 0, 0)
CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
CHK2 = 0
GO TO 150
20 IF (K1.EQ.L1 .OR. K1.EQ.2 .AND. L1.EQ.5) GO TO 30
CALL ERROR2(33H MISMATCHED TYPE ASSOCIATED WITH ,33,AER,-2,1,0)
CALL ERROR2(17H IN REFERENCE TO ,17,LAT(IE),1, 0, 0)
CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
C
C CHECK STRUCTURE L2 = 0 SCALAR, 1 ARRAY, 2 ARRAY ELE
C
30 IF (K2.EQ.1 .AND. L2.GT.0 .OR. K2.EQ.0 .AND. (L2.EQ.2 .OR.
* L2.EQ.0)) GO TO 40
CALL ERROR2(38H MISMATCHED STRUCTURE ASSOCIATED WITH ,38,AER,-2,
* 1, 0)
CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE),1, 0, 0)
CALL ERROR2(1H1, 0, REF(3), -1,0,1)
CHK2 = 0
GO TO 150
C
C CHECK IF ACTUAL ARG IS NON-PROC DUMMY ARG IN CURRENT PGM UNIT
C IF SO CREATE ARGLINK.
C NO ARGLINK CREATED IF FCN CALLED IS AN ASF
C
40 IF (REF(L).LE.0 .OR. REF(4).EQ.4) GO TO 150
K1 = IGATT1(REF(L),4)
IF (K1.EQ.0) GO TO 150
C
C FIND REL. POSITION OF CALLING PGM
C DUMMY , L1 PTS TO IT IN LAT
L3 = DSA(NAME+2)
KK = 0
50 KK = KK + 1
IF (DSA(L3).EQ.REF(L)) GO TO 60
L3 = DSA(L3+1)
GO TO 50
60 K2 = 0
L1 = IR + SYMLEN - 2
70 L1 = LAT(L1+3)
K2 = K2 + 1
IF (K2.LT.KK) GO TO 70
C FIND REL POSITION OF CALLED DUMMY ARG
C L2 PTS TO IT IN LAT
K1 = 0
L2 = IE + SYMLEN - 2
80 L2 = LAT(L2+3)
K1 = K1 + 1
IF (K1.LT.K) GO TO 80
IF (MATCH(LAT(L2+2),1,L1).NE.0) GO TO 150
IF (PLAT+2.GT.LLAT) GO TO 180
LAT(PLAT) = L1
LAT(PLAT+1) = LAT(L2+2)
LAT(L2+2) = PLAT
PLAT = PLAT + 2
GO TO 150
C CHECK PROC ARGUMENTS TO SEE THEY ARE CORRECT USAGE AND TYPE
C LAT(N) PTS TO DUMMY ARG ENTRY IN LAT
C REF(L) PTS TO CORRESP REF ARG IN DSA
90 IF (IGATT1(REF(L),4).EQ.1) GO TO 110
C REFERENCE CONTAINS AN AACTUAL PROC NAME
C CHECK FOR MISSING SUBPROGRAM
L3 = REF(L)
L2 = FINDND(DSA(L3+4),L3)
IF (L2.NE.0) GO TO 100
L3 = REF(L) + 4
CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(L3), 1, 1, 0)
CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE), 1, 0, 0)
CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
GO TO 150
C CALL CHK3 TO PREFORM CHECKS
100 L5 = L2 + SYMLEN + 6
CALL CHK3(LAT(N), L2, L1, MOD(LAT(L5),8), IE, REF(3), AER)
GO TO 150
C REFERENCE CONTAINS A DUMMY ARGUMENT MUST CHECK ALL ACTUALS
C WHICH CAN CORRESPOND TO THAT DUMMY
C FIRST FIND ITS CORRESP ACTUAL, IF ANY
110 L2 = REF(L)
L2 = DSA(L2+2)
C L2 IS OFFSET AMONG ALL DUMMIES OF LAT(IR)
C OF THE DUMMY ARG AT REF(L)
L3 = IR + SYMLEN + 1
L3 = LAT(L3)
IF (L2.EQ.1) GO TO 130
DO 120 L4=2,L2
L3 = LAT(L3+3)
120 CONTINUE
C L3 PTS TO DUMMY ARG IN CALLING RTNE
130 L3 = LAT(L3+1)
C L3 CONTAINS OFFSET FOR PROC ACTUALS
C MATCHED TO THIS DUMMY ARG
C IN TEMPLATED OFF LAT(IR)
L2 = IR + SYMLEN + 5
IF (LAT(L2).NE.0) GO TO 140
L3 = REF(L) + 4
CALL ERROR2(35H NO ACTUAL PROCS SUBSTITUTABLE FOR , 35,
* DSA(L3), 1, 1, 0)
CALL ERROR2(17H IN REFERENCE TO , 17, LAT(IE), 1, 0, 0)
CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
GO TO 150
C L2 PTS TO ACTUALS TEMPLATE
140 L2 = LAT(L2)
L4 = L2 + L3
C LAT(L4) IS ACTUAL PAIRED TO REF(L)
L5 = LAT(L4) + SYMLEN + 6
CALL CHK3(LAT(N), LAT(L4), L1, MOD(LAT(L5),8), IE, REF(3), AER)
C CYCLE TO NEXT ACTUAL
L2 = LAT(L2) + L2
IF (LAT(L2)) 150, 150, 140
150 L = L + 2
N = LAT(N) + 3
160 CONTINUE
170 RETURN
180 SYSERR = .TRUE.
CHK2 = 0
CALL ERROR1(31H IN CHK2, TABLE OVERFLOW OF LAT, 31)
GO TO 170
END
C XXXXXFIND.f
INTEGER FUNCTION FIND(K)
C
C FIND HAS TO FIND THE INDEX IN NODE
C OF THE LATTICE ENTRY AT K, DOES A
C LINEAR SEARCH ON NODE ARRAY
C P.U. ASSUMES NODE ARRAY SET UP PROPERLY
C AND THAT NODES ITS ASKED TO FIND ARE ALWAYS IN THE
C ARRAY SOMEWHERE. CAN BE ASKED TO FIND INDEX OF
C ANY NODE IN LATTICE, EVEN ASFS
C
INTEGER PNODE
COMMON /HEAD/ LNODE, PNODE, NODE(500)
L = PNODE - 1
DO 10 I=1,L
IF (K.NE.IABS(NODE(I))) GO TO 10
FIND = I
GO TO 20
10 CONTINUE
20 RETURN
END
C XXXXXASLEV.f
SUBROUTINE ASLEV(IPT)
C
C ASLEV TAKES A SUBLATTICE WITH ITS ROOT AT NODE(IABS(IPT)))
C AND READJUSTS THE LEVELS IN THE SUBLATTICE
C IN ACCORDANCE WITH NEW LEVEL AT ROOT
C NOTE, IPT LT 0 FROM CALL IN SETREF (EXT) AND FROM ACTUALS
C PASSED DOWN IN PROC
C
INTEGER PNODE, STACK, PLAT, FIND, SYMLEN
INTEGER ZERO(1)
LOGICAL SYSERR, ERR, ABORT, GR
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /HEAD/ LNODE, PNODE, NODE(500)
COMMON /SCR1/ LINODE, INODE(500)
COMMON /SCR2/ LSTACK, STACK(500)
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
DATA ZERO(1) /0/
C
C STACK (IS) IS SIGNED NODE INDEX OF SUBPGM
C IF GT 0, NODE IS ALONG A RED LINK TO PARENT
C IF LT 0, NODE IS ALONG A GREEN LINK TO PARENT
C
C STACK(IS+1) IS PTR TO TWO WORD DESC ENTRY FOR THIS
C SUBPGM, OR 0 FOR END OF DESC LIST
C
K = IABS (IPT )
K = SYMLEN + NODE(K) + 4
STACK(2) = IPT
STACK (1) = IABS ( LAT(K) )
IS = 2
C DOES TOP OF STACK ENTRY HAVE UNVISITED DESC
10 IF (STACK(IS-1).NE.0) GO TO 20
C TEST IF ARE DONE WITH SUBLATTICE
IF (IS.EQ.2) RETURN
C POP UP A LEVEL IN PATH
IS = IS - 2
GO TO 10
C UPDATE ENTRY OF NEXT DESCENDENT TO BE CHECKED ON STACK
20 K = STACK(IS-1)
STACK(IS-1) = IABS (LAT(K+1))
C LAT(K) CONTAINS SIGNED INDEX OF DESC BEING PROCESSED
C SIGN INDICATES COLOR OF LINK TO PARENT, (I.E.
C NODE AT TOP OF STACK)
C LT 0 IS GREEN LINK, GT 0 IS RED LINK
C L IS INDEX IN NODE(*) OF DESC BEING PROCESSED
C KK IS INDEX IN LAT(*) OF DESC BEING PROCESSED
LL = 1
IF( LAT(K) .LT. 0) LL = -1
KK = IABS(LAT(K))
L = FIND(KK)
C SKIP ALL DESC WITH NEGATIVE LEVELS
IF (INODE(L).LT.0) GO TO 10
C SEE IF STACK TOO SHORT FOR LOOPS
IF( IS.LE.2) GOTO 40
C CHECK FOR LOOPS IN PATH STACK DESC
LOOP = 0
GR = .FALSE.
IF(LL.EQ.(-1)) GR = .TRUE.
DO 60 I = 2,IS,2
IF(LOOP) 70,70,90
90 IF(STACK(I).LT.0) GR = .TRUE.
GOTO 60
70 IF(L.EQ.IABS(STACK(I))) LOOP = I
60 CONTINUE
C NO LOOPS
IF(LOOP.EQ.0) GOTO 40
C LOOP OF MIXED COLORED LINKS
C DO NOT STACK DESC
IF(GR) GOTO 10
C RECURSION
ABORT = .TRUE.
CALL ERROR2(19H RECURSIVE CALL OF ,19,LAT(KK), 1, 1, 0)
DO 80 K=LOOP,IS,2
KK = IABS(STACK(K))
KK = NODE(KK)
80 CALL ERROR2(11H INVOLVING ,11,LAT(KK),1, 0, 0)
CALL ERROR2(1H1, 0, ZERO, -3, 0, 1)
30 RETURN
C TEST IF DESC LEVEL IS ALREADY GT LEVEL OF PAR
C THEN NEEDNT CHECK PART OF SUBLATTICE UNDER THIS DESC
40 K = IABS (STACK(IS))
IF (INODE(L).GT.INODE(K)) GO TO 10
C PUSH DESC ONTO STACK AFTER FIXING HIS LEVEL
INODE(L) = INODE(K) + 1
C TEST AGAINST LNODE BECAUSE SCRATCH ARRAY
C IS AS LONG AS NODE ARRAY
IF (IS+2.GT.LNODE) GO TO 50
STACK(IS+2) = LL * L
K = NODE(L) + SYMLEN + 4
STACK(IS+1) = IABS( LAT(K))
IS = IS + 2
GO TO 10
50 SYSERR = .TRUE.
CALL ERROR1(43H IN ASLEV, PATH LONGER THAN NUMBER OF NODES, 43)
GO TO 30
END
C XXXXXINVOKE.f
SUBROUTINE INVOKE
C
C PGM UNIT STEPS THROUGH NODES IN INVOCATION ORDER
C PUSHING ACTUAL PROC ARGS DOWN LATTICE WHERE NECESSARY
C AND READJUSTING LEVEL IF NECESSARY
C
INTEGER PNODE, PLAT, PDSA, DSA, SYMLEN, PREF, REF, FIND, CHK1,
* ZERO(1), FINDND
LOGICAL ERR, SYSERR, ABORT, OK, AOK
COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /HEAD/ LNODE, PNODE, NODE(500)
COMMON /SCR1/ LINODE, INODE(500)
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /CREF/ LREF, PREF, REF(100)
COMMON /FACTS/ NAME, NOST, ITYPE, IASF
DATA ZERO(1)/0/
C NC IS CURRENT NODE, NP IS PREVIOUS NODE PROCESSED
NC = 0
10 NP = NC
OK = .TRUE.
AOK = .TRUE.
C
C SEARCH FOR NEXT NODE TO DO, NODE WITH LOWEST POSIT LEVEL IN INODE
C UPON ENTRY TO INVOKE, SUPEROOT IS -1, ASFS AND BLOCK DATA
C ARE -2. IF CANT FIND A POSITIVE LEVEL ARE DONE
C
L = PNODE - 1
DO 20 I=1,L
IF (INODE(I).LT.0) GO TO 20
NC = I
GO TO 40
20 CONTINUE
30 RETURN
40 J = NC
DO 50 I=J,L
IF (INODE(I).GE.0 .AND. INODE(I).LT.INODE(NC)) NC = I
50 CONTINUE
C READ IN SYMBOL TABLE FOR NODE(NC) AND POSITION REFS CORRECTLY
CALL RDSYM(NC, NP)
60 IF (INREF(I6)) 140, 140, 70
C HAVE A REFERENCE TO PROCESS
70 IF (IGATT1(REF(2),4).EQ.1) GO TO 80
C PROCESSING A DIRECT REFERENCE
C NEED ONLY PROCESS REF TEMPLATE IF ANY PROC ACTUAL ARGS IN REF
L = REF(2)
L = FINDND(DSA(L+4),K)
CALL PROC(NODE(NC), L, K, AOK)
IF (SYSERR .OR. ABORT) GO TO 30
GO TO 60
C PROCESSING AN INDIRECT REF
80 K = NODE(NC) + SYMLEN + 5
K = LAT(K)
IF (K.EQ.0) GO TO 150
C K PTS TO A TEMPLATE OF ACTUALS AT LAT(NODE(NC))
C L GIVES REL POSIT AMONG PROC DUMMIES IN LAT(NODE(NC))
C OF PROC DUMMY BEING CALLED
L = REF(2)
L = DSA(L+2)
I = NODE(NC) + SYMLEN + 1
I = LAT(I)
IF (L.EQ.1) GO TO 100
DO 90 M=2,L
I = LAT(I+3)
90 CONTINUE
C
C I PTS TO DUMMY PROC ARG ENTRY IN LAT
C
100 M = LAT(I+1) + K
M = LAT(M)
C M PTS TO ACTUAL SUBSTITUTABLE FOR I
L = FIND(M)
C RECURSION DUE TO INDIRECT REF COMPLETING THE LOOP
IF (-1.NE.INODE(L)) GO TO 110
ABORT = .TRUE.
CALL ERROR2(26H RECURSIVE LOOP INVOLVING , 26, DSA(NAME+4), 1,1,0)
CALL ERROR2(14H AND POSSIBLY , 14, LAT(M), 1, 0, 1)
GO TO 30
C NOTE NEED NOT WORRY ABOUT MISSING SUBPGM SINCE
C THEN ITS LAT INDEX COULDNOT BE IN TEMPLATE
110 IF (CHK1(NODE(NC),M).EQ.0) GO TO 130
C PROCESSED A LEGAL INDIRET REF
CALL SETPD(M, NODE(NC))
IF (SYSERR) GO TO 30
IF (-2.EQ.INODE(L) .OR. INODE(NC).LT.INODE(L)) GO TO 120
INODE(L) = INODE(NC) + 1
CALL ASLEV(L)
IF (ABORT .OR. SYSERR) GO TO 30
C LOOK FOR MORE ACTUALS
120 CALL PROC(NODE(NC), M, L, AOK)
IF (SYSERR .OR. ABORT) GO TO 30
130 K = LAT(K) + K
K = LAT(K)
IF (K) 60, 60, 100
C MARK CURRENT NODE DONE
140 INODE(NC) = -1
GO TO 10
150 IF (.NOT.OK) GO TO 60
K = NODE(NC)
CALL ERROR2(20H NO ACTUAL PROCS IN ,20, LAT(K), 1, 1, 0)
CALL ERROR2(28H CANNOT PROCESS FORMAL REFS , 28,
* ZERO, -3, 0, 1)
OK = .FALSE.
GO TO 60
END
C XXXXXRDSYM.f
SUBROUTINE RDSYM(IC, IP)
C
C PGM UNIT RDSYM POSITIONS I4,I6 CORRECTLY AND INPUTS SYMBOL
C TABLE OF PGM UNIT AT NODE(IC) WHEN LAST ONE READ WAS THAT OF NODE
C
INTEGER SYMLEN, PDSA, PLAT, FINDND, PNODE, DSA
LOGICAL INSYM, L
COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /HEAD/ LNODE, PNODE, NODE(500)
IF (IP.LT.IC) GO TO 10
REWIND I4
REWIND I6
10 L = INSYM(I6,0)
IF (FINDND(DSA(NAME+4),I).EQ.NODE(IC)) RETURN
20 IF (INREF(I6).EQ.1) GO TO 20
GO TO 10
END
C XXXXXPROC.f
SUBROUTINE PROC(IP, IM, IIM, OK)
C
C P.U. AT LAT(IP) CALLS P.U. AT LAT(IM) (NODE(IIM))
C PROC COLLECTS ACTUAL PROC TEMPLATE(S) FROM THE CALL IF IT CAN
C CHECKS FOR MISSING SUBPGMS AND STORES TEMPLATES OFF PGM UNIT
C AT LAT(IM), THEM PROC CALLS ASLEV TO READJUST LEVELS OF ACTUALS
C SENT TO LAT(IM) VS LEVEL (IM)
C
LOGICAL ERR, SYSERR, ABORT, OK
INTEGER STACK, SYMLEN, PDSA, DSA, REF, PREF, PNODE, PLAT, FINDND,
* FIND, SS(120), KBR(1)
COMMON /CEXPRS/ LSTACK, STACK(620)
COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /CREF/ LREF, PREF, REF(100)
COMMON /HEAD/ LNODE, PNODE, NODE(500)
COMMON /SCR1/ LINODE, INODE(500)
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /DETECT/ ERR, SYSERR, ABORT
EQUIVALENCE (SS(1),STACK(501))
DATA KBR(1) /0/
LSS = 501
C ARE THERE ARGS IN THIS REF
IF (REF(1).NE.0) GO TO 20
10 RETURN
C CYCLE THROUGH REF ARGS
C JJ IS LAST ENTRY IN REF FOR ARGS
C IS PTS TO FIRST FREE WD IN STACK
C MAX IS 1 IF NO DUMMY PROCS IN REF, ELSE IS EQUAL TO THE
C NUMBER OF ACTUAL PROCS SUBSTITUTABLE FOR THE DUMMY PROCS
20 JJ = REF(1) + 4
IS = 1
MAX = 0
DO 90 I=5,JJ,2
C SKIP OVER EXPR AS ACTUAL ARGS AND ALL ACTUALS BUT PROC ARGS
IF (REF(I).EQ.0) GO TO 90
IF (REF(I+1).NE.6) GO TO 90
C SEE IF ACTUAL ARG IS DUMMY PROC ARG AT LAT(IP)
C OR ACTUAL PROCEDURE
IF (IGATT1(REF(I),4).EQ.1) GO TO 40
C HAVE AN ACTUAL PROCEDURE
L = REF(I)
L = FINDND(DSA(L+4),K)
IF (L.NE.0) GO TO 30
C IF, AS GATHERING ACTUAL PROCS MATCHED TO DUMMY PROC ARGS
C PROC FINDS A MISSING SUBPROGM, PROCESSING OF THIS REF CEASES
L = REF(I)
CALL ERROR2(20H MISSING SUBPROGRAM , 20, DSA(L+4), 1, 1, 0)
CALL ERROR2(1H1, 0, REF(3), -1, 0, 1)
GO TO 10
30 IF (IS+2.GT.LSS) GO TO 200
C 2 WD STACK ENTRY FOR AN ACTUAL PROC AS AN ACTUAL ARG
C IS FIRST WD - 1, 2ND WD - LAT INDEX OF ACTUAL PROC
STACK(IS) = 1
STACK(IS+1) = L
IF (MAX.EQ.0) MAX = 1
IS = IS + 2
GO TO 90
C HAVE A DUMMY PROC CHECK OUT NO OF ACTUALS
C MATCHED TO IT AND STACK THOSE WITH COUNTER ON TOP
40 L = IP + SYMLEN + 5
L = LAT(L)
IF (L.NE.0) GO TO 50
IF (.NOT.OK) GOTO 10
CALL ERROR2(26H MISSING ACTUAL PROCEDURES ,26, KBR(1), -1,1,1)
OK = .FALSE.
GO TO 10
C COLLECT ACTUALS CORRESPONDING TO THIS PROC ARG
C K IS REL POSIT OF PROC ARG AMONG ALL ARGS AT LAT(IP)
C L PTS TO TEMPLATE AT LAT(IP)
50 K = REF(I)
K = DSA(K+2)
C J POINTS TO FIRST ELEMENT ON ARGLIST
J = IP + SYMLEN + 1
J = LAT(J)
IF (K.LE.1) GO TO 70
DO 60 LL=2,K
J = LAT(J+3)
60 CONTINUE
C K IS REL POSIT OF PROC ARG AMONG PROC ARGS IN LAT(IP)
C THAT IS IT IS OFFSET NECESS TO READ CORRESP ACTUAL
C PROCS OFF TEMPLATES AT LAT(IP)
C J POINTS TO DUMMY PROC ARG ENTRY IN LAT (IP)
70 K = LAT(J+1)
IF (IS+1.GE.LSS) GO TO 200
C J POINTS TO POSITION IN STACK OF COUNT OF HOW MANY
C ACTUALS ARE MATCHED TO THIS DUMMY
J = IS
STACK(IS) = 0
IS = IS + 1
80 IF (IS+1.GE.LSS) GO TO 200
C N WD STACK ENTRY FOR DUMMY PROC ARGS USED AS ACTUAL ARGS IN REF
C WD 1 CONTAINS NO OF ACTUAL PROCS MATCHED TO THE DUMMY
C WDS 2 - N CONTAIN THE LAT INDICES OF EACH ACTUAL PROC
STACK(J) = STACK(J) + 1
LL = K + L
STACK(IS) = LAT(LL)
IS = IS + 1
L = LAT(L) + L
L = LAT(L)
IF (L.NE.0) GO TO 80
IF (STACK(J).GT.MAX) MAX = STACK(J)
90 CONTINUE
C HAVE COLLECTED ALL PROC ACTUALS CORRESP TO THE PROC
C ARGS IN THE REF, NOTE MAX IS NO OF TEMPLATES RESULTING FROM
C THIS REF TO BE PASSED TO LAT(IM) AS LONG AS THEIR DUPS
C ARE NOT THERE ALREADY
C BUILD EACH TEMPLATE IN LOOP AND CHECK FOR DUPLICATION
C IF NOT THERE COPY INTO LAT OFF LAT(IM) AND CHECK LEVEL OF ACTUALS
C PASSED DOWN VS LEVEL OF LAT(IM)
IF (MAX.EQ.0) GO TO 10
DO 190 I=1,MAX
C CREATE PROC INDICES PORTION OF TEMPLATE IN SS
K = 1
ISS = 1
100 IF (K.GE.IS) GO TO 110
L = 1
IF (STACK(K).GT.1) L = I
IF (ISS+1.GE.120) GO TO 200
J = K + L
SS(ISS) = STACK(J)
K = K + STACK(K) + 1
ISS = ISS + 1
GO TO 100
C HAVE TEMPLATE IN SS(1) THROUGH SS(ISS-1)
C SEE IF IT HAS A DUPLICATE AT LAT(IM)
110 K = IM + SYMLEN + 5
K = LAT(K)
IST = ISS - 1
120 IF (K.EQ.0) GO TO 150
DO 130 L=1,IST
J = K + L
IF (LAT(J).NE.SS(L)) GO TO 140
130 CONTINUE
C FOUND DUPLICATE
GO TO 190
C HAVENT FOUND A DUPLICATE YET
C SEE IF THERE ARE MORE TEMPLATES TO COMPARE
140 K = LAT(K) + K
K = LAT(K)
GO TO 120
C NOT A DUPLICATE WILL ADD IT ON
150 IF (PLAT+IST+2.LE.LLAT) GO TO 160
CALL ERROR1(32H IN PROC, TABLE OVERFLOW OF LAT , 32)
SYSERR = .TRUE.
GO TO 10
C MAKE AN ENTRY CONSISTING OF 1ST WORD - NO OF PROCS+1, SUBSEQUENT
C WORDS - PROCS LAT INDICES, LAST WORD - PTR
C TO NEXT SUCH TEMPLATE
160 DO 170 L=1,IST
J = PLAT + L
LAT(J) = SS(L)
170 CONTINUE
LAT(PLAT) = IST + 1
L = PLAT
PLAT = PLAT + IST + 2
J = IM + SYMLEN + 5
LAT(PLAT-1) = LAT(J)
LAT(J) = L
C CHECK LEVELS
DO 180 L=1,IST
J = FIND(SS(L))
C FIND HEAD OF GREEN LINKS LIST AT LAT(IM)
JR = IM + SYMLEN + 3
JLR = -SS(L)
210 IF(LAT(JR+1) .LE. 0) GOTO 220
JR = LAT(JR+1)
GOTO 210
C HAVE TOP OF GREEN LINKS LIST AT LAT(JR)
220 IF(LAT(JR+1) .EQ. 0) GOTO 230
JR = IABS( LAT(JR+1) )
C LOOK FOR DUPLICATE ENTRY ON GREEN LINKS LIST
IF(LAT(JR) .EQ. JLR) GOTO 240
GOTO 220
C ADD ON ENTRY TO GREEN LINKS LIST
230 IF(PLAT + 2 .GT. LLAT) GOTO 250
LAT(PLAT) = JLR
LAT(PLAT+1) = 0
LAT(JR+1) = -PLAT
PLAT = PLAT+2
240 IF((-1).EQ.INODE(J) .OR. (-2).EQ.INODE(J) .OR.
* INODE(J).GT.INODE(IIM)) GOTO 180
INODE(J) = INODE(IIM) + 1
CALL ASLEV (-J)
IF (SYSERR .OR. ABORT) GO TO 10
180 CONTINUE
190 CONTINUE
GO TO 10
200 SYSERR = .TRUE.
CALL ERROR1(33H IN PROC, TABLE OVERFLOW OF STACK, 33)
GO TO 10
250 SYSERR = .TRUE.
CALL ERROR1(31H IN PROC, TABLE OVERFLOW OF LAT,31)
GOTO 10
END
C XXXXXCHKALL.f
SUBROUTINE CHKALL
C
C CHKALL READS IN REFS FROM OUTUT4 AND CHECKS THEM
C EXPANDS ALL INDIRECTS AND CHECKS THEM, IF ALL OK
C WRITES THE EXPANDED VERSION OUT ON OUTUT3
C TEMPLATE WRITTEN OUT CONSISTS OF
C PREF - NO OF WORDS TO FOLLOW
C IBR - CODE .LT.3 TO SHOW OK REF
C REF(1) - 2*NO OF ARGS
C IJR - LAT INDEX OF CALLED P.U.
C REF(3) - STMT NO OF REF
C REF(4) - CODE 0-SUBR, 1-FCN
C REF(5 -) - ARG ENTRIES
C FOR DIRECT REFS IF OK WRITES THE DIRECT REF OUT ON OUTUT3
C CHKALL WRITES END OF REFS ON OUTUT3 BEFORE RETURNING
C
INTEGER OUTUT3, OUTUT4, DSA, PDSA, REF, PREF, PLAT, SYMLEN, FINDND
INTEGER CHK1, CHK2
LOGICAL ERR, SYSERR, ABORT, QP2, QBR
COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, OUTUT3, OUTUT4
COMMON /CTABL/ LDSA, PDSA, DSA(5000)
COMMON /CREF/ LREF, PREF, REF(100)
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
COMMON /DETECT/ ERR, SYSERR, ABORT
COMMON /FACTS/ NAME, NOST, ITYP, IASF
COMMON /PASS/ QP2, QBR
DATA IBR /1/, JBR /3/
C IJK IS CALLING PGM UNIT; IJR IS PGM UNIT CALLED
IJK = FINDND(DSA(NAME+4),L1)
10 IF (INREF(OUTUT4)) 20, 20, 30
C WRITE END OF REFS AND RETURN
20 WRITE (OUTUT3) IBR, JBR, IBR
QBR = .FALSE.
RETURN
C CHECK IF REF INDIRECT OR DIRECT
30 IF (IGATT1(REF(2),4).EQ.1) GO TO 40
C HAVE A DIRECT REF
IJR = REF(2)
IJR = FINDND(DSA(IJR+4),L1)
IBAR = CHK2(IJK,IJR)
IF (SYSERR) GO TO 20
IF (IBAR.EQ.1) WRITE (OUTUT3) PREF, IBR, REF(1), IJR,
* (REF(L),L=3,PREF)
GO TO 10
C HAVE AN INDIRECT REF
40 K = IJK + SYMLEN + 5
K = LAT(K)
C NOTE HAVE FLAGGED THIS ERROR OF NO ACTUALS AT LAT(IM)
C BEFORE IN PROC SO NOW SKIP OVER REF
IF (K.EQ.0) GO TO 10
C K POINTS TO ACTUALS TEMPLATE AT CALLING PGM
L = REF(2)
L = DSA(L+2)
J = IJK + SYMLEN + 1
J = LAT(J)
IF (L.LE.1) GO TO 60
DO 50 LL=2,L
J = LAT(J+3)
50 CONTINUE
60 L = LAT(J+1)
C L IS OFFSET IN ACTUALS TEMPLATE OF ACTUALS
C CORRESP TO THIS DUMMY
70 J = K + L
IJR = LAT(J)
QBR = .TRUE.
IF (CHK1(IJK,IJR).NE.1) GO TO 80
IBAR = CHK2(IJK,IJR)
IF (SYSERR) GO TO 20
IF (IBAR.EQ.1) WRITE (OUTUT3) PREF, IBR, REF(1), IJR,
* (REF(L),L=3,PREF)
80 QBR = .FALSE.
K = LAT(K) + K
K = LAT(K)
IF (K) 10, 10, 70
END
C XXXXXCHK3.f
SUBROUTINE CHK3(IDUM, IACT, IDUM8, IACT8, IE, R, NO)
C
C CHECKS PROC ARGUMENTS FOR PROPER USAGE AND TYPE
C IDUM LAT INDEX DUMY PROC ARG
C IACT LAT INDEX ACTUAL PROC
C IDUM8 USAGE DUMMY FROM DSA ATTRIBUTES
C IACT8 USAGE ACTUAL FROM LAT ENTRY
C IE CALLED RTNE
C R STMT NO OF CALL
C NO CONTAINS THE NUMBER OF PARAMETER BEING CHECKED BY THIS CALL
C
INTEGER PLAT, R(1), SYMLEN, NO(1)
COMMON /PARAMS/ I1, I2, I3, SYMLEN, I4, I5, I6
COMMON /GRAPH/ LLAT, PLAT, LAT(6000)
C SEPARATE OUT EXTERNAL ENTITIES
IF (IDUM8.NE.13) GO TO 20
L = IGATT2(IDUM,1)/8
IF (L.NE.1) GO TO 50
C FURTHER CHECK THAT EPLICITLY TYPED EXTERNAL ENTITIES
C MATCH FCNS
IF (IACT8.NE.1 .AND. IACT8.NE.6) GO TO 30
C CHECK FCN HAS SAME TYPE ACROSS REF BNDRY
10 L = IACT + SYMLEN + 6
IF (MOD(IGATT2(IDUM,1),8).EQ.LAT(L)/8) GO TO 50
CALL ERROR2(40H INCONSISTENT FCN TYPES IN REFERENCE TO , 40,
* LAT(IE), 1, 1, 0)
CALL ERROR2(1H1, 0, R(1), -1, 0, 1)
GO TO 50
C CHECK SUBROUTINES
20 IF (IDUM8.EQ.6 .AND. IACT8.EQ.0) GO TO 50
C CHECK OUT FCNS
IF (IDUM8.EQ.5 .AND. IACT8.EQ.1) GO TO 10
C SEPARATE OUT BASIC EXTERNALS BECAUSE THEY ARE CONSIDERED
C TYPED BY THE FORTRAN.
IF (IDUM8.EQ.5 .AND. IACT8.EQ.6) GO TO 40
30 CALL ERROR2(
* 50H INCOMPATIBLE PROCEDURE PARAMETER ASSOCIATED WITH ,50,
* NO, -2, 1, 0)
CALL ERROR2(17H IN REFERENCE TO ,17, LAT(IE), 1, 0, 0)
CALL ERROR2(1H1, 0, R(1), -1, 0, 1)
GO TO 50
C CHECK BASIC EXTER HAS NOT BEEN EXPLICITLY TYPED
C OR ELSE IT HAS TO AGREE WITH THE ACTUAL TYPE
40 L = IACT + SYMLEN + 6
IF (LAT(L)/8.EQ.1) GO TO 10
50 RETURN
END
combine done
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.