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>