Add qemu 2.4.0

Change-Id: Ic99cbad4b61f8b127b7dc74d04576c0bcbaaf4f5
Signed-off-by: Yang Zhang <yang.z.zhang@intel.com>

10 files changed, 841 insertions, 0 deletions

diff --git a/qemu/roms/openbios/forth/lib/64bit.fs b/qemu/roms/openbios/forth/lib/64bit.fs
new file mode 100644
index 000000000..239ddd028
--- /dev/null
+++ b/qemu/roms/openbios/forth/lib/64bit.fs
@@ -0,0 +1,128 @@
+\ 
+\ Copyright (C) 2009 Stefan Reinauer
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\ 
+
+\ Implementation of IEEE Draft Std P1275.6/D5
+\ Standard for Boot (Initialization Configuration) Firmware
+\ 64 Bit Extensions
+
+
+cell /x = constant 64bit?
+
+64bit? [IF] 
+
+: 32>64 ( 32bitsigned -- 64bitsigned )
+  dup 80000000 and if		\ is it negative?
+    ffffffff00000000 or		\ then set all high bits
+  then
+;
+
+: 64>32 ( 64bitsigned -- 32bitsigned )
+  h# ffffffff and
+;
+
+: lxjoin ( quad.lo quad.hi -- o )
+  d# 32 lshift or
+;
+
+: wxjoin ( w.lo w.2 w.3 w.hi -- o )
+  wljoin >r wljoin r> lxjoin
+;
+
+: bxjoin ( b.lo b.2 b.3 b.4 b.5 b.6 b.7 b.hi -- o )
+  bljoin >r bljoin r> lxjoin
+;
+
+: <l@ ( qaddr -- n )
+  l@ 32>64
+;
+
+: unaligned-x@ ( addr - o )
+  dup la1+ unaligned-l@ 64>32 swap unaligned-l@ 64>32 lxjoin
+;
+
+: unaligned-x! ( o oaddr -- )
+  >r dup d# 32 rshift r@ unaligned-l!
+  h# ffffffff and r> la1+ unaligned-l!
+;
+  
+: x@ ( oaddr -- o )
+  unaligned-x@ \ for now
+;
+
+: x! ( o oaddr -- )
+  unaligned-x! \ for now
+;
+
+: (rx@) ( oaddr - o )
+  x@
+;
+
+: (rx!) ( o oaddr -- )
+  x!
+;
+
+: x, ( o -- )
+  here /x allot x!
+;
+
+: /x* ( nu1 -- nu2 )
+  /x *
+;
+
+: xa+ ( addr1 index -- addr2 )
+  /x* +
+;
+
+: xa1+ ( addr1 -- addr2 )
+  /x +
+;
+
+: xlsplit ( o -- quad.lo quad.hi )
+  dup h# ffffffff and swap d# 32 rshift
+;
+
+: xwsplit ( o -- w.lo w.2 w.3 w.hi )
+  xlsplit >r lwsplit r> lwsplit
+;
+
+: xbsplit ( o -- b.lo b.2 b.3 b.4 b.5 b.6 b.7 b.hi )
+  xlsplit >r lbsplit r> lbsplit
+;
+
+: xlflip ( oct1 -- oct2 )
+  xlsplit swap lxjoin
+;
+
+: xlflips ( oaddr len -- )
+  bounds ?do 
+    i unaligned-x@ xlflip i unaligned-x!
+  /x +loop
+;
+
+: xwflip ( oct1 -- oct2 )
+  xlsplit lwflip swap lwflip lxjoin
+;
+
+: xwflips ( oaddr len -- )
+  bounds ?do
+    i unaligned-x@ xwflip i unaligned-x! /x
+  +loop
+;
+
+: xbflip ( oct1 -- oct2 )
+  xlsplit lbflip swap lbflip lxjoin
+;
+
+: xbflips ( oaddr len -- )
+  bounds ?do
+    i unaligned-x@ xbflip i unaligned-x!
+  /x +loop
+;
+
+\ : b(lit) b(lit) 32>64 ;
+
+[THEN]
diff --git a/qemu/roms/openbios/forth/lib/build.xml b/qemu/roms/openbios/forth/lib/build.xml
new file mode 100644
index 000000000..34eee4072
--- /dev/null
+++ b/qemu/roms/openbios/forth/lib/build.xml
@@ -0,0 +1,22 @@
+<build>
+ <!--
+  build description for openbios forth library functions
+ 
+  Copyright (C) 2003-2005 by Stefan Reinauer
+  See the file "COPYING" for further information about
+  the copyright and warranty status of this work.
+  -->
+ 
+ <dictionary name="openbios" target="forth">
+  <object source="vocabulary.fs"/>
+  <object source="string.fs"/>
+  <object source="preprocessor.fs"/>
+  <object source="preinclude.fs" /> <!-- FIXME dependencies -->
+  <object source="creation.fs"/>
+  <object source="split.fs"/>
+  <object source="lists.fs"/>
+  <object source="64bit.fs"/>
+  <object source="locals.fs"/>
+ </dictionary>
+
+</build>
diff --git a/qemu/roms/openbios/forth/lib/creation.fs b/qemu/roms/openbios/forth/lib/creation.fs
new file mode 100644
index 000000000..c3d0db84c
--- /dev/null
+++ b/qemu/roms/openbios/forth/lib/creation.fs
@@ -0,0 +1,52 @@
+\ tag: misc useful functions
+\ 
+\ C bindings
+\ 
+\ Copyright (C) 2003, 2004 Samuel Rydh
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\ 
+
+\ return xt of the word just defined
+: last-xt ( -- xt )
+  latest @ na1+
+;
+
+\ -------------------------------------------------------------------------
+\ word creation
+\ -------------------------------------------------------------------------
+
+: $is-ibuf ( size name name-len -- xt )
+  instance $buffer: drop
+  last-xt
+;
+
+: is-ibuf ( size -- xt )
+  0 0 $is-ibuf
+;
+
+: is-ivariable ( size name len -- xt )
+  4 -rot instance $buffer: drop
+  last-xt
+;
+
+: is-xt-func ( xt|0 wordstr len )
+  header 1 ,
+  ?dup if , then
+  ['] (semis) , reveal
+;
+
+: is-2xt-func ( xt1 xt2 wordstr len )
+  header 1 ,
+  swap , ,
+  ['] (semis) , reveal
+;
+
+: is-func-begin ( wordstr len )
+  header 1 ,
+;
+
+: is-func-end ( wordstr len )
+  ['] (semis) , reveal
+;
diff --git a/qemu/roms/openbios/forth/lib/lists.fs b/qemu/roms/openbios/forth/lib/lists.fs
new file mode 100644
index 000000000..91f7867b9
--- /dev/null
+++ b/qemu/roms/openbios/forth/lib/lists.fs
@@ -0,0 +1,26 @@
+\ tag: misc useful functions
+\ 
+\ Misc useful functions
+\ 
+\ Copyright (C) 2003 Samuel Rydh
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\ 
+
+\ -------------------------------------------------------------------------
+\ statically allocated lists
+\ -------------------------------------------------------------------------
+\ list-head should be a variable
+
+: list-add ( listhead -- )
+  here 0 , swap                  \ next, [data...]
+  ( here listhead )
+  begin dup @ while @ repeat !
+;
+
+: list-get ( listptr -- nextlistptr dictptr true | false )
+  @ dup if
+    dup na1+ true
+  then
+;
diff --git a/qemu/roms/openbios/forth/lib/locals.fs b/qemu/roms/openbios/forth/lib/locals.fs
new file mode 100644
index 000000000..e697383b6
--- /dev/null
+++ b/qemu/roms/openbios/forth/lib/locals.fs
@@ -0,0 +1,197 @@
+\ tag: local variables
+\ 
+\ Copyright (C) 2012 Mark Cave-Ayland
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\
+
+[IFDEF] CONFIG_LOCALS
+
+\ Init local variable stack
+variable locals-var-stack
+here 200 cells allot locals-var-stack !
+
+\ Set initial stack pointer
+\
+\ Stack looks like this:
+\ ... (sp n-2) local1 ... localm-1 localm (sp n-1)  <-- sp
+
+locals-var-stack @ value locals-var-sp
+locals-var-sp locals-var-stack @ !
+
+0 value locals-var-count
+0 value locals-flags
+
+here 200 cells allot locals-dict-buf !
+
+8 constant #locals
+
+: (local1) locals-var-sp @ /n + ;
+: (local2) locals-var-sp @ 2 cells + ;
+: (local3) locals-var-sp @ 3 cells + ;
+: (local4) locals-var-sp @ 4 cells + ;
+: (local5) locals-var-sp @ 5 cells + ;
+: (local6) locals-var-sp @ 6 cells + ;
+: (local7) locals-var-sp @ 7 cells + ;
+: (local8) locals-var-sp @ 8 cells + ;
+
+: local1@ (local1) @ ;
+: local2@ (local2) @ ;
+: local3@ (local3) @ ;
+: local4@ (local4) @ ;
+: local5@ (local5) @ ;
+: local6@ (local6) @ ;
+: local7@ (local7) @ ;
+: local8@ (local8) @ ;
+
+: local1! (local1) ! ;
+: local2! (local2) ! ;
+: local3! (local3) ! ;
+: local4! (local4) ! ;
+: local5! (local5) ! ;
+: local6! (local6) ! ;
+: local7! (local7) ! ;
+: local8! (local8) ! ;
+
+create locals-read-table
+['] local1@ ,
+['] local2@ ,
+['] local3@ ,
+['] local4@ ,
+['] local5@ ,
+['] local6@ ,
+['] local7@ ,
+['] local8@ ,
+
+create locals-write-table
+['] local1! ,
+['] local2! ,
+['] local3! ,
+['] local4! ,
+['] local5! ,
+['] local6! ,
+['] local7! ,
+['] local8! ,
+
+
+: locals-push ( n -- )
+  locals-var-sp /n + to locals-var-sp
+  locals-var-sp !
+;
+
+: locals-0-push ( -- )
+  0 locals-push
+;
+  
+: (apply-local-flags) ( lfa -- )
+  1 - dup c@ locals-flags or swap c!
+;  
+
+: locals-no-pop? ( lfa -- ? )
+  1 - c@ 8 and 0<>
+;
+
+: locals-drop      \ Destroy current stack frame
+  locals-var-sp @ to locals-var-sp
+;
+
+['] locals-drop to locals-end
+
+: (local-init) ( str len -- )
+  header 1 , 		 \ DOCOL
+  ['] (lit) , ['] noop , \ read-xt
+  ['] (lit) , ['] noop , \ write-xt
+  ['] 2drop ,		 \ do nothing
+  ['] (lit) ,
+  here 5 cells - ,
+  ['] @ , ['] , ,   \ store read-xt
+  ['] (semis) ,
+  reveal
+  immediate
+  last @ (apply-local-flags)
+;
+
+: (local-noop) ( str len -- )
+  2drop
+;
+
+\ Word called when consuming a local variable
+defer (local)
+
+: } ( C: current latest here -- )
+  here! latest ! current !           \ Switch back to normal dict
+  locals-dict-buf @ to locals-dict   \ Make locals-dict visible to $find
+  0 to locals-var-count
+  ['] locals-var-sp ,    \ save previous sp on rstack
+  ['] >r ,
+  locals-dict @    \ ( last -- )
+  begin
+    ?dup 0<>
+  while
+    >r
+    locals-var-count /n *
+    locals-read-table + @ r@ 3 cells + !    \ set read-xt
+    locals-var-count /n *
+    locals-write-table + @ r@ 5 cells + !   \ set write-xt
+    locals-var-count 1+ to locals-var-count
+    r@ locals-no-pop? if
+      ['] locals-0-push ,    \ initialise with 0
+    else
+      ['] locals-push ,      \ initialise from stack
+    then
+    r> @  \ next lfa
+  repeat
+  ['] r> ,
+  ['] locals-push ,   \ write previous sp
+; immediate
+
+: { ( C: -- current latest here )
+  current @ latest @ here
+  ['] (local-init) to (local)
+  0 to locals-flags
+  0 to locals-var-count
+  locals-dict-buf @ 200 cells 0 fill    \ Zero out temporary dictionary
+  locals-dict-buf @ current !     \ Switch to locals dictionary
+  locals-dict-buf @ /n + here!
+  
+  begin
+    parse-word
+    2dup s" }" strcmp 0= if
+      2drop
+      ['] } execute -1
+    else
+      2dup s" ;" strcmp 0= if
+        2drop
+        8 to locals-flags 0  \ Don't init from stack
+      else     
+        2dup s" |" strcmp 0= if
+          2drop
+          8 to locals-flags 0   \ Don't init from stack
+        else    
+          2dup s" --" strcmp 0= if
+            2drop
+            ['] (local-noop) to (local) 0
+          else
+            locals-var-count #locals < if
+              (local) 0    \ accept local
+            else
+              s" maximum locals used ignoring " type type cr 0
+            then
+	    locals-var-count 1+ to locals-var-count
+          then
+        then
+      then
+    then
+  until
+; immediate
+
+: -> ( n -- )
+  parse-word $find if
+    4 cells + @ ,
+  else
+    s" unable to find word " type type
+  then
+; immediate
+
+[THEN]
diff --git a/qemu/roms/openbios/forth/lib/preinclude.fs b/qemu/roms/openbios/forth/lib/preinclude.fs
new file mode 100644
index 000000000..6f20ea8f7
--- /dev/null
+++ b/qemu/roms/openbios/forth/lib/preinclude.fs
@@ -0,0 +1,11 @@
+\ 
+\ config and build date includes
+\ 
+\ Copyright (C) 2005 Stefan Reinauer
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\ 
+
+include config.fs
+include version.fs
diff --git a/qemu/roms/openbios/forth/lib/preprocessor.fs b/qemu/roms/openbios/forth/lib/preprocessor.fs
new file mode 100644
index 000000000..89d478cff
--- /dev/null
+++ b/qemu/roms/openbios/forth/lib/preprocessor.fs
@@ -0,0 +1,76 @@
+\ tag: Forth preprocessor
+\ 
+\ Forth preprocessor
+\ 
+\ Copyright (C) 2003, 2004 Samuel Rydh
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\ 
+
+0 value prep-wid
+0 value prep-dict
+0 value prep-here
+
+: ([IF])
+  begin
+    begin parse-word dup 0= while
+      2drop refill
+    repeat
+
+    2dup " [IF]" strcmp 0= if 1 throw then
+    2dup " [IFDEF]" strcmp 0= if 1 throw then
+    2dup " [ELSE]" strcmp 0= if 2 throw then
+    2dup " [THEN]" strcmp 0= if 3 throw then
+    " \\" strcmp 0= if linefeed parse 2drop then
+  again
+;
+
+: [IF] ( flag -- )
+  if exit then
+  1 begin
+    ['] ([IF]) catch case
+      \ EOF (FIXME: this does not work)
+      \ -1 of ." Missing [THEN]" abort exit endof
+      \ [IF]
+      1 of 1+ endof
+      \ [ELSE]
+      2 of dup 1 = if 1- then endof
+      \ [THEN]
+      3 of 1- endof
+    endcase
+  dup 0 <=
+  until drop
+; immediate
+
+: [ELSE] 0 [ ['] [IF] , ] ; immediate
+: [THEN] ; immediate
+
+:noname
+  0 to prep-wid
+  0 to prep-dict
+; initializer
+
+: [IFDEF] ( <word> -- )
+  prep-wid if
+    parse-word prep-wid search-wordlist dup if nip then
+  else 0 then
+  [ ['] [IF] , ]
+; immediate
+
+: [DEFINE] ( <word> -- )
+  parse-word here get-current >r >r
+  prep-dict 0= if
+    2000 alloc-mem here!
+    here to prep-dict
+    wordlist to prep-wid
+    here to prep-here
+  then
+  prep-wid set-current prep-here here!
+  $create
+  here to prep-here
+  r> r> set-current here!
+; immediate
+
+: [0] 0 ; immediate
+: [1] 1 ; immediate
diff --git a/qemu/roms/openbios/forth/lib/split.fs b/qemu/roms/openbios/forth/lib/split.fs
new file mode 100644
index 000000000..1a7ac3a0a
--- /dev/null
+++ b/qemu/roms/openbios/forth/lib/split.fs
@@ -0,0 +1,49 @@
+\ implements split-before, split-after and left-split 
+\ as described in 4.3 (Path resolution)
+
+\ delimeter returned in R-string
+: split-before ( addr len delim -- addr-R len-R addr-L len-L ) 
+  0 rot dup >r 0 ?do
+    ( str char cnt R: len <sys> )
+    2 pick over + c@ 2 pick = if leave then
+    1+
+  loop
+  nip
+  2dup + r> 2 pick -
+  2swap
+;
+
+\ delimeter returned in L-string
+: split-after ( addr len delim -- addr-R len-R addr-L len-L ) 
+  over 1- rot dup >r 0 ?do
+    ( str char cnt R: len <sys> )
+    2 pick over + c@ 2 pick = if leave then
+    1-
+	loop
+  nip
+	dup 0 >= if 1+ else drop r@ then
+	2dup + r> 2 pick -
+  2swap
+;
+
+\ delimiter not returned
+: left-split ( addr len delim -- addr-R len-R addr-L len-L )
+  0 rot dup >r 0 ?do
+    ( str char cnt R: len <sys> )
+    2 pick i + c@ 2 pick = if leave then
+    1+
+  loop
+  nip
+  2dup + 1+ r> 2 pick -
+  dup if 1- then
+  2swap
+;
+
+\ delimiter not returned [THIS FUNCTION IS NOT NEEDED]
+: right-split ( addr len delim -- addr-R len-R addr-L len-L )
+	dup >r
+	split-after
+	dup if 2dup + 1-
+		c@ r@ = if 1- then then
+	r> drop
+;
diff --git a/qemu/roms/openbios/forth/lib/string.fs b/qemu/roms/openbios/forth/lib/string.fs
new file mode 100644
index 000000000..eb6474917
--- /dev/null
+++ b/qemu/roms/openbios/forth/lib/string.fs
@@ -0,0 +1,127 @@
+\ tag: misc useful functions
+\ 
+\ Misc useful functions
+\ 
+\ Copyright (C) 2003 Samuel Rydh
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\ 
+
+\ compare c-string with (str len) pair 
+: comp0 ( cstr str len -- 0|-1|1 )
+  3dup
+  comp ?dup if >r 3drop r> exit then
+  nip + c@ 0<> if 1 else 0 then
+;
+
+\ returns 0 if the strings match
+: strcmp ( str1 len1 str2 len2 -- 0|1 )
+  rot over <> if 3drop 1 exit then
+  comp if 1 else 0 then 
+;
+  
+: strchr ( str len char -- where|0 )
+  >r
+  begin
+    1- dup 0>=
+  while
+    ( str len )
+    over c@ r@ = if r> 2drop exit then
+    swap 1+ swap
+  repeat
+  r> 3drop 0
+;
+
+: cstrlen ( cstr -- len )
+  dup
+  begin dup c@ while 1+ repeat
+  swap -
+;
+
+: strdup ( str len -- newstr len )
+  dup if
+    dup >r
+    dup alloc-mem dup >r swap move
+    r> r>
+  else
+    2drop 0 0
+  then
+;
+
+: dict-strdup ( str len -- dict-addr len )
+  dup here swap allot null-align
+  swap 2dup >r >r move r> r>
+;
+
+\ -----------------------------------------------------
+\ string copy and cat variants
+\ -----------------------------------------------------
+
+: tmpstrcat ( addr2 len2 addr1 len1 tmpbuf -- buf len1+len2 tmpbuf+l1+l2 )
+  \ save return arguments
+  dup 2 pick + 4 pick + >r      ( R: buf+l1+l2 )
+  over 4 pick + >r
+  dup >r
+  \ copy...
+  2dup + >r
+  swap move r> swap move
+  r> r> r>
+;
+
+: tmpstrcpy ( addr1 len1 tmpbuf -- tmpbuf len1 tmpbuf+len1 )
+  swap 2dup >r >r move
+  r> r> 2dup +
+;
+
+
+
+\ -----------------------------------------------------
+\ number to string conversion
+\ -----------------------------------------------------
+
+: numtostr ( num buf -- buf len )
+  swap rdepth -rot
+  ( rdepth buf num )
+  begin
+    base @ u/mod swap
+    \ dup 0< if base @ + then
+    dup a < if ascii 0 else ascii a a - then + >r
+    ?dup 0=
+  until
+
+  rdepth rot - 0
+  ( buf len cnt )
+  begin
+    r> over 4 pick + c!
+    1+ 2dup <=
+  until
+  drop
+;
+
+: tohexstr ( num buf -- buf len )
+  base @ hex -rot numtostr rot base !
+;
+
+: toudecstr ( num buf -- buf len )
+  base @ decimal -rot numtostr rot base !
+;
+
+: todecstr ( num buf -- buf len )
+  over 0< if
+    swap negate over ascii - over c! 1+
+    ( buf num buf+1 )
+    toudecstr 1+ nip
+  else
+    toudecstr
+  then
+;
+
+
+\ -----------------------------------------------------
+\ string to number conversion
+\ -----------------------------------------------------
+
+: parse-hex ( str len -- value )
+  base @ hex -rot $number if 0 then swap base !
+;
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?