home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume12 / ffccc / part03 < prev    next >
Encoding:
Text File  |  1990-05-14  |  30.4 KB  |  924 lines
  1. Newsgroups: comp.sources.misc
  2. organization: CERN, Geneva, Switzerland
  3. keywords: fortran
  4. subject: v12i089: REPOST Floppy - Fortran Coding Convention Checker Part 03/11
  5. from: julian@cernvax.cern.ch (julian bunn)
  6. Sender: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc)
  7.  
  8. Posting-number: Volume 12, Issue 89
  9. Submitted-by: julian@cernvax.cern.ch (julian bunn)
  10. Archive-name: ffccc/part03r
  11.  
  12. #!/bin/sh
  13. echo 'Start of Floppy, part 03 of 11:'
  14. echo 'x - CUSSTMT.h'
  15. sed 's/^X//' > CUSSTMT.h << '/'
  16. X*IF DEF,NEVER   
  17. X*-----------------------------------------------------------------------
  18. X*   ISGLOB  = running count of statements in source deck
  19. X*   ICLOLD  = the class (ICLASS) of the last EXECUTABLE statement   
  20. X*   NFIOLD  = the line number of the last statement in the module   
  21. X*   NFAULT  = the number of WARNINGS in the module so far   
  22. X*   RPROCS  = set .TRUE. if module is to be processed   
  23. X*-----------------------------------------------------------------------
  24. X*EI 
  25. /
  26. echo 'x - URTERM.f'
  27. sed 's/^X//' > URTERM.f << '/'
  28. X      SUBROUTINE URTERM 
  29. X*-----------------------------------------------------------------------
  30. X*   
  31. X*--- user routine termination   
  32. X*   
  33. X*-----------------------------------------------------------------------
  34. X      include 'PARAM.h' 
  35. X      include 'ALCAZA.h' 
  36. X      include 'CLASS.h' 
  37. X      include 'CURSTA.h' 
  38. X      include 'FLWORK.h' 
  39. X      include 'KEYCOM.h' 
  40. X      include 'TYPDEF.h' 
  41. X      include 'JOBSUM.h' 
  42. X      include 'STATE.h' 
  43. X      include 'FLAGS.h' 
  44. X      include 'USGCOM.h' 
  45. X      include 'USCOMN.h' 
  46. X      include 'USSTMT.h' 
  47. X      include 'USIGNO.h' 
  48. X      include 'USUNIT.h' 
  49. X      include 'USARGS.h' 
  50. X      include 'CHECKS.h' 
  51. X      PARAMETER (NFS=28)
  52. X      DIMENSION IB(21)  
  53. X      CHARACTER*(MXNMCH) CNAM,CNAMOL
  54. X      CHARACTER*1 CFRST 
  55. X      CHARACTER*6 CFORT(NFS)
  56. X      CHARACTER*131 CZUN
  57. X      LOGICAL LIMPNO,BTEST  
  58. X      DATA CFORT /'ASSIGN', 'CALL  ','COMMON','CLOSE ', 'DATA  ',   
  59. X     +'DO    ','DECODE','DOUBLE', 'END   ','ENDIF ','ENTRY ', 'ELSE  ', 
  60. X     +'ELSEIF','ENCODE','FORMAT', 'GOTO  ','IF    ', 'OPEN  ','PRINT ', 
  61. X     +'PAUSE ', 'PUNCH ','READ  ','REAL  ','RETURN', 'REWIND','SAVE  ', 
  62. X     +'STOP  ','WRITE '/
  63. XC   
  64. X      IF(UNFLP) RETURN  
  65. X      WRITE(MZUNIT,500) NFAULT  
  66. X      WRITE(MZUNIT,560) 
  67. XC Update statement number for input file
  68. X      ISGLOB = ISGLOB + NLINES - 1  
  69. X      NGLOBF = 0
  70. XC Check that module is to be processed  
  71. X      IF(.NOT.RPROCS)                                           GOTO 190
  72. XC Check for comment lines after end of module   
  73. X      IF(LCHECK(1).AND.NLINES-1.GT.NFIOLD) THEN 
  74. X         WRITE(MZUNIT,570)  
  75. X         NGLOBF = NGLOBF + 1
  76. X      ENDIF 
  77. XC Check that module ended with END  
  78. X      IF(LCHECK(2).AND.ICLOLD.NE.IEND) THEN 
  79. X         WRITE(MZUNIT,580)  
  80. X         NGLOBF = NGLOBF + 1
  81. X      ENDIF 
  82. X      IF(LCHECK(3)) THEN
  83. XC Check for COMMON blocks remaining unused  
  84. X         DO 20 IC=1,NCOMT   
  85. X            IF(ICTITL(IC).GT.0) THEN
  86. X               LEN=INDEX(SCTITL(IC),' ')-1  
  87. X               DO 10 IGN=1,NIGNOR   
  88. X                  IF(LIGNOR(IGN).NE.LEN)                         GOTO 10
  89. X                  IF(SCTITL(IC)(:LEN).EQ.CIGNOR(IGN)(:LEN))      GOTO 20
  90. X   10          CONTINUE 
  91. X               WRITE(MZUNIT,590) SCTITL(IC) 
  92. X               NGLOBF = NGLOBF + 1  
  93. X            ENDIF   
  94. X   20    CONTINUE   
  95. X      ENDIF 
  96. XC Check that COMPLEX and DOUBLE PRECISION variables occur   
  97. XC at the start of a COMMON block
  98. X      IF(LCHECK(4)) THEN
  99. X         CNAMOL = '        '
  100. X         DO 70 IC=1,NCOMN   
  101. X            IF(SCTITL(ICNAME(IC)).NE.CNAMOL) THEN   
  102. XC Change of COMMON block name ... reset counters
  103. XC NLAST = 1 signifies last variable in common was real/doublep  
  104. XC NLAST = 0 signifies otherwise 
  105. X               CNAMOL = SCTITL(ICNAME(IC))  
  106. X               NLAST = 1
  107. X            ENDIF   
  108. X            CNAM = SCNAME(IC)   
  109. X            ILEN = INDEX(CNAM,' ')  
  110. XC Search for NAMTYP 
  111. X            MATCH = 0   
  112. X            DO 30 IN=1,NRNAME   
  113. X               IF(ILEN.NE.INDEX(SNAMES(IN+IRNAME),' '))          GOTO 30
  114. X               IF(CNAM.NE.SNAMES(IN+IRNAME))                     GOTO 30
  115. X               NTYP = NAMTYP(IN+IRNAME) 
  116. XC The variable must be a COMMON variable (not a dimensionality) 
  117. X               IF(.NOT.BTEST(NTYP,19))                           GOTO 40
  118. X               MATCH = 1
  119. X                                                                 GOTO 40
  120. X   30       CONTINUE
  121. X   40       IF(MATCH.EQ.0)                                       GOTO 70
  122. X            IF(.NOT.BTEST(NTYP,3).AND..NOT.BTEST(NTYP,4)) THEN  
  123. X               NLAST = 0
  124. X            ELSE IF(NLAST.EQ.0) THEN
  125. X               DO 50 IGN=1,NIGNOR   
  126. X                  IF(LIGNOR(IGN).NE.INDEX(CNAM,' ')-1)           GOTO 50
  127. X                  IF(CNAM(:LIGNOR(IGN)).EQ.CIGNOR(IGN)(:LIGNOR(IGN)))   
  128. X     +                                                           GOTO 60
  129. X   50          CONTINUE 
  130. X               WRITE(MZUNIT,600) CNAM,CNAMOL
  131. X               NGLOBF = NGLOBF + 1  
  132. X   60          NLAST = 0
  133. X            ENDIF   
  134. X   70    CONTINUE   
  135. X      ENDIF 
  136. XC Check for clashes in COMMON definitions   
  137. X      IF(LCHECK(5)) THEN
  138. X         DO 140 IT=1,NCOMT  
  139. X            ILEN1 = INDEX(SCTITL(IT),' ')-1 
  140. X            DO 80 IGN=1,NIGNOR  
  141. X               IF(LIGNOR(IGN).NE.ILEN1)                          GOTO 80
  142. X               IF(SCTITL(IT)(:ILEN1).EQ.CIGNOR(IGN)(:ILEN1))    GOTO 140
  143. X   80       CONTINUE
  144. X            IFOUN = 0   
  145. X            DO 110 ITG=1,NGCOT  
  146. X               ILEN2 = INDEX(SGCTIT(ITG),' ')-1 
  147. X               IF(ILEN2.NE.ILEN1)                               GOTO 110
  148. X               IF(SCTITL(IT).NE.SGCTIT(ITG))                    GOTO 110
  149. X               IFOUN = 1
  150. X               IST1 = IABS(ICTITL(IT))  
  151. X               IST2 = IABS(IGCTIT(ITG)) 
  152. X               DO 90 IN1=IST1,NCOMN 
  153. X                  IF(ICNAME(IN1).NE.IT.AND.IGCNAM(IST2+IN1-IST1). EQ.   
  154. X     +            ITG) THEN 
  155. X                     WRITE(MZUNIT,510) SCTITL(IT)   
  156. X                     NGLOBF = NGLOBF + 1
  157. X                                                                GOTO 100
  158. X                  ENDIF 
  159. X                  IF(ICNAME(IN1).NE.IT)                         GOTO 100
  160. X                  IF(IGCNAM(IST2+IN1-IST1).NE.ITG.OR. SCNAME(IN1).NE.   
  161. X     +            SGCNAM (IST2+IN1-IST1)) THEN  
  162. X                     WRITE(MZUNIT,510) SCTITL(IT)   
  163. X                     NGLOBF = NGLOBF + 1
  164. X                                                                GOTO 100
  165. X                  ENDIF 
  166. X   90          CONTINUE 
  167. X  100          CONTINUE 
  168. X  110       CONTINUE
  169. X            IF(IFOUN.EQ.0) THEN 
  170. X               NGCOT = NGCOT + 1
  171. X               IF(NGCOT.GT.MGCOT) THEN  
  172. X                  WRITE(MZUNIT,520) 
  173. X                                                                GOTO 140
  174. X               ENDIF
  175. X               SGCTIT(NGCOT) = SCTITL(IT)   
  176. X               IST1 = NGCON + 1 
  177. X               IGCTIT(NGCOT) = -IST1
  178. X               IST2 = IABS(ICTITL(IT))  
  179. X               IMX = NCOMN-IST2+1   
  180. X               DO 120 INEW=1,IMX
  181. X                  IF(ICNAME(IST2+INEW-1).NE.IT)                 GOTO 130
  182. X                  IF(NGCON.GE.MGCON) THEN   
  183. X                     WRITE(MZUNIT,530)  
  184. X                                                                GOTO 130
  185. X                  ENDIF 
  186. X                  NGCON = NGCON + 1 
  187. X                  IGCNAM(NGCON) = NGCOT 
  188. X                  SGCNAM(NGCON) = SCNAME(IST2+INEW-1)   
  189. X  120          CONTINUE 
  190. X  130          CONTINUE 
  191. X            ENDIF   
  192. X  140    CONTINUE   
  193. X      ENDIF 
  194. XC Make second pass over statements in this module to check  
  195. XC for statement function definitions and correct ordering   
  196. XC of all statements 
  197. XC   
  198. XC Also check argument types of module (dimensionality etc)  
  199. XC   
  200. X      CALL SECPAS(NGLOBF,LIMPNO)
  201. XC Loop over routine names   
  202. X      DO 180 IN=1,NRNAME
  203. XC Skip GEANT3 names if flag GALEPH  
  204. X         CNAM = SNAMES(IRNAME+IN)   
  205. X         IF(GALEPH) THEN
  206. X            IF(CNAM(1:1).EQ.'G'.OR.CNAM(2:2).EQ.'G')            GOTO 180
  207. X         ENDIF  
  208. X         DO 150 IGN=1,NIGNOR
  209. X            IF(LIGNOR(IGN).NE.INDEX(SNAMES(IRNAME+IN),' ')-1)   GOTO 150
  210. X            IF(CNAM(:LIGNOR(IGN)).EQ.CIGNOR(IGN)(:LIGNOR(IGN))) GOTO 180
  211. X  150    CONTINUE   
  212. X         NTYP = NAMTYP(IRNAME+IN)   
  213. X         DO 160 II=1,21 
  214. XC Interrogate bit pattern for type of name IN   
  215. X            IB(II)=0
  216. X            IF(BTEST(NTYP,II-1)) THEN   
  217. X               IB(II)=1 
  218. X            ENDIF   
  219. X  160    CONTINUE   
  220. XC now extract the first blank in the name   
  221. X         ILEN = INDEX(CNAM,' ')-1   
  222. X         IF((ILEN.GT.6.OR.ILEN.EQ.-1).AND.LCHECK(6)) THEN   
  223. X            WRITE(MZUNIT,620) CNAM  
  224. X            NGLOBF = NGLOBF + 1 
  225. X         ENDIF  
  226. XC now enforce some rules
  227. X         IF(IB(20).EQ.1.AND.LCHECK(7).AND.ILEN.NE.6) THEN   
  228. XC in a common block 
  229. X            WRITE(MZUNIT,630) CNAM  
  230. X            NGLOBF = NGLOBF + 1 
  231. X         ENDIF  
  232. X         IF(LCHECK(8).AND.ILEN.GE.6.AND.IB(8)+IB(10)+IB(11)+IB(12)+ IB  
  233. X     +   (13)+IB(14)+IB(15)+IB(16)+IB(17)+IB(20).EQ.0) THEN 
  234. XC variable name in routine (not COMMON,FUNCTION etc)
  235. X            WRITE(MZUNIT,640) CNAM  
  236. X            NGLOBF = NGLOBF + 1 
  237. X         ENDIF  
  238. X         IF(LCHECK(43).AND.ILEN.GE.6.AND.IB(8)+IB(10)+IB(11)+IB(12)+ IB 
  239. X     +   (13)+IB(14)+IB(15)+IB(16)+IB(17)+IB(20)+IB(7).EQ.0) THEN   
  240. XC variable name in routine (not COMMON,FUNCTION,PARAMETER etc)  
  241. X            WRITE(MZUNIT,640) CNAM  
  242. X            NGLOBF = NGLOBF + 1 
  243. X         ENDIF  
  244. X         CFRST = CNAM(1:1)  
  245. X         IF(LCHECK(9).AND.IB(1).EQ.1.AND..NOT.LIMPNO) THEN  
  246. XC integer name  
  247. X            IF(CFRST.NE.'I'.AND.CFRST.NE.'J'. AND.CFRST.NE.'K'.AND. 
  248. X     +      CFRST .NE.'L'. AND.CFRST.NE.'M'.AND.CFRST.NE.'N') THEN  
  249. X    
  250. X               WRITE(MZUNIT,650) CNAM   
  251. X               NGLOBF = NGLOBF + 1  
  252. X            ENDIF   
  253. X         ENDIF  
  254. X         IF(LCHECK(9).AND.IB(2).EQ.1.AND..NOT.LIMPNO) THEN  
  255. XC real name 
  256. X            IF(CFRST.EQ.'I'.OR.CFRST.EQ.'J'.OR.CFRST.EQ.'K'. OR.CFRST.  
  257. X     +      EQ . 'L'.OR.CFRST.EQ.'M'.OR.CFRST.EQ.'N') THEN  
  258. X               WRITE(MZUNIT,660) CNAM   
  259. X               NGLOBF = NGLOBF + 1  
  260. X            ENDIF   
  261. X         ENDIF  
  262. XC now check that the variable isn't a FORTRAN key-word  
  263. XC Except in the case of 'REAL' which is a KEYWORD and a generic function
  264. X         IF(LCHECK(10)) THEN
  265. X            IF(CNAM.EQ.'REAL    ')                              GOTO 180
  266. X            DO 170 II=1,NFS 
  267. X               ILENF = INDEX(CFORT(II),' ')-1   
  268. X               IF(ILENF.LE.0) ILENF = 6 
  269. X               IF(ILENF.NE.ILEN)                                GOTO 170
  270. X               IF(CNAM.EQ.CFORT(II)) THEN   
  271. X                  WRITE(MZUNIT,670) CNAM,CFORT(II)  
  272. X                  NGLOBF = NGLOBF + 1   
  273. X               ENDIF
  274. X  170       CONTINUE
  275. X         ENDIF  
  276. XC   
  277. X  180 CONTINUE  
  278. X      WRITE(MZUNIT,540) NGLOBF  
  279. X      WRITE(MZUNIT,680) SCROUT  
  280. XC Now rewind MZUNIT and check for non-zero errors before
  281. XC  copying to MPUNIT
  282. X  190 CONTINUE  
  283. X      REWIND(MZUNIT)
  284. X      IF(NGLOBF+NFAULT.NE.0.AND.RPROCS) THEN
  285. X  200    READ(MZUNIT,550,ERR=210,END=210) CZUN  
  286. X         WRITE(MPUNIT,550) CZUN 
  287. X                                                                GOTO 200
  288. X  210    REWIND(MZUNIT) 
  289. X         ENDFILE(MZUNIT)
  290. X         REWIND(MZUNIT) 
  291. X      ENDIF 
  292. XC Reset NFAULT to zero ready for next module
  293. X      NFAULT = 0
  294. X      RPROCS = .TRUE.   
  295. X  500 FORMAT(/,1X,'!!! ',I3,' STATEMENT WARNING(S) IN THIS MODULE ')
  296. X  510 FORMAT(1X,'!!! WARNING ... COMMON ',A,
  297. X     +' HAS CHANGED IN DEFINITION') 
  298. X  520 FORMAT(1X,'!!! NON-FATAL ERROR IN URTERM . MGCOT EXCEEDED')   
  299. X  530 FORMAT(1X,'!!! NON-FATAL ERROR IN URTERM . MGCON EXCEEDED')   
  300. X  540 FORMAT(/,1X,'!!! ',I3,' GLOBAL WARNING(S) IN THIS MODULE ')   
  301. X  550 FORMAT(A131)  
  302. X  560 FORMAT(/,1X,'BEGIN GLOBAL CHECKS WITHIN THIS MODULE',/)   
  303. X  570 FORMAT(1X,'!!! WARNING ... AVOID COMMENT LINES AFTER END')
  304. X  580 FORMAT(1X,'!!! WARNING ... MODULE DOES NOT HAVE "END"')   
  305. X  590 FORMAT(1X,'!!! WARNING ... COMMON ',A,
  306. X     +' DECLARED BUT NOT USED IN THIS MODULE')  
  307. X  600 FORMAT(1X,'!!! WARNING ... VARIABLE ',A, ' IN COMMON ',A, 
  308. X     +',COMPLEX OR DOUBLE PRECISION, SHOULD BE AT START OF COMMON') 
  309. X  610 FORMAT(1X,'!!! WARNING ... VARIABLE ',A,  
  310. X     +' CONTAINS "$" AND IS ILLEGAL')   
  311. X  620 FORMAT(1X,'!!! WARNING ... VARIABLE ',A,  
  312. X     +' HAS LENGTH OF >6 CHARACTERS')   
  313. X  630 FORMAT(1X,'!!! WARNING ... VARIABLE ',A,  
  314. X     +' IS IN COMMON AND IS NOT 6 CHARACTERS LONG') 
  315. X  640 FORMAT(1X,'!!! WARNING ... VARIABLE ',A,  
  316. X     +' IS A VARIABLE WITH LENGTH >5')  
  317. X  650 FORMAT(1X,'!!! WARNING ... VARIABLE ',A,  
  318. X     +' IS INTEGER BUT DOES NOT START I -> N')  
  319. X  660 FORMAT(1X,'!!! WARNING ... VARIABLE ',A,  
  320. X     +' IS REAL BUT STARTS WITH I -> N')
  321. X  670 FORMAT(1X,'!!! WARNING ... VARIABLE ',A,  
  322. X     +' CLASHES WITH FORTRAN KEY-WORD ',A6) 
  323. X  680 FORMAT(1X,20('+'), ' END MODULE CHECKS            ',10('+'),  
  324. X     +/,1X,20(' '), ' FOR ',A,//)   
  325. X      END   
  326. /
  327. echo 'x - floppy.o'
  328. sed 's/^X//' > floppy.o << '/'
  329. XPPPM<~]H]P{o}VZQZM(~oDPZ+]]l[PPPM`~TMd~TMh~TMl~TMp~TMx~TM$|]P]P{oz] A$|]P]P]HUM |o(o-[P]PA[P]P{ow]]$]+hP]PA~[P]P]HUP    o]Adx]P]P]H"]P]P{o%o]]Ho0k]At]P]P]HPMtsA~[PPPMlsPMxs^o3
  330. P]PAYr]P]P]Ho XX{of]]p~AP~]P]P{odUP    o{~]P]P{o bUPoXm]P]PAPm]P]PAam]P]P{ow`]]ile  Tidied Fortran: E 99TATEMENTS,GOTO;UT,FULL,COMPRESS;GXXXXXXXXXXXXXXXXXXXXXXXXXXXX XXX
  331. jXXXXXXXXXXXXXXX.46/
  332. echo 'x - floppy.rexx'
  333. sed 's/^X//' > floppy.rexx << '/'
  334. X/***********************************************************************/
  335. X/* FLOPPY exec                                                         */
  336. X/*                                                                     */
  337. X/* JJB May 1987                                                        */
  338. X/***********************************************************************/
  339. Xaddress 'COMMAND'
  340. Xsignal on novalue
  341. Xparse source . . execname .
  342. Xfnin = " "; ftin = "FORTRAN"; fmin = "A"
  343. Xfnold = ""; ftold = "FLOPIGN"; fmold = "A"
  344. Xtree = "NO"; checks = "STANDARD"; ignore = "NO"
  345. Xflopo = "YES"; full = "NO"; tidy = "NO"
  346. Xfntdy = "OUTPUT"; fttdy = "FORTRAN"; fmtdy = "A"
  347. Xgotos = "NO"; indent = "NO"; spaces = 3; groupf = "NO"
  348. Xrenums = "NO"; renumf = "NO"; startf = 500; stepf = 10
  349. Xstarts = 10; steps = 10
  350. X 
  351. Xoptset = "CHECKS IGNORE TREE DISK FULL GOTOS INDENT GROUPF"
  352. Xoptset = optset "RENUMF RENUMS OLD OUTPUT TIDY"
  353. Xsngset = "TREE DISK FULL GOTOS GROUPF IGNORE TIDY"
  354. X 
  355. X 
  356. Xerr = "Name of source Fortran file not yet given."
  357. Xcursor = "0001"
  358. Xinteractive = "YES"
  359. Xparse upper arg input
  360. Xparse value input with filename '(' options
  361. Xxx = 'XPARSE'(filename,'A')
  362. X 
  363. X/***********************/
  364. X/* LINE MODE TREATMENT */
  365. X/***********************/
  366. X 
  367. Xif A.0 ^= 0 then do
  368. X   interactive = "NO"
  369. X   if A.1 = "?" then do; ADDRESS CMS 'HELP 'execname; signal EXIT; end
  370. X   fnin = A.1
  371. X   if A.0 > 1 then ftin = A.2
  372. X   if A.0 > 2 then fmin = A.3
  373. X   if A.0 > 3 then do
  374. X      err = "Too many parameters given :" A.4
  375. X      signal EXIT
  376. X   end
  377. X   nopts = words(options)
  378. X   iopt = 0 ; err = " " ; flopo = "NO"
  379. X   do forever
  380. X      iopt = iopt + 1 ; if iopt > nopts then leave
  381. X      if find(optset,word(options,iopt))= 0 then do
  382. X         err = "Unidentified option on command line: "word(options,iopt)
  383. X         signal EXIT
  384. X      end
  385. X      if find(sngset,word(options,iopt)) ^= 0 then do
  386. X         interpret word(options,iopt)||'="YES"'
  387. X         if abbrev(word(options,iopt),"DISK",4) then flopo = "YES"
  388. X         iterate
  389. X      end
  390. X      if iopt < nopts then do
  391. X         key = word(options,iopt) ; val = word(options,iopt+1)
  392. X         if abbrev(key,"OLD",3) then do
  393. X            if iopt + 3 > nopts then do
  394. X               err = "Specify full file name for OLD file."
  395. X               signal EXIT
  396. X            end
  397. X            fnold = val
  398. X            ftold = word(options,iopt+2)
  399. X            fmold = word(options,iopt+3)
  400. X            iopt = iopt + 2
  401. X         end
  402. X         if abbrev(key,"OUT",3) then do
  403. X            if iopt + 3 > nopts then do
  404. X               err = "Specify full file name for OUTPUT file."
  405. X               signal EXIT
  406. X            end
  407. X            fntdy = val
  408. X            fttdy = word(options,iopt+2)
  409. X            fmtdy = word(options,iopt+3)
  410. X            iopt = iopt + 2
  411. X         end
  412. X         if abbrev(key,"CHEC",4) then checks = val
  413. X         if abbrev(key,"INDE",4) then do
  414. X            spaces = val
  415. X            indent = "YES"
  416. X         end
  417. X         if abbrev(key,"RENUMF",6) then do
  418. X            /* renumber FORMAT statements. Get the step and start. */
  419. X            ipos = pos(",",val,1)
  420. X            if ipos = 0 then startf = val
  421. X            else do
  422. X               startf = substr(val,1,ipos-1)
  423. X               stepf  = substr(val,ipos+1)
  424. X            end
  425. X            renumf = "YES"
  426. X         end
  427. X         if abbrev(key,"RENUMS",6) then do
  428. X            /* renumber other statements. Get the step and start. */
  429. X            ipos = pos(",",val,1)
  430. X            if ipos = 0 then starts = val
  431. X            else do
  432. X               starts = substr(val,1,ipos-1)
  433. X               steps  = substr(val,ipos+1)
  434. X            end
  435. X            renums = "YES"
  436. X         end
  437. X         iopt = iopt + 1
  438. X         iterate
  439. X      end
  440. X      if iopt = nopts then do
  441. X         err = 'Missing value for option 'word(options,iopt)
  442. X         signal EXIT
  443. X      end
  444. X   end
  445. Xend
  446. X 
  447. X/****************/
  448. X/* GENERAL MODE */
  449. X/****************/
  450. X 
  451. XSTART:
  452. Xif interactive = "NO" then signal CHECK
  453. Xif ^'QCONSOLE'('GRAPHIC') then do
  454. X   err = 'Not a full screen device'
  455. X   signal EXIT
  456. Xend
  457. Xdo forever
  458. X   signal off error
  459. X   'IOS3270' execname 'PANEL ;PANEL1 (CLEAR 'cursor
  460. X/* signal on error    ios3270 gives codes that aren't errors...*/
  461. X   if IOSK = 'PF03' then do; err = ' '; signal EXIT; end
  462. X   if IOSK = 'PF02' then do
  463. X      say "Enter the CMS command :"
  464. X      parse pull command
  465. X      signal off error; ADDRESS CMS command; signal on error
  466. X      say "Continue with "execname" ? [CR=YES]"
  467. X      parse upper pull answer
  468. X      if abbrev(answer,"N",1) then signal EXIT
  469. X      iterate
  470. X   end
  471. X   if IOSK = 'PF01' then do
  472. X      /* extract cursor position and find appropriate part of help */
  473. X      row = substr(IOSC,1,2) ; col = substr(IOSC,3,2)
  474. X      cursor = IOSC
  475. X      if row = 5 then do
  476. X         push 'FIND FLOPPY'
  477. X         ADDRESS CMS 'XEDIT 'execname' HELPCMS'
  478. X         iterate
  479. X      end
  480. X      if row = 7 then do
  481. X         push 'FIND OLD'
  482. X         ADDRESS CMS 'XEDIT 'execname' HELPCMS'
  483. X         iterate
  484. X      end
  485. X      if row = 8 then do
  486. X         push 'FIND CHECKS'
  487. X         ADDRESS CMS 'XEDIT 'execname' HELPCMS'
  488. X         iterate
  489. X      end
  490. X      if row = 9 then do
  491. X         push 'FIND IGNORE'
  492. X         ADDRESS CMS 'XEDIT 'execname' HELPCMS'
  493. X         iterate
  494. X      end
  495. X      if row = 11 then do
  496. X         push 'FIND TREE'
  497. X         ADDRESS CMS 'XEDIT 'execname' HELPCMS'
  498. X         iterate
  499. X      end
  500. X      if row = 13 then do
  501. X         push 'FIND DISK'
  502. X         ADDRESS CMS 'XEDIT 'execname' HELPCMS'
  503. X         iterate
  504. X      end
  505. X      if row = 14 then do
  506. X         push 'FIND FULL'
  507. X         ADDRESS CMS 'XEDIT 'execname' HELPCMS'
  508. X         iterate
  509. X      end
  510. X      if row = 16 & col > 40 then do
  511. X         push 'FIND OUTPUT'
  512. X         ADDRESS CMS 'XEDIT 'execname' HELPCMS'
  513. X         iterate
  514. X      end
  515. X      if row = 16 & col < 41 then do
  516. X         push 'FIND FLOPPY'
  517. X         ADDRESS CMS 'XEDIT 'execname' HELPCMS'
  518. X         iterate
  519. X      end
  520. X      if row = 17 then do
  521. X         push 'FIND GOTOS'
  522. X         ADDRESS CMS 'XEDIT 'execname' HELPCMS'
  523. X         iterate
  524. X      end
  525. X      if row = 18 then do
  526. X         push 'FIND INDENT'
  527. X         ADDRESS CMS 'XEDIT 'execname' HELPCMS'
  528. X         iterate
  529. X      end
  530. X      if row = 19 then do
  531. X         push 'FIND GROUPF'
  532. X         ADDRESS CMS 'XEDIT 'execname' HELPCMS'
  533. X         iterate
  534. X      end
  535. X      if row = 20 | row = 21 then do
  536. X         push 'FIND RENUMF'
  537. X         ADDRESS CMS 'XEDIT 'execname' HELPCMS'
  538. X         iterate
  539. X      end
  540. X      if row = 22 | row = 23 then do
  541. X         push 'FIND RENUMS'
  542. X         ADDRESS CMS 'XEDIT 'execname' HELPCMS'
  543. X         iterate
  544. X      end
  545. X      ADDRESS CMS 'HELP 'execname
  546. X   end
  547. X   leave
  548. Xend
  549. X 
  550. XCHECK:
  551. Xerr = ' '
  552. Xupper fnin ftin fmin fntdy fttdy fmtdy fnold ftold fmold
  553. Xupper tree checks ignore flopo full tidy gotos
  554. Xupper indent renums renumf groupf
  555. X 
  556. Xif ^'FEXIST'(fnin ftin fmin) then do
  557. X   err = "Input FORTRAN file does not exist."
  558. X   cursor = "0001"
  559. X   if interactive = "YES" then signal START
  560. X   signal EXIT
  561. Xend
  562. X 
  563. Xif 'QFILE'(fnin ftin fmin,"RECFM") ^= "F" then do
  564. X   err = "Input FORTRAN file is RECFM V. Change to RECFM F please."
  565. X   cursor = "0001"
  566. X   if interactive = "YES" then signal START
  567. X   signal EXIT
  568. Xend
  569. X 
  570. Xif ^'FEXIST'(fnold ftold fmold) & LENGTH(fnold) ^= 0 then do
  571. X   err = "FLOPPY parameter file does not exist."
  572. X   cursor = "0004"
  573. X   if interactive = "YES" then signal START
  574. X   signal EXIT
  575. Xend
  576. X 
  577. Xchecks = strip(checks)
  578. Xif words(checks) ^= 1 then do
  579. X   err = "Use a single Checks keyword, or separate numbers with commas"
  580. X   cursor = "0007"
  581. X   if interactive = "YES" then signal START
  582. X   signal EXIT
  583. Xend
  584. X 
  585. Xif find("STANDARD ALEPH GALEPH ONLINE NONE LIST",checks) = 0 then do
  586. X   if ^datatype(checks,'N') then do
  587. X      if index(checks,',') = 0 then do
  588. X         err = "Must be list of numbers or keyword. See HELP file."
  589. X         cursor = "0007"
  590. X         if interactive = "YES" then signal START
  591. X         signal EXIT
  592. X      end
  593. X      else do
  594. X         ipos = 1
  595. X         do until ipos > length(checks)
  596. X            ipose = index(checks,',',ipos) - 1
  597. X            if ipose = -1 then ipose = length(checks)
  598. X            num = substr(checks,ipos,ipose-ipos+1)
  599. X            if ^datatype(num,"N") then do
  600. X                err = "Invalid integer "num" in list of checks."
  601. X                cursor = "0007"
  602. X                if interactive = "YES" then signal START
  603. X                signal EXIT
  604. X            end
  605. X            ipos = ipose + 2
  606. X         end
  607. X      end
  608. X   end
  609. Xend
  610. X 
  611. Xset1 = "N"
  612. Xif abbrev(gotos,"Y",1) | abbrev(indent,"Y",1) ,
  613. X     | abbrev(groupf,"Y",1) | abbrev(renumf,"Y",1),
  614. X     | abbrev(renumf,"Y",1) then set1 = "Y"
  615. X 
  616. Xif set1 = "Y" then tidy = "Y"
  617. Xif set1 = "N" & abbrev(tidy,"Y",1) then do
  618. X   err = "Specify how you want to tidy the code."
  619. X   cursor = "0012"
  620. X   if interactive = "YES" then signal START
  621. X   signal EXIT
  622. Xend
  623. X 
  624. Xif abbrev(tidy,"Y",1) then do
  625. X   if fntdy = " " then do
  626. X      err = "Specify the name of the output FORTRAN file."
  627. X      cursor = "0013"
  628. X      if interactive = "YES" then signal START
  629. X      signal EXIT
  630. X   end
  631. X   if fttdy = " " then do
  632. X      err = "Specify the name of the output FORTRAN file."
  633. X      cursor = "0014"
  634. X      if interactive = "YES" then signal START
  635. X      signal EXIT
  636. X   end
  637. X   if fnin||ftin||fmin = fntdy||fttdy||fmtdy then do
  638. X      err = "Output FORTRAN will overwrite input. Rename."
  639. X      cursor = "0013"
  640. X      if interactive = "YES" then signal START
  641. X      signal EXIT
  642. X   end
  643. X   if abbrev(indent,"Y",1) & ^datatype(spaces,"N") then do
  644. X      err = "Number of spaces to indent must be an integer."
  645. X      cursor = "0018"
  646. X      if interactive = "YES" then signal START
  647. X      signal EXIT
  648. X   end
  649. X   if abbrev(indent,"Y",1) & ( spaces>5 | spaces<1 ) then do
  650. X      err = "Number of spaces must be between 1 and 5 for indent."
  651. X      cursor = "0018"
  652. X      if interactive = "YES" then signal START
  653. X      signal EXIT
  654. X   end
  655. X   if abbrev(renumf,"Y",1) then do
  656. X      if ^datatype(startf,"N") then do
  657. X         err = "Statement number must be numeric."
  658. X         cursor = "0021"
  659. X         if interactive = "YES" then signal START
  660. X         signal EXIT
  661. X      end
  662. X      if ^datatype(stepf,"N") then do
  663. X         err = "Statement number step must be numeric."
  664. X         cursor = "0022"
  665. X         if interactive = "YES" then signal START
  666. X         signal EXIT
  667. X      end
  668. X   end
  669. X   if abbrev(renumf,"Y",1) then do
  670. X      if ^datatype(starts,"N") then do
  671. X         err = "Statement number must be numeric."
  672. X         cursor = "0024"
  673. X         if interactive = "YES" then signal START
  674. X         signal EXIT
  675. X      end
  676. X      if ^datatype(steps,"N") then do
  677. X         err = "Statement number step must be numeric."
  678. X         cursor = "0025"
  679. X         if interactive = "YES" then signal START
  680. X         signal EXIT
  681. X      end
  682. X   end
  683. Xend
  684. X 
  685. Xif ^abbrev(flopo,"N",1) & ^abbrev(flopo,"Y",1) then do
  686. X   err = "FLOPPY output to disk: give Yes or No."
  687. X   cursor = "0010"
  688. X   if interactive = "YES" then signal START
  689. X   signal EXIT
  690. Xend
  691. X 
  692. Xif ^abbrev(tree,"N",1) & ^abbrev(tree,"Y",1) then do
  693. X   err = "TREE output from FLOPPY: give Yes or No."
  694. X   cursor = "0009"
  695. X   if interactive = "YES" then signal START
  696. X   signal EXIT
  697. Xend
  698. X 
  699. Xif ^abbrev(full,"N",1) & ^abbrev(full,"Y",1) then do
  700. X   err = "Full source listing from FLOPPY: give Yes or No."
  701. X   cursor = "0011"
  702. X   if interactive = "YES" then signal START
  703. X   signal EXIT
  704. Xend
  705. X 
  706. Xif ^abbrev(ignore,"N",1) & ^abbrev(ignore,"Y",1) then do
  707. X   err = "List of ignore names for FLOPPY: give Yes or No."
  708. X   cursor = "0008"
  709. X   if interactive = "YES" then signal START
  710. X   signal EXIT
  711. Xend
  712. X 
  713. X 
  714. X 
  715. X/* Now write the necessary input files */
  716. Xoldflag = length(fnold)
  717. Xif oldflag ^= 0 then file = fnold' TEMP$T A'
  718. Xif oldflag  = 0 then do
  719. X   file = fnin' FLOPIGN A'
  720. X   if 'FEXIST'(file) then 'ERASE 'file /* erase unwanted ignore file */
  721. Xend
  722. Xexw = 'EXECIO 1 DISKW 'file' (STRING '
  723. Xexw" "
  724. X 
  725. Xif abbrev(full,'Y',1) then exw"*FULL"
  726. X 
  727. Xif abbrev(checks,'ALEP',1) & oldflag = 0 then exw"*ALEPH"
  728. X 
  729. Xif abbrev(ignore,"Y",1) then do
  730. X    say "You must now enter a list of the names FLOPPY is to ignore"
  731. X    /* push terminal control characters before reading names */
  732. X    cpus= "CPUSH"("TERM")
  733. X    "CP TERM CHARDEL OFF"
  734. X    "CP TERM LINEDEL OFF"
  735. X    "CP TERM LINEND  OFF"
  736. X    "CP TERM ESCAPE  OFF"
  737. X    "CP TERM TABCHAR OFF"
  738. X    say "Names to ignore ..... "
  739. X    say " eg to ignore variable NUMGEN enter NUMGEN "
  740. X    say "    to ignore subroutine FRED enter #FRED "
  741. X    say " "
  742. X    n = 0
  743. X    do forever
  744. X       say "Enter name to ignore [CR=no more]"
  745. X       parse upper pull name
  746. X       if name = "" then leave
  747. X       n = n + 1
  748. X       exw name
  749. X    end
  750. X    /* restore control characters                            */
  751. X    cpo = "CPOP"("TERM")
  752. Xend
  753. X 
  754. Xif abbrev("LIST",checks,1) then do
  755. X   say 'Enter the long list of rule numbers to be checked.'
  756. X   say 'Separate each rule by a comma (,)'
  757. X   parse upper pull checks
  758. Xend
  759. X 
  760. Xif find("STANDARD ALEPH GALEPH ONLINE NONE LIST",checks) = 0 then do
  761. X   if ^datatype(checks,'N') then do
  762. X      ipos = 1
  763. X      do until ipos > length(checks)
  764. X         ipose = index(checks,',',ipos) - 1
  765. X         if ipose = -1 then ipose = length(checks)
  766. X         num = substr(checks,ipos,ipose-ipos+1)
  767. X         if length(num) = 1 then num = "  "||num
  768. X         if length(num) = 2 then num = " "||num
  769. X         if datatype(num,"N") then exw"*CHECK RULE "num
  770. X         ipos = ipose + 2
  771. X      end
  772. X   end
  773. X   else do
  774. X      if length(checks) = 1 then checks = " "||checks
  775. X      exw"*CHECK RULE  "checks
  776. X   end
  777. Xend
  778. Xelse do
  779. X   if abbrev("STANDARD",checks,1) & oldflag = 0 then exw"*CHECK RULE *"
  780. X   if abbrev("ALEPH",checks,1) & oldflag = 0 then exw"*ALEPH"
  781. X   if abbrev("GALEPH",checks,1) & oldflag = 0 then exw"*ALEPH"
  782. X   if abbrev("GALEPH",checks,1) & oldflag = 0 then exw"*GALEPH"
  783. X   if abbrev("NONE",checks,1) then exw"*CHECK RULE -99"
  784. Xend
  785. X'FINIS 'file
  786. X 
  787. Xif fnold ^= " " then do
  788. X   'COPYFILE 'fnold ftold fmold' = = A (REPLACE'
  789. X   'COPYFILE 'file fnold ftold' A (APPEND'
  790. X   'ERASE 'file
  791. Xend
  792. Xelse fnold = fnin
  793. X 
  794. X/* Now the FLOP (not FLOPPY) input data */
  795. X 
  796. Xfile = 'FLOPPY TEMP$T A'
  797. Xif 'FEXIST'(file) then 'ERASE 'file
  798. Xexw = 'EXECIO 1 DISKW 'file' (STRING '
  799. X 
  800. Xif abbrev(tidy,"Y",1)   then exw"OUTPUT,FULL,COMPRESS;"
  801. Xif abbrev(tree,"Y",1)   then exw"OPTIONS,TREE;"
  802. Xif abbrev(gotos,"Y",1)  then exw"STATEMENTS,GOTO;"
  803. Xif abbrev(groupf,"Y",1) then exw"STATEMENTS,SEPARATE;"
  804. Xif abbrev(indent,"Y",1) then exw"OPTIONS,INDENT="spaces";"
  805. Xif abbrev(renumf,"Y",1) then exw"STATEMENTS,FORMAT="startf","stepf";"
  806. Xif abbrev(renums,"Y",1) then exw"STATEMENTS,NUMBER="starts","steps";"
  807. X/* default cards for FLOP */
  808. Xexw"LIST,GLOBAL,TYPE;"
  809. Xexw"PRINT,ILLEGAL;"
  810. Xexw"OPTIONS,USER;"
  811. Xexw"END;"
  812. X'FINIS 'file
  813. X 
  814. X'COPYFILE 'file' = = = (RECFM F LRECL 80 REPLACE'
  815. X 
  816. X'COPYFILE 'fnold ftold fmold' = = = (RECFM F LRECL 80 REPLACE'
  817. X 
  818. X/* Now assign the FILEDEFs */
  819. X'MAKEBUF'
  820. Xbufno = rc
  821. X'SENTRIES'
  822. Xentries = rc
  823. X'QFILEDEF ( STACK'
  824. Xpull dummy
  825. Xnum_fdefs = 0
  826. Xdo queued()-entries
  827. X   num_fdefs = num_fdefs + 1
  828. X   pull fdef.num_fdefs
  829. Xend
  830. X'DROPBUF 'bufno
  831. X'FILEDEF 5 CLEAR'
  832. X'FILEDEF 6 CLEAR'
  833. X'FILEDEF 11 CLEAR'
  834. X'FILEDEF 13 CLEAR'
  835. X'FILEDEF 14 CLEAR'
  836. X'FILEDEF 15 CLEAR'
  837. X'FILEDEF 50 CLEAR'
  838. X'FILEDEF 99 CLEAR'
  839. X 
  840. X'FILEDEF 5 DISK 'file
  841. X'FILEDEF 11 DISK 'fnin ftin fmin
  842. X'FILEDEF 15 DISK 'fnold ftold fmold
  843. X'FILEDEF 99 DISK FLOPPY SCRATCH A (RECFM F LRECL 132'
  844. X 
  845. Xif abbrev(tidy,"Y",1) then do
  846. X  say 'Tidied FORTRAN output will be called 'fntdy fttdy fmtdy
  847. X  'FILEDEF 14 DISK 'fntdy fttdy fmtdy '(LRECL 80 RECFM F'
  848. Xend
  849. X 
  850. Xif abbrev(flopo,"Y",1) then do
  851. X  say 'FLOPPY listing file will be called 'fnin 'FLOPLIS A'
  852. X  'FILEDEF 6 DISK 'fnin' FLOPLIS A (LRECL 132 RECFM F'
  853. Xend
  854. Xelse 'FILEDEF 6 TERMINAL (LRECL 132 PERM'
  855. X 
  856. Xif abbrev(tree,"Y",1) then do
  857. X  say 'FLOPPY output for TREE will be called 'fnin 'FLOPTRE A'
  858. X  'FILEDEF 13 DISK 'fnin' TEMPTRE A (LRECL 8000 RECFM VS'
  859. X  'FILEDEF 50 DISK 'fnin' FLOPTRE A (LRECL 8000 RECFM VS'
  860. Xend
  861. X 
  862. Xsay 'FLOPPY begins .... '
  863. X 
  864. X/* MONITOR USAGE */
  865. X 
  866. Xlogline = 'Fn 'fnin' Che 'checks,
  867. X          'Tre' substr(tree,1,1),
  868. X          'Ign' substr(ignore,1,1),
  869. X          'Out' substr(flopo,1,1),
  870. X          'Ful' substr(full,1,1),
  871. X          'Tid' substr(tidy,1,1),
  872. X          'Got' substr(gotos,1,1),
  873. X          'Ind' indent,
  874. X          'Rns' substr(renums,1,1),
  875. X          'Rnf' substr(renumf,1,1),
  876. X          'Grf' substr(groupf,1,1)
  877. Xlogline = substr(logline,1,80)
  878. X 
  879. X'EXEC LOGUSAGE FLOPPY 'logline
  880. X 
  881. X/* RUN FLOPPY */
  882. X'EXEC CERNLIB'
  883. X'FLOPPY$M'
  884. X 
  885. X'EXEC LOGUSAGE FLOPPY Successful completion'
  886. X 
  887. X/* Reinstate original FILEDEFs */
  888. X'FILEDEF 5 CLEAR'
  889. X'FILEDEF 6 CLEAR'
  890. X'FILEDEF 11 CLEAR'
  891. X'FILEDEF 13 CLEAR'
  892. X'FILEDEF 14 CLEAR'
  893. X'FILEDEF 15 CLEAR'
  894. X'FILEDEF 50 CLEAR'
  895. X'FILEDEF 99 CLEAR'
  896. Xdo i = 1 to num_fdefs
  897. X   fdef.i
  898. Xend
  899. X 
  900. X/* Erase unwanted files */
  901. Xif 'FEXIST'('FLOPPY SCRATCH A') then 'ERASE FLOPPY SCRATCH A'
  902. Xif 'FEXIST'(file) then 'ERASE 'file
  903. X 
  904. Xsay 'FLOPPY has finished'
  905. X 
  906. Xcall EXIT
  907. X 
  908. X 
  909. X 
  910. XNOVALUE:
  911. Xsay 'Uninitialised variable encountered on line' sigl
  912. Xcall EXIT
  913. X 
  914. XERROR:
  915. Xsay 'Error on line' sigl
  916. Xcall EXIT
  917. X 
  918. XEXIT:
  919. Xif err ^= " " then say execname ": " err
  920. Xexit
  921. /
  922. echo 'Part 03 of Floppy complete.'
  923. exit
  924.  
  925.  
  926.