SUBROUTINE PARSE INTEGER INPTR INTEGER OUTPTR INTEGER INMAX INTEGER MAXTAB INTEGER MAXLIN INTEGER IFMAX INTEGER MAXLEV INTEGER LINENO INTEGER PAGE INTEGER CLINE INTEGER TLIMIT INTEGER LN INTEGER I, J, K INTEGER II, JJ, KK INTEGER LEXVAL INTEGER SLEN INTEGER LEVEL INTEGER LEN INTEGER INCHAN INTEGER OUTCHN INTEGER LPTCHN INTEGER TTICHN INTEGER TTOCHN INTEGER PROCCN INTEGER COMCHN INTEGER TABS (10) LOGICAL SKIPFL LOGICAL POFF LOGICAL FIRST INTEGER ISP INTEGER ICSTK (20) INTEGER IFSP INTEGER IFST (20) INTEGER LPSP INTEGER LPST (100) LOGICAL TSEEN INTEGER CHAR INTEGER CTEMP LOGICAL NEWFIL INTEGER COMPMS (11) INTEGER LSAVE (5) LOGICAL PSAVE (5) INTEGER FFILE INTEGER EOF INTEGER LETTER INTEGER DIGIT INTEGER TAB INTEGER EOL INTEGER BLANK INTEGER QUOTE INTEGER GIZZY INTEGER LPAREN INTEGER RPAREN INTEGER AST INTEGER COMMA INTEGER PERIOD INTEGER SLASH INTEGER CHAR0 INTEGER CHAR1 INTEGER CHAR9 INTEGER SEMI INTEGER EQUAL INTEGER CHARA INTEGER CHARZ INTEGER BBLANK INTEGER UPAROW INTEGER DOOP INTEGER WHILE INTEGER ENDOP INTEGER FOR INTEGER DOLOOP INTEGER BREAK INTEGER NEXT INTEGER IFOP INTEGER ELSE INTEGER ENDIF INTEGER DEFINE INTEGER HEAD INTEGER EJECT INTEGER INCLUD INTEGER OUTFIL INTEGER IBUF (42) INTEGER PBUF (58) INTEGER HBUF (42) INTEGER OUTBUF (42) INTEGER BUF (58) INTEGER NAME (22) COMMON /STRN/ INPTR COMMON /STRN/ OUTPTR COMMON /STRN/ INMAX COMMON /STRN/ MAXTAB COMMON /STRN/ MAXLIN COMMON /STRN/ IFMAX COMMON /STRN/ MAXLEV COMMON /STRN/ LINENO COMMON /STRN/ PAGE COMMON /STRN/ CLINE COMMON /STRN/ TLIMIT COMMON /STRN/ LN COMMON /STRN/ I, J, K COMMON /STRN/ II, JJ, KK COMMON /STRN/ LEXVAL COMMON /STRN/ SLEN COMMON /STRN/ LEVEL COMMON /STRN/ LEN COMMON /STRN/ INCHAN COMMON /STRN/ OUTCHN COMMON /STRN/ LPTCHN COMMON /STRN/ TTICHN COMMON /STRN/ TTOCHN COMMON /STRN/ PROCCN COMMON /STRN/ COMCHN COMMON /STRN/ TABS COMMON /STRN/ SKIPFL COMMON /STRN/ POFF COMMON /STRN/ FIRST COMMON /STRN/ ISP COMMON /STRN/ ICSTK COMMON /STRN/ IFSP COMMON /STRN/ IFST COMMON /STRN/ LPSP COMMON /STRN/ LPST COMMON /STRN/ TSEEN COMMON /STRN/ CHAR COMMON /STRN/ CTEMP COMMON /STRN/ NEWFIL COMMON /STRN/ COMPMS COMMON /STRN/ LSAVE COMMON /STRN/ PSAVE COMMON /STRN/ FFILE COMMON /STRN/ EOF COMMON /STRN/ LETTER COMMON /STRN/ DIGIT COMMON /STRN/ TAB COMMON /STRN/ EOL COMMON /STRN/ BLANK COMMON /STRN/ QUOTE COMMON /STRN/ GIZZY COMMON /STRN/ LPAREN COMMON /STRN/ RPAREN COMMON /STRN/ AST COMMON /STRN/ COMMA COMMON /STRN/ PERIOD COMMON /STRN/ SLASH COMMON /STRN/ CHAR0 COMMON /STRN/ CHAR1 COMMON /STRN/ CHAR9 COMMON /STRN/ SEMI COMMON /STRN/ EQUAL COMMON /STRN/ CHARA COMMON /STRN/ CHARZ COMMON /STRN/ BBLANK COMMON /STRN/ UPAROW COMMON /STRN/ DOOP COMMON /STRN/ WHILE COMMON /STRN/ ENDOP COMMON /STRN/ FOR COMMON /STRN/ DOLOOP COMMON /STRN/ BREAK COMMON /STRN/ NEXT COMMON /STRN/ IFOP COMMON /STRN/ ELSE COMMON /STRN/ ENDIF COMMON /STRN/ DEFINE COMMON /STRN/ HEAD COMMON /STRN/ EJECT COMMON /STRN/ INCLUD COMMON /STRN/ OUTFIL COMMON /STRN/ IBUF COMMON /STRN/ PBUF COMMON /STRN/ HBUF COMMON /STRN/ OUTBUF COMMON /STRN/ BUF COMMON /STRN/ NAME INTEGER LEX, LEXTMP, LABGEN, INLEN INTEGER CHARC, CHARD, CHARP, CHARX, CHARN INTEGER GCHAR, GETC INTEGER EXTN (5) INTEGER CHARI,CHARL,CHARY DATA CHARI/73/,CHARL/76/,CHARY/89/ DATA CHARC /67/, CHARD /68/, CHARP /80/, CHARX /88/ DATA CHARN /78/ DATA EXTN /'.F','R/','NO','TR',' '/ IFSP = 1 LPSP = 1 10 CONTINUE 13045 CONTINUE LEXVAL = LEX (CHAR) IF (.NOT.(CHAR .NE. EOF))GO TO 13046 IF (.NOT. (CHAR .EQ. EOL))GO TO 13047 GO TO 13045 13047 CONTINUE IF (.NOT. (LEXVAL .EQ. LETTER))GO TO 13049 IF (.NOT. (INPTR .EQ. 2))GO TO 13051 IF (.NOT. (CHAR .EQ. CHARX .OR. CHAR .EQ. CHARD))GO TO 13053 CALL PUTC (CHARD) GO TO 13045 13053 CONTINUE IF (.NOT. (CHAR .EQ. CHARN))GO TO 13055 CALL IGNORE GO TO 13045 13055 CONTINUE IF(.NOT.(CHAR.EQ.CHARP))GOTO 13056 CALL IGNORE GOTO 13045 13056 CONTINUE IF (.NOT. (CHAR .EQ. CHARI))GO TO 13057 GO TO 13045 13057 CONTINUE 13051 CONTINUE CALL PUTBAK (CHAR) IF (.NOT. (CHAR .NE. CHARC .OR. INPTR .NE. 2))GO TO 13059 CALL LSTART CALL ENDLIN GO TO 13060 13059 CONTINUE CALL IGNORE 13060 CONTINUE GO TO 13045 13049 CONTINUE IF (.NOT. (LEXVAL .EQ. DIGIT))GO TO 13061 CALL COPYLN GO TO 13045 13061 CONTINUE LEXTMP = LEXVAL - 99 IF (.NOT. (LEXTMP .GT. 0 .AND. LEXTMP .LT. 16))GO TO 13063 GOTO (100, 100, 200, 100, 100, 300, 300, 400, 500, 600, 700, 800, 1900, 1000, 1100) LEXTMP GO TO 13064 13063 CONTINUE 700 CALL IGNORE 13064 CONTINUE GO TO 13045 13046 CONTINUE IF (LEVEL .NE. 1) GOTO 1050 IF (.NOT. (IFSP .NE. 1))GO TO 13065 CALL REMARK ('IF STACK NOT CLEARED.') 13065 CONTINUE IF (.NOT. (LPSP .NE. 1))GO TO 13067 CALL REMARK ('LOOP STACK NOT CLEARED.') 13067 CONTINUE IF (.NOT. (IAND (PAGE, 1) .NE. 0))GO TO 13069 CALL SET (BBLANK, IBUF, 40) CLINE = MAXLIN + 1 CALL PRINT 13069 CONTINUE RETURN 30 CALL ENDLIN GOTO 10 100 IF (.NOT. (LEXVAL .EQ. WHILE))GO TO 13071 IF (.NOT. (LPST (LPSP) .EQ. DOOP))GO TO 13073 CONTINUE 13075 CONTINUE CALL LSTART LPST (LPSP) = WHILE LPST (LPSP + 2) = 1 CALL PSTR ('IF (.NOT./') CALL CPAREN CALL PSTR (')/') LN = LPST (LPSP + 1) + 1 CALL GOLN (LN) GOTO 30 GO TO 13074 13073 CONTINUE CALL REMARK ('WHILE WITHOUT DO.') CALL LSTART LPSP = LPSP + 3 CALL PSTR ('CONTINUE;/') LN = LABGEN (2) CALL LNCONT (LN) LPST (LPSP + 1) = LN GO TO 13075 13074 CONTINUE 13071 CONTINUE LPSP = LPSP + 3 IF (.NOT. (LEXVAL .EQ. FOR))GO TO 13077 KK = 1 CALL COPYTO (NAME, KK, LPAREN) CALL SKIPBL CALL LSTART CALL COPYTO (OUTBUF, OUTPTR, SEMI) CALL PUTC (EOL) LN = LABGEN (3) + 2 CALL PLN (LN) CALL PSTR ('IF (.NOT.(/') CALL SKIPBL CALL COPYTO (OUTBUF, OUTPTR, SEMI) CALL PSTR ('))/') LN = LN - 1 CALL GOLN (LN) KK = LPSP*4 - 3 CALL SKIPBL CALL COPYTO (LPST, KK, RPAREN) LPSP = LPSP + (SLEN + 3)/4 LPST (LPSP) = SLEN LPSP = LPSP + 1 LN = LN - 1 GO TO 13078 13077 CONTINUE IF (.NOT. (LEXVAL .EQ. DOLOOP))GO TO 13079 LN = LABGEN (2) CALL LSTART CALL PSTR ('DO /') CALL ESP (LN, OUTBUF, OUTPTR, OUTPTR + 5) OUTPTR = OUTPTR + 6 GO TO 13080 13079 CONTINUE IF (.NOT. (LEXVAL .EQ. DOOP))GO TO 13081 CALL LSTART LN = LABGEN (2) CALL PSTR ('CONTINUE;/') CALL LNCONT (LN) 13081 CONTINUE 13080 CONTINUE 13078 CONTINUE LPST (LPSP) = LEXVAL LPST (LPSP + 1) = LN LPST (LPSP + 2) = 0 GOTO 30 200 IF (.NOT. (LPSP .EQ. 1))GO TO 13083 CALL REMARK ('MISPLACED END OF LOOP.') GOTO 30 13083 CONTINUE IF (.NOT. (LPST (LPSP) .EQ. DOOP .OR. LPST (LPSP) .EQ. WHILE))GO T 1O 13085 LN = LPST (LPSP + 1) CALL LSTART CALL GOLN (LN) IF (.NOT. (LPST (LPSP + 2) .NE. 0))GO TO 13087 LN = LN + 1 CALL LNCONT (LN) 13087 CONTINUE LPSP = LPSP - 3 GOTO 30 13085 CONTINUE IF (.NOT. (LPST (LPSP) .EQ. FOR))GO TO 13089 LN = LPST (LPSP + 1) IF (.NOT. (LPST (LPSP + 2) .EQ. 1))GO TO 13091 CALL PLN (LN) 13091 CONTINUE CALL LSTART SLEN = LPST (LPSP - 1) LPSP = LPSP - (SLEN + 3)/4 - 1 KK = LPSP*4 - 3 DO 13093 JJ = 1, SLEN II = GCHAR (LPST, KK) CALL PUTC (II) KK = KK + 1 13093 CONTINUE CALL PUTC (EOL) CALL LSTART LN = LN + 2 CALL GOLN (LN) LN = LN - 1 CALL LNCONT (LN) GO TO 13090 13089 CONTINUE LN = LPST (LPSP + 1) CALL LNCONT (LN) IF (.NOT. (LPST (LPSP + 2) .EQ. 1))GO TO 13095 LN = LN + 1 CALL LNCONT (LN) 13095 CONTINUE 13090 CONTINUE LPSP = LPSP - 3 IF (LEXVAL .NE. OUTFIL) GOTO 30 GOTO 1100 300 IF (.NOT. (LPSP .EQ. 1))GO TO 13097 CALL REMARK ('MISPLACED BREAK OR NEXT.') GOTO 30 13097 CONTINUE KK = LPSP + 1 LN = LPST (KK) IF (.NOT. (LEXVAL .EQ. BREAK))GO TO 13099 LN = LN + 1 IF (.NOT. (LPST (LPSP) .NE. FOR))GO TO 13101 KK = LPSP + 2 LPST (KK) = 1 13101 CONTINUE GO TO 13100 13099 CONTINUE IF (.NOT. (LPST (LPSP) .EQ. FOR))GO TO 13103 KK = LPSP + 2 LPST (KK) = 1 13103 CONTINUE 13100 CONTINUE CALL LSTART CALL GOLN (LN) GOTO 30 400 IF (.NOT. (IFSP .GE. IFMAX))GO TO 13105 CALL REMARK ('IF STACK OVERFLOW.') CALL IGNORE GOTO 10 13105 CONTINUE IFSP = IFSP + 1 IFST (IFSP) = IFOP IFSP = IFSP + 1 LN = LABGEN (2) IFST (IFSP) = LN CALL LSTART CALL PSTR ('IF (.NOT. /') CALL CPAREN CALL PSTR (')/') CALL GOLN (LN) GOTO 30 500 IF (.NOT. (IFSP .EQ. 1))GO TO 13107 510 CALL REMARK ('ELSE WITHOUT IF.') CALL IGNORE GOTO 10 13107 CONTINUE JJ = IFSP CONTINUE 13109 CONTINUE IF (.NOT.(JJ .GT. 1))GO TO 13110 KK = JJ - 1 IF (.NOT. (IFST (KK) .EQ. IFOP))GO TO 13111 IFST (KK) = ELSE LN = IFST (JJ) + 1 CALL LSTART CALL GOLN (LN) LN = LN - 1 CALL LNCONT (LN) GO TO 13112 13111 CONTINUE JJ = JJ - 2 GO TO 13109 13110 CONTINUE GOTO 510 13112 CONTINUE GOTO 30 600 IF (.NOT. (IFSP .EQ. 1))GO TO 13113 CALL REMARK ('ENDIF WITHOUT IF.') CALL IGNORE GOTO 10 13113 CONTINUE KK = IFSP - 1 IF (.NOT. (IFST (KK) .EQ. IFOP))GO TO 13115 LN = IFST (IFSP) GO TO 13116 13115 CONTINUE LN = IFST (IFSP) + 1 13116 CONTINUE CALL LNCONT (LN) IFSP = IFSP - 2 GOTO 30 800 CALL SKIPBL JJ = 1 CALL COPYTO (HBUF, JJ, EOL) DO 13117 II = JJ, 80 CALL PCHAR (HBUF, II, BLANK) 13117 CONTINUE FIRST = .FALSE. SKIPFL = .TRUE. CALL PUTBAK (EOL) GOTO 30 900 IF (POFF) GOTO 30 SKIPFL = .TRUE. CLINE = 1000 GOTO 30 1000 INCHAN = INCHAN - 1 LSAVE (LEVEL) = LINENO PSAVE (LEVEL) = POFF LEVEL = LEVEL + 1 CALL SKIPBL INLEN = 1 CALL SET (0, NAME, 22) CALL COPYTO (NAME, INLEN, COMMA) CALL NAMCOM(NAME,INLEN) CALL PCHAR (NAME, INLEN+1, 0) CALL PRINT CHAR = GETC (CHAR) IF (.NOT. (CHAR .EQ. CHARP))GO TO 13119 SKIPFL = .TRUE. POFF = .FALSE. GO TO 13120 13119 CONTINUE POFF = .TRUE. 13120 CONTINUE IF (.NOT. (CHAR .NE. EOL))GO TO 13121 CALL COPYTO (NAME, INLEN, EOL) 13121 CONTINUE CALL PUTBAK (EOL) LINENO = 0 CALL OPENF (INCHAN, NAME, KK) IF (.NOT. (KK .NE. 1))GO TO 13123 CALL REMARK ('INCLUDE FILE OPEN ERROR.') CALL IGNORE GOTO 1050 13123 CONTINUE GOTO 30 1100 IF (.NOT. (OUTCHN .EQ. -1))GO TO 13125 OUTCHN = 1 GO TO 13126 13125 CONTINUE CONTINUE 13127 CONTINUE IF (.NOT.(IFSP .NE. 1))GO TO 13128 CALL REMARK ('MISSING ENDIF.') IFSP = IFSP - 2 GO TO 13127 13128 CONTINUE CONTINUE 13129 CONTINUE IF (.NOT.(LPSP .NE. 1))GO TO 13130 CALL REMARK ('MISSING LOOP END.') GOTO 200 GO TO 13129 13130 CONTINUE CALL CLOSF (OUTCHN, KK) 13126 CONTINUE CALL SKIPBL JJ = 1 CLINE = 1000 CALL SET (0, NAME, 22) CALL COPYTO (NAME, JJ, EOL) CALL NAMCOM(NAME,SLEN) CALL PCHAR (NAME, SLEN + 1, 0) CALL OPENN (OUTCHN, NAME, KK) IF (.NOT. (KK .NE. 1))GO TO 13131 CALL REMARK ('FILE PROTECTED OR IN USE.') OUTCHN = -1 13131 CONTINUE CALL WRLIN(TTOCHN,NAME,SLEN) IF (.NOT. (PROCCN .NE. -1))GO TO 13133 CALL SET(BBLANK,BUF,40) CALL EST('FORTE ',BUF,1,6) CALL EST(NAME,BUF,7,SLEN+6) KK=6+SLEN CALL PCHAR(BUF,KK+1,COMMA) KK=KK+1 SLEN=SLEN-2 CALL EST(NAME,BUF,KK+1,KK+SLEN) KK=KK+SLEN CALL EST('Y, ',BUF,KK+1,KK+2) KK=KK+2 CALL EST(NAME,BUF,KK+1,KK+SLEN) KK=KK+SLEN CALL PCHAR(BUF,KK+1,CHARL) KK=KK+1 CALL WRLIN(PROCCN,BUF,KK) 13133 CONTINUE NEWFIL = .TRUE. CALL PUTBAK (EOL) GOTO 30 1050 CALL CLOSF (INCHAN, KK) LEVEL = LEVEL - 1 LINENO = LSAVE (LEVEL) POFF = PSAVE (LEVEL) INCHAN = INCHAN + 1 SKIPFL = .TRUE. GOTO 10 END