Commit 1a243cc2 authored by anton's avatar anton

added required.fs

parent 755c8415
\ 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]
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment