Category : Forth Source Code
Archive   : FORTHCOM.ZIP
Filename : FILTER.4TH

\ FILTER INTERFACE
0 #IF
COPYRIGHT 1985 (C) BY THOMAS ALMY. ALL RIGHTS RESERVED
Revision copyright 1991 (C) by Thomas Almy.

Permission is granted to registered users of FORTHCOM to sell or distribute
computer programs incorporating the compiled contents of this file.

VARS and DOS1 must be INCLUDED from the main program

User functions are SETFILES, BYE, ABORT, CONSOLE, FILTER,
KEY, EMIT, EXPECT, SETBUFS and the variable OPTIONSTRING.
DO NOT use PRINTER and/or MESSAGES (latter is "CONSOLE" here)
SDEFSTR, DDEFSTR, and BUFSIZ tailor the program for
specific applications.
See UNLOAD.4TH and LIST.4TH for examples of use.
#THEN

\ FILTER SUPORT -- EMITS
10 DECIMAL .( LOADING FILTER ) CR
FIND BUFSIZ #IF DROP #ELSE 512 CONSTANT BUFSIZ #THEN
FIND TIB #IF DROP #ELSE INCLUDE VARS #THEN
FIND stdin #IF DROP #ELSE INCLUDE DOS1 #THEN
HCB outfile ( when file is set )
DSEG stdout outfile ! ( set to default to STD-OUTPUT )
VARIABLE outhandle ( handle to use on output )
DSEG stderr outhandle ! ( initially the display )
VARIABLE outbuffer ( pointer to allocated buffer )
VARIABLE outbufptr
0 0 IN/OUT
: flushout outbuffer @ outbufptr @ <> IF
outhandle @ outbuffer @ outbufptr @ outbuffer @ - DUP >R write
outbuffer @ outbufptr ! R> <> IF stderr outhandle !
." DISK FULL " flushout 4 RETURN THEN THEN ;

: EMIT outbufptr @ DUP outbuffer @ BUFSIZ + = IF flushout
DROP outbuffer @ THEN C! 1 outbufptr +! ;
0 0 IN/OUT : CONSOLE flushout stderr outhandle ! ;
0 0 IN/OUT : FILTER flushout outfile HCB>H outhandle ! ;

1 0 IN/OUT : bye2 ( errorCode -- )
flushout stdout outfile @ <> IF ( file to close )
outfile FCLOSE DROP THEN RETURN ;
0 0 IN/OUT : BYE 0 bye2 ;
0 0 IN/OUT : ABORT 4 bye2 ;


\ LOW LEVEL INTERFACE -- INPUT
VARIABLE inbuffer ( pointer to allocated buffer )
VARIABLE inbufptr VARIABLE inbufend
HCB infile
stdin infile ! \ default

0 0 IN/OUT
: SETBUFS ( must execute before any I/O to allocate buffers )
HERE inbuffer !
BUFSIZ ALLOT
HERE DUP outbuffer ! outbufptr !
BUFSIZ ALLOT ;


\ LOW LEVEL INTERFACE -- KEY AND EXPECT
\ This version of KEY returns -1 on end of file!
: KEY inbufptr @ inbufend @ = IF ( fetch block )
infile @ inbuffer @ BUFSIZ read ?DUP 0= IF ( EOF/ERROR ) -1 EXIT THEN
inbuffer @ + inbufend ! inbuffer @ inbufptr ! THEN
inbufptr @ C@ 1 inbufptr +! ;
\ This version of EXPECT sets SPAN to -1 if end of file!
: EXPECT ( buffer count -- ) DUP SPAN !
0 DO BEGIN KEY DUP CONTROL M = WHILE DROP REPEAT
DUP 0< IF SPAN ON DROP LEAVE THEN
DUP CONTROL Z = IF SPAN ON DROP LEAVE THEN
DUP CONTROL J = IF I SPAN ! DROP LEAVE THEN
OVER C! 1+ LOOP DROP ;

\ STRING COMPARISON UTILITY WORD
PRIMITIVE
: S= ( string1 string2 length -- flag, true if equal )
>R -1 -ROT R> 0 ?DO
OVER I + C@ OVER I + C@
<> IF ROT DROP 0 -ROT LEAVE THEN
LOOP
2DROP ;


\ SHOULD BACKUP FILE IF SAME
0 1 IN/OUT : ?samefile ( -- failflag )
infile HCB>N outfile HCB>N DUP C@ 1+ S= IF
( files are same -- indicate error and abort )
." SOURCE AND DESTINATION FILES IDENTICAL "
-1 ELSE 0 THEN ;

\ SETUP OPTIONS
SEPDSEG? CONSTANT ?dseg
0 0 IN/OUT : setcommand ( set up for command parsing )
?dseg #IF ?CS: 129 ?DS: TIB 127 CMOVEL #ELSE
129 TIB 127 CMOVE #THEN
128 CS: C@ #TIB ! >IN OFF ( read args from TIB ) ;
2VARIABLE OPTIONSTRING
0 0 IN/OUT : setoptions ( get option string, if any )
BL WORD C@ 1 > IF HERE 1+ C@ ASCII - = IF ( got one! )
>IN @ HERE C@ - TIB + DUP 1- C@ ASCII - <> IF 1+ THEN
HERE C@ 1- OPTIONSTRING 2! BL WORD DROP EXIT THEN THEN
0. OPTIONSTRING 2! ;
0 #IF
A pointer to the options string, and its length, is in the
2VARIABLE "OPTIONSTRING". The value is valid until the next
query.
#THEN

\ SET IN DEFAULT EXTENSIONS
FIND SDEFSTR #IF DROP #ELSE 0 CONSTANT SDEFSTR #THEN
FIND DDEFSTR #IF DROP #ELSE 0 CONSTANT DDEFSTR #THEN
SDEFSTR DDEFSTR OR #IF
2 0 IN/OUT

: setext ( hcb extension -- )
SWAP HCB>N DUP >R 1+ ( ext string )
BEGIN COUNT DUP ASCII . = IF DROP BEGIN COUNT DUP 0=
IF R> 2DROP 2DROP EXIT THEN ASCII \ = UNTIL 1 THEN
0= UNTIL
DUP 1- ASCII . C<- ( replace null with dot )
SWAP COUNT 0 ?DO COUNT 2 PICK C! SWAP 1+ SWAP LOOP
DROP ( extension address )
DUP 0 C<- ( delimit string )
R@ - 1- R> C! ( set length byte )
; #THEN

\ MAJOR OPEN DRIVE FUNCTION
0 1 IN/OUT : SETFILES ( -- failureflag )
setcommand setoptions
HERE C@ 0= IF 0 FILTER EXIT THEN
HERE @ ASCII - 8 << 1 + <> IF ( input file )
-1 infile !
HERE infile NAME>HCB
SDEFSTR #IF infile SDEFSTR setext #THEN
infile O_RD FOPEN IF infile .FNAME ." not found"
-1 EXIT THEN THEN
BL WORD C@ IF HERE @ ASCII - 8 << 1 + <> IF ( output file )
-1 outfile !
HERE outfile NAME>HCB
DDEFSTR #IF outfile DDEFSTR setext #THEN
?samefile IF -1 EXIT THEN
outfile 0 FMAKE IF ." cannot create " outfile
.FNAME -1 EXIT THEN
THEN THEN 0 FILTER ;
HEX 0A = #IF DECIMAL #THEN