summaryrefslogtreecommitdiffstats
path: root/qemu/roms/openbios/forth/lib
diff options
context:
space:
mode:
authorYang Zhang <yang.z.zhang@intel.com>2015-08-28 09:58:54 +0800
committerYang Zhang <yang.z.zhang@intel.com>2015-09-01 12:44:00 +0800
commite44e3482bdb4d0ebde2d8b41830ac2cdb07948fb (patch)
tree66b09f592c55df2878107a468a91d21506104d3f /qemu/roms/openbios/forth/lib
parent9ca8dbcc65cfc63d6f5ef3312a33184e1d726e00 (diff)
Add qemu 2.4.0
Change-Id: Ic99cbad4b61f8b127b7dc74d04576c0bcbaaf4f5 Signed-off-by: Yang Zhang <yang.z.zhang@intel.com>
Diffstat (limited to 'qemu/roms/openbios/forth/lib')
-rw-r--r--qemu/roms/openbios/forth/lib/64bit.fs128
-rw-r--r--qemu/roms/openbios/forth/lib/build.xml22
-rw-r--r--qemu/roms/openbios/forth/lib/creation.fs52
-rw-r--r--qemu/roms/openbios/forth/lib/lists.fs26
-rw-r--r--qemu/roms/openbios/forth/lib/locals.fs197
-rw-r--r--qemu/roms/openbios/forth/lib/preinclude.fs11
-rw-r--r--qemu/roms/openbios/forth/lib/preprocessor.fs76
-rw-r--r--qemu/roms/openbios/forth/lib/split.fs49
-rw-r--r--qemu/roms/openbios/forth/lib/string.fs127
-rw-r--r--qemu/roms/openbios/forth/lib/vocabulary.fs153
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?