'HEAD' INPUT/OUTPUT PRIMITIVES C EDIT DATE 15JAN79 08:35 C SOURCE FILE STIO.FS C AUTHOR F. T. MICKEY C CLUSTER 1 'OUTFILE' REMARKFTM.FR SUBROUTINE REMARK (STRING) 'INCLUDE' STRAN.IN, INTEGER STRING (66) INTEGER TS, GCHAR 'DOLOOP' I = 1, 4 CALL PCHAR (BUF, I, AST) 'END' 'DOLOOP' I = 5, 80 TS = GCHAR (STRING, I-4) 'IF' (TS .NE. PERIOD) CALL PCHAR (BUF, I, TS) 'END' 'ENDIF' CALL PCHAR (BUF, I, EOL) CALL WRLIN (TTOCHN, BUF, I) CALL WRLIN (LPTCHN, BUF, I) RETURN END 'OUTFILE' GETWRDFTM.FR INTEGER FUNCTION GETWRD (BUFIN, INX, MAXIN, BUFOUT) 'INCLUDE' STRAN.IN, INTEGER GCHAR, BUFIN(1), INX, MAXIN, BUFOUT(1) INTEGER TS GETWRD = 1 'DO' 'WHILE' (INX .LE. MAXIN) TS = GCHAR (BUFIN, INX) INX = INX + 1 'IF' (TS .EQ. BLANK .OR. TS .EQ. TAB ^ .OR. TS .EQ. GIZZY .OR. TS .EQ. 0) 'BREAK' 'ENDIF' CALL PCHAR (BUFOUT, GETWRD, TS) GETWRD = GETWRD + 1 'END' CALL PCHAR (BUFOUT, GETWRD, BLANK) GETWRD = GETWRD - 1 RETURN END 'OUTFILE' GETLINFTM.FR INTEGER FUNCTION GETLIN (BUFFER, CHAN) 'INCLUDE' STRAN.IN, INTEGER GCHAR, BUFFER (40), CHAN INTEGER TS, ERROR GETLIN = -1 CALL SET (BBLANK, BUFFER, 40) TS = 80 CALL RDLIN (CHAN, BUFFER, TS, ERROR) IF (ERROR .EQ. 9) RETURN 'FOR' (GETLIN = 36; GETLIN .GE. 1; GETLIN = GETLIN - 1) 'IF' (BUFFER (GETLIN) .EQ. BBLANK) 'END' 'ENDIF' GETLIN = GETLIN * 2 'DO' 'WHILE' (GETLIN .GE. 1) TS = GCHAR (BUFFER, GETLIN) 'IF' (TS .EQ. BLANK .OR. TS .EQ. TAB) GETLIN = GETLIN - 1 'END' 'ENDIF' GETLIN = GETLIN + 1 CALL PCHAR (BUFFER, GETLIN, EOL) RETURN END 'OUTFILE' PUTBAKFTM.FR SUBROUTINE PUTBAK (ICHAR) 'INCLUDE' STRAN.IN, INTEGER ICHAR ISP = ISP + 1 ICSTK (ISP) = ICHAR RETURN END 'OUTFILE' SKIPBLFTM.FR SUBROUTINE SKIPBL 'INCLUDE' STRAN.IN, INTEGER GETC 'DO' CHAR = GETC (CHAR) 'WHILE' (CHAR .EQ. BLANK .OR. CHAR .EQ. TAB) 'END' CALL PUTBAK (CHAR) RETURN END 'OUTFILE' IGNOREFTM.FR SUBROUTINE IGNORE 'INCLUDE' STRAN.IN, INTEGER GETC 'DO' CHAR = GETC (CHAR) 'WHILE' (CHAR .NE. EOL) 'END' CALL PUTBAK (CHAR) RETURN END 'OUTFILE' GETNUMFTM.FR INTEGER FUNCTION GETNUM (/DUMMY/) 'INCLUDE' STRAN.IN, INTEGER DUMMY INTEGER CTYPE, GETC GETNUM = 0 'DO' 'WHILE' (LEXVAL .EQ. DIGIT) GETNUM = GETNUM * 10 + CHAR - CHAR0 LEXVAL = CTYPE (GETC (CHAR)) 'END' CALL PUTBAK (CHAR) RETURN END 'OUTFILE' COPYLNFTM.FR SUBROUTINE COPYLN 'INCLUDE' STRAN.IN, INTEGER GETNUM LN = GETNUM (CHAR) CALL PLN (LN) RETURN END 'OUTFILE' COPYTOFTM.FR SUBROUTINE COPYTO (BUFOUT, OUTX, ICHAR) 'INCLUDE' STRAN.IN, INTEGER TS, GETC, BUFOUT(1), OUTX, ICHAR SLEN = 0 'DO' TS = GETC (CHAR) 'WHILE' (TS .NE. ICHAR) 'IF' (TS .EQ. EOL) CALL REMARK ('MISSING DELIMITER.') RETURN 'ENDIF' CALL PCHAR (BUFOUT, OUTX, TS) OUTX = OUTX + 1 SLEN = SLEN + 1 'END' RETURN END 'OUTFILE' GETC.FR INTEGER FUNCTION GETC (/DUMMY/) 'INCLUDE' STRAN.IN, INTEGER DUMMY, TS, GCHAR, GETLIN 'IF' (ISP .GT. 1) CHAR = ICSTK (ISP) ISP = ISP - 1 GOTO 10 'ENDIF' 'IF' (INPTR .EQ. INMAX) CHAR = EOL INPTR = INPTR + 1 10 GETC = CHAR RETURN 'ENDIF' 'DO' 'IF' (INPTR .LT. INMAX) CHAR = GCHAR (IBUF, INPTR) INPTR = INPTR + 1 'IF' (CHAR .EQ. TAB) TSEEN = .TRUE. CHAR = BLANK GOTO 10 'ENDIF' 'IF' (CHAR .EQ. SLASH) 'IF' (GCHAR (IBUF, INPTR) .EQ. SLASH) INPTR = INMAX + 1 CHAR = EOL GOTO 10 'ENDIF' 'ENDIF' CTEMP = CHAR IF (CTEMP .NE. UPAROW .AND. INPTR .LE. INMAX) GOTO 10 'ENDIF' CALL PRINT LINENO = LINENO + 1 INMAX = GETLIN (IBUF, INCHAN) INPTR = 1 'IF' (CTEMP .EQ. UPAROW) 'DO' TS = GCHAR (IBUF, INPTR) 'WHILE' (TS .EQ. BLANK .OR. TS .EQ. TAB) INPTR = INPTR + 1 'END' 'ENDIF' 'WHILE' (INMAX .NE. EOF) 'END' CHAR = EOF INPTR = INMAX + 1 SKIPFL = .TRUE. GOTO 10 END 'OUTFILE' PUTCFTM.FR SUBROUTINE PUTC (ICHAR) 'INCLUDE' STRAN.IN, INTEGER CONTL INTEGER ICHAR, TS 'IF' (OUTCHN .NE. -1) 'IF' (ICHAR .EQ. EOL) 'IF' (NEWFIL) NEWFIL = .FALSE. N CALL PSTR (' COMPILER NOSTACK;/') 'ENDIF' N CALL PCHAR (OUTBUF, OUTPTR, EOL) CALL PCHAR (OUTBUF, OUTPTR, BLANK) TS = 72 OUTPTR = OUTPTR + 1 CALL WRLIN (OUTCHN, OUTBUF, TS) CALL INITOB CONTL = 0 RETURN 'ENDIF' 'IF' (OUTPTR .LE. 72) CALL PCHAR (OUTBUF, OUTPTR, ICHAR) OUTPTR = OUTPTR + 1 RETURN 'ENDIF' N CALL PCHAR (OUTBUF, 73, EOL) P CALL PCHAR (OUTBUF, 73, BLANK) TS = 72 CALL WRLIN (OUTCHN, OUTBUF, TS) CALL INITOB CALL PCHAR (OUTBUF, 6, CHAR1) CALL LSTART CALL PCHAR (OUTBUF, 7, ICHAR) OUTPTR = OUTPTR + 1 IF(.NOT.QSEEN)CALL SKIPBL CONTL = CONTL + 1 'IF' (CONTL .EQ. 20) CALL REMARK ('TOO MANY CONTINUATION LINES.') 'ENDIF' 'ENDIF' RETURN END 'OUTFILE' PRINTFTM.FR SUBROUTINE PRINT 'INCLUDE' STRAN.IN, LOGICAL TLOGIC INTEGER GCHAR, FORMF DATA FORMF /Z0C0D0D0D/ 'IF' ((.NOT.POFF) .AND. LPTCHN .GE. 0) TLOGIC=.NOT.SKIPFL 'IF' (TLOGIC) 'IF' (TSEEN) CALL SET(BBLANK,PBUF,56) II = 1 JJ = 1 'DO' 'WHILE' (II .LT. INMAX) CHAR = GCHAR (IBUF, II) 'IF' (CHAR .NE. TAB) CALL PCHAR (PBUF, JJ, CHAR) JJ = JJ + 1 'NEXT' 'ENDIF' 'DOLOOP' K = 1, MAXTAB 'IF' (JJ .GE. TABS (K)) 'END' CALL PCHAR (PBUF, JJ, CHAR) JJ = JJ + 1 'NEXT' 'ENDIF' TLIMIT = TABS (K) 'DOLOOP' JJ = JJ, TLIMIT CALL PCHAR (PBUF, JJ, BLANK) 'END' 'END' 'ENDIF' 'IF' (CLINE .GE. MAXLIN) 'IF' (FIRST) FIRST = .FALSE. CALL SET(BBLANK,HBUF,40) 'ENDIF' PAGE = PAGE + 1 CALL SET (BBLANK, BUF, 60) CALL EST ('PAGE ', BUF, 1, 5) CALL ESP (PAGE, BUF, 6, 9) CALL EST (' ', BUF, 10, 13) CALL EST (HBUF, BUF, 14, 64) KK = 1 CALL WRLIN (LPTCHN, FORMF, KK) CALL PCHAR (BUF, 65, EOL) KK = 64 CALL WRLIN (LPTCHN, BUF, KK) CALL SET(BBLANK,BUF,2) KK = 1 CALL WRLIN (LPTCHN, BUF, KK) CLINE = 0 'ENDIF' 'ELSE' SKIPFL = .FALSE. RETURN 'ENDIF' 'IF' (LINENO .NE. 0) CALL SET (BBLANK, BUF, 5) CALL ESP (LINENO, BUF, 1, 4) 'IF' (TSEEN) TSEEN = .FALSE. CALL EST (PBUF, BUF, 9, 120) CALL PCHAR (BUF, 121, EOL) KK = 120 'ELSE' CALL EST (IBUF, BUF, 9, 88) CALL PCHAR (BUF, 89, EOL) KK = 88 'ENDIF' CALL WRLIN (LPTCHN, BUF, KK) 'ENDIF' CLINE = CLINE + 1 'ENDIF' RETURN END