'HEAD' PARSING AND STRAN FUNCTIONS C EDIT DATE 15JAN79 10:14 C SOURCE FILE STPARSE.FS C AUTHOR F. T. MICKEY 'OUTFILE' CTYPEFTM.FR INTEGER FUNCTION CTYPE (ICHAR) 'INCLUDE' STRAN.IN, INTEGER ICHAR 'IF' (ICHAR .GE. CHAR0 .AND. ICHAR .LE. CHAR9) CTYPE = DIGIT 'ELSE' 'IF' (ICHAR .GE. CHARA .AND. ICHAR .LE. CHARZ) CTYPE = LETTER 'ELSE' CTYPE = ICHAR 'ENDIF' 'ENDIF' RETURN END 'OUTFILE' LSTARTFTM.FR SUBROUTINE LSTART 'INCLUDE' STRAN.IN, 'IF' (OUTPTR .GT. 7) CALL PUTC (EOL) 'ENDIF' OUTPTR = 7 RETURN END 'OUTFILE' PLNFTM.FR SUBROUTINE PLN (/DUMMY/) 'INCLUDE' STRAN.IN, INTEGER DUMMY, TS, GCHAR IF (OUTPTR .GT. 7) CALL PUTC (EOL) CALL SET (BBLANK, NAME, 3) CALL ESP (LN, NAME, 1, 5) 'DOLOOP' TS = 1, 5 CALL PUTC (GCHAR (NAME, TS)) 'END' OUTPTR = 7 RETURN END 'OUTFILE' PSTRFTM.FR SUBROUTINE PSTR (STR) 'INCLUDE' STRAN.IN, INTEGER STR(80), III, GCHAR 'DOLOOP' III = 1, 80 CHAR = GCHAR (STR, III) 'IF' (CHAR .NE. SLASH) 'IF' (CHAR .EQ. SEMI) CALL PUTC (EOL) 'ELSE' CALL PUTC (CHAR) 'ENDIF' 'END' 'ENDIF' RETURN END 'OUTFILE' GOLNFTM.FR SUBROUTINE GOLN (/DUMMY/) 'INCLUDE' STRAN.IN, INTEGER DUMMY, GOMSG (2), GCHAR DATA GOMSG /'GO TO /'/ CALL PSTR (GOMSG) CALL SET (BBLANK, NAME, 3) CALL ESP (LN, NAME, 1, 5) 'DOLOOP' II = 1, 5 CALL PUTC (GCHAR (NAME, II)) 'END' CALL PUTC (EOL) RETURN END 'OUTFILE' LNCONTFTM.FR SUBROUTINE LNCONT (/DUMMY/) 'INCLUDE' STRAN.IN, INTEGER DUMMY CALL PLN (LN) CALL PSTR ('CONTINUE;/') RETURN END 'OUTFILE' CPARENFTM.FR SUBROUTINE CPAREN 'INCLUDE' STRAN.IN, INTEGER PCOUNT, GETC PCOUNT = 1 'DO' CHAR = GETC (CHAR) 'WHILE' (CHAR .NE. LPAREN) 'IF' (CHAR .EQ. EOL) CALL REMARK ('INVALID STRAN SYNTAX.') RETURN 'ENDIF' 'END' 'DO' CALL PUTC (CHAR) 'WHILE' (PCOUNT .GT. 0) CHAR = GETC (CHAR) 'IF' (CHAR .EQ. RPAREN) PCOUNT = PCOUNT - 1 'ELSE' 'IF' (CHAR .EQ. LPAREN) PCOUNT = PCOUNT + 1 'ELSE' 'IF' (CHAR .EQ. EOL) 'FOR' (; PCOUNT .GT. 0; PCOUNT = PCOUNT - 1) CALL PUTC (RPAREN) 'END' CALL REMARK ('UNBALANCED PARENS.') CALL PUTBAK (EOL) RETURN 'ENDIF' 'ENDIF' 'ENDIF' 'END' RETURN END 'OUTFILE' LABGENFTM.FR INTEGER FUNCTION LABGEN (NUM) C RESERVES K LABELS, PASSES BACK FIRST LABEL 'INCLUDE' STRAN.IN, INTEGER LABEL, NUM DATA LABEL /13000/ LABGEN = LABEL LABEL = LABEL + NUM RETURN END 'OUTFILE' PARSEFTM.FR SUBROUTINE PARSE 'INCLUDE' STRAN.IN, 'INCLUDE' FNAMES.IN, INTEGER LEX, LEXTMP, LABGEN, INLEN INTEGER CHARC, CHARD, CHARP, CHARX, CHARN INTEGER CHARY,CHARL,CHARI INTEGER GCHAR, GETC P INTEGER EXTN (5) DATA CHARC /67/, CHARD /68/, CHARP /80/, CHARX /88/ DATA CHARN /78/,CHARI/73/,CHARY/89/,CHARL/76/ P DATA EXTN /'.FR/NOTR '/ IFSP = 1 LPSP = 1 10 'DO' LEXVAL = LEX (CHAR) 'WHILE' (CHAR .NE. EOF) 'IF' (CHAR .EQ. EOL) 'NEXT' 'ENDIF' 'IF' (LEXVAL .EQ. LETTER) 'IF' (INPTR .EQ. 2) 'IF' (CHAR .EQ. CHARX .OR. CHAR .EQ. CHARD) N CALL PUTC (CHARX) P CALL PUTC (CHARD) I CALL PUTC(CHARC) 'NEXT' 'ENDIF' 'IF' (CHAR .EQ. CHARN) P CALL IGNORE I CALL IGNORE 'NEXT' 'ENDIF' 'IF' (CHAR .EQ. CHARP) N CALL IGNORE I CALL IGNORE 'NEXT' 'ENDIF' 'IF' (CHAR.EQ.CHARI) P CALL IGNORE N CALL IGNORE 'NEXT' 'ENDIF' 'ENDIF' CALL PUTBAK (CHAR) 'IF' (CHAR .NE. CHARC .OR. INPTR .NE. 2) CALL LSTART CALL ENDLIN 'ELSE' CALL IGNORE 'ENDIF' 'NEXT' 'ENDIF' 'IF' (LEXVAL .EQ. DIGIT) CALL COPYLN 'NEXT' 'ENDIF' LEXTMP = LEXVAL - 99 'IF' (LEXTMP .GT. 0 .AND. LEXTMP .LT. 16) GOTO (100, 100, 200, 100, 100, 300, 300, ^ 400, 500, 600, 700, 800, 900, 1000, ^ 1100) LEXTMP 'ELSE' 700 CALL IGNORE 'ENDIF' 'END' CALL CLOSF(INCHAN,SRCEFS(1,LEVEL)) IF (LEVEL .NE. 1) GOTO 1050 'IF' (IFSP .NE. 1) CALL REMARK ('IF STACK NOT CLEARED.') 'ENDIF' 'IF' (LPSP .NE. 1) CALL REMARK ('LOOP STACK NOT CLEARED.') 'ENDIF' 'IF' (IAND (PAGE, 1) .NE. 0) CALL SET (BBLANK, IBUF, 40) CLINE = MAXLIN + 1 CALL PRINT 'ENDIF' RETURN 30 CALL ENDLIN GOTO 10 'EJECT' C LOOP CONSTRUCTION PROCESSING - C 'FOR' 'DOLOOP' 'DO'-'WHILE' 100 'IF' (LEXVAL .EQ. WHILE) 'IF' (LPST (LPSP) .EQ. DOOP) 'DO' 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 'ELSE' CALL REMARK ('WHILE WITHOUT DO.') CALL LSTART LPSP = LPSP + 3 CALL PSTR ('CONTINUE;/') LN = LABGEN (2) CALL LNCONT (LN) LPST (LPSP + 1) = LN 'END' 'ENDIF' 'ENDIF' LPSP = LPSP + 3 'IF' (LEXVAL .EQ. FOR) 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 'ELSE' 'IF' (LEXVAL .EQ. DOLOOP) LN = LABGEN (2) CALL LSTART CALL PSTR ('DO /') CALL ESP (LN, OUTBUF, OUTPTR, OUTPTR + 5) OUTPTR = OUTPTR + 6 'ELSE' 'IF' (LEXVAL .EQ. DOOP) CALL LSTART LN = LABGEN (2) CALL PSTR ('CONTINUE;/') CALL LNCONT (LN) 'ENDIF' 'ENDIF' 'ENDIF' LPST (LPSP) = LEXVAL LPST (LPSP + 1) = LN LPST (LPSP + 2) = 0 GOTO 30 'EJECT' C END PROCESSING FOR LOOPS C 200 'IF' (LPSP .EQ. 1) CALL REMARK ('MISPLACED END OF LOOP.') GOTO 30 'ENDIF' 'IF' (LPST (LPSP) .EQ. DOOP .OR. LPST (LPSP) .EQ. WHILE) LN = LPST (LPSP + 1) CALL LSTART CALL GOLN (LN) 'IF' (LPST (LPSP + 2) .NE. 0) C BREAK ENCOUNTERED LN = LN + 1 CALL LNCONT (LN) 'ENDIF' LPSP = LPSP - 3 GOTO 30 'ENDIF' 'IF' (LPST (LPSP) .EQ. FOR) LN = LPST (LPSP + 1) 'IF' (LPST (LPSP + 2) .EQ. 1) C NEXT ENCOUNTERED CALL PLN (LN) 'ENDIF' CALL LSTART SLEN = LPST (LPSP - 1) LPSP = LPSP - (SLEN + 3)/4 - 1 KK = LPSP*4 - 3 'DOLOOP' JJ = 1, SLEN II = GCHAR (LPST, KK) CALL PUTC (II) KK = KK + 1 'END' CALL PUTC (EOL) CALL LSTART LN = LN + 2 CALL GOLN (LN) LN = LN - 1 CALL LNCONT (LN) 'ELSE' LN = LPST (LPSP + 1) CALL LNCONT (LN) 'IF' (LPST (LPSP + 2) .EQ. 1) LN = LN + 1 CALL LNCONT (LN) 'ENDIF' 'ENDIF' LPSP = LPSP - 3 IF (LEXVAL .NE. OUTFIL) GOTO 30 GOTO 1100 // RETURN TO OUTFILE PROCESSOR 'EJECT' C BREAK AND NEXT PROCESSING 300 'IF' (LPSP .EQ. 1) CALL REMARK ('MISPLACED BREAK OR NEXT.') GOTO 30 'ENDIF' KK = LPSP + 1 LN = LPST (KK) 'IF' (LEXVAL .EQ. BREAK) LN = LN + 1 'IF' (LPST (LPSP) .NE. FOR) KK = LPSP + 2 LPST (KK) = 1 'ENDIF' 'ELSE' 'IF' (LPST (LPSP) .EQ. FOR) KK = LPSP + 2 LPST (KK) = 1 'ENDIF' 'ENDIF' CALL LSTART CALL GOLN (LN) GOTO 30 'EJECT' C IF PROCESSOR 400 'IF' (IFSP .GE. IFMAX) CALL REMARK ('IF STACK OVERFLOW.') CALL IGNORE GOTO 10 'ENDIF' 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 'EJECT' C ELSE PROCESSOR 500 'IF' (IFSP .EQ. 1) 510 CALL REMARK ('ELSE WITHOUT IF.') CALL IGNORE GOTO 10 'ENDIF' JJ = IFSP 'DO' 'WHILE' (JJ .GT. 1) KK = JJ - 1 'IF' (IFST (KK) .EQ. IFOP) IFST (KK) = ELSE LN = IFST (JJ) + 1 CALL LSTART CALL GOLN (LN) LN = LN - 1 CALL LNCONT (LN) 'ELSE' JJ = JJ - 2 'END' GOTO 510 'ENDIF' GOTO 30 'EJECT' C ENDIF PROCESSOR 600 'IF' (IFSP .EQ. 1) CALL REMARK ('ENDIF WITHOUT IF.') CALL IGNORE GOTO 10 'ENDIF' KK = IFSP - 1 'IF' (IFST (KK) .EQ. IFOP) LN = IFST (IFSP) 'ELSE' LN = IFST (IFSP) + 1 'ENDIF' CALL LNCONT (LN) IFSP = IFSP - 2 GOTO 30 'EJECT' C HEAD CARD PROCESSOR 800 CALL SKIPBL JJ = 1 CALL COPYTO (HBUF, JJ, EOL) 'DOLOOP' II = JJ, 80 CALL PCHAR (HBUF, II, BLANK) 'END' FIRST = .FALSE. SKIPFL = .TRUE. CALL PUTBAK (EOL) GOTO 30 'EJECT' C EJECT CODE 900 IF (POFF) GOTO 30 SKIPFL = .TRUE. CLINE = 1000 GOTO 30 'EJECT' C INFILE PROCESSOR 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 MOVE(NAME,SRCEFS(1,LEVEL),(INLEN+2)/2) CALL PRINT CHAR = GETC (CHAR) 'IF' (CHAR .EQ. CHARP) SKIPFL = .TRUE. POFF = .FALSE. 'ELSE' POFF = .TRUE. 'ENDIF' 'IF' (CHAR .NE. EOL) CALL COPYTO (NAME, INLEN, EOL) 'ENDIF' CALL PUTBAK (EOL) LINENO = 0 CALL OPENF(INCHAN,SRCEFS(1,LEVEL),KK) 'IF' (KK .NE. 1) CALL REMARK ('INCLUDE FILE OPEN ERROR.') CALL IGNORE GOTO 1050 'ENDIF' GOTO 30 'EJECT' C 'OUTFILE' PROCESSING 1100 'IF' (OUTCHN .EQ. -1) OUTCHN = 1 'ELSE' 'DO' 'WHILE' (IFSP .NE. 1) CALL REMARK ('MISSING ENDIF.') IFSP = IFSP - 2 'END' 'DO' 'WHILE' (LPSP .NE. 1) CALL REMARK ('MISSING LOOP END.') GOTO 200 'END' CALL CLOSF (OUTCHN, OUTF) 'ENDIF' 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 MOVE(NAME,OUTF,(SLEN+2)/2) CALL OPENN (OUTCHN, OUTF, KK) 'IF' (KK .NE. 1) CALL REMARK ('FILE PROTECTED OR IN USE.') OUTCHN = -1 'ENDIF' 'IF' (PROCCN .NE. -1) I CALL WRLIN(TTOCHN,NAME,SLEN) I CALL SET (BBLANK,BUF,40) I CALL EST('FORTE ',BUF,1,6) I CALL EST(NAME,BUF,7,SLEN+6) I KK=6+SLEN I CALL PCHAR(BUF,KK+1,COMMA) I KK=KK+1 I SLEN=SLEN-2 I CALL EST(NAME,BUF,KK+1,KK+SLEN) I KK=KK+SLEN I CALL EST('Y, ',BUF,KK+1,KK+2) I KK=KK+2 I CALL EST(NAME,BUF,KK+1,KK+SLEN) I KK=KK+SLEN I CALL PCHAR(BUF,KK+1,CHARL) I KK=KK+1 P SLEN = SLEN - 3 P CALL SET (BBLANK, BUF, 40) P CALL EST (NAME, BUF, 1, SLEN) P JJ = SLEN + 1 P CALL PCHAR (BUF, JJ, COMMA) P CALL EST (NAME, BUF, JJ+1, JJ + SLEN) P JJ = JJ + SLEN + 1 P CALL PCHAR (BUF, JJ, EQUAL) P CALL EST (NAME, BUF, JJ+1, JJ + SLEN) P JJ = JJ + SLEN + 1 P CALL EST (EXTN, BUF, JJ, JJ+7) P CALL PCHAR (BUF, JJ + SLEN + 1, BLANK) P KK = JJ + 7 N CALL SET (BBLANK, BUF, 40) N CALL EST ('FORT/B/P ', BUF, 1, 9) N CALL EST (NAME, BUF, 10, SLEN + 9) N CALL EST (' FORTERR/E', BUF, SLEN + 10, SLEN + 19) N CALL PCHAR (BUF, SLEN + 20, EOL) N KK = SLEN + 20 CALL WRLIN (PROCCN, BUF, KK) 'ENDIF' NEWFIL = .TRUE. CALL PUTBAK (EOL) GOTO 30 'EJECT' 1050 CONTINUE LEVEL = LEVEL - 1 LINENO = LSAVE (LEVEL) POFF = PSAVE (LEVEL) INCHAN = INCHAN + 1 SKIPFL = .TRUE. GOTO 10 END 'OUTFILE' LEXFTM.FR INTEGER FUNCTION LEX (ICHAR) 'INCLUDE' STRAN.IN, INTEGER ICHAR, CTYPE, GETC, GCHAR, GETWRD INTEGER FPTR, FLIST (55) DATA FLIST ^ / 2, 'IF', 107, ^ 4, 'ELSE', 108, ^ 5, 'ENDIF', 109, ^ 2, 'DO', 100, ^ 5, 'WHILE', 101, ^ 3, 'END', 102, ^ 3, 'FOR', 103, ^ 6, 'DOLOOP',104, ^ 5, 'BREAK', 105, ^ 4, 'NEXT', 106, ^ 6, 'DEFINE',110, ^ 7, 'INCLUDE', 113, ^ 4, 'HEAD', 111, ^ 5, 'EJECT', 112, ^ 7, 'OUTFILE', 114, ^ 0, 0/ CALL SKIPBL CHAR = GETC (CHAR) ICHAR=CHAR LEXVAL = CTYPE (CHAR) 'IF' (LEXVAL .NE. GIZZY) LEX = LEXVAL RETURN 'ENDIF' SLEN = GETWRD (IBUF, INPTR, INMAX, NAME) FPTR = 1 'DO' 'WHILE' (FLIST (FPTR) .NE. 0) 'IF' (FLIST (FPTR) .EQ. SLEN) KK = FPTR*4 + 1 'DOLOOP' JJ = 1, SLEN 'IF' (GCHAR (FLIST, KK) .EQ. GCHAR (NAME, JJ)) KK = KK + 1 'END' FPTR = (KK+2)/4+1 LEX = FLIST (FPTR) RETURN 'ENDIF' 'ENDIF' FPTR = FPTR + (FLIST (FPTR) + 11)/4 'END' LEX = 0 RETURN END 'OUTFILE' ENDLINFTM.FR SUBROUTINE ENDLIN 'INCLUDE' STRAN.IN, INTEGER GETC, GCHAR, QCOUNT, CHARD, CHART, ICHAR LOGICAL QSEEN, QALLOW DATA CHARD /68/ , CHART /84/ QALLOW = .FALSE. QSEEN = .FALSE. 'DO' CHAR = GETC (CHAR) 'WHILE' (CHAR .NE. EOL) 'IF' (CHAR .EQ. CHARD) 'IF' (GCHAR (IBUF, INPTR) .EQ. CHARA ^ .AND. GCHAR (IBUF, INPTR+1) .EQ. CHART ^ .AND. GCHAR (IBUF, INPTR+2) .EQ. CHARA) QALLOW = .TRUE. 'ENDIF' 'ENDIF' 'IF' (QALLOW) 'IF' (CHAR .EQ. GIZZY) QCOUNT = -2 QSEEN =.NOT.(QSEEN) 'ELSE' 'IF' (QSEEN) QCOUNT = QCOUNT + 1 'IF' (QCOUNT .EQ. 0) QCOUNT = -1 CALL PUTC (CHAR) CHAR = GETC (CHAR) 'IF' (CHAR .NE. GIZZY) ICHAR = CHAR CALL PUTC (GIZZY) CALL PUTC (COMMA) CALL PUTC (GIZZY) CHAR = ICHAR 'ELSE' QSEEN =.NOT.(QSEEN) 'ENDIF' 'ENDIF' 'ENDIF' 'ENDIF' 'ENDIF' CALL PUTC (CHAR) 'END' QSEEN=.FALSE. CALL PUTC (EOL) RETURN END