home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / MISC / FORTHCMP.ZIP / FFIND.4TH < prev    next >
Encoding:
Text File  |  1992-03-30  |  5.6 KB  |  212 lines
  1. \ FORTH FIND PROGRAM, BY TOM ALMY.
  2.  
  3. \ THIS PROGRAM IS COPYRIGHT (C) 1985 BY TOM ALMY,
  4. \ ALL RIGHTS RESERVED.
  5.  
  6. \  Users of ForthCMP are given permission to use or distribute this
  7. \  program, as long as no charge is made and the credit message is maintained.
  8.  
  9.  
  10. 100 MSDOS
  11. \ I80186    \ FOR PC/AT
  12. \ ALIGNDATA    \ FOR PC/AT
  13. INCLUDE VARS
  14. INCLUDE DOS1
  15.  
  16.  
  17. 0 0 IN/OUT NEED HELP-ME
  18. VARIABLE CHPOS   \ Position in line
  19.  
  20. \ KEY -- FROM A FILE
  21.  
  22. 32768 CONSTANT INBUFSZ
  23. HCB INFILE            \ File being read
  24. 10000 CONSTANT INBUFFER     \ Buffer for input file
  25. VARIABLE INBUFPTR        \ Pointer to next character in buffer
  26. VARIABLE INBUFEND        \ End of buffer
  27.  
  28. 128 CONSTANT SCRATCH_BUF
  29.  
  30.  
  31. : KEY  INBUFPTR @ INBUFEND @ = IF ( fetch block )
  32.      INFILE INBUFFER INBUFSZ FREAD ?DUP IF ( everything OK )
  33.             INBUFFER INBUFPTR !  
  34.             INBUFFER + INBUFEND !
  35.      ELSE CHPOS OFF  CONTROL Z EXIT 
  36.      THEN
  37.     THEN
  38.     CHPOS @ 64 <> IF ( character is in line )
  39.         1 CHPOS +!
  40.         INBUFPTR @ C@ 127 AND  1 INBUFPTR +! 
  41.       ELSE 
  42.         13 ( cr ) CHPOS OFF 
  43.       THEN  ;
  44.  
  45.  
  46. \ DIRECTORY SEARCHING STUFF
  47.  
  48. 256 CONSTANT LINBUFSIZE        \ Lines should not be longer than this
  49. CREATE LINEBUF  LINBUFSIZE ALLOT
  50. CREATE MATCHBUF 128 ALLOT 
  51. CREATE UCMATCHBUF 128 ALLOT    \ upcased version of above )
  52. VARIABLE NEXTITEM        \ must scan for new wildcard file name
  53. HCB WILDFILE            \ possibly wildcarded file name
  54. VARIABLE INFILEP        \ just a pointer
  55. VARIABLE /PNTR            \ location of last / or \
  56.  
  57. 1 0 IN/OUT
  58. : ADD.DEFAULT.EXTENSION ( handle -- )
  59.   2+ DUP >R  1+  ( ext string )
  60.   BEGIN COUNT DUP ASCII . = IF DROP BEGIN COUNT DUP 0=
  61.         IF R> DROP 2DROP EXIT THEN DUP ASCII \ = SWAP ASCII / = OR UNTIL  1 THEN
  62.         0= UNTIL
  63.   DUP 1- ASCII . C<-  ( replace null with dot )
  64.   CNT" SCR"  0 DO COUNT 2 PICK C! SWAP 1+ SWAP LOOP
  65.   DROP ( extension address )
  66.   DUP 0 C<-  ( delimit string )
  67.   R@ - 1- R> C!   ( set length byte )
  68.   ; 
  69.  
  70. 0 0 IN/OUT
  71. : PARSE-COMMAND-LINE  ( -- )
  72.    128 1+ TIB 127 CMOVE 
  73.    128 C@ #TIB !
  74.    >IN OFF
  75.    NEXTITEM ON
  76.    BL WORD COUNT DUP 0= IF HELP-ME THEN ( NO ARGUMENTS )
  77.    MATCHBUF SWAP CMOVE  ( MOVE IN MATCH STRING )
  78.    128 0 DO MATCHBUF I + C@ DUP ASCII a >= IF DUP ASCII z <= 
  79.                                               IF 32 - THEN THEN
  80.             UCMATCHBUF I + C! LOOP   ( fill uppercase buffer )
  81.    ;
  82.  
  83.  
  84. 1 0 IN/OUT 
  85. : PUTN ( character -- , put in string of INFILE )
  86.    INFILEP @ C! 1 INFILEP +! ;
  87.  
  88.  
  89. 0 0 IN/OUT
  90. : MAKE-FILENAME \ set up INFILE with path from WILDFILE and
  91.         \ file name from SCRATCH_BUF
  92.     INFILE 3 + INFILEP ! \ address of destination string
  93.     INFILEP @  /PNTR !  \ location of last slash 
  94.     WILDFILE 2+ COUNT 0 ?DO COUNT DUP PUTN 
  95.                  DUP ASCII \ = SWAP ASCII / = OR IF INFILEP @ /PNTR ! THEN LOOP
  96.     DROP ( wildfile pointer )
  97.     /PNTR @ INFILEP !    \ get rid of characters after last \
  98.     SCRATCH_BUF 30 + \ remainder of filename
  99.     BEGIN COUNT DUP WHILE PUTN REPEAT 2DROP
  100.     INFILEP @ INFILE 3 + - INFILE 2+ C! \ length
  101.     0 PUTN \ zero delimit string
  102.     ;
  103.  
  104.  
  105. 0 1 IN/OUT 
  106. : NEW-FILE? ( -- success )
  107.   BEGIN NEXTITEM @ IF ( must scan input stream )
  108.     BL WORD DUP C@ 0= IF DROP 0 EXIT THEN ( End of line )
  109.         WILDFILE NAME>HCB
  110.     WILDFILE ADD.DEFAULT.EXTENSION
  111.     WILDFILE HCB>N 0 firstf
  112.     NEXTITEM OFF 
  113.     ELSE
  114.     nextf THEN 
  115.     WHILE ( search failed )
  116.     NEXTITEM ON
  117.     REPEAT
  118.   MAKE-FILENAME
  119.   INFILE O_RD FOPEN IF CR 
  120.     ." OPEN FAILED FOR " INFILE .FNAME
  121.     NEW-FILE? EXIT THEN
  122.   INBUFEND @ INBUFPTR !  ( force first read )
  123.   -1 ( SUCCESS! )   ;
  124.  
  125.  
  126. 0 0 IN/OUT
  127. : CLOSE-THE-FILE  INFILE FCLOSE DROP ;
  128.  
  129.  
  130. 0 0 IN/OUT
  131. : PRINT-SEARCHING ( --- )
  132.   CR ." Searching " INFILE .FNAME ;
  133.  
  134. 0 0 IN/OUT
  135. : HELLO                   
  136.   ." Forth Search Program.  Copyright (C) 1865 by Tom Almy" CR
  137. ;
  138.  
  139. 0 0 IN/OUT
  140. : HELP-ME
  141.   ." Usage: FFIND string {filenames}" CR
  142.   0 0 BDOS 
  143. ;  
  144.  
  145. VARIABLE LINE#
  146.  
  147. VARIABLE ^LINE
  148.  
  149. 1 0 IN/OUT 
  150. : PUT-LINE ( char -- ) ^LINE @ C!  1 ^LINE +! ;
  151.  
  152. 0 0 IN/OUT
  153. : CLEAR-LINE   LINEBUF ^LINE ! ;
  154.  
  155. 0 0 IN/OUT
  156. : .LINE   ( display matched line ) 
  157.        CR  LINE# @ 16 /MOD 4 .R SPACE 3 .R SPACE
  158.        LINEBUF ^LINE @ LINEBUF - TYPE
  159.        BEGIN KEY DUP BL >= WHILE EMIT REPEAT DROP
  160.        CLEAR-LINE  ;
  161.  
  162.  
  163.  
  164. 0 0 IN/OUT
  165. : SEARCHING   PRINT-SEARCHING
  166.    LINE# OFF  CLEAR-LINE
  167.    UCMATCHBUF COUNT
  168.    MATCHBUF COUNT  ( first char on top of stack, bufferaddr under )
  169.    BEGIN KEY  CASE
  170.       13 OF  CLEAR-LINE   2DROP  2DROP  1 LINE# +!
  171.              UCMATCHBUF COUNT MATCHBUF COUNT ENDOF   \ CR
  172.       26 OF  2DROP 2DROP  EXIT ENDOF                 \ END OF FILE
  173.        0 OF  2DROP 2DROP  EXIT ENDOF                 \ null is also eof
  174.      \ stack has ucbufaddr char bufaddr char key
  175.       OVER  OF                                       \ CHARACTER MATCHES
  176.              PUT-LINE  NIP SWAP COUNT ROT COUNT 
  177.                DUP 0= IF   2DROP 2DROP   \ COMPLETE MATCH          
  178.                  .LINE
  179.                  UCMATCHBUF COUNT MATCHBUF COUNT THEN    
  180.             ENDOF
  181.      \ stack has ucbufaddr char bufaddr char key
  182.       3 PICK  OF                                 \ UPPERCASE CHARACTER MATCHES
  183.              ROT PUT-LINE  DROP SWAP COUNT ROT COUNT 
  184.                DUP 0= IF   2DROP 2DROP   \ COMPLETE MATCH          
  185.                  .LINE
  186.                  UCMATCHBUF COUNT MATCHBUF COUNT THEN    
  187.             ENDOF
  188.        PUT-LINE 2DROP 2DROP                                   \ NO MATCH
  189.        UCMATCHBUF COUNT MATCHBUF COUNT  0   
  190.      ENDCASE
  191.    0 UNTIL  \ REPEAT FOREVER
  192.    ;
  193.  
  194.  
  195.  
  196. \ MAIN LOOP
  197. : MAIN
  198.   HELLO
  199.   PARSE-COMMAND-LINE
  200.   BEGIN 
  201.     NEW-FILE? WHILE
  202.     SEARCHING 
  203.     CLOSE-THE-FILE
  204.   REPEAT ;
  205.  
  206. INCLUDE DOS2
  207. INCLUDE FORTHLIB
  208. NOMAP
  209. END
  210.  
  211.  
  212.