Annotation of gforth/compat/required.fs, revision 1.1
1.1 ! anton 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>