ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng)/ProfitPress-MegaCDROM2.B6I/PROG/MISC/FORTHCMP.ZIP/FILTER.4TH

Text File | 1992-03-30 | 5.2 KB | 147 lines

\ 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 ForthCMP 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