File:  [gforth] / gforth / compat / required.fs
Revision 1.1: download - view: text, annotated - select for diffs
Thu Apr 30 14:48:18 1998 UTC (21 years, 6 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

\ required

\ This file is in the public domain. NO WARRANTY.

\ s" filename" required
\ includes the file if no file name "filename" has been included before
\ warning: does not deal correctly with accesses to the same file through
\ different path names; but since ANS Forth does not specify path handling...

\ The program uses the following words
\ from CORE :
\ 0= : swap >r dup 2dup r> rot move ; cells r@ @ over ! cell+ 2! BEGIN
\ WHILE 2@ IF drop 2drop EXIT THEN REPEAT ELSE Variable
\ from CORE-EXT :
\ 2>r 2r@ 2r> true 
\ from BLOCK-EXT :
\ \ 
\ from EXCEPTION :
\ throw 
\ from FILE :
\ S" ( included 
\ from MEMORY :
\ allocate 
\ from SEARCH :
\ forth-wordlist search-wordlist 
\ from STRING :
\ compare 
\ from TOOLS-EXT :
\ [IF] [THEN] 

s" required" forth-wordlist search-wordlist [if]
    drop
[else]

\ we use a linked list of names

: save-mem	( addr1 u -- addr2 u ) \ gforth
    \ copy a memory block into a newly allocated region in the heap
    swap >r
    dup allocate throw
    swap 2dup r> rot rot move ;

: name-add ( addr u listp -- )
    >r save-mem ( addr1 u )
    3 cells allocate throw \ allocate list node
    r@ @ over ! \ set next pointer
    dup r> ! \ store current node in list var
    cell+ 2! ;
    
: name-present? ( addr u list -- f )
    rot rot 2>r begin ( list R: addr u )
	dup
    while
	dup cell+ 2@ 2r@ compare 0= if
	    drop 2r> 2drop true EXIT
	then
	@
    repeat
    ( drop 0 ) 2r> 2drop ;

: name-join ( addr u list -- )
    >r 2dup r@ @ name-present? if
	r> drop 2drop
    else
	r> name-add
    then ;

variable included-names 0 included-names !

: included ( i*x addr u -- j*x )
    2dup included-names name-join
    included ;

: required ( i*x addr u -- j*x )
    2dup included-names @ name-present? 0= if
	included
    else
	2drop
    then ;

[then]

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