File:  [gforth] / gforth / compat / required.fs
Revision 1.1: download - view: text, annotated - select for diffs
Thu Apr 30 14:48:18 1998 UTC (24 years, 7 months ago) by anton
Branches: MAIN
CVS tags: v0-7-0, v0-6-2, v0-6-1, v0-6-0, v0-5-0, v0-4-0, HEAD
added required.fs

    1: \ required
    2: 
    3: \ This file is in the public domain. NO WARRANTY.
    4: 
    5: \ s" filename" required
    6: \ includes the file if no file name "filename" has been included before
    7: \ warning: does not deal correctly with accesses to the same file through
    8: \ different path names; but since ANS Forth does not specify path handling...
    9: 
   10: \ The program uses the following words
   11: \ from CORE :
   12: \ 0= : swap >r dup 2dup r> rot move ; cells r@ @ over ! cell+ 2! BEGIN
   13: \ WHILE 2@ IF drop 2drop EXIT THEN REPEAT ELSE Variable
   14: \ from CORE-EXT :
   15: \ 2>r 2r@ 2r> true 
   16: \ from BLOCK-EXT :
   17: \ \ 
   18: \ from EXCEPTION :
   19: \ throw 
   20: \ from FILE :
   21: \ S" ( included 
   22: \ from MEMORY :
   23: \ allocate 
   24: \ from SEARCH :
   25: \ forth-wordlist search-wordlist 
   26: \ from STRING :
   27: \ compare 
   28: \ from TOOLS-EXT :
   29: \ [IF] [THEN] 
   30: 
   31: s" required" forth-wordlist search-wordlist [if]
   32:     drop
   33: [else]
   34: 
   35: \ we use a linked list of names
   36: 
   37: : save-mem	( addr1 u -- addr2 u ) \ gforth
   38:     \ copy a memory block into a newly allocated region in the heap
   39:     swap >r
   40:     dup allocate throw
   41:     swap 2dup r> rot rot move ;
   42: 
   43: : name-add ( addr u listp -- )
   44:     >r save-mem ( addr1 u )
   45:     3 cells allocate throw \ allocate list node
   46:     r@ @ over ! \ set next pointer
   47:     dup r> ! \ store current node in list var
   48:     cell+ 2! ;
   49:     
   50: : name-present? ( addr u list -- f )
   51:     rot rot 2>r begin ( list R: addr u )
   52: 	dup
   53:     while
   54: 	dup cell+ 2@ 2r@ compare 0= if
   55: 	    drop 2r> 2drop true EXIT
   56: 	then
   57: 	@
   58:     repeat
   59:     ( drop 0 ) 2r> 2drop ;
   60: 
   61: : name-join ( addr u list -- )
   62:     >r 2dup r@ @ name-present? if
   63: 	r> drop 2drop
   64:     else
   65: 	r> name-add
   66:     then ;
   67: 
   68: variable included-names 0 included-names !
   69: 
   70: : included ( i*x addr u -- j*x )
   71:     2dup included-names name-join
   72:     included ;
   73: 
   74: : required ( i*x addr u -- j*x )
   75:     2dup included-names @ name-present? 0= if
   76: 	included
   77:     else
   78: 	2drop
   79:     then ;
   80: 
   81: [then]

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>