*S~ SUBROUTINE TOKEN (I, TYPE) C The next characters of LIST are examined for IFTRAN keywords. C The type of the token found is returned as parameter TYPE, using C the following convention: C C TYPE TOKEN C -1 (...) C 0 NOT AN IFTRAN TOKEN C 1 IF C 2 DO C 3 OR C 4 END C 5 FOR C 6 DATA C 7 ELSE C 8 EXIT C 9 THEN C 10 WHILE C 11 UNTIL C 12 FORMAT C Revision History: C 19-JAN-81 Character variables changed to type BYTE C 19-JAN-81 IFTCOM common rearranged C 17-FEB-81 Hooks added to decode FORMAT and DATA stmts C 24-APR-81 LOOP removed, OR added IMPLICIT INTEGER (A - Z) BYTE KW, LPAR, RPAR, QUOTE, X, Y ; Internal string variables BYTE LABEL, LHEAD, LIST, CONLBL ; Common string variables LOGICAL*1 LISTNG, PASCOM ; Listing, pass comments flags COMMON /IFTCOM/ DONE, INFILE, IP, KIND, L, LNUM, LOUT, OUTFIL, + ERRCNT, LISTNG, PASCOM, CONLBL(6), LABEL(66), LHEAD(6), LIST(1320) DIMENSION KW (6, 12) DATA KW /'I', 'F', ' ', ' ', ' ', ' ', 'D', 'O', ' ', ' ', ' ', ' ', + 'O', 'R', ' ', ' ', ' ', ' ', 'E', 'N', 'D', ' ', ' ', ' ', + 'F', 'O', 'R', ' ', ' ', ' ', 'D', 'A', 'T', 'A', ' ', ' ', + 'E', 'L', 'S', 'E', ' ', ' ', 'E', 'X', 'I', 'T', ' ', ' ', + 'T', 'H', 'E', 'N', ' ', ' ', 'W', 'H', 'I', 'L', 'E', ' ', + 'U', 'N', 'T', 'I', 'L', ' ', 'F', 'O', 'R', 'M', 'A', 'T'/ DATA LPAR /'('/, RPAR /')'/, QUOTE /1H'/ TYPE = 0 ; Guess no token X = NEXT(I) ; Get next char IF (X .EQ. LPAR) ; Look for (...) PAR = 1 ; Set paren level to 1 QFLAG = 0 ; Reset quote flag WHILE (I .LE. L) X = NEXT(I) ; Get next char IF (QFLAG .EQ. 1) ; If quote flag set IF (X .EQ. QUOTE) QFLAG = 0 ; Reset flag if char a quote ELSE IF (X .EQ. LPAR) ; If char a left paren PAR = PAR + 1 ; Increment paren level OR IF (X .EQ. RPAR) ; If char a right paren PAR = PAR - 1 ; Decrement paren level IF (PAR .EQ. 0) ; If all paren sets closed TYPE = -1 ; Must be a paren enclosure RETURN END IF OR IF (X .EQ. QUOTE) ; If char a quote QFLAG = 1 ; Set quote flag END IF END IF END WHILE ELSE Y = NEXT(I) ; Get next char FOR J = 1, 12 IF ((X .EQ. KW(1, J)) .AND. (Y .EQ. KW(2, J))) ; Check 1st two chars TYPE = J ; TYPE = pass number EXIT FOR END IF END FOR IF (TYPE .LT. 4) RETURN ; If token length 2, return X = NEXT(I) ; Look for length 3 tokens IF (X .EQ. KW(3, TYPE)) IF (TYPE .LT. 6) RETURN ; If token length 3, return X = NEXT(I) ; Look for length 4 tokens IF (X .EQ. KW(4, TYPE)) IF (TYPE .LT. 10) RETURN ; If token length 4, return X = NEXT(I) ; Look for length 5 tokens IF (TYPE .LT. 12) RETURN ; If token length 5, return X = NEXT(I) ; Look for length 6 tokens IF (X .EQ. KW(6, TYPE)) RETURN ; If token length 6, return END IF END IF END IF TYPE = 0 ; Not an IFTRAN token RETURN END