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>