added required.fs

Author: anton

compat/required.fs

@@ -0,0 +1,81 @@
+\ 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]