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?