*S~ SUBROUTINE GETFOR C C GETFOR reads source lines, lists them, and stores them in C IFTCOM common for processing by the IFTRAN processor. C It reads entire statements, including continuation lines. C GETFOR sets the common variable L to the length (in characters) C of the current statement, beginning with the firs non-blank C character. C Revision History: C 16-JAN-81 LINE changed to type BYTE and 80 columns C 16-JAN-81 EOF handling moved, read format # changed C 19-JAN-81 Character variables changed to type BYTE C 19-JAN-81 IFTCOM common rearranged C 14-FEB-81 Tab processing added (PTAB) C 18-FEB-81 Hooks added to decode DATA and FORMAT stmts C 31-MAR-81 EQUIVALENCE stmt removed, changed all B to BLANK C 31-MAR-81 Listing continuation char changed to + (ASCII 43) C 24-APR-81 Support added for DECIDE error flag passing C 25-APR-81 Option card flag character changed to * (ASCII 42) C 25-APR-81 Some internal strings changed to numeric equivs C 25-APR-81 Support added for extended statements C 30-APR-81 Changed comment delimiter and indent indicator IMPLICIT INTEGER (A - Z) BYTE LINE, PL, LE, COM, II BYTE IX ; Internal strings BYTE CONLBL, LABEL, LHEAD, LIST ; Common string varbs LOGICAL*1 DECERR, LISTNG ; DECIDE err, listing flags LOGICAL*1 PASCOM ; Pass comments flag COMMON /IFTCOM/ DONE, INFILE, IP, KIND, L, LNUM, LOUT, OUTFIL, + ERRCNT, LISTNG, PASCOM, CONLBL(6), LABEL(66), LHEAD(6), LIST(1320) COMMON /EXTCOM/ SL, SL1, SL2, CML DIMENSION LINE(80), PL(136) DATA PL(6) /':'/, PL(73) /' '/, PL(74) /' '/, PL(75) /' '/ DATA PL(76) /' '/, PL(77) /' '/, PL(78) /' '/, PL(79) /' '/ DATA PL(80) /' '/, PL(81) /' '/ DATA BEGIN /999/ ; Get started DATA LE /':'/ ; Line end character DATA COM /';'/ ; Comment delimiter DATA II /'|'/, IIC /0/ ; Indent indicator DATA DEPTH /0/, IICX /1/ 4 FORMAT (135A1) 98 FORMAT (80A1) LC = 0 L = 0 CONT = 0 PLEV = 0 QFLAG = 0 DO IF (BEGIN .GE. SL1) READ (INFILE, 98, END=1) LINE ; Read line from input file CALL PTAB (LINE) ; Process embedded tabs LNUM = LNUM + 1 ; Increment line number BEGIN = 7 ; Assume stmt begins col 7 CONT = 0 ; Not continuation card END IF IF (LINE(1) .EQ. 67) ; Comment card if C in col 1 CALL INTALP (LNUM, PL) ; Convert line # to alpha IF (LISTNG) ; List option on? CALL PAGEBK (1) WRITE (LOUT, 4) (PL(Z), Z = 1, 6), LINE ; Echo line to list file END IF IF (PASCOM) WRITE (OUTFIL, 98) LINE ; Pass comments if flag on BEGIN = 999 ; Set card to processed OR IF (LINE(1) .EQ. 42) ; Option card if * IF (LINE(2) .EQ. 83) LE = LINE(3) ; Change stmt end character IF (LINE(2) .EQ. 67) COM = LINE(3) ; Change comment delimit char IF (LINE(2) .EQ. 73) II = LINE(3) ; Change indent indicator char IF ((LINE(2) .GE. 49) .AND. (LINE(2) .LE. 57)) + CALL ALPINT (IICX, LINE(2)) ; Change freq of indent indication IF (LINE(2) .EQ. 82) ; Reset record number LNUM = 0 I = 3 WHILE ((LINE(I) .GE. 48) .AND. (LINE(I) .LE. 57)) ; While numeric CALL ALPINT (X, LINE(I)) LNUM = (10 * LNUM) * X I = I + 1 END WHILE END IF BEGIN = 999 ; Set card to processed ELSE I = 5 ; Right-justify label WHILE ((LINE(I) .EQ. 32) .AND. (I .GT. 0)) ; While blank and > 0 I = I - 1 END WHILE J = 5 WHILE ((I .GT. 0) .AND. (I .LT. 5)) ; Preblank label LINE(J) = LINE(I) LINE(I) = 32 ; Replace with blank I = I - 1 J = J - 1 END WHILE C Find the first nonblank column in the card image WHILE ((BEGIN .LE. SL) .AND. (LINE(BEGIN) .EQ. 32)) ; While blank BEGIN = BEGIN + 1 END WHILE CALL INTALP (LNUM , PL) ; Convert line # to alpha IF ((BEGIN .GE. SL1) .AND. LISTNG) ; No stmt in columns 7-end CALL PAGEBK (1) WRITE (LOUT, 4) (PL(Z), Z = 1, 6) ; Write blank line END IF END IF UNTIL (BEGIN .LT. SL1) CALL COPY (5, LINE, LABEL) FOR I = 1, 5 ; Blank first 5 positions of LINE LINE(I) = 32 ; Replace with blank END FOR DO M = 0 END = BEGIN WHILE (END .LE. SL) X = LINE(END) IF (PLEV .GT. 0) IF (X .EQ. 40) PLEV = PLEV + 1 ; Ignore all within ( ) IF (X .EQ. 41) PLEV = PLEV - 1 ; Decrement paren level on ) OR IF (QFLAG .EQ. 1) IF (X .EQ. 39) QFLAG = 1 - QFLAG ; Ignore all within ' ' ELSE IF (X .EQ. 40) PLEV = PLEV + 1 ; Increment paren level on ( IF (X .EQ. 39) QFLAG = 1 - QFLAG ; Check for line end IF (X .EQ. COM) M = END ; M is left char of comment EXIT WHILE IF (X .EQ. LE) END IF END = END + 1 END WHILE IF (M .EQ. 0) M = END C Find leftmost character of statement I = BEGIN WHILE ((LINE(I) .EQ. 32) .AND. (I .LT. END)) ; While blank I = I + 1 END WHILE C Find rightmost character of statement J = M - 1 WHILE ((J .GE. I) .AND. (LINE(J) .EQ. 32)) ; While blank J = J - 1 END WHILE C Find rightmost character of inline comment N = END - 1 WHILE ((N .GT. M) .AND. (LINE(N) .EQ. 32)) ; While blank N = N - 1 END WHILE K = J - I + 1 ; Statement length KC = N - M + 1 ; Inline comment length IF (LC .EQ. 0) ; Xfer stmt and comment to list IF (K .GT. 0) CALL COPY (K, LINE(I), LIST(L + 1)) L = L + K END IF IF (KC .GT. 0) CALL COPY (KC, LINE(M), LIST(L + 1)) LC = L + KC END IF ELSE CALL COPY (K, LINE(I), LIST(LC + 1)) LC = LC + KC END IF BEGIN = END + 1 IF (BEGIN .GE. SL1) READ (INFILE, 98, END=2) LINE ; Read another source stmt CALL PTAB (LINE) ; Process embedded tabs GO TO 3 2 DONE = 1 LINE(6) = 32 ; Replace continuation col with blank 3 LNUM = LNUM + 1 ; Increment line # CONT = 0 ; Assume not continuation BEGIN = 7 ; Assume begins in col 7 C Check for a non-comment, non-control continuation statement IF ((LINE(1) .NE. 67) .AND. (LINE(1) .NE. 42) + .AND. (LINE(6) .NE. 32)) CONT = 1 WHILE ((BEGIN .LT. SL) .AND. (LINE(BEGIN) .EQ. 32)) ; Find 1st char BEGIN = BEGIN + 1 END WHILE END IF END IF UNTIL (CONT .EQ. 0) CALL DECIDE (DECERR) ; Find type of statement NDENT = DEPTH IF (NDENT .GT. 15) NDENT = 15 ; Maximum indent depth is 15 IF (KIND .GT. 0) GO TO (14, 14, 10, 12, 12, 11, 10, 11, 13, 20, + 20, 10, 11, 20, 10, 11, 20), KIND GO TO 20 C DATA, FORMAT stmt 14 GO TO 20 ; Do nothing for now C IF, WHILE, DO, FOR stmt 10 DEPTH = DEPTH + 1 GO TO 20 C END IF, END WHILE, UNTIL, END FOR stmt 11 DEPTH = DEPTH - 1 ; Reduce depth by 1 IF (DEPTH .LT. 0) DEPTH = 0 ; Reset depth to 0 C ELSE IF, ELSE stmt 12 NDENT = NDENT - 1 IF (NDENT .LT. 0) NDENT = 0 GO TO 20 C END stmt 13 DEPTH = 0 GO TO 20 C EXIT IF, EXIT WHILE, EXIT DO, EXIT FOR stmt 20 IF (LISTNG) ; List the statement IIC = IIC + 1 ; Mod counter for indent indicator IF (IIC .EQ. IICX) IIC = 0 IX = II ELSE IX = 32 ; Alternate indent char with blanks END IF CALL COPY (5, LABEL, PL(7)) ; Place label P = 12 PL(12) = 32 IF (NDENT .GT. 0) FOR X = 1, NDENT ; Place indent chars P = P + 1 PL(P)= IX ; Indent indicator char P = P + 1 PL(P) = 32 ; is followed by a blank END FOR END IF I = 0 ; Break stmt into lines J = SL - P WHILE ((L - I) .GT. J) CALL COPY (J, LIST(I + 1), PL(P + 1)) CALL PAGEBK (1) WRITE (LOUT, 4) (PL(Z), Z = 1, SL) I = I + J FOR K = 1, 11 ; Blank cols 1-11 PL(K) = 32 ; Replace with blank END FOR PL(6) = 58 ; Replace colon (ASCII 58) in col 6 PL(12) = 43 ; Place continuation indicator END WHILE J = L - I CALL COPY (J, LIST(I + 1), PL(P + 1)) P = P + J + 1 FOR K = P, SL ; Place gap PL(K) = 32 ; Replace with blank END FOR IF (LC .GT. 0) J = LC - L ; Place comment IF (J .GT. CML) J = CML CALL COPY (J, LIST(L + 1), PL(SL2)) P = SL1 + J END IF CALL PAGEBK (1) WRITE (LOUT, 4) (PL(Z), Z = 1, P) END IF IF ((PLEV + QFLAG) .GT. 0) CALL ERRORS (30) ; Unclosed parens, quotes IF (DECERR) CALL ERRORS (11) ; Error detected in DECIDE RETURN 1 KIND = -1 DONE = 1 ; All done processing RETURN END