home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware 1 2 the Maxx
/
sw_1.zip
/
sw_1
/
PROGRAM
/
FORTHCMP.ZIP
/
FIND.4TH
< prev
next >
Wrap
Text File
|
1992-03-30
|
6KB
|
258 lines
\ FIND PROGRAM, BY TOM ALMY.
\ THIS PROGRAM IS COPYRIGHT (C) 1985 BY TOM ALMY,
\ ALL RIGHTS RESERVED.
\ Users of ForthCMP are given permission to use or distribute this
\ program, as long as no charge is made and the credit message is maintained.
100 MSDOS
INCLUDE VARS
INCLUDE DOS1
0 0 IN/OUT NEED HELP-ME
\ KEY -- FROM A FILE
32768 CONSTANT INBUFSZ
128 CONSTANT SCRATCH_BUF
HCB INFILE \ File being read
10000 CONSTANT INBUFFER \ Buffer for input file in high memory
VARIABLE INBUFPTR \ Pointer to next character in buffer
VARIABLE INBUFEND \ End of buffer
: KEY
INBUFPTR @ INBUFEND @ = IF ( fetch block )
INFILE INBUFFER INBUFSZ FREAD ?DUP IF ( everything OK )
INBUFFER INBUFPTR !
INBUFFER + INBUFEND !
ELSE
CONTROL Z EXIT
THEN
THEN
INBUFPTR @ C@ 127 AND
1 INBUFPTR +! ;
\ DIRECTORY SEARCHING STUFF
256 CONSTANT LINBUFSIZE \ Lines should not be longer than this
CREATE LINEBUF LINBUFSIZE ALLOT
CREATE MATCHBUF 128 ALLOT
CREATE UCMATCHBUF 128 ALLOT \ upcased version of above )
VARIABLE NEXTITEM \ must scan for new wildcard file name
HCB WILDFILE \ possibly wildcarded file name
VARIABLE INFILEP \ just a pointer
VARIABLE /PNTR \ location of last / or \
0 EQU NEWFILE? \ new file
2 1 IN/OUT
: PROCESS-WORD ( destAddr srcaddr -- newdestaddr )
BEGIN #TIB @ >IN @ > WHILE \ more characters to process
DUP C@ BL = IF DROP EXIT THEN \ found blank -- quit
DUP C@ ASCII \ = IF 1+ 1 >IN +! THEN \ quote next character
2DUP C@ SWAP C!
1+ SWAP 1+ SWAP 1 >IN +!
REPEAT
DROP \ reached end (bad news), we are finished
;
2 2 IN/OUT
: SEEK-START ( destAddr srcAddr -- destAddr newSrcAddr )
BEGIN #TIB @ >IN @ > WHILE \ more characters to process
DUP C@ BL = IF 1+ 1 >IN +!
ELSE EXIT THEN
REPEAT \ BAD NEWS IF FINISHES
;
0 1 IN/OUT
: NICE-WORD ( -- addr )
DP @ 1+ TIB >IN @ + \ destAddr srcAddr
SEEK-START
PROCESS-WORD
DP @ 1+ - \ length of match string
DP @ C! \ gets stored at start
DP @
;
0 0 IN/OUT
: PARSE-COMMAND-LINE ( -- )
128 1+ TIB 127 CMOVE
128 C@ #TIB !
>IN OFF
NEXTITEM ON
NICE-WORD COUNT DUP 0= IF HELP-ME THEN ( NO ARGUMENTS )
MATCHBUF SWAP CMOVE ( MOVE IN MATCH STRING )
128 0 DO MATCHBUF I + C@ DUP ASCII a >= IF DUP ASCII z <=
IF 32 - THEN THEN
UCMATCHBUF I + C! LOOP ( fill uppercase buffer )
;
1 0 IN/OUT
: PUTN ( character -- , put in string of INFILE )
INFILEP @ C! 1 INFILEP +! ;
0 0 IN/OUT
: MAKE-FILENAME \ set up INFILE with path from WILDFILE and
\ file name from SCRATCH_BUF
INFILE 3 + INFILEP ! \ address of destination string
INFILEP @ /PNTR ! \ location of last slash
WILDFILE 2+ COUNT 0 ?DO COUNT DUP PUTN
DUP ASCII \ = OVER ASCII : = OR SWAP ASCII / = OR IF
INFILEP @ /PNTR ! THEN
LOOP
DROP ( wildfile pointer )
/PNTR @ INFILEP ! \ get rid of characters after last \
SCRATCH_BUF 30 + \ remainder of filename
BEGIN COUNT DUP WHILE PUTN REPEAT 2DROP
INFILEP @ INFILE 3 + - INFILE 2 + C! \ length
0 PUTN \ zero delimit string
;
0 1 IN/OUT
: NEW-FILE? ( -- success )
BEGIN NEXTITEM @ IF ( must scan input stream )
BL WORD DUP C@ 0= IF DROP 0 EXIT THEN ( End of line )
WILDFILE NAME>HCB
WILDFILE HCB>N 0 firstf
NEXTITEM OFF
ELSE
nextf
THEN
WHILE ( search failed )
NEXTITEM ON
REPEAT
MAKE-FILENAME
INFILE O_RD FOPEN IF MESSAGES CR
." OPEN FAILED FOR " INFILE .FNAME CONSOLE
NEW-FILE? EXIT THEN
INBUFEND @ INBUFPTR ! ( force first read )
-1 ( SUCCESS! ) ;
0 0 IN/OUT
: CLOSE-THE-FILE INFILE FCLOSE DROP ;
\ Messages
0 0 IN/OUT
: PRINT-SEARCHING ( --- )
NEWFILE? IF
CR ." Searching " INFILE .FNAME
0 EQU NEWFILE?
THEN
;
0 0 IN/OUT
: HELLO
MESSAGES
." Search Program. Copyright (C) 1985 by Tom Almy" CR
CONSOLE
;
0 0 IN/OUT
: HELP-ME
MESSAGES
." Usage: FIND string {filenames}" CR
." String escape character is \" CR
bye
;
\ Searching functions
VARIABLE LINE#
VARIABLE ^LINE
0 0 IN/OUT
: CLEAR-LINE LINEBUF ^LINE ! ;
1 0 IN/OUT
: PUT-LINE ( char -- )
LINEBUF LINBUFSIZE + ^LINE @ = IF
MESSAGES CR ." LINE TOO LONG!" CLEAR-LINE CONSOLE THEN
^LINE @ C! 1 ^LINE +! ;
10 CONSTANT aLF
13 CONSTANT aCR
9 CONSTANT aTAB
0 0 IN/OUT
: PRINT-TO-EOL
BEGIN
KEY DUP aLF <> OVER CONTROL Z <> AND
WHILE
DUP aCR = IF DROP ELSE EMIT THEN
REPEAT
DROP ;
0 0 IN/OUT
: SEARCHING
-1 EQU NEWFILE?
1 LINE# !
CLEAR-LINE
UCMATCHBUF COUNT
MATCHBUF COUNT ( first char on top of stack, bufferaddr under )
BEGIN KEY CASE
aLF OF CLEAR-LINE 2DROP 2DROP \ lf
UCMATCHBUF COUNT MATCHBUF COUNT
1 LINE# +! ENDOF
\ stack has ucbufaddr char bufaddr char key
OVER OF \ CHARACTER MATCHES
PUT-LINE NIP SWAP COUNT ROT COUNT
DUP 0= IF 2DROP 2DROP \ COMPLETE MATCH
PRINT-SEARCHING
CR LINE# @ 4 .R SPACE
LINEBUF ^LINE @ LINEBUF - TYPE
PRINT-TO-EOL
CLEAR-LINE
UCMATCHBUF COUNT MATCHBUF COUNT THEN
ENDOF
\ stack has ucbufaddr char bufaddr char key
3 PICK OF \ UPPERCASE CHARACTER MATCHES
ROT PUT-LINE DROP SWAP COUNT ROT COUNT
DUP 0= IF 2DROP 2DROP \ COMPLETE MATCH
PRINT-SEARCHING
CR LINE# @ 4 .R SPACE
LINEBUF ^LINE @ LINEBUF - TYPE
PRINT-TO-EOL
CLEAR-LINE
UCMATCHBUF COUNT MATCHBUF COUNT THEN
ENDOF
CONTROL Z OF 2DROP 2DROP EXIT ENDOF \ END OF FILE
PUT-LINE 2DROP 2DROP \ NO MATCH
UCMATCHBUF COUNT MATCHBUF COUNT 0
ENDCASE
AGAIN \ REPEAT FOREVER
;
\ MAIN LOOP
: MAIN
HELLO
PARSE-COMMAND-LINE
BEGIN
NEW-FILE? WHILE
SEARCHING
CLOSE-THE-FILE
REPEAT ;
INCLUDE DOS2
INCLUDE FORTHLIB
END