Annotation of gforth/search-order.fs, revision 1.1
1.1 ! anton 1: \ search order wordset 14may93py
! 2:
! 3: $10 constant maxvp
! 4: Variable vp
! 5: 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A,
! 6: 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A, 0 A,
! 7:
! 8: : get-current ( -- wid ) current @ ;
! 9: : set-current ( wid -- ) current ! ;
! 10:
! 11: : context ( -- addr ) vp dup @ cells + ;
! 12: : definitions ( -- ) context @ current ! ;
! 13:
! 14: \ wordlist Vocabulary also previous 14may93py
! 15:
! 16: AVariable voclink
! 17:
! 18: : wordlist ( -- wid )
! 19: here 0 A, Forth-wordlist cell+ @ A, voclink @ A, 0 A,
! 20: dup 2 cells + voclink ! ;
! 21:
! 22: : Vocabulary ( -- ) Create wordlist drop DOES> context ! ;
! 23:
! 24: : also ( -- )
! 25: context @ vp @ 1+ dup maxvp > abort" Vocstack full"
! 26: vp ! context ! ;
! 27:
! 28: : previous ( -- ) vp @ 1- dup 0= abort" Vocstack empty" vp ! ;
! 29:
! 30: \ vocabulary find 14may93py
! 31:
! 32: : (vocfind) ( addr count nfa1 -- nfa2 / false ) drop
! 33: 1 vp @ DO 2dup vp I cells + @ (search-wordlist)
! 34: dup IF nip nip UNLOOP exit THEN drop
! 35: -1 +LOOP 2drop false ;
! 36:
! 37: Create vocsearch ] (vocfind) (reveal) [
! 38:
! 39: \ Only root 14may93py
! 40:
! 41: wordlist vocsearch over cell+ A!
! 42:
! 43: Vocabulary Forth
! 44: Vocabulary Root
! 45:
! 46: : Only vp off also Root also definitions ;
! 47:
! 48: \ set initial search order 14may93py
! 49:
! 50: Forth-wordlist @ ' Forth >body A!
! 51:
! 52: Only Forth also definitions
! 53:
! 54: search A!
! 55:
! 56: \ get-order set-order 14may93py
! 57:
! 58: : get-order ( -- wid1 .. widn n )
! 59: vp @ 0 ?DO vp cell+ I cells + @ LOOP vp @ ;
! 60:
! 61: : set-order ( wid1 .. widn n / -1 -- )
! 62: dup -1 = IF drop Only exit THEN dup vp !
! 63: ?dup IF 1- FOR vp cell+ I cells + ! NEXT THEN ;
! 64:
! 65: : seal ( -- ) context @ 1 set-order ;
! 66:
! 67: \ words visible in roots 14may93py
! 68:
! 69: : .name ( name -- ) name>string type space ;
! 70: : words cr 0 context @
! 71: BEGIN @ dup WHILE 2dup cell+ c@ $1F and 2 + dup >r +
! 72: &79 > IF cr nip 0 swap THEN
! 73: dup .name space r> rot + swap REPEAT 2drop ;
! 74:
! 75: : body> ( data -- cfa ) 0 >body - ;
! 76:
! 77: : .voc body> >name .name ;
! 78: : order 1 vp @ DO vp I cells + @ .voc -1 +LOOP 2 spaces
! 79: current @ .voc ;
! 80: : vocs voclink BEGIN @ dup @ WHILE dup 2 cells - .voc REPEAT drop ;
! 81:
! 82: Root definitions
! 83:
! 84: ' words Alias words
! 85: ' Forth Alias Forth
! 86:
! 87: Forth definitions
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>