PROGRAM IFTRAN C C IFTRAN precompiler for the PDP-11 series of computers C This version created on 11-SEP-80 C Last update on 28-JAN-81 C C History of Revisions C 9-JAN-81 Removed parsing for switches (IFTRAN) C 13-JAN-81 Greater spacing between line # and statement (GETFOR) C 17-JAN-81 Improved command phase error messages (IFTRAN) C 24-JAN-81 Fixed problem in phase 3 command parse (IFTRAN) C IMPLICIT INTEGER (A - Z) LOGICAL*1 BUFFR1, BUFFR2, BUFFR3, SPACE, COMMA, EQUAL, SLASH LOGICAL*1 CMDLIN, CMDFIL, COMFLG, EQUFLG, EXTNS, CHAR, LABEL LOGICAL*1 CONLBL, LIST, IHEAD, ITAIL, IHEAD2, LHEAD REAL TYME, SECNDS COMMON /PAGING/ ISYS, PPN1, PPN2, BUFFR1(9), BUFFR2(8) COMMON /FORCOM/ ERRS, ITYPE, L, KIND, IP, INFILE, OUTFIL, LOUT, + LISTNG, PLINES, LPPAGE, LABEL(66), LHEAD(6), LIST(1320), CONLBL(6) C Buffers for GETMCR, GETTSK DIMENSION BUFFR3 (80), BUFFR4 (16) C Cmd line, cmd length, filename extensions DIMENSION CMDLIN (3, 19), CMDLEN(3), EXTNS (3, 4) DIMENSION CMDFIL(3), IHEAD(9), ITAIL(9), DAY(6), IHEAD2(9) DIMENSION LAST(100), WSTACK(100), LSTACK(100), DOSTK(100), + FORSTK(100) DATA ZDUMMY, ERRS /0, 0/ DATA SPACE, COMMA, EQUAL, SLASH /' ', ',', '=', '/'/ DATA EXTNS /'.', '.', '.', 'F', 'L', 'I', 'T', 'S', 'F', 'N', + 'T', 'T'/ DATA CMDLIN(1,1), CMDLIN(1,2), CMDLIN(1,3) /'N', 'L', ':'/ DATA CMDLIN(2,1), CMDLIN(2,2), CMDLIN(2,3) /'N', 'L', ':'/ DATA CMDLEN /0, 0, 0/ DATA COMFLG, EQUFLG /.FALSE., .FALSE./ DATA CMDFIL /.FALSE., .FALSE., .FALSE./ DATA NCHAR /0/ DATA IHEAD / 'I', 'F', '(', '.', 'N', 'O', 'T', '.', '(' / DATA ITAIL / ')', ')', ' ', 'G', 'O', ' ', 'T', 'O', ' ' / DATA IHEAD2 /'D', 'O', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ C ERROR MESSAGES 78 FORMAT (' IFT - Fatal flaw in command line') 79 FORMAT (' IFT - Cannot find or open input file') 81 FORMAT (' IFT - Cannot create listing file') 82 FORMAT (' IFT - Cannot create output file') 83 FORMAT (' IFT - Missing input file') 84 FORMAT (' IFT - Missing space after call or empty command line') 86 FORMAT (1X, ' ERRORS ENCOUNTERED: ', I3, /, + ' TRANSLATION TIME: ', F6.2, ' SECONDS', /, 1H1) 87 FORMAT (1X, ' OUTPUT FILE: ', 19A1) 88 FORMAT (1X, ' LISTING FILE:', 19A1) 89 FORMAT (1H0, 'TRANSLATION STATISTICS', /, '0 INPUT FILE: ', 19A1) 91 FORMAT (' ERROR: Invalid usage. Statement deleted.') 92 FORMAT (' ERROR: Extra or invalid terminator. Statement deleted.') 93 FORMAT (' Bad character in column ', I2, ' of command line - <', + A1, '>.') 94 FORMAT (' ERROR: Invalid EXIT. Statement deleted.') 95 FORMAT (' ERROR: Program ends with an unclosed IF clause.') 96 FORMAT (' ERROR: Program ends with an unclosed DO clause.') 97 FORMAT (' ERROR: Program ends with an unclosed FOR clause.') 98 FORMAT (' ERROR: Program ends with an unclosed WHILE clause.') 99 FORMAT (1H1, ' UW IFTRAN V01.0-02 ', 4A2, ' USER [', O3, ',', + O3, '] ', 8A1, 2X, 9A1, ' PAGE ', I3, // ) C C ******************************************************************* C C Listing defaults to ON LISTNG = 1 C 66 lines per page, input LUN 3, output LUN 1, listing LUN 2 LPPAGE = 66 INFILE = 3 OUTFIL = 1 LOUT = 2 C Synthetic line #s begin at 32000 LBL = 32000 ITYPE = 1 NDSTK = 0 NSTACK = 0 NWSTAK = 0 NFSTK=0 LP = 1 LAST(LP) = 0 C C Get begin translation time TYME = SECNDS(0.0) C Get invoking command line CALL GETMCR (BUFFR3, NCHAR) C Get task parameters CALL GETTSK (BUFFR4, IFLAG) PPN1 = IAND(ISHFT(BUFFR4(8), -8), 255) PPN2 = IAND(BUFFR4(8), 255) ISYS = BUFFR4(15) + 1 C Get date CALL DATE (BUFFR1) C Get time CALL TIME (BUFFR2) C Parse command line J1 = 4 5 IF (BUFFR3(J1) .EQ. SPACE) GO TO 10 J1 = J1 + 1 IF (J1 .LE. 7) GO TO 5 C Missing space after call to processor or void command line WRITE (5, 84) CALL EXIT 10 J1 = J1 + 1 C Push down line, strip spaces, check valid character J3 = 0 DO 20 J2 = J1, NCHAR CHAR = BUFFR3(J2) IF (CHAR .EQ. SPACE) GO TO 20 IF (((CHAR .GE. 65) .AND. (CHAR .LE. 90)) .OR. + ((CHAR .GE. 48) .AND. (CHAR .LE. 59)) .OR. + (CHAR .EQ. 44) .OR. (CHAR .EQ. 46) .OR. (CHAR .EQ. 61)) GO TO 15 WRITE (5, 93) J2, CHAR CALL EXIT 15 J3 = J3 + 1 BUFFR3(J3) = BUFFR3(J2) 20 CONTINUE NCHAR = J3 C State transition parse of line J1 = 1 J2 = 1 DO 40 J3 = 1, NCHAR CHAR = BUFFR3(J3) IF (CHAR .NE. COMMA) GO TO 25 IF ((.NOT. COMFLG) .AND. (.NOT. EQUFLG)) GO TO 21 WRITE (5, 78) CALL EXIT 21 COMFLG = .TRUE. J1 = 2 J2 = 1 GO TO 40 25 IF (CHAR .NE. EQUAL) GO TO 35 IF (.NOT. EQUFLG) GO TO 26 WRITE (5, 78) CALL EXIT 26 EQUFLG = .TRUE. J1 = 3 J2 = 1 GO TO 40 C Alphanumeric; tack on end of this spec 35 CMDLIN(J1, J2) = CHAR IF (CHAR .EQ. 46) CMDFIL(J1) = .TRUE. CMDLEN(J1) = J2 J2 = J2 + 1 40 CONTINUE NCMDS = J1 C Check for existence of input file IF (CMDLEN(3) .NE. 0) GO TO 36 WRITE (5,83) CALL EXIT C Check for existence of listing file 36 IF (CMDLEN(2) .EQ. 0) CMDLEN(2) = 3 C Check for existence of output file IF (CMDLEN(1) .EQ. 0) CMDLEN(1) = 3 C If no file extensions, append them DO 50 J4 = 1, 3 IF (CMDFIL(J4)) GO TO 50 J1 = CMDLEN(J4) + 1 CMDLEN(J4) = CMDLEN(J4) + 4 J2 = J1 + 3 J3 = 1 DO 45 J5 = J1, J2 CMDLIN(J4, J5) = EXTNS(J4, J3) J3 = J3 + 1 45 CONTINUE 50 CONTINUE C Assign logical unit numbers to units DO 55 J1 = 1, 3 J2 = CMDLEN(J1) DO 60 J3 = 1, J2 BUFFR3(J3) = CMDLIN(J1, J3) 60 CONTINUE CALL ASSIGN (J1, BUFFR3, J2) 55 CONTINUE C Open files OPEN (UNIT=1, TYPE='NEW', ERR=70, CARRIAGECONTROL='LIST') GO TO 75 70 WRITE (5, 82) CALL EXIT 75 OPEN (UNIT=2, TYPE='NEW', ERR=80) GO TO 85 80 WRITE (5, 81) CALL EXIT 85 OPEN (UNIT=3, TYPE='OLD', ERR=90) GO TO 101 90 WRITE (5, 79) CALL EXIT C Print initial header 101 CALL HEADER C C *** START OF DIETMEYER'S CODE *** C 1 FORMAT (10A2) CONLBL(5) = SPACE CONLBL(6) = SPACE 32098 IF (ITYPE .LT. 0) GO TO 32097 C Get an IFTRAN line from the input file CALL GETFOR C IF (KIND .NE. 0) GO TO 32095 C KIND = 0; not an IFTRAN statement CALL PUTFOR (7, L, 1) GO TO 32098 C 32095 IF (KIND .NE. 1) GO TO 32094 C KIND = 1; an IF (logical) statement NSTACK = NSTACK + 1 LBL = LBL - 5 LSTACK(NSTACK) = -1 * LBL NSTACK = NSTACK + 1 LBL = LBL - 5 LSTACK(NSTACK) = LBL GO TO 100 C 32094 IF (KIND .NE. 2) GO TO 32093 C KIND = 2; an OR IF statement IF ((LAST(LP) .EQ. 1) .OR. (LAST(LP) .EQ. 2)) GO TO 32091 IF ((LISTNG .EQ. 1) .AND. (PLINES .GE. LPPAGE)) CALL HEADER WRITE (LOUT, 91) PLINES = PLINES + 1 ERRS = ERRS + 1 GO TO 32098 C 32091 LSTACK(NSTACK-1) = IABS(LSTACK(NSTACK-1)) CALL PUTFOR (ZDUMMY, LSTACK(NSTACK-1), 2) CALL PUTFOR (LSTACK(NSTACK), ZDUMMY, 3) LBL = LBL - 5 LSTACK(NSTACK) = LBL GO TO 31 C 32093 IF (KIND .NE. 3) GO TO 32090 C KIND = 3; an ELSE statement IF ((LAST(LP) .EQ. 1) .OR. (LAST(LP) .EQ. 2)) GO TO 32088 IF ((LISTNG .EQ. 1) .AND. (PLINES .GE. LPPAGE)) CALL HEADER WRITE (LOUT, 91) PLINES = PLINES + 1 ERRS = ERRS + 1 GO TO 32098 C 32088 LSTACK(NSTACK-1) = IABS(LSTACK(NSTACK-1)) CALL PUTFOR (ZDUMMY, LSTACK(NSTACK-1), 2) CALL PUTFOR (LSTACK(NSTACK), ZDUMMY, 3) LSTACK(NSTACK) = -1 * LSTACK(NSTACK) LAST(LP) = KIND IF (LABEL(5) .NE. SPACE) CALL PUTFOR (0, ZDUMMY, 3) GO TO 32098 C 32090 IF (KIND .NE. 4) GO TO 32087 C KIND = 4; an END IF statement IF ((LAST(LP) .LT. 1) .OR. (LAST(LP) .GT. 3)) GO TO 110 IF (LABEL(5) .NE. SPACE) CALL PUTFOR (0, ZDUMMY, 3) CALL PUTFOR (LSTACK(NSTACK), ZDUMMY, 3) CALL PUTFOR (LSTACK(NSTACK-1), ZDUMMY, 3) NSTACK = NSTACK - 2 GO TO 120 C 32087 IF (KIND .NE. 5) GO TO 32086 C KIND = 5; a WHILE (logical) statement NWSTAK = NWSTAK + 1 LBL = LBL - 5 WSTACK(NWSTAK) = LBL CALL PUTFOR (LBL, ZDUMMY, 3) NWSTAK = NWSTAK + 1 LBL = LBL - 5 WSTACK(NWSTAK) = LBL 100 LP = LP + 1 31 LAST(LP) = KIND IP = IP - 8 CALL COPY (8, IHEAD(1), LHEAD(IP)) CALL COPY (8, ITAIL(2), LIST(L+1)) CALL INTALP (LBL, LIST(L+9)) L = L + 13 CALL PUTFOR (IP, L, 1) GO TO 32098 C 32086 IF (KIND .NE. 6) GO TO 32085 C KIND = 6; an END WHILE statement IF (LAST(LP) .NE. 5) GO TO 110 IF (LABEL(5) .NE. SPACE) CALL PUTFOR (0, ZDUMMY, 3) CALL PUTFOR (ZDUMMY, WSTACK(NWSTAK-1), 2) CALL PUTFOR (WSTACK(NWSTAK), ZDUMMY, 3) NWSTAK = NWSTAK - 2 GO TO 120 C 32085 IF (KIND .NE. 7) GO TO 32084 C KIND = 7; an END statement CALL PUTFOR (7, L, 1) C Check for unclosed clauses IF (NSTACK .EQ. 0) GO TO 30999 WRITE (LOUT, 95) ERRS = ERRS + 1 30999 IF (NDSTK .EQ. 0) GO TO 30998 WRITE (LOUT, 96) ERRS = ERRS + 1 30998 IF (NFSTK .EQ. 0) GO TO 30997 WRITE (LOUT, 97) ERRS = ERRS + 1 30997 IF (NWSTAK .EQ. 0) GO TO 30996 WRITE (LOUT, 98) ERRS = ERRS + 1 C Reset for possible following routines 30996 LBL = 32000 NSTACK = 0 NWSTAK = 0 NDSTK = 0 NFSTK = 0 LP = 1 IF ((LISTNG .EQ. 1) .AND. (ITYPE .GE. 0)) CALL HEADER GO TO 32098 C 32084 IF (KIND .NE. 8) GO TO 32083 C KIND = 8; an EXIT IF statement IF (NSTACK .EQ. 0) GO TO 32081 IF (L .EQ. (IP - 6)) L = L - 1 CALL COPY (7, ITAIL(3), LIST(L+1)) LSTACK(NSTACK-1) = IABS(LSTACK(NSTACK-1)) CALL INTALP (LSTACK(NSTACK-1), LIST(L+8)) L = L + 12 CALL PUTFOR (IP+1, L, 1) GO TO 32098 C 32081 IF ((LISTNG .EQ. 1) .AND. (PLINES .GE. LPPAGE)) CALL HEADER WRITE (LOUT, 94) PLINES = PLINES + 1 ERRS = ERRS + 1 GO TO 32098 C 32083 IF (KIND .NE. 9) GO TO 32080 C KIND = 9; an EXIT WHILE statement IF (NWSTAK .EQ. 0) GO TO 32078 IF (L .EQ. (IP - 6)) L = L - 1 CALL COPY (7, ITAIL(3), LIST(L+1)) CALL INTALP (WSTACK(NWSTAK), LIST(L+8)) L = L + 12 CALL PUTFOR (IP+1, L, 1) GO TO 32098 C 32078 IF ((LISTNG .EQ. 1) .AND. (PLINES .GE. LPPAGE)) CALL HEADER WRITE (LOUT, 94) PLINES = PLINES + 1 ERRS = ERRS + 1 GO TO 32098 C 32080 IF (KIND .NE. 10) GO TO 32077 C KIND = 10; a DO statement NDSTK = NDSTK + 1 LBL = LBL - 5 DOSTK(NDSTK) = -LBL NDSTK = NDSTK + 1 LBL = LBL - 5 DOSTK(NDSTK) = LBL IF (LABEL(5) .NE. SPACE) CALL PUTFOR (0, ZDUMMY, 3) CALL PUTFOR (LBL, ZDUMMY, 3) LP = LP + 1 LAST(LP) = KIND GO TO 32098 C 32077 IF (KIND .NE. 11) GO TO 32076 C KIND = 11; an UNTIL (logical) statement IF (LAST(LP) .EQ. 10) GO TO 32074 110 IF ((LISTNG .EQ. 1) .AND. (PLINES .GE. LPPAGE)) CALL HEADER WRITE (LOUT, 92) PLINES = PLINES + 1 ERRS = ERRS + 1 GO TO 32098 C 32074 IP = IP - 8 CALL COPY (8, IHEAD(1), LHEAD(IP)) CALL COPY (8, ITAIL(2), LIST(L+1)) CALL INTALP (DOSTK(NDSTK), LIST(L+9)) L = L + 13 CALL PUTFOR (IP, L, 1) NDSTK = NDSTK - 1 CALL PUTFOR (DOSTK(NDSTK), ZDUMMY, 3) NDSTK = NDSTK - 1 120 LP = LP - 1 IF (LP .LT. 1) LP = 1 GO TO 32098 C 32076 IF (KIND .NE. 12) GO TO 32073 C KIND = 12; an EXIT DO statement IF (NDSTK .GT. 0) GO TO 32071 IF ((LISTNG .EQ. 1) .AND. (PLINES .GE. LPPAGE)) CALL HEADER WRITE (LOUT, 94) PLINES = PLINES + 1 ERRS = ERRS + 1 GO TO 32098 C 32071 IF (L .EQ. (IP - 6)) L = L - 1 CALL COPY (7, ITAIL(3), LIST(L+1)) DOSTK(NDSTK-1) = IABS(DOSTK(NDSTK-1)) CALL INTALP (DOSTK(NDSTK-1), LIST(L+8)) L = L + 12 CALL PUTFOR (IP+1, L, 1) GO TO 32098 C 32073 IF (KIND .NE. 13) GO TO 32070 C KIND = 13; a FOR var1 = var2, var3 statement NFSTK = NFSTK + 1 LBL = LBL - 5 FORSTK(NFSTK) = -LBL NFSTK = NFSTK + 1 LBL = LBL - 5 FORSTK(NFSTK) = LBL LP = LP + 1 LAST(LP) = KIND IP = IP - 8 CALL COPY (9, IHEAD2, LHEAD(IP)) CALL INTALP (LBL, LHEAD(IP+3)) CALL PUTFOR (IP, L, 1) GO TO 32098 C 32070 IF (KIND .NE. 14) GO TO 32069 C KIND = 14; an END FOR statement IF (LAST(LP) .NE. 13) GO TO 110 IF (LABEL(5) .EQ. SPACE) GO TO 32067 CALL PUTFOR (0, ZDUMMY, 3) LABEL(5) = SPACE 32067 CALL PUTFOR (FORSTK(NFSTK), ZDUMMY, 3) CALL PUTFOR (0, ZDUMMY, 3) CALL PUTFOR (FORSTK(NFSTK-1), ZDUMMY, 3) NFSTK = NFSTK - 2 GO TO 120 C 32069 IF (KIND .NE. 15) GO TO 32098 C KIND = 15; an EXIT FOR statement IF (NFSTK .EQ. 0) GO TO 32064 IF (L .EQ. (IP - 6)) L = L - 1 CALL COPY (7, ITAIL(3), LIST(L+1)) FORSTK(NFSTK-1) = IABS(FORSTK(NFSTK-1)) CALL INTALP (FORSTK(NFSTK-1), LIST(L+8)) L = L + 12 CALL PUTFOR (IP+1, L, 1) GO TO 32098 C 32064 IF ((LISTNG .EQ. 1) .AND. (PLINES .GE. LPPAGE)) CALL HEADER WRITE (LOUT, 94) PLINES = PLINES + 1 ERRS = ERRS + 1 GO TO 32098 C 32097 TYME = SECNDS(TYME) WRITE (LOUT, 89) (CMDLIN(3,J1), J1=1,CMDLEN(3)) WRITE (LOUT, 88) (CMDLIN(2,J1), J1=1,CMDLEN(2)) WRITE (LOUT, 87) (CMDLIN(1,J1), J1=1,CMDLEN(1)) WRITE (LOUT, 86) ERRS, TYME CALL EXIT END