diff options
Diffstat (limited to 'qemu/roms/openbios/forth/lib/vocabulary.fs')
-rw-r--r-- | qemu/roms/openbios/forth/lib/vocabulary.fs | 153 |
1 files changed, 153 insertions, 0 deletions
diff --git a/qemu/roms/openbios/forth/lib/vocabulary.fs b/qemu/roms/openbios/forth/lib/vocabulary.fs new file mode 100644 index 000000000..faa75ea87 --- /dev/null +++ b/qemu/roms/openbios/forth/lib/vocabulary.fs @@ -0,0 +1,153 @@ +\ tag: vocabulary implementation for openbios +\ +\ Copyright (C) 2003 Stefan Reinauer +\ +\ See the file "COPYING" for further information about +\ the copyright and warranty status of this work. +\ + +\ +\ this is an implementation of DPANS94 wordlists (SEARCH EXT) +\ + + +16 constant #vocs +create vocabularies #vocs cells allot \ word lists +['] vocabularies to context + +: search-wordlist ( c-addr u wid -- 0 | xt 1 | xt -1 ) + \ Find the definition identified by the string c-addr u in the word + \ list identified by wid. If the definition is not found, return zero. + \ If the definition is found, return its execution token xt and + \ one (1) if the definition is immediate, minus-one (-1) otherwise. + find-wordlist + if + true over immediate? if + negate + then + else + 2drop false + then + ; + +: wordlist ( -- wid ) + \ Creates a new empty word list, returning its word list identifier + \ wid. The new word list may be returned from a pool of preallocated + \ word lists or may be dynamically allocated in data space. A system + \ shall allow the creation of at least 8 new word lists in addition + \ to any provided as part of the system. + here 0 , + ; + +: get-order ( -- wid1 .. widn n ) + #order @ 0 ?do + #order @ i - 1- cells context + @ + loop + #order @ + ; + +: set-order ( wid1 .. widn n -- ) + dup -1 = if + drop forth-last 1 \ push system default word list and number of lists + then + dup #order ! + 0 ?do + i cells context + ! + loop + ; + +: order ( -- ) + \ display word lists in the search order in their search order sequence + \ from the first searched to last searched. Also display word list into + \ which new definitions will be placed. + cr + get-order 0 ?do + ." wordlist " i (.) type 2e emit space u. cr + loop + cr ." definitions: " current @ u. cr + ; + + +: previous ( -- ) + \ Transform the search order consisting of widn, ... wid2, wid1 (where + \ wid1 is searched first) into widn, ... wid2. An ambiguous condition + \ exists if the search order was empty before PREVIOUS was executed. + get-order nip 1- set-order + ; + + +: do-vocabulary ( -- ) \ implementation factor + does> + @ >r ( ) ( R: widnew ) + get-order swap drop ( wid1 ... widn-1 n ) + r> swap set-order + ; + +: discard ( x1 .. xu u - ) \ implementation factor + 0 ?do + drop + loop + ; + +: vocabulary ( >name -- ) + wordlist create , do-vocabulary + ; + +: also ( -- ) + get-order over swap 1+ set-order + ; + +: only ( -- ) + -1 set-order also + ; + +only + +\ create forth forth-wordlist , do-vocabulary +create forth get-order over , discard do-vocabulary + +: findw ( c-addr -- c-addr 0 | w 1 | w -1 ) + 0 ( c-addr 0 ) + #order @ 0 ?do + over count ( c-addr 0 c-addr' u ) + i cells context + @ ( c-addr 0 c-addr' u wid ) + search-wordlist ( c-addr 0; 0 | w 1 | w -1 ) + ?dup if ( c-addr 0; w 1 | w -1 ) + 2swap 2drop leave ( w 1 | w -1 ) + then ( c-addr 0 ) + loop ( c-addr 0 | w 1 | w -1 ) + ; + +: get-current ( -- wid ) + current @ + ; + +: set-current ( wid -- ) + current ! + ; + +: definitions ( -- ) + \ Make the compilation word list the same as the first word list in + \ the search order. Specifies that the names of subsequent definitions + \ will be placed in the compilation word list. + \ Subsequent changes in the search order will not affect the + \ compilation word list. + context @ set-current + ; + +: forth-wordlist ( -- wid ) + forth-last + ; + +: #words ( -- ) + 0 last + begin + @ ?dup + while + swap 1+ swap + repeat + + cr + ; + +true to vocabularies? |