Add qemu 2.4.0

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

7 files changed, 3158 insertions, 0 deletions

diff --git a/qemu/roms/openbios/forth/bootstrap/bootstrap.fs b/qemu/roms/openbios/forth/bootstrap/bootstrap.fs
new file mode 100644
index 000000000..0668cf7d8
--- /dev/null
+++ b/qemu/roms/openbios/forth/bootstrap/bootstrap.fs
@@ -0,0 +1,1590 @@
+\ tag: bootstrap of basic forth words
+\ 
+\ Copyright (C) 2003-2005 Stefan Reinauer, Patrick Mauritz
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\ 
+
+\ 
+\ this file contains almost all forth words described
+\ by the open firmware user interface. Some more complex
+\ parts are found in seperate files (memory management,
+\ vocabulary support)
+\ 
+
+\ 
+\ often used constants (reduces dictionary size)
+\ 
+
+1 constant 1
+2 constant 2
+3 constant 3
+-1 constant -1
+0 constant 0
+
+0 value my-self
+
+\ 
+\ 7.3.5.1 Numeric-base control
+\ 
+
+: decimal 10 base ! ;
+: hex 16 base ! ;
+: octal 8 base ! ;
+hex
+
+\ 
+\ vocabulary words
+\ 
+
+variable current forth-last current !
+
+: last 
+  current @ 
+  ;
+
+variable #order 0 #order !
+
+defer context
+0 value vocabularies?
+
+defer locals-end
+0 value locals-dict
+variable locals-dict-buf
+
+\ 
+\ 7.3.7 Flag constants
+\ 
+
+1 1 = constant true
+0 1 = constant false
+
+\ 
+\ 7.3.9.2.2 Immediate words (part 1)
+\ 
+
+: (immediate) ( xt -- )
+  1 - dup c@ 1 or swap c!
+  ;
+
+: (compile-only)
+  1 - dup c@ 2 or swap c!
+  ;
+
+: immediate 
+  last @ (immediate) 
+  ;
+  
+: compile-only 
+  last @ (compile-only) 
+  ;
+
+: flags? ( xt -- flags )
+  /n /c + - c@ 7f and
+  ;
+
+: immediate? ( xt -- true|false )
+  flags? 1 and 1 =
+  ;
+
+: compile-only? ( xt -- true|false )
+  flags? 2 and 2 =
+  ;
+
+: [  0 state ! ; compile-only
+: ] -1 state ! ; 
+
+
+
+\ 
+\ 7.3.9.2.1 Data space allocation
+\ 
+
+: allot here + here! ;
+: ,  here /n allot ! ;
+: c, here /c allot c! ;
+
+: align
+  /n here /n 1 - and -   \ how many bytes to next alignment
+  /n 1 - and allot       \ mask out everything that is bigger 
+  ;                      \ than cellsize-1
+
+: null-align
+  here dup align here swap - 0 fill 
+  ;
+
+: w, 
+  here 1 and allot       \ if here is not even, we have to align.
+  here /w allot w! 
+  ;
+
+: l, 
+  /l here /l 1 - and -   \ same as in align, with /l
+  /l 1 - and             \ if it's /l we are already aligned.
+  allot
+  here /l allot l! 
+  ;
+
+
+\ 
+\ 7.3.6 comparison operators (part 1)
+\ 
+
+: <> = invert ;
+
+
+\ 
+\ 7.3.9.2.4 Miscellaneous dictionary (part 1)
+\ 
+
+: (to) ( xt-new xt-defer -- )
+  /n + !
+  ;
+
+: >body ( xt -- a-addr )  /n 1 lshift + ;
+: body> ( a-addr -- xt )  /n 1 lshift - ;
+
+: reveal latest @ last ! ;
+: recursive reveal ; immediate
+: recurse latest @ /n +  , ; immediate
+
+: noop ;
+
+defer environment?
+: no-environment?
+  2drop false 
+  ;
+
+['] no-environment? ['] environment? (to)
+
+
+\ 
+\ 7.3.8.1 Conditional branches
+\ 
+
+\ A control stack entry is implemented using 2 data stack items
+\ of the form ( addr type ). type can be one of the
+\ following:
+\   0 - orig
+\   1 - dest
+\   2 - do-sys
+
+: resolve-orig here nip over /n + - swap ! ;
+: (if) ['] do?branch , here 0 0 , ; compile-only
+: (then) resolve-orig ; compile-only
+
+variable tmp-comp-depth -1 tmp-comp-depth !
+variable tmp-comp-buf 0 tmp-comp-buf !
+
+: setup-tmp-comp ( -- )
+  state @ 0 = (if)
+    here tmp-comp-buf @ here! ,     \ save here and switch to tmp directory
+    1 ,                              \ DOCOL
+    depth tmp-comp-depth !          \ save control depth
+    ]
+  (then)
+;
+
+: execute-tmp-comp ( -- )
+  depth tmp-comp-depth @ =
+  (if)
+    -1 tmp-comp-depth !
+    ['] (semis) ,
+    tmp-comp-buf @
+    dup @ here!
+    0 state !
+    /n + execute
+  (then)
+;
+
+: if setup-tmp-comp ['] do?branch , here 0 0 , ; immediate
+: then resolve-orig execute-tmp-comp ; compile-only
+: else ['] dobranch , here 0 0 , 2swap resolve-orig ; compile-only
+
+\ 
+\ 7.3.8.3 Conditional loops
+\ 
+
+\ some dummy words for see
+: (begin) ;
+: (again) ;
+: (until) ;
+: (while) ;
+: (repeat) ;
+
+\ resolve-dest requires a loop...
+: (resolve-dest) here /n + nip - , ;
+: (resolve-begin) setup-tmp-comp ['] (begin) , here 1 ; immediate
+: (resolve-until) ['] (until) , ['] do?branch , (resolve-dest) execute-tmp-comp ; compile-only
+
+: resolve-dest ( dest origN ... orig )
+  2 >r
+  (resolve-begin)
+    \ Find topmost control stack entry with a type of 1 (dest)
+    r> dup dup pick 1 = if
+      \ Move it to the top
+      roll
+      swap 1 - roll
+      \ Resolve it
+      (resolve-dest)
+      1		\ force exit
+    else
+      drop
+      2 + >r
+      0
+    then
+  (resolve-until)
+;
+
+: begin
+  setup-tmp-comp
+  ['] (begin) , 
+  here
+  1
+  ; immediate
+
+: again
+  ['] (again) ,
+  ['] dobranch , 
+  resolve-dest
+  execute-tmp-comp
+  ; compile-only
+
+: until
+  ['] (until) ,
+  ['] do?branch , 
+  resolve-dest
+  execute-tmp-comp
+  ; compile-only
+
+: while
+  setup-tmp-comp
+  ['] (while) ,
+  ['] do?branch , 
+  here 0 0 , 2swap  
+  ; immediate
+
+: repeat
+  ['] (repeat) ,
+  ['] dobranch , 
+  resolve-dest resolve-orig
+  execute-tmp-comp
+  ; compile-only
+
+
+\ 
+\ 7.3.8.4 Counted loops
+\ 
+
+variable leaves 0 leaves !
+
+: resolve-loop
+  leaves @
+  begin
+    ?dup 
+  while 
+    dup @               \ leaves -- leaves *leaves )
+    swap                \ -- *leaves leaves )
+    here over -         \ -- *leaves leaves here-leaves
+    swap !              \ -- *leaves
+  repeat
+  here nip - , 
+  leaves !
+  ;
+
+: do
+  setup-tmp-comp
+  leaves @
+  here 2
+  ['] (do) , 
+  0 leaves !
+  ; immediate
+
+: ?do
+  setup-tmp-comp
+  leaves @ 
+  ['] (?do) ,
+  here 2
+  here leaves !
+  0 ,
+  ; immediate
+
+: loop
+  ['] (loop) ,
+  resolve-loop
+  execute-tmp-comp
+  ; immediate 
+
+: +loop
+  ['] (+loop) ,
+  resolve-loop
+  execute-tmp-comp
+  ; immediate
+
+
+\ Using primitive versions of i and j
+\ speeds up loops by 300%
+\ : i r> r@ swap >r ;
+\ : j r> r> r> r@ -rot >r >r swap >r ;
+
+: unloop r> r> r> 2drop >r ;
+
+: leave 
+  ['] unloop , 
+  ['] dobranch , 
+  leaves @ 
+  here leaves !  
+  , 
+  ; immediate
+
+: ?leave if leave then ;
+
+\ 
+\ 7.3.8.2  Case statement
+\ 
+ 
+: case
+  setup-tmp-comp
+  0
+; immediate
+
+: endcase
+  ['] drop , 
+  0 ?do
+    ['] then execute
+  loop
+  execute-tmp-comp
+; immediate
+
+: of
+  1 + >r 
+  ['] over , 
+  ['] = , 
+  ['] if execute 
+  ['] drop , 
+  r> 
+  ; immediate
+
+: endof
+  >r 
+  ['] else execute 
+  r> 
+  ; immediate
+
+\ 
+\ 7.3.8.5    Other control flow commands
+\ 
+
+: exit r> drop ;
+
+
+\ 
+\ 7.3.4.3 ASCII constants (part 1)
+\ 
+
+20 constant bl
+07 constant bell
+08 constant bs
+0d constant carret
+0a constant linefeed
+
+
+\ 
+\ 7.3.1.1 - stack duplication
+\ 
+: tuck swap over ;
+: 3dup 2 pick 2 pick 2 pick ;
+
+\ 
+\ 7.3.1.2 - stack removal
+\ 
+: clear 0 depth! ;
+: 3drop 2drop drop ;
+
+\ 
+\ 7.3.1.3 - stack rearrangement
+\ 
+
+: 2rot >r >r 2swap r> r> 2swap ;
+
+\
+\ 7.3.1.4 - return stack
+\
+
+\ Note: these words are not part of the official OF specification, however
+\ they are part of the ANSI DPANS94 core extensions (see section 6.2) and
+\ so this seems an appropriate place for them.
+: 2>r r> -rot swap >r >r >r ;
+: 2r> r> r> r> rot >r swap ;
+: 2r@ r> r> r> 2dup >r >r rot >r swap ;
+
+\ 
+\ 7.3.2.1 - single precision integer arithmetic (part 1)
+\ 
+
+: u/mod 0 swap mu/mod drop ;
+: 1+ 1 + ;
+: 1- 1 - ;
+: 2+ 2 + ;
+: 2- 2 - ;
+: even 1+ -2 and ;
+: bounds over + swap ;
+
+\ 
+\ 7.3.2.2 bitwise logical operators
+\ 
+: << lshift ;
+: >> rshift ;
+: 2* 1 lshift ;
+: u2/ 1 rshift ;
+: 2/ 1 >>a ;
+: not invert ;
+
+\ 
+\ 7.3.2.3 double number arithmetic
+\ 
+
+: s>d      dup 0 < ; 
+: dnegate  0 0 2swap d- ;
+: dabs     dup 0 < if dnegate then ;
+: um/mod   mu/mod drop ;
+
+\ symmetric division
+: sm/rem  ( d n -- rem quot )
+  over >r >r dabs r@ abs um/mod r> 0 < 
+  if 
+    negate 
+  then 
+  r> 0 < if 
+    negate swap negate swap
+  then
+  ;
+
+\ floored division
+: fm/mod ( d n -- rem quot ) 
+  dup >r 2dup xor 0 < >r sm/rem over 0 <> r> and if 
+    1 - swap r> + swap exit 
+  then
+  r> drop
+  ;
+
+\ 
+\ 7.3.2.1 - single precision integer arithmetic (part 2)
+\ 
+
+: */mod ( n1 n2 n3 -- quot rem ) >r m* r> fm/mod  ;
+: */ ( n1 n2 n3 -- n1*n2/n3 ) */mod nip ;
+: /mod >r s>d r> fm/mod ;
+: mod /mod drop ;
+: / /mod nip ;
+
+
+\ 
+\ 7.3.2.4 Data type conversion
+\ 
+
+: lwsplit ( quad -- w.lo w.hi )
+  dup ffff and swap 10 rshift ffff and
+;
+
+: wbsplit ( word -- b.lo b.hi )
+  dup ff and swap 8 rshift ff and
+;
+
+: lbsplit ( quad -- b.lo b2 b3 b.hi )
+  lwsplit swap wbsplit rot wbsplit
+;
+
+: bwjoin ( b.lo b.hi -- word )
+  ff and 8 lshift swap ff and or
+;
+
+: wljoin ( w.lo w.hi -- quad )
+  ffff and 10 lshift swap ffff and or
+;
+
+: bljoin ( b.lo b2 b3 b.hi -- quad )
+  bwjoin -rot bwjoin swap wljoin
+;
+
+: wbflip ( word -- word ) \ flips bytes in a word
+  dup 8 rshift ff and swap ff and bwjoin
+;
+
+: lwflip ( q1 -- q2 ) 
+  dup 10 rshift ffff and swap ffff and wljoin
+;
+
+: lbflip ( q1 -- q2 )
+  dup 10 rshift ffff and wbflip swap ffff and wbflip wljoin
+;
+
+\ 
+\ 7.3.2.5 address arithmetic
+\ 
+
+: /c* /c * ;
+: /w* /w * ;
+: /l* /l * ;
+: /n* /n * ;
+: ca+ /c* + ;
+: wa+ /w* + ;
+: la+ /l* + ;
+: na+ /n* + ;
+: ca1+ /c + ;
+: wa1+ /w + ;
+: la1+ /l + ;
+: na1+ /n + ;
+: aligned /n 1- + /n negate and ;
+: char+ ca1+ ;
+: cell+ na1+ ;
+: chars /c* ;
+: cells /n* ;
+/n constant cell
+
+\ 
+\ 7.3.6 Comparison operators
+\ 
+
+: <= > not ;
+: >= < not ;
+: 0= 0 = ;
+: 0<= 0 <= ;
+: 0< 0 < ;
+: 0<> 0 <> ;
+: 0> 0 > ;
+: 0>=  0 >= ;
+: u<= u> not ;
+: u>= u< not ;
+: within  >r over > swap r> >= or not ;
+: between 1 + within ;
+
+\ 
+\ 7.3.3.1 Memory access
+\ 
+
+: 2@ dup cell+ @ swap @  ;
+: 2! dup >r ! r> cell+ ! ;
+
+: <w@ w@ dup 8000 >= if 10000 - then ;
+
+: comp ( str1 str2 len -- 0|1|-1 )
+  >r 0 -rot r>
+  bounds ?do
+    dup c@ i c@ - dup if
+      < if 1 else -1 then swap leave
+    then 
+    drop ca1+
+  loop
+  drop
+;
+
+\ compare two string
+
+: $= ( str1 len1 str2 len2 -- true|false )
+    rot ( str1 str2 len2 len1 )
+    over ( str1 str2 len2 len1 len2 )  
+    <> if ( str1 str2 len2 )
+        3drop
+        false
+    else ( str1 str2 len2 )
+        comp
+	0=
+    then
+;
+
+\ : +! tuck @ + swap ! ;
+: off false swap ! ;
+: on true swap ! ;
+: blank bl fill ;
+: erase 0 fill ;
+: wbflips ( waddr len -- )
+  bounds do i w@ wbflip i w! /w +loop
+;
+
+: lwflips ( qaddr len -- )
+  bounds do i l@ lwflip i l! /l +loop
+;
+
+: lbflips ( qaddr len -- )
+  bounds do i l@ lbflip i l! /l +loop
+;
+
+
+\ 
+\ 7.3.8.6    Error handling (part 1)
+\ 
+
+variable catchframe
+0 catchframe !
+
+: catch
+  my-self >r
+  depth >r
+  catchframe @ >r
+  rdepth catchframe !
+  execute
+  r> catchframe !
+  r> r> 2drop 0
+  ;
+
+: throw
+  ?dup if
+    catchframe @ rdepth!
+    r> catchframe !
+    r> swap >r depth!
+    drop r>
+    r> ['] my-self (to)
+  then
+  ;
+
+\ 
+\ 7.3.3.2 memory allocation
+\ 
+
+include memory.fs
+
+
+\ 
+\ 7.3.4.4 Console output (part 1)
+\ 
+
+defer emit
+
+: type bounds ?do i c@ emit loop ;
+
+\ this one obviously only works when called 
+\ with a forth string as count fetches addr-1.
+\ openfirmware has no such req. therefore it has to go:
+
+\ : type 0 do count emit loop drop ;
+
+: debug-type bounds ?do i c@ (emit) loop ;
+
+\ 
+\ 7.3.4.1 Text Input
+\ 
+
+0 value source-id 
+0 value ib
+variable #ib 0 #ib !
+variable >in 0 >in !
+
+: source ( -- addr len )
+  ib #ib @
+  ;
+
+: /string  ( c-addr1 u1 n -- c-addr2 u2 )
+   tuck - -rot + swap 
+; 
+
+
+\ 
+\ pockets implementation for 7.3.4.1
+
+100 constant pocketsize
+4   constant numpockets
+variable pockets 0 pockets !
+variable whichpocket 0 whichpocket !
+
+\ allocate 4 pockets to begin with
+: init-pockets     ( -- )
+  pocketsize numpockets * alloc-mem pockets !
+  ;
+
+: pocket ( ?? -- ?? )
+  pocketsize whichpocket @ *
+  pockets @ +
+  whichpocket @ 1 + numpockets mod
+  whichpocket !
+  ;
+
+\ span variable from 7.3.4.2
+variable span 0 span !
+
+\ if char is bl then any control character is matched
+: findchar ( str len char -- offs true | false )
+  swap 0 do
+    over i + c@
+    over dup bl = if <= else = then if
+      2drop i dup dup leave
+      \ i nip nip true exit \ replaces above
+    then
+  loop
+  =
+  \ drop drop false
+  ;
+
+: parse ( delim  text<delim>  -- str len )
+  >r              \ save delimiter
+  ib >in @ +
+  span @ >in @ -  \ ib+offs len-offset.
+  dup 0 < if      \ if we are already at the end of the string, return an empty string
+    + 0	          \ move to end of input string
+    r> drop
+    exit
+  then
+  2dup r>         \ ib+offs len-offset ib+offs len-offset delim
+  findchar if     \ look for the delimiter. 
+    nip dup 1+
+  else
+     dup
+  then
+  >in +!
+  \ dup -1 = if drop 0 then \ workaround for negative length
+  ;
+
+: skipws ( -- )
+  ib span @        ( -- ib recvchars )
+  begin
+    dup >in @ > if    ( -- recvchars>offs )
+      over >in @ +
+      c@ bl <=
+    else
+      false
+    then
+  while
+      1 >in +!
+  repeat
+  2drop
+  ;
+
+: parse-word (  < >text< >  -- str len )
+  skipws bl parse
+  ;
+
+: word ( delim  <delims>text<delim>  -- pstr )
+  pocket >r parse dup r@ c! bounds r> dup 2swap
+  do
+    char+ i c@ over c!
+  loop
+  drop
+  ;
+
+: ( 29 parse 2drop ; immediate
+: \ span @ >in !   ; immediate
+
+
+
+\ 
+\ 7.3.4.7 String literals
+\ 
+
+: ",
+  bounds ?do
+    i c@ c,
+  loop
+  ;
+
+: (")  ( -- addr len )
+  r> dup 
+  2 cells +                   ( r-addr addr )
+  over cell+ @                ( r-addr addr len )
+  rot over + aligned cell+ >r ( addr len R: r-addr )
+  ;
+ 
+: handle-text ( temp-addr len -- addr len )
+  state @ if
+    ['] (") , dup , ", null-align
+  else
+    pocket swap
+    dup >r
+    0 ?do
+      over i + c@ over i + c!
+    loop
+    nip r>
+  then
+  ;
+
+: s"
+  22 parse handle-text
+  ; immediate
+
+
+
+\ 
+\ 7.3.4.4 Console output (part 2)
+\ 
+
+: ."
+  22 parse handle-text
+  ['] type
+  state @ if
+    ,
+  else
+    execute
+  then
+  ; immediate
+
+: .(
+  29 parse handle-text
+  ['] type
+  state @ if
+    ,
+  else
+    execute
+  then
+  ; immediate
+
+
+
+\ 
+\ 7.3.4.8 String manipulation
+\ 
+
+: count ( pstr -- str len ) 1+ dup 1- c@ ;
+
+: pack  ( str len addr -- pstr )
+  2dup c!     \ store len
+  1+ swap 0 ?do
+    over i + c@ over i + c!
+  loop nip 1-
+  ;
+
+: lcc   ( char1 -- char2 ) dup 41 5a between if 20 + then ;
+: upc   ( char1 -- char2 ) dup 61 7a between if 20 - then ;
+
+: -trailing ( str len1 -- str len2 )
+  begin 
+    dup 0<> if  \ len != 0 ?
+      2dup 1- + 
+      c@ bl =
+    else 
+      false 
+    then
+  while
+    1-
+  repeat
+  ;
+
+
+\ 
+\ 7.3.4.5   Output formatting
+\ 
+
+: cr linefeed emit ;
+: debug-cr linefeed (emit) ;
+: (cr carret emit ;
+: space bl emit ;
+: spaces 0 ?do space loop ;
+variable #line 0 #line !
+variable #out  0 #out  !
+
+
+\ 
+\ 7.3.9.2.3 Dictionary search
+\ 
+
+\ helper functions
+
+: lfa2name ( lfa -- name len )
+  1-                   \ skip flag byte
+  begin                \ skip 0 padding 
+    1- dup c@ ?dup 
+  until
+  7f and               \ clear high bit in length
+
+  tuck - swap          ( ptr-to-len len - name len )
+  ;
+
+: comp-nocase ( str1 str2 len -- true|false )
+  0 do
+    2dup i + c@ upc    ( str1 str2 byteX )
+    swap i + c@ upc ( str1 str2 byte1 byte2 )
+    <> if
+      0 leave
+    then
+  loop
+  if -1 else drop 0 then
+  swap drop
+  ;
+
+: comp-word ( b-str len lfa -- true | false )
+  lfa2name        ( str len str len -- )
+  >r swap r>      ( str str len len )
+  over = if       ( str str len )
+    comp-nocase
+  else
+    drop drop drop false   \ if len does not match, string does not match
+  then
+;
+
+\ $find is an fcode word, but we place it here since we use it for find.
+
+: find-wordlist ( name-str name-len last -- xt true | name-str name-len false )
+
+  @ >r
+
+  begin
+    2dup r@ dup if comp-word dup false = then
+  while
+    r> @ >r drop
+  repeat
+
+  r@ if \ successful?
+    -rot 2drop r> cell+ swap
+  else
+    r> drop drop drop false
+  then
+
+  ;
+
+: $find ( name-str name-len -- xt true | name-str name-len false )
+  locals-dict 0<> if
+    locals-dict-buf @ find-wordlist ?dup if
+      exit
+    then
+  then
+  vocabularies? if
+    #order @ 0 ?do
+      i cells context + @
+      find-wordlist
+      ?dup if
+        unloop exit
+      then
+    loop
+    false
+  else
+    forth-last find-wordlist
+  then
+  ;
+
+\ look up a word in the current wordlist
+: $find1 ( name-str name-len -- xt true | name-str name-len false )
+  vocabularies? if
+    current @
+  else
+    forth-last
+  then
+  find-wordlist
+  ;
+
+  
+: '
+  parse-word $find 0= if 
+    type 3a emit -13 throw
+  then
+  ;
+
+: ['] 
+  parse-word $find 0= if
+    type 3a emit -13 throw
+  then 
+  state @ if
+    ['] (lit) , , 
+  then
+  ; immediate
+
+: find ( pstr -- xt n | pstr false )
+  dup count $find           \  pstr xt true | pstr name-str name-len false
+  if
+    nip true
+    over immediate? if
+      negate                \ immediate returns 1
+    then
+  else
+    2drop false
+  then
+  ;
+
+
+\ 
+\ 7.3.9.2.2 Immediate words (part 2)
+\ 
+
+: literal ['] (lit) , , ; immediate
+: compile, , ; immediate
+: compile r> cell+ dup @ , >r ;
+: [compile] ['] ' execute , ; immediate
+
+: postpone
+  parse-word $find if
+    dup immediate? not if
+      ['] (lit) , , ['] ,
+    then
+    ,
+  else
+    s" undefined word " type type cr
+  then
+  ; immediate
+
+
+\ 
+\ 7.3.9.2.4 Miscellaneous dictionary (part 2)
+\ 
+
+variable #instance
+
+: instance ( -- )
+  true #instance !
+;
+
+: #instance-base
+  my-self dup if @ then
+;
+
+: #instance-offs
+  my-self dup if na1+ then
+;
+
+\ the following instance words are used internally
+\ to implement variable instantiation.
+
+: instance-cfa? ( cfa -- true | false )
+  b e within                              \ b,c and d are instance defining words
+;
+
+: behavior ( xt-defer -- xt )
+  dup @ instance-cfa? if
+    #instance-base ?dup if
+      swap na1+ @ + @
+    else
+      3 /n* + @
+    then
+  else
+    na1+ @
+  then
+;
+
+: (ito) ( xt-new xt-defer -- )
+  #instance-base ?dup if
+    swap na1+ @ + !
+  else
+    3 /n* + !
+  then
+;
+  
+: (to-xt) ( xt -- )  
+  dup @ instance-cfa?
+  state @ if
+    swap ['] (lit) , , if ['] (ito) else ['] (to) then ,
+  else
+    if (ito) else /n + ! then
+  then
+;
+
+: to
+  ['] ' execute
+  (to-xt)
+  ; immediate
+  
+: is ( xt "wordname<>" -- )
+  parse-word $find if
+    (to)
+  else
+    s" could not find " type type
+  then
+  ;
+
+\ 
+\ 7.3.4.2 Console Input
+\ 
+
+defer key?
+defer key
+
+: accept ( addr len -- len2 )
+  tuck 0 do
+    key
+    dup linefeed = if
+      space drop drop drop i 0 leave
+    then
+    dup emit over c! 1 +
+  loop
+  drop ( cr )
+  ;
+
+: expect ( addr len -- )
+  accept span !
+  ;
+
+
+\ 
+\ 7.3.4.3 ASCII constants (part 2)
+\ 
+
+: handle-lit
+  state @ if
+    2 = if
+      ['] (lit) ,  ,
+    then
+    ['] (lit) ,  ,
+  else
+    drop
+  then
+  ;
+
+: char
+  parse-word 0<> if c@ else s" Unexpected EOL." type cr then ;
+  ;
+
+: ascii  char 1 handle-lit ; immediate
+: [char] char 1 handle-lit ; immediate
+
+: control   
+  char bl 1- and 1 handle-lit 
+; immediate
+
+
+
+\ 
+\ 7.3.8.6    Error handling (part 2)
+\ 
+
+: abort 
+  -1 throw
+  ;
+
+: abort"
+  ['] if execute
+  22 parse handle-text 
+  ['] type , 
+  ['] (lit) , 
+  -2 , 
+  ['] throw ,
+  ['] then execute
+  ; compile-only 
+
+\ 
+\ 7.5.3.1 Dictionary search
+\ 
+
+\ this does not belong here, but its nice for testing
+
+: words ( -- )
+  last
+  begin @ 
+    ?dup while
+    dup lfa2name
+
+    \ Don't print spaces for headerless words
+    dup if
+      type space
+    else
+      type
+    then
+
+  repeat
+  cr
+  ;
+
+\ 
+\ 7.3.5.4 Numeric output primitives
+\ 
+
+false value capital-hex?
+
+: pad       ( -- addr )      here 100 + aligned ;
+
+: todigit   ( num -- ascii ) 
+  dup 9 > if 
+    capital-hex? not if
+      20 +
+    then
+    7 + 
+  then 
+  30 + 
+  ;
+
+: <#   pad dup ! ;
+: hold pad dup @ 1- tuck swap ! c! ;
+: sign 
+  0< if 
+    2d hold 
+  then 
+  ;
+
+: #    base @ mu/mod rot todigit hold ;
+: #s   begin # 2dup or 0= until ;
+: #>   2drop pad dup @ tuck - ;
+: (.)  <# dup >r abs 0 #s r> sign #> ;
+
+: u#   base @ u/mod swap todigit hold ;
+: u#s  begin u# dup 0= until ;
+: u#> 0 #> ;
+: (u.) <# u#s u#> ;
+
+\ 
+\ 7.3.5.3 Numeric output
+\ 
+
+: .    (.) type space ;
+: s.   . ;
+: u.   (u.) type space ;
+: .r   swap (.) rot 2dup < if over - spaces else drop then type ;
+: u.r  swap (u.) rot 2dup < if over - spaces else drop then type ;
+: .d   base @ swap decimal . base ! ;
+: .h   base @ swap hex . base ! ;
+
+: .s 
+  3c emit depth dup (.) type 3e emit space
+  0 
+  ?do
+    depth i - 1- pick .
+  loop 
+  cr
+  ;
+
+\ 
+\ 7.3.5.2 Numeric input
+\ 
+
+: digit ( char base -- n true | char false )
+  swap dup upc dup 
+  41 5a ( A - Z ) between if
+    7 -
+  else
+    dup 39 > if \ protect from : and ;
+      -rot 2drop false exit
+    then
+  then
+  
+  30 ( number 0 ) - rot over swap 0 swap within  if
+    nip true
+  else
+    drop false
+  then  
+  ;
+
+: >number
+   begin 
+      dup 
+   while
+      over c@ base @ digit 0= if    
+         drop exit 
+      then  >r 2swap r> swap base @ um* drop rot base @ um* d+ 2swap 
+      1 /string 
+   repeat 
+   ;
+
+: numdelim?   
+   dup 2e = swap 2c = or 
+; 
+
+
+: $dnumber?   
+   0 0 2swap dup 0= if    
+      2drop 2drop 0 exit 
+   then  over c@ 2d = dup >r negate /string begin 
+      >number dup 1 > 
+   while
+      over c@ numdelim? 0= if    
+         2drop 2drop r> drop 0 exit 
+      then  1 /string 
+   repeat if    
+      c@ 2e = if    
+         true 
+      else
+         2drop r> drop 0 exit 
+      then  
+   else
+      drop false 
+   then  over or if    
+      r> if    
+         dnegate 
+      then  2 
+   else
+     drop r> if    
+         negate 
+      then  1 
+   then  
+; 
+
+
+: $number (  )
+   $dnumber? 
+   case
+   0 of   true endof
+   1 of   false endof
+   2 of   drop false endof
+   endcase
+; 
+
+: d#
+  parse-word
+  base @ >r
+
+  decimal
+
+  $number if
+    s" illegal number" type cr 0
+  then
+  r> base !
+  1 handle-lit
+  ; immediate
+
+: h#
+  parse-word
+  base @ >r
+
+  hex
+
+  $number if
+    s" illegal number" type cr 0
+  then
+  r> base !
+  1 handle-lit
+  ; immediate
+
+: o#
+  parse-word
+  base @ >r
+
+  octal
+
+  $number if
+    s" illegal number" type cr 0
+  then
+  r> base !
+  1 handle-lit
+  ; immediate
+
+
+\ 
+\ 7.3.4.7 String Literals (part 2)
+\ 
+
+: "
+  pocket dup
+  begin
+    span @ >in @ > if
+      22 parse >r         ( pocket pocket str  R: len )
+      over r@ move        \ copy string
+      r> +                ( pocket nextdest )
+      ib >in @ + c@       ( pocket nextdest nexchar )
+      1 >in +!
+      28 =                \ is nextchar a parenthesis?
+      span @ >in @ >      \ more input?
+      and
+    else
+      false
+    then
+  while
+    29 parse              \ parse everything up to the next ')'
+    bounds ?do
+      i c@ 10 digit if
+        i 1+ c@ 10 digit if
+          swap 4 lshift or
+        else
+          drop
+        then
+        over c! 1+
+        2
+      else
+        drop 1
+      then
+    +loop
+  repeat
+  over -
+  handle-text
+; immediate
+
+
+\ 
+\ 7.3.3.1 Memory Access (part 2)
+\ 
+
+: dump ( addr len -- )
+  over + swap
+  cr
+  do i u. space
+    10 0 do
+      j i + c@
+      dup 10 / todigit emit
+      10 mod todigit emit
+      space
+      i 7 = if space then
+    loop
+    3 spaces
+    10 0 do
+      j i + c@
+      dup 20 < if drop 2e then \ non-printables as dots?
+      emit
+    loop
+    cr
+  10 +loop
+;
+
+
+
+\ 
+\ 7.3.9.1 Defining words
+\ 
+
+: header ( name len -- )
+  dup if                            \ might be a noname...
+    2dup $find1 if
+      drop 2dup type s"  isn't unique." type cr
+    else
+      2drop
+    then
+  then
+  null-align
+  dup -rot ", 80 or c,              \ write name and len
+  here /n 1- and 0= if 0 c, then    \ pad and space for flags
+  null-align
+  80 here 1- c!                     \ write flags byte
+  here last @ , latest !            \ write backlink and set latest
+ ;
+
+
+: :
+  parse-word header
+  1 , ]
+  ;
+
+: :noname 
+  0 0 header 
+  here
+  1 , ]
+  ;
+
+: ;
+  locals-dict 0<> if
+    0 ['] locals-dict /n + !
+    ['] locals-end , 
+  then
+  ['] (semis) , reveal ['] [ execute
+  ; immediate
+
+: constant
+  parse-word header
+  3 , ,                             \ compile DOCON and value
+  reveal
+  ;
+
+0 value active-package
+: instance, ( size -- )
+  \ first word of the device node holds the instance size
+  dup active-package @ dup rot + active-package !
+  , ,      \ offset size
+;
+
+: instance? ( -- flag )
+  #instance @ dup if
+    false #instance !
+  then
+;
+
+: value
+  parse-word header
+  instance? if
+    /n b , instance, ,              \ DOIVAL
+  else
+    3 , ,
+  then
+  reveal
+  ;
+
+: variable
+  parse-word header
+  instance? if
+    /n c , instance, 0 ,
+  else
+    4 , 0 ,
+  then
+  reveal
+  ;
+
+: $buffer: ( size str len -- where )
+  header
+  instance? if
+    /n over /n 1- and - /n 1- and +     \ align buffer size
+    dup c , instance,                   \ DOIVAR
+  else
+    4 ,
+  then
+  here swap
+  2dup 0 fill                            \ zerofill
+  allot
+  reveal
+;
+
+: buffer: ( size -- )
+  parse-word $buffer: drop
+;
+
+: (undefined-defer)  ( -- )
+  \ XXX: this does not work with behavior ... execute
+  r@ 2 cells - lfa2name
+  s" undefined defer word " type type cr ;
+
+: (undefined-idefer)  ( -- )
+  s" undefined idefer word " type cr ;
+
+: defer  (  new-name< >  -- )
+  parse-word header
+  instance? if
+    2 /n* d , instance,                 \ DOIDEFER
+    ['] (undefined-idefer)
+  else
+    5 ,
+    ['] (undefined-defer)
+  then
+  ,
+  ['] (semis) ,
+  reveal
+  ;
+
+: alias  (  new-name< >old-name< >  -- )
+  parse-word
+  parse-word $find if
+    -rot                     \ move xt behind.
+    header
+    1 ,                      \ fixme we want our own cfa here.
+    ,                        \ compile old name xt
+    ['] (semis) ,
+    reveal
+  else
+    s" undefined word " type type space
+    2drop
+  then
+  ;
+
+: $create
+  header 6 ,
+  ['] noop ,
+  reveal
+  ;
+
+: create
+  parse-word $create
+  ;
+
+: (does>)
+  r> cell+              \ get address of code to execute
+  latest @              \ backlink of just "create"d word
+  cell+ cell+ !         \ write code to execute after the
+                        \ new word's CFA
+  ;
+
+: does>
+  ['] (does>) ,         \ compile does handling
+  1 ,                   \ compile docol
+  ; immediate
+
+0 constant struct
+
+: field
+  create
+    over ,
+    +
+  does>
+    @ +
+  ;
+
+: 2constant
+  create , ,
+  does> 2@ reveal
+  ;
+
+\ 
+\ initializer for the temporary compile buffer
+\ 
+
+: init-tmp-comp
+  here 200 allot tmp-comp-buf !
+;
+
+\ the end
diff --git a/qemu/roms/openbios/forth/bootstrap/build.xml b/qemu/roms/openbios/forth/bootstrap/build.xml
new file mode 100644
index 000000000..d950a46df
--- /dev/null
+++ b/qemu/roms/openbios/forth/bootstrap/build.xml
@@ -0,0 +1,16 @@
+<build>
+ <!--
+  build description for openbios forth bootstrap
+ 
+  Copyright (C) 2004-2005 by Stefan Reinauer
+  See the file "COPYING" for further information about
+  the copyright and warranty status of this work.
+  -->
+
+ <dictionary name="bootstrap">
+  <object source="start.fs" target="forth"/>
+ </dictionary>
+
+ <dictionary name="openbios" init="bootstrap"/>
+ 
+</build>
diff --git a/qemu/roms/openbios/forth/bootstrap/builtin.fs b/qemu/roms/openbios/forth/bootstrap/builtin.fs
new file mode 100644
index 000000000..03f5fde1f
--- /dev/null
+++ b/qemu/roms/openbios/forth/bootstrap/builtin.fs
@@ -0,0 +1,28 @@
+\ tag: initialize builtin functionality
+\ 
+\ Copyright (C) 2003 Stefan Reinauer
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\ 
+
+ 
+
+: init-builtin-terminal  ( -- )
+
+  \ define key, key? and emit
+  ['] (key) ['] key (to)
+  ['] (key?) ['] key? (to)
+  ['] (emit) ['] emit (to)
+
+  \ 2 bytes band guard on each side
+  100 #ib !
+  #ib @ dup             ( -- ibs ibs )
+  cell+ alloc-mem       ( -- ibs addr )
+  dup -rot              ( -- addr ibs addr )
+
+  /w + ['] ib (to)      \ assign input buffer
+  0 fill                \ erase tib
+  0 ['] source-id (to)  \ builtin terminal has id 0
+
+  ;
diff --git a/qemu/roms/openbios/forth/bootstrap/hayes.fs b/qemu/roms/openbios/forth/bootstrap/hayes.fs
new file mode 100644
index 000000000..e5a46f406
--- /dev/null
+++ b/qemu/roms/openbios/forth/bootstrap/hayes.fs
@@ -0,0 +1,1064 @@
+\ From: John Hayes S1I
+\ Subject: tester.fr
+\ Date: Mon, 27 Nov 95 13:10:09 PST  
+
+\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
+\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
+\ VERSION 1.1
+
+HEX
+
+\ switch output of hex values to capital letters
+true to capital-hex?
+
+
+\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY
+\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG.
+
+VARIABLE VERBOSE
+   FALSE VERBOSE !
+
+: EMPTY-STACK	\ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO.
+   DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ;
+
+: ERROR		\ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY
+		\ THE LINE THAT HAD THE ERROR.
+   \ TYPE SOURCE TYPE CR			\ DISPLAY LINE CORRESPONDING TO ERROR
+
+   \ FIXME beginagain wants the following for output:
+   TYPE SOURCE drop span @ TYPE CR	\ DISPLAY LINE CORRESPONDING TO ERROR
+   EMPTY-STACK				\ THROW AWAY EVERY THING ELSE
+   -99 SYS-DEBUG                        \ MAKE BEGINAGAIN BOOTSTRAP FAIL.
+;
+
+VARIABLE ACTUAL-DEPTH			\ STACK RECORD
+CREATE ACTUAL-RESULTS 20 CELLS ALLOT
+
+: {		\ ( -- ) SYNTACTIC SUGAR.
+   ;
+
+: ->		\ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK.
+   DEPTH DUP ACTUAL-DEPTH !		\ RECORD DEPTH
+   ?DUP IF				\ IF THERE IS SOMETHING ON STACK
+      0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM
+   THEN ;
+
+: }		\ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED
+		\ (ACTUAL) CONTENTS.
+   DEPTH ACTUAL-DEPTH @ = IF		\ IF DEPTHS MATCH
+      DEPTH ?DUP IF			\ IF THERE IS SOMETHING ON THE STACK
+         0 DO				\ FOR EACH STACK ITEM
+	    ACTUAL-RESULTS I CELLS + @	\ COMPARE ACTUAL WITH EXPECTED
+	    <> IF S" INCORRECT RESULT: " ERROR LEAVE THEN
+	 LOOP
+      THEN
+   ELSE					\ DEPTH MISMATCH
+      S" WRONG NUMBER OF RESULTS: " ERROR
+   THEN ;
+
+: TESTING	\ ( -- ) TALKING COMMENT.
+   SOURCE VERBOSE @
+   IF DUP >R TYPE CR R> >IN !
+   ELSE >IN ! DROP
+   THEN 
+   ;
+
+\ From: John Hayes S1I
+\ Subject: core.fr
+\ Date: Mon, 27 Nov 95 13:10
+
+\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
+\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
+\ VERSION 1.2
+\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
+\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
+\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
+\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
+\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
+\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
+
+TESTING CORE WORDS
+HEX
+
+\ ------------------------------------------------------------------------
+TESTING BASIC ASSUMPTIONS
+
+{ -> }					\ START WITH CLEAN SLATE
+( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 )
+{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }
+{  0 BITSSET? -> 0 }		( ZERO IS ALL BITS CLEAR )
+{  1 BITSSET? -> 0 0 }		( OTHER NUMBER HAVE AT LEAST ONE BIT )
+{ -1 BITSSET? -> 0 0 }
+
+\ ------------------------------------------------------------------------
+TESTING BOOLEANS: INVERT AND OR XOR
+
+{ 0 0 AND -> 0 }
+{ 0 1 AND -> 0 }
+{ 1 0 AND -> 0 }
+{ 1 1 AND -> 1 }
+
+{ 0 INVERT 1 AND -> 1 }
+{ 1 INVERT 1 AND -> 0 }
+
+0	 CONSTANT 0S
+0 INVERT CONSTANT 1S
+
+{ 0S INVERT -> 1S }
+{ 1S INVERT -> 0S }
+
+{ 0S 0S AND -> 0S }
+{ 0S 1S AND -> 0S }
+{ 1S 0S AND -> 0S }
+{ 1S 1S AND -> 1S }
+
+{ 0S 0S OR -> 0S }
+{ 0S 1S OR -> 1S }
+{ 1S 0S OR -> 1S }
+{ 1S 1S OR -> 1S }
+
+{ 0S 0S XOR -> 0S }
+{ 0S 1S XOR -> 1S }
+{ 1S 0S XOR -> 1S }
+{ 1S 1S XOR -> 0S }
+
+\ ------------------------------------------------------------------------
+TESTING 2* 2/ LSHIFT RSHIFT
+
+( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER )
+1S 1 RSHIFT INVERT CONSTANT MSB
+{ MSB BITSSET? -> 0 0 }
+
+{ 0S 2* -> 0S }
+{ 1 2* -> 2 }
+{ 4000 2* -> 8000 }
+{ 1S 2* 1 XOR -> 1S }
+{ MSB 2* -> 0S }
+
+{ 0S 2/ -> 0S }
+{ 1 2/ -> 0 }
+{ 4000 2/ -> 2000 }
+{ 1S 2/ -> 1S }				\ MSB PROPOGATED
+{ 1S 1 XOR 2/ -> 1S }
+{ MSB 2/ MSB AND -> MSB }
+
+{ 1 0 LSHIFT -> 1 }
+{ 1 1 LSHIFT -> 2 }
+{ 1 2 LSHIFT -> 4 }
+{ 1 F LSHIFT -> 8000 }			\ BIGGEST GUARANTEED SHIFT
+{ 1S 1 LSHIFT 1 XOR -> 1S }
+{ MSB 1 LSHIFT -> 0 }
+
+{ 1 0 RSHIFT -> 1 }
+{ 1 1 RSHIFT -> 0 }
+{ 2 1 RSHIFT -> 1 }
+{ 4 2 RSHIFT -> 1 }
+{ 8000 F RSHIFT -> 1 }			\ BIGGEST
+{ MSB 1 RSHIFT MSB AND -> 0 }		\ RSHIFT ZERO FILLS MSBS
+{ MSB 1 RSHIFT 2* -> MSB }
+
+\ ------------------------------------------------------------------------
+TESTING COMPARISONS: 0= = 0< < > U< MIN MAX
+0 INVERT			CONSTANT MAX-UINT
+0 INVERT 1 RSHIFT		CONSTANT MAX-INT
+0 INVERT 1 RSHIFT INVERT	CONSTANT MIN-INT
+0 INVERT 1 RSHIFT		CONSTANT MID-UINT
+0 INVERT 1 RSHIFT INVERT	CONSTANT MID-UINT+1
+
+0S CONSTANT <FALSE>
+1S CONSTANT <TRUE>
+
+{ 0 0= -> <TRUE> }
+{ 1 0= -> <FALSE> }
+{ 2 0= -> <FALSE> }
+{ -1 0= -> <FALSE> }
+{ MAX-UINT 0= -> <FALSE> }
+{ MIN-INT 0= -> <FALSE> }
+{ MAX-INT 0= -> <FALSE> }
+
+{ 0 0 = -> <TRUE> }
+{ 1 1 = -> <TRUE> }
+{ -1 -1 = -> <TRUE> }
+{ 1 0 = -> <FALSE> }
+{ -1 0 = -> <FALSE> }
+{ 0 1 = -> <FALSE> }
+{ 0 -1 = -> <FALSE> }
+
+{ 0 0< -> <FALSE> }
+{ -1 0< -> <TRUE> }
+{ MIN-INT 0< -> <TRUE> }
+{ 1 0< -> <FALSE> }
+{ MAX-INT 0< -> <FALSE> }
+
+{ 0 1 < -> <TRUE> }
+{ 1 2 < -> <TRUE> }
+{ -1 0 < -> <TRUE> }
+{ -1 1 < -> <TRUE> }
+{ MIN-INT 0 < -> <TRUE> }
+{ MIN-INT MAX-INT < -> <TRUE> }
+{ 0 MAX-INT < -> <TRUE> }
+{ 0 0 < -> <FALSE> }
+{ 1 1 < -> <FALSE> }
+{ 1 0 < -> <FALSE> }
+{ 2 1 < -> <FALSE> }
+{ 0 -1 < -> <FALSE> }
+{ 1 -1 < -> <FALSE> }
+{ 0 MIN-INT < -> <FALSE> }
+{ MAX-INT MIN-INT < -> <FALSE> }
+{ MAX-INT 0 < -> <FALSE> }
+
+{ 0 1 > -> <FALSE> }
+{ 1 2 > -> <FALSE> }
+{ -1 0 > -> <FALSE> }
+{ -1 1 > -> <FALSE> }
+{ MIN-INT 0 > -> <FALSE> }
+{ MIN-INT MAX-INT > -> <FALSE> }
+{ 0 MAX-INT > -> <FALSE> }
+{ 0 0 > -> <FALSE> }
+{ 1 1 > -> <FALSE> }
+{ 1 0 > -> <TRUE> }
+{ 2 1 > -> <TRUE> }
+{ 0 -1 > -> <TRUE> }
+{ 1 -1 > -> <TRUE> }
+{ 0 MIN-INT > -> <TRUE> }
+{ MAX-INT MIN-INT > -> <TRUE> }
+{ MAX-INT 0 > -> <TRUE> }
+
+{ 0 1 U< -> <TRUE> }
+{ 1 2 U< -> <TRUE> }
+{ 0 MID-UINT U< -> <TRUE> }
+{ 0 MAX-UINT U< -> <TRUE> }
+{ MID-UINT MAX-UINT U< -> <TRUE> }
+{ 0 0 U< -> <FALSE> }
+{ 1 1 U< -> <FALSE> }
+{ 1 0 U< -> <FALSE> }
+{ 2 1 U< -> <FALSE> }
+{ MID-UINT 0 U< -> <FALSE> }
+{ MAX-UINT 0 U< -> <FALSE> }
+{ MAX-UINT MID-UINT U< -> <FALSE> }
+
+{ 0 1 MIN -> 0 }
+{ 1 2 MIN -> 1 }
+{ -1 0 MIN -> -1 }
+{ -1 1 MIN -> -1 }
+{ MIN-INT 0 MIN -> MIN-INT }
+{ MIN-INT MAX-INT MIN -> MIN-INT }
+{ 0 MAX-INT MIN -> 0 }
+{ 0 0 MIN -> 0 }
+{ 1 1 MIN -> 1 }
+{ 1 0 MIN -> 0 }
+{ 2 1 MIN -> 1 }
+{ 0 -1 MIN -> -1 }
+{ 1 -1 MIN -> -1 }
+{ 0 MIN-INT MIN -> MIN-INT }
+{ MAX-INT MIN-INT MIN -> MIN-INT }
+{ MAX-INT 0 MIN -> 0 }
+
+{ 0 1 MAX -> 1 }
+{ 1 2 MAX -> 2 }
+{ -1 0 MAX -> 0 }
+{ -1 1 MAX -> 1 }
+{ MIN-INT 0 MAX -> 0 }
+{ MIN-INT MAX-INT MAX -> MAX-INT }
+{ 0 MAX-INT MAX -> MAX-INT }
+{ 0 0 MAX -> 0 }
+{ 1 1 MAX -> 1 }
+{ 1 0 MAX -> 1 }
+{ 2 1 MAX -> 2 }
+{ 0 -1 MAX -> 0 }
+{ 1 -1 MAX -> 1 }
+{ 0 MIN-INT MAX -> 0 }
+{ MAX-INT MIN-INT MAX -> MAX-INT }
+{ MAX-INT 0 MAX -> MAX-INT }
+
+\ ------------------------------------------------------------------------
+TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP
+
+{ 1 2 2DROP -> }
+{ 1 2 2DUP -> 1 2 1 2 }
+{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }
+{ 1 2 3 4 2SWAP -> 3 4 1 2 }
+{ 0 ?DUP -> 0 }
+{ 1 ?DUP -> 1 1 }
+{ -1 ?DUP -> -1 -1 }
+{ DEPTH -> 0 }
+{ 0 DEPTH -> 0 1 }
+{ 0 1 DEPTH -> 0 1 2 }
+{ 0 DROP -> }
+{ 1 2 DROP -> 1 }
+{ 1 DUP -> 1 1 }
+{ 1 2 OVER -> 1 2 1 }
+{ 1 2 3 ROT -> 2 3 1 }
+{ 1 2 SWAP -> 2 1 }
+
+\ ------------------------------------------------------------------------
+TESTING >R R> R@
+
+{ : GR1 >R R> ; -> }
+{ : GR2 >R R@ R> DROP ; -> }
+{ 123 GR1 -> 123 }
+{ 123 GR2 -> 123 }
+{ 1S GR1 -> 1S }   ( RETURN STACK HOLDS CELLS )
+
+\ ------------------------------------------------------------------------
+TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE
+
+{ 0 5 + -> 5 }
+{ 5 0 + -> 5 }
+{ 0 -5 + -> -5 }
+{ -5 0 + -> -5 }
+{ 1 2 + -> 3 }
+{ 1 -2 + -> -1 }
+{ -1 2 + -> 1 }
+{ -1 -2 + -> -3 }
+{ -1 1 + -> 0 }
+{ MID-UINT 1 + -> MID-UINT+1 }
+
+{ 0 5 - -> -5 }
+{ 5 0 - -> 5 }
+{ 0 -5 - -> 5 }
+{ -5 0 - -> -5 }
+{ 1 2 - -> -1 }
+{ 1 -2 - -> 3 }
+{ -1 2 - -> -3 }
+{ -1 -2 - -> 1 }
+{ 0 1 - -> -1 }
+{ MID-UINT+1 1 - -> MID-UINT }
+
+{ 0 1+ -> 1 }
+{ -1 1+ -> 0 }
+{ 1 1+ -> 2 }
+{ MID-UINT 1+ -> MID-UINT+1 }
+
+{ 2 1- -> 1 }
+{ 1 1- -> 0 }
+{ 0 1- -> -1 }
+{ MID-UINT+1 1- -> MID-UINT }
+
+{ 0 NEGATE -> 0 }
+{ 1 NEGATE -> -1 }
+{ -1 NEGATE -> 1 }
+{ 2 NEGATE -> -2 }
+{ -2 NEGATE -> 2 }
+
+{ 0 ABS -> 0 }
+{ 1 ABS -> 1 }
+{ -1 ABS -> 1 }
+{ MIN-INT ABS -> MID-UINT+1 }
+
+\ ------------------------------------------------------------------------
+TESTING MULTIPLY: S>D * M* UM*
+
+{ 0 S>D -> 0 0 }
+{ 1 S>D -> 1 0 }
+{ 2 S>D -> 2 0 }
+{ -1 S>D -> -1 -1 }
+{ -2 S>D -> -2 -1 }
+{ MIN-INT S>D -> MIN-INT -1 }
+{ MAX-INT S>D -> MAX-INT 0 }
+
+{ 0 0 M* -> 0 S>D }
+{ 0 1 M* -> 0 S>D }
+{ 1 0 M* -> 0 S>D }
+{ 1 2 M* -> 2 S>D }
+{ 2 1 M* -> 2 S>D }
+{ 3 3 M* -> 9 S>D }
+{ -3 3 M* -> -9 S>D }
+{ 3 -3 M* -> -9 S>D }
+{ -3 -3 M* -> 9 S>D }
+{ 0 MIN-INT M* -> 0 S>D }
+{ 1 MIN-INT M* -> MIN-INT S>D }
+{ 2 MIN-INT M* -> 0 1S }
+{ 0 MAX-INT M* -> 0 S>D }
+{ 1 MAX-INT M* -> MAX-INT S>D }
+{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }
+{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }
+{ MAX-INT MIN-INT M* -> MSB MSB 2/ }
+{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }
+
+{ 0 0 * -> 0 }				\ TEST IDENTITIES
+{ 0 1 * -> 0 }
+{ 1 0 * -> 0 }
+{ 1 2 * -> 2 }
+{ 2 1 * -> 2 }
+{ 3 3 * -> 9 }
+{ -3 3 * -> -9 }
+{ 3 -3 * -> -9 }
+{ -3 -3 * -> 9 }
+
+{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }
+{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }
+{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }
+
+{ 0 0 UM* -> 0 0 }
+{ 0 1 UM* -> 0 0 }
+{ 1 0 UM* -> 0 0 }
+{ 1 2 UM* -> 2 0 }
+{ 2 1 UM* -> 2 0 }
+{ 3 3 UM* -> 9 0 }
+
+{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }
+{ MID-UINT+1 2 UM* -> 0 1 }
+{ MID-UINT+1 4 UM* -> 0 2 }
+{ 1S 2 UM* -> 1S 1 LSHIFT 1 }
+{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }
+
+\ ------------------------------------------------------------------------
+TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD
+
+{ 0 S>D 1 FM/MOD -> 0 0 }
+{ 1 S>D 1 FM/MOD -> 0 1 }
+{ 2 S>D 1 FM/MOD -> 0 2 }
+{ -1 S>D 1 FM/MOD -> 0 -1 }
+{ -2 S>D 1 FM/MOD -> 0 -2 }
+{ 0 S>D -1 FM/MOD -> 0 0 }
+{ 1 S>D -1 FM/MOD -> 0 -1 }
+{ 2 S>D -1 FM/MOD -> 0 -2 }
+{ -1 S>D -1 FM/MOD -> 0 1 }
+{ -2 S>D -1 FM/MOD -> 0 2 }
+{ 2 S>D 2 FM/MOD -> 0 1 }
+{ -1 S>D -1 FM/MOD -> 0 1 }
+{ -2 S>D -2 FM/MOD -> 0 1 }
+{  7 S>D  3 FM/MOD -> 1 2 }
+{  7 S>D -3 FM/MOD -> -2 -3 }
+{ -7 S>D  3 FM/MOD -> 2 -3 }
+{ -7 S>D -3 FM/MOD -> -1 2 }
+{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }
+{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }
+{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }
+{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }
+{ 1S 1 4 FM/MOD -> 3 MAX-INT }
+{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }
+{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }
+{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }
+{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }
+{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }
+{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }
+{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }
+{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }
+{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }
+{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }
+{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }
+{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }
+
+{ 0 S>D 1 SM/REM -> 0 0 }
+{ 1 S>D 1 SM/REM -> 0 1 }
+{ 2 S>D 1 SM/REM -> 0 2 }
+{ -1 S>D 1 SM/REM -> 0 -1 }
+{ -2 S>D 1 SM/REM -> 0 -2 }
+{ 0 S>D -1 SM/REM -> 0 0 }
+{ 1 S>D -1 SM/REM -> 0 -1 }
+{ 2 S>D -1 SM/REM -> 0 -2 }
+{ -1 S>D -1 SM/REM -> 0 1 }
+{ -2 S>D -1 SM/REM -> 0 2 }
+{ 2 S>D 2 SM/REM -> 0 1 }
+{ -1 S>D -1 SM/REM -> 0 1 }
+{ -2 S>D -2 SM/REM -> 0 1 }
+{  7 S>D  3 SM/REM -> 1 2 }
+{  7 S>D -3 SM/REM -> 1 -2 }
+{ -7 S>D  3 SM/REM -> -1 -2 }
+{ -7 S>D -3 SM/REM -> -1 2 }
+{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }
+{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }
+{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }
+{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }
+{ 1S 1 4 SM/REM -> 3 MAX-INT }
+{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }
+{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }
+{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }
+{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }
+{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }
+{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }
+{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }
+{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }
+
+{ 0 0 1 UM/MOD -> 0 0 }
+{ 1 0 1 UM/MOD -> 0 1 }
+{ 1 0 2 UM/MOD -> 1 0 }
+{ 3 0 2 UM/MOD -> 1 1 }
+{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }
+{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }
+{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }
+
+: IFFLOORED
+   [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ;
+: IFSYM
+   [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ;
+
+\ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION.
+\ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST.
+IFFLOORED : T/MOD  >R S>D R> FM/MOD ;
+IFFLOORED : T/     T/MOD SWAP DROP ;
+IFFLOORED : TMOD   T/MOD DROP ;
+IFFLOORED : T*/MOD >R M* R> FM/MOD ;
+IFFLOORED : T*/    T*/MOD SWAP DROP ;
+IFSYM     : T/MOD  >R S>D R> SM/REM ;
+IFSYM     : T/     T/MOD SWAP DROP ;
+IFSYM     : TMOD   T/MOD DROP ;
+IFSYM     : T*/MOD >R M* R> SM/REM ;
+IFSYM     : T*/    T*/MOD SWAP DROP ;
+
+{ 0 1 /MOD -> 0 1 T/MOD }
+{ 1 1 /MOD -> 1 1 T/MOD }
+{ 2 1 /MOD -> 2 1 T/MOD }
+{ -1 1 /MOD -> -1 1 T/MOD }
+{ -2 1 /MOD -> -2 1 T/MOD }
+{ 0 -1 /MOD -> 0 -1 T/MOD }
+{ 1 -1 /MOD -> 1 -1 T/MOD }
+{ 2 -1 /MOD -> 2 -1 T/MOD }
+{ -1 -1 /MOD -> -1 -1 T/MOD }
+{ -2 -1 /MOD -> -2 -1 T/MOD }
+{ 2 2 /MOD -> 2 2 T/MOD }
+{ -1 -1 /MOD -> -1 -1 T/MOD }
+{ -2 -2 /MOD -> -2 -2 T/MOD }
+{ 7 3 /MOD -> 7 3 T/MOD }
+{ 7 -3 /MOD -> 7 -3 T/MOD }
+{ -7 3 /MOD -> -7 3 T/MOD }
+{ -7 -3 /MOD -> -7 -3 T/MOD }
+{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }
+{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }
+{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }
+{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }
+
+{ 0 1 / -> 0 1 T/ }
+{ 1 1 / -> 1 1 T/ }
+{ 2 1 / -> 2 1 T/ }
+{ -1 1 / -> -1 1 T/ }
+{ -2 1 / -> -2 1 T/ }
+{ 0 -1 / -> 0 -1 T/ }
+{ 1 -1 / -> 1 -1 T/ }
+{ 2 -1 / -> 2 -1 T/ }
+{ -1 -1 / -> -1 -1 T/ }
+{ -2 -1 / -> -2 -1 T/ }
+{ 2 2 / -> 2 2 T/ }
+{ -1 -1 / -> -1 -1 T/ }
+{ -2 -2 / -> -2 -2 T/ }
+{ 7 3 / -> 7 3 T/ }
+{ 7 -3 / -> 7 -3 T/ }
+{ -7 3 / -> -7 3 T/ }
+{ -7 -3 / -> -7 -3 T/ }
+{ MAX-INT 1 / -> MAX-INT 1 T/ }
+{ MIN-INT 1 / -> MIN-INT 1 T/ }
+{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }
+{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }
+
+{ 0 1 MOD -> 0 1 TMOD }
+{ 1 1 MOD -> 1 1 TMOD }
+{ 2 1 MOD -> 2 1 TMOD }
+{ -1 1 MOD -> -1 1 TMOD }
+{ -2 1 MOD -> -2 1 TMOD }
+{ 0 -1 MOD -> 0 -1 TMOD }
+{ 1 -1 MOD -> 1 -1 TMOD }
+{ 2 -1 MOD -> 2 -1 TMOD }
+{ -1 -1 MOD -> -1 -1 TMOD }
+{ -2 -1 MOD -> -2 -1 TMOD }
+{ 2 2 MOD -> 2 2 TMOD }
+{ -1 -1 MOD -> -1 -1 TMOD }
+{ -2 -2 MOD -> -2 -2 TMOD }
+{ 7 3 MOD -> 7 3 TMOD }
+{ 7 -3 MOD -> 7 -3 TMOD }
+{ -7 3 MOD -> -7 3 TMOD }
+{ -7 -3 MOD -> -7 -3 TMOD }
+{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }
+{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }
+{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }
+{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }
+
+{ 0 2 1 */ -> 0 2 1 T*/ }
+{ 1 2 1 */ -> 1 2 1 T*/ }
+{ 2 2 1 */ -> 2 2 1 T*/ }
+{ -1 2 1 */ -> -1 2 1 T*/ }
+{ -2 2 1 */ -> -2 2 1 T*/ }
+{ 0 2 -1 */ -> 0 2 -1 T*/ }
+{ 1 2 -1 */ -> 1 2 -1 T*/ }
+{ 2 2 -1 */ -> 2 2 -1 T*/ }
+{ -1 2 -1 */ -> -1 2 -1 T*/ }
+{ -2 2 -1 */ -> -2 2 -1 T*/ }
+{ 2 2 2 */ -> 2 2 2 T*/ }
+{ -1 2 -1 */ -> -1 2 -1 T*/ }
+{ -2 2 -2 */ -> -2 2 -2 T*/ }
+{ 7 2 3 */ -> 7 2 3 T*/ }
+{ 7 2 -3 */ -> 7 2 -3 T*/ }
+{ -7 2 3 */ -> -7 2 3 T*/ }
+{ -7 2 -3 */ -> -7 2 -3 T*/ }
+{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }
+{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }
+
+{ 0 2 1 */MOD -> 0 2 1 T*/MOD }
+{ 1 2 1 */MOD -> 1 2 1 T*/MOD }
+{ 2 2 1 */MOD -> 2 2 1 T*/MOD }
+{ -1 2 1 */MOD -> -1 2 1 T*/MOD }
+{ -2 2 1 */MOD -> -2 2 1 T*/MOD }
+{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }
+{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }
+{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }
+{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }
+{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }
+{ 2 2 2 */MOD -> 2 2 2 T*/MOD }
+{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }
+{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }
+{ 7 2 3 */MOD -> 7 2 3 T*/MOD }
+{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }
+{ -7 2 3 */MOD -> -7 2 3 T*/MOD }
+{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }
+{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }
+{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }
+
+\ ------------------------------------------------------------------------
+TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT
+
+HERE 1 ALLOT
+HERE
+CONSTANT 2NDA
+CONSTANT 1STA
+{ 1STA 2NDA U< -> <TRUE> }		\ HERE MUST GROW WITH ALLOT
+{ 1STA 1+ -> 2NDA }			\ ... BY ONE ADDRESS UNIT
+( MISSING TEST: NEGATIVE ALLOT )
+
+HERE 1 ,
+HERE 2 ,
+CONSTANT 2ND
+CONSTANT 1ST
+{ 1ST 2ND U< -> <TRUE> }			\ HERE MUST GROW WITH ALLOT
+{ 1ST CELL+ -> 2ND }			\ ... BY ONE CELL
+{ 1ST 1 CELLS + -> 2ND }
+{ 1ST @ 2ND @ -> 1 2 }
+{ 5 1ST ! -> }
+{ 1ST @ 2ND @ -> 5 2 }
+{ 6 2ND ! -> }
+{ 1ST @ 2ND @ -> 5 6 }
+{ 1ST 2@ -> 6 5 }
+{ 2 1 1ST 2! -> }
+{ 1ST 2@ -> 2 1 }
+{ 1S 1ST !  1ST @ -> 1S }		\ CAN STORE CELL-WIDE VALUE
+
+HERE 1 C,
+HERE 2 C,
+CONSTANT 2NDC
+CONSTANT 1STC
+{ 1STC 2NDC U< -> <TRUE> }		\ HERE MUST GROW WITH ALLOT
+{ 1STC CHAR+ -> 2NDC }			\ ... BY ONE CHAR
+{ 1STC 1 CHARS + -> 2NDC }
+{ 1STC C@ 2NDC C@ -> 1 2 }
+{ 3 1STC C! -> }
+{ 1STC C@ 2NDC C@ -> 3 2 }
+{ 4 2NDC C! -> }
+{ 1STC C@ 2NDC C@ -> 3 4 }
+
+ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT
+CONSTANT A-ADDR  CONSTANT UA-ADDR
+{ UA-ADDR ALIGNED -> A-ADDR }
+{    1 A-ADDR C!  A-ADDR C@ ->    1 }
+{ 1234 A-ADDR  !  A-ADDR  @ -> 1234 }
+{ 123 456 A-ADDR 2!  A-ADDR 2@ -> 123 456 }
+{ 2 A-ADDR CHAR+ C!  A-ADDR CHAR+ C@ -> 2 }
+{ 3 A-ADDR CELL+ C!  A-ADDR CELL+ C@ -> 3 }
+{ 1234 A-ADDR CELL+ !  A-ADDR CELL+ @ -> 1234 }
+{ 123 456 A-ADDR CELL+ 2!  A-ADDR CELL+ 2@ -> 123 456 }
+
+: BITS ( X -- U )
+   0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ;
+( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS )
+{ 1 CHARS 1 < -> <FALSE> }
+{ 1 CHARS 1 CELLS > -> <FALSE> }
+( TBD: HOW TO FIND NUMBER OF BITS? )
+
+( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS )
+{ 1 CELLS 1 < -> <FALSE> }
+{ 1 CELLS 1 CHARS MOD -> 0 }
+{ 1S BITS 10 < -> <FALSE> }
+
+{ 0 1ST ! -> }
+{ 1 1ST +! -> }
+{ 1ST @ -> 1 }
+{ -1 1ST +! 1ST @ -> 0 }
+
+\ ------------------------------------------------------------------------
+TESTING CHAR [CHAR] [ ] BL S"
+
+{ BL -> 20 }
+{ CHAR X -> 58 }
+{ CHAR HELLO -> 48 }
+{ : GC1 [CHAR] X ; -> }
+{ : GC2 [CHAR] HELLO ; -> }
+{ GC1 -> 58 }
+{ GC2 -> 48 }
+{ : GC3 [ GC1 ] LITERAL ; -> }
+{ GC3 -> 58 }
+{ : GC4 S" XY" ; -> }
+{ GC4 SWAP DROP -> 2 }
+{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }
+
+\ ------------------------------------------------------------------------
+TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE
+
+{ : GT1 123 ; -> }
+{ ' GT1 EXECUTE -> 123 }
+{ : GT2 ['] GT1 ; IMMEDIATE -> }
+{ GT2 EXECUTE -> 123 }
+HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING
+HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING
+{ GT1STRING FIND -> ' GT1 -1 }
+{ GT2STRING FIND -> ' GT2 1 }
+( HOW TO SEARCH FOR NON-EXISTENT WORD? )
+{ : GT3 GT2 LITERAL ; -> }
+{ GT3 -> ' GT1 }
+{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }
+
+{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }
+{ : GT5 GT4 ; -> }
+{ GT5 -> 123 }
+{ : GT6 345 ; IMMEDIATE -> }
+{ : GT7 POSTPONE GT6 ; -> }
+{ GT7 -> 345 }
+
+{ : GT8 STATE @ ; IMMEDIATE -> }
+{ GT8 -> 0 }
+{ : GT9 GT8 LITERAL ; -> }
+{ GT9 0= -> <FALSE> }
+
+\ ------------------------------------------------------------------------
+TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE
+
+{ : GI1 IF 123 THEN ; -> }
+{ : GI2 IF 123 ELSE 234 THEN ; -> }
+{ 0 GI1 -> }
+{ 1 GI1 -> 123 }
+{ -1 GI1 -> 123 }
+{ 0 GI2 -> 234 }
+{ 1 GI2 -> 123 }
+{ -1 GI1 -> 123 }
+
+{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }
+{ 0 GI3 -> 0 1 2 3 4 5 }
+{ 4 GI3 -> 4 5 }
+{ 5 GI3 -> 5 }
+{ 6 GI3 -> 6 }
+
+{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }
+{ 3 GI4 -> 3 4 5 6 }
+{ 5 GI4 -> 5 6 }
+{ 6 GI4 -> 6 7 }
+
+{ : GI5 BEGIN DUP 2 > WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }
+{ 1 GI5 -> 1 345 }
+{ 2 GI5 -> 2 345 }
+{ 3 GI5 -> 3 4 5 123 }
+{ 4 GI5 -> 4 5 123 }
+{ 5 GI5 -> 5 123 }
+
+{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }
+{ 0 GI6 -> 0 }
+{ 1 GI6 -> 0 1 }
+{ 2 GI6 -> 0 1 2 }
+{ 3 GI6 -> 0 1 2 3 }
+{ 4 GI6 -> 0 1 2 3 4 }
+
+\ ------------------------------------------------------------------------
+TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT
+
+{ : GD1 DO I LOOP ; -> }
+{ 4 1 GD1 -> 1 2 3 }
+{ 2 -1 GD1 -> -1 0 1 }
+{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }
+
+{ : GD2 DO I -1 +LOOP ; -> }
+{ 1 4 GD2 -> 4 3 2 1 }
+{ -1 2 GD2 -> 2 1 0 -1 }
+{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }
+
+{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }
+{ 4 1 GD3 -> 1 2 3 }
+{ 2 -1 GD3 -> -1 0 1 }
+{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }
+
+{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }
+{ 1 4 GD4 -> 4 3 2 1 }
+{ -1 2 GD4 -> 2 1 0 -1 }
+{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }
+
+{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }
+{ 1 GD5 -> 123 }
+{ 5 GD5 -> 123 }
+{ 6 GD5 -> 234 }
+
+{ : GD6  ( PAT: {0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} )
+   0 SWAP 0 DO
+      I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP
+    LOOP ; -> }
+{ 1 GD6 -> 1 }
+{ 2 GD6 -> 3 }
+{ 3 GD6 -> 4 1 2 }
+
+\ ------------------------------------------------------------------------
+TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY
+
+{ 123 CONSTANT X123 -> }
+{ X123 -> 123 }
+{ : EQU CONSTANT ; -> }
+{ X123 EQU Y123 -> }
+{ Y123 -> 123 }
+
+{ VARIABLE V1 -> }
+{ 123 V1 ! -> }
+{ V1 @ -> 123 }
+
+{ : NOP : POSTPONE ; ; -> }
+{ NOP NOP1 NOP NOP2 -> }
+{ NOP1 -> }
+{ NOP2 -> }
+
+{ : DOES1 DOES> @ 1 + ; -> }
+{ : DOES2 DOES> @ 2 + ; -> }
+{ CREATE CR1 -> }
+{ CR1 -> HERE }
+{ ' CR1 >BODY -> HERE }
+{ 1 , -> }
+{ CR1 @ -> 1 }
+{ DOES1 -> }
+{ CR1 -> 2 }
+{ DOES2 -> }
+{ CR1 -> 3 }
+
+{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }
+{ WEIRD: W1 -> }
+{ ' W1 >BODY -> HERE }
+{ W1 -> HERE 1 + }
+{ W1 -> HERE 2 + }
+
+\ ------------------------------------------------------------------------
+TESTING EVALUATE
+
+: GE1 S" 123" ; IMMEDIATE
+: GE2 S" 123 1+" ; IMMEDIATE
+: GE3 S" : GE4 345 ;" ;
+: GE5 EVALUATE ; IMMEDIATE
+
+{ GE1 EVALUATE -> 123 }			( TEST EVALUATE IN INTERP. STATE )
+{ GE2 EVALUATE -> 124 }
+{ GE3 EVALUATE -> }
+{ GE4 -> 345 }
+
+{ : GE6 GE1 GE5 ; -> }			( TEST EVALUATE IN COMPILE STATE )
+{ GE6 -> 123 }
+{ : GE7 GE2 GE5 ; -> }
+{ GE7 -> 124 }
+
+\ ------------------------------------------------------------------------
+TESTING SOURCE >IN WORD
+
+: GS1 S" SOURCE" 2DUP EVALUATE
+       >R SWAP >R = R> R> = ;
+{ GS1 -> <TRUE> <TRUE> }
+
+VARIABLE SCANS
+: RESCAN?  -1 SCANS +! SCANS @ IF 0 >IN ! THEN ;
+
+{ 2 SCANS !
+345 RESCAN?
+-> 345 345 }
+
+: GS2  5 SCANS ! S" 123 RESCAN?" EVALUATE ;
+{ GS2 -> 123 123 123 123 123 }
+
+: GS3 WORD COUNT SWAP C@ ;
+{ BL GS3 HELLO -> 5 CHAR H }
+{ CHAR " GS3 GOODBYE" -> 7 CHAR G }
+{ BL GS3
+DROP -> 0 }				\ BLANK LINE RETURN ZERO-LENGTH STRING
+
+: GS4 SOURCE >IN ! DROP ;
+{ GS4 123 456
+-> }
+
+\ ------------------------------------------------------------------------
+TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL
+
+: S=  \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS.
+   >R SWAP R@ = IF			\ MAKE SURE STRINGS HAVE SAME LENGTH
+      R> ?DUP IF			\ IF NON-EMPTY STRINGS
+	 0 DO
+	    OVER C@ OVER C@ - IF 2DROP <FALSE> UNLOOP EXIT THEN
+	    SWAP CHAR+ SWAP CHAR+
+         LOOP
+      THEN
+      2DROP <TRUE>			\ IF WE GET HERE, STRINGS MATCH
+   ELSE
+      R> DROP 2DROP <FALSE>		\ LENGTHS MISMATCH
+   THEN ;
+
+: GP1  <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ;
+{ GP1 -> <TRUE> }
+
+: GP2  <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ;
+{ GP2 -> <TRUE> }
+
+: GP3  <# 1 0 # # #> S" 01" S= ;
+{ GP3 -> <TRUE> }
+
+: GP4  <# 1 0 #S #> S" 1" S= ;
+{ GP4 -> <TRUE> }
+
+24 CONSTANT MAX-BASE			\ BASE 2 .. 36
+: COUNT-BITS
+   0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ;
+COUNT-BITS 2* CONSTANT #BITS-UD		\ NUMBER OF BITS IN UD
+
+: GP5
+   BASE @ <TRUE>
+   MAX-BASE 1+ 2 DO			\ FOR EACH POSSIBLE BASE
+      I BASE !				\ TBD: ASSUMES BASE WORKS
+      I 0 <# #S #> S" 10" S= AND
+   LOOP
+   SWAP BASE ! ;
+{ GP5 -> <TRUE> }
+
+: GP6
+   BASE @ >R  2 BASE !
+   MAX-UINT MAX-UINT <# #S #>		\ MAXIMUM UD TO BINARY
+   R> BASE !				\ S: C-ADDR U
+   DUP #BITS-UD = SWAP
+   0 DO					\ S: C-ADDR FLAG
+      OVER C@ [CHAR] 1 = AND		\ ALL ONES
+      >R CHAR+ R>
+   LOOP SWAP DROP ;
+{ GP6 -> <TRUE> }
+
+: GP7
+   BASE @ >R    MAX-BASE BASE !
+   <TRUE>
+   A 0 DO
+      I 0 <# #S #>
+      1 = SWAP C@ I 30 + = AND AND
+   LOOP
+   MAX-BASE A DO
+      I 0 <# #S #>
+      1 = SWAP C@ 41 I A - + = AND AND
+   LOOP
+   R> BASE ! ;
+
+{ GP7 -> <TRUE> }
+
+\ >NUMBER TESTS
+CREATE GN-BUF 0 C,
+: GN-STRING	GN-BUF 1 ;
+: GN-CONSUMED	GN-BUF CHAR+ 0 ;
+: GN'		[CHAR] ' WORD CHAR+ C@ GN-BUF C!  GN-STRING ;
+
+{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }
+{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }
+{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }
+{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }	\ SHOULD FAIL TO CONVERT THESE
+{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }
+{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }
+
+: >NUMBER-BASED
+   BASE @ >R BASE ! >NUMBER R> BASE ! ;
+
+{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }
+{ 0 0 GN' 2'  2 >NUMBER-BASED -> 0 0 GN-STRING }
+{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }
+{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }
+{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }
+{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }
+
+: GN1	\ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO.
+   BASE @ >R BASE !
+   <# #S #>
+   0 0 2SWAP >NUMBER SWAP DROP		\ RETURN LENGTH ONLY
+   R> BASE ! ;
+{ 0 0 2 GN1 -> 0 0 0 }
+{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }
+{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }
+{ 0 0 MAX-BASE GN1 -> 0 0 0 }
+{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }
+{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }
+
+: GN2	\ ( -- 16 10 )
+   BASE @ >R  HEX BASE @  DECIMAL BASE @  R> BASE ! ;
+{ GN2 -> 10 A }
+
+\ ------------------------------------------------------------------------
+TESTING FILL MOVE
+
+CREATE FBUF 00 C, 00 C, 00 C,
+CREATE SBUF 12 C, 34 C, 56 C,
+: SEEBUF FBUF C@  FBUF CHAR+ C@  FBUF CHAR+ CHAR+ C@ ;
+
+{ FBUF 0 20 FILL -> }
+{ SEEBUF -> 00 00 00 }
+
+{ FBUF 1 20 FILL -> }
+{ SEEBUF -> 20 00 00 }
+
+{ FBUF 3 20 FILL -> }
+{ SEEBUF -> 20 20 20 }
+
+{ FBUF FBUF 3 CHARS MOVE -> }		\ BIZARRE SPECIAL CASE
+{ SEEBUF -> 20 20 20 }
+
+{ SBUF FBUF 0 CHARS MOVE -> }
+{ SEEBUF -> 20 20 20 }
+
+{ SBUF FBUF 1 CHARS MOVE -> }
+{ SEEBUF -> 12 20 20 }
+
+{ SBUF FBUF 3 CHARS MOVE -> }
+{ SEEBUF -> 12 34 56 }
+
+{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }
+{ SEEBUF -> 12 12 34 }
+
+{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }
+{ SEEBUF -> 12 34 34 }
+
+\ ------------------------------------------------------------------------
+TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U.
+
+: OUTPUT-TEST
+   ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR
+   41 BL DO I EMIT LOOP CR
+   61 41 DO I EMIT LOOP CR
+   7F 61 DO I EMIT LOOP CR
+   ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR
+   9 1+ 0 DO I . LOOP CR
+   ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR
+   [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR
+   ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR
+   [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR
+   ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR
+   5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR
+   ." YOU SHOULD SEE TWO SEPARATE LINES:" CR
+   S" LINE 1" TYPE CR S" LINE 2" TYPE CR
+   ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR
+   ."   SIGNED: " MIN-INT . MAX-INT . CR
+   ." UNSIGNED: " 0 U. MAX-UINT U. CR
+;
+
+{ OUTPUT-TEST -> }
+
+\ ------------------------------------------------------------------------
+TESTING INPUT: ACCEPT
+
+CREATE ABUF 80 CHARS ALLOT
+
+: ACCEPT-TEST
+   CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
+   ABUF 80 ACCEPT
+   CR ." RECEIVED: " [CHAR] " EMIT
+   ABUF SWAP TYPE [CHAR] " EMIT CR
+;
+
+{ ACCEPT-TEST -> }
+
+\ ------------------------------------------------------------------------
+TESTING DICTIONARY SEARCH RULES
+
+{ : GDX   123 ; : GDX   GDX 234 ; -> }
+
+{ GDX -> 123 234 }
+
+
+\ test suite finished. leaving engine.
+
+bye
diff --git a/qemu/roms/openbios/forth/bootstrap/interpreter.fs b/qemu/roms/openbios/forth/bootstrap/interpreter.fs
new file mode 100644
index 000000000..51870581f
--- /dev/null
+++ b/qemu/roms/openbios/forth/bootstrap/interpreter.fs
@@ -0,0 +1,175 @@
+\ tag: forth interpreter
+\ 
+\ Copyright (C) 2003 Stefan Reinauer
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\ 
+
+
+\ 
+\ 7.3.4.6 Display pause
+\ 
+
+0 value interactive?
+0 value terminate?
+
+: exit?
+  interactive? 0= if
+    false exit
+  then
+  false \ FIXME we should check whether to interrupt output
+        \ and ask the user how to proceed.
+  ;
+
+
+\ 
+\ 7.3.9.1 Defining words
+\ 
+
+: forget 
+  s" This word is obsolescent." type cr
+  ['] ' execute
+  cell - dup 
+  @ dup 
+  last ! latest !
+  here!
+  ;
+ 
+\ 
+\ 7.3.9.2.4 Miscellaneous dictionary
+\ 
+
+\ interpreter. This word checks whether the interpreted word
+\ is a word in dictionary or a number. It honours compile mode 
+\ and immediate/compile-only words.
+
+: interpret 
+  0 >in !
+  begin
+    parse-word dup 0> \ was there a word at all?
+  while
+    $find 
+    if
+      dup flags? 0<> state @ 0= or if
+        execute
+      else
+        ,             \ compile mode && !immediate
+      then
+    else              \ word is not known. maybe it's a number
+      2dup $number
+      if
+        span @ >in !  \ if we encountered an error, don't continue parsing
+        type 3a emit
+	-13 throw
+      else
+        -rot 2drop 1 handle-lit
+      then
+    then
+    depth 200 >=  if -3 throw then 
+    depth 0<      if -4 throw then
+    rdepth 200 >= if -5 throw then 
+    rdepth 0<     if -6 throw then
+  repeat
+  2drop
+  ;
+
+: refill ( -- )
+	ib #ib @ expect 0 >in ! ;
+
+: print-status  ( exception -- )
+  space
+  ?dup if
+    dup sys-debug \ system debug hook
+    case 
+       -1 of s" Aborted." type endof
+       -2 of s" Aborted." type endof
+       -3 of s" Stack Overflow." type 0 depth! endof
+       -4 of s" Stack Underflow." type 0 depth! endof
+       -5 of s" Return Stack Overflow." type endof
+       -6 of s" Return Stack Underflow." type endof
+      -13 of s" undefined word." type endof
+      -15 of s" out of memory." type endof
+      -21 of s" undefined method." type endof
+      -22 of s" no such device." type endof
+      dup s" Exception #" type . 
+      0 state !
+    endcase
+  else
+    state @ 0= if
+      s" ok"
+    else 
+      s" compiled"
+    then
+    type
+  then
+  cr
+  ;
+
+defer status
+['] noop ['] status (to)
+
+: print-prompt
+  status 
+  depth . 3e emit space
+  ;
+  
+defer outer-interpreter
+:noname
+  cr
+  begin
+    print-prompt
+    source 0 fill           \ clean input buffer
+    refill 
+
+    ['] interpret catch print-status
+    terminate?
+  until
+; ['] outer-interpreter (to)
+
+\ 
+\ 7.3.8.5 Other control flow commands
+\ 
+
+: save-source  ( -- )
+  r>               \ fetch our caller
+  ib >r #ib @ >r   \ save current input buffer
+  source-id >r     \ and all variables 
+  span @ >r        \ associated with it.
+  >in @ >r
+  >r               \ move back our caller
+  ;
+
+: restore-source ( -- )
+  r> 
+  r> >in ! 
+  r> span ! 
+  r> ['] source-id (to) 
+  r> #ib ! 
+  r> ['] ib (to) 
+  >r
+  ;
+
+: (evaluate) ( str len -- ??? )
+  save-source
+  -1 ['] source-id (to)
+  dup
+  #ib ! span !
+  ['] ib (to)
+  interpret
+  restore-source
+  ; 
+
+: evaluate ( str len -- ?? )
+  2dup + -rot
+  over + over do 
+    i c@ 0a = if 
+      i over - 
+      (evaluate)
+      i 1+ 
+    then 
+  loop 
+  swap over - (evaluate)
+  ;
+  
+: eval evaluate ;
diff --git a/qemu/roms/openbios/forth/bootstrap/memory.fs b/qemu/roms/openbios/forth/bootstrap/memory.fs
new file mode 100644
index 000000000..6fa4a2cc7
--- /dev/null
+++ b/qemu/roms/openbios/forth/bootstrap/memory.fs
@@ -0,0 +1,216 @@
+\ tag: forth memory allocation
+\ 
+\ Copyright (C) 2002-2003 Stefan Reinauer
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\ 
+
+\ 7.3.3.2 memory allocation
+
+\ these need to be initialized by the forth kernel by now.
+variable start-mem 0 start-mem !	\ start of memory
+variable end-mem   0 end-mem   !	\ end of memory
+variable free-list 0 free-list !	\ free list head
+
+\ initialize necessary variables and write a valid 
+\ free-list entry containing all of the memory.
+\   start-mem: pointer to start of memory.
+\   end-mem:   pointer to end of memory.
+\   free-list: head of linked free list
+
+: init-mem ( start-addr size )
+  over dup
+  start-mem !		\ write start-mem 
+  free-list !		\ write first freelist entry
+  2dup /n - swap !	\ write 'len'  entry
+  over cell+ 0 swap !	\ write 'next' entry
+  + end-mem  !		\ write end-mem 
+  ;
+ 
+\ --------------------------------------------------------------------
+
+\ return pointer to smallest free block that contains 
+\ at least nb bytes and the block previous the the 
+\ actual block. On failure the pointer to the smallest
+\ free block is 0.
+
+: smallest-free-block ( nb -- prev ptr | 0 0 )
+  0 free-list @
+  fffffff 0 0 >r >r >r
+  begin
+    dup
+  while
+    ( nb prev pp R: best_nb best_pp )
+    dup @ 3 pick r@ within if
+      ( nb prev pp )
+      r> r> r> 3drop            \ drop old smallest
+      2dup >r >r dup @ >r       \ new smallest
+    then
+    nip dup                     \ prev = pp
+    cell + @                    \ pp = pp->next
+  repeat
+  3drop r> drop r> r>
+;
+
+
+\ --------------------------------------------------------------------
+
+\ allocate size bytes of memory
+\ return pointer to memory (or throws an exception on failure).
+
+: alloc-mem ( size -- addr )
+
+  \ make it legal (and fast) to allocate 0 bytes
+  dup 0= if exit then
+
+  aligned			\ keep memory aligned.
+  dup smallest-free-block	\ look up smallest free block.
+  
+  dup 0= if 
+    \ 2drop
+    -15 throw \ out of memory
+  then
+  
+  ( al-size prev addr )
+  
+  \ If the smallest fitting block found is bigger than
+  \ the size of the requested block plus 2*cellsize we
+  \ can split the block in 2 parts. otherwise return a
+  \ slightly bigger block than requested.
+
+  dup @ ( d->len ) 3 pick cell+ cell+ > if
+  
+    \ splitting the block in 2 pieces.
+    \ new block = old block + len field + size of requested mem
+    dup 3 pick cell+ +	(  al-size prev addr nd )
+
+    \ new block len = old block len - req. mem size - 1 cell
+    over @		( al-size prev addr nd addr->len )
+    4 pick		( ... al-size )
+    cell+ -		( al-size prev addr nd nd nd->len )
+    over !		( al-size prev addr nd )
+
+    over cell+ @	( al-size prev addr nd addr->next )
+    			\ write addr->next to nd->next
+    over cell+ !	( al-size prev addr nd )
+    over 4 pick swap !
+  else
+    \ don't split the block, it's too small.
+    dup cell+ @
+  then
+
+  ( al-size prev addr nd )
+
+  \ If the free block we got is the first one rewrite free-list
+  \ pointer instead of the previous entry's next field.
+  rot dup 0= if drop free-list else cell+ then
+  ( al-size addr nd prev->next|fl )
+  !
+  nip cell+	\ remove al-size and skip len field of returned pointer
+
+  ;
+
+
+\ --------------------------------------------------------------------
+  
+\ free block given by addr. The length of the
+\ given block is stored at addr - cellsize.
+\ 
+\ merge with blocks to the left and right 
+\ immediately, if they are free.
+
+: free-mem ( addr len -- )
+
+  \ we define that it is legal to free 0-byte areas
+  0= if drop exit then
+  ( addr )
+	
+  \ check if the address to free is somewhere within
+  \ our available memory. This fails badly on discontigmem
+  \ architectures. If we need more RAM than fits on one 
+  \ contiguous memory area we are too bloated anyways. ;)
+  
+  dup start-mem @ end-mem @ within 0= if
+ \   ." free-mem: no such memory: 0x" u. cr
+    exit
+  then
+
+  /n -				\ get real block address
+  0 free-list @			( addr prev l )
+  
+  begin				\ now scan the free list
+    dup 0<> if			\ only check len, if block ptr != 0
+      dup dup @ cell+ + 3 pick < 
+    else
+      false
+    then
+  while 
+    nip dup			\ prev=l
+    cell+ @			\ l=l->next
+  repeat
+
+  ( addr prev l )
+
+  dup 0<> if				\ do we have free memory to merge with?
+  
+    dup dup @ cell+ + 3 pick  = if	\ hole hit. adding bytes.
+      \ freeaddr = end of current block -> merge
+      ( addr prev l )
+      rot @ cell+		( prev l f->len+cellsize )
+      over @ +			\ add l->len
+      over !			( prev l )
+      swap over cell+ @		\ f = l; l = l->next;
+
+      \ The free list is sorted by addresses. When merging at the
+      \ start of our block we might also want to merge at the end
+      \ of it. Therefore we fall through to the next border check
+      \ instead of returning.
+      true				\ fallthrough value
+    else
+      false				\ no fallthrough
+    then
+    >r					\ store fallthrough on ret stack
+    
+    ( addr prev l )
+
+    dup 3 pick dup @ cell+ + = if	\ hole hit. real merging.
+      \ current block starts where block to free ends.
+      \ end of free block addr = current block -> merge and exit
+      					( addr prev l )
+      2 pick dup @			( f f->len ) 
+      2 pick @ cell+ +			( f newlen )
+      swap !				( addr prev l )
+      3dup drop
+      0= if
+	free-list
+      else
+	2 pick cell+ 
+      then				( value prev->next|free-list )
+      !					( addr prev l )
+      cell+ @ rot			( prev l->next addr )
+      cell+ ! drop
+      r> drop exit			\ clean up return stack
+    then
+
+    r> if 3drop exit then		\ fallthrough? -> exit
+  then
+  
+  \ loose block - hang it before current.
+
+  ( addr prev l )
+
+  \ hang block to free in front of the current entry.
+  dup 3 pick cell+ !			\ f->next = l;
+  free-list @ = if			\ is block to free new list head?
+    over free-list !
+  then
+  
+  ( addr prev )
+  dup 0<> if				\ if (prev) prev->next=f
+    cell+ !
+  else 
+    2drop				\ no fixup needed. clean up.
+  then
+    
+  ;
diff --git a/qemu/roms/openbios/forth/bootstrap/start.fs b/qemu/roms/openbios/forth/bootstrap/start.fs
new file mode 100644
index 000000000..9aabfa2c4
--- /dev/null
+++ b/qemu/roms/openbios/forth/bootstrap/start.fs
@@ -0,0 +1,69 @@
+\ tag: forth bootstrap starter.
+\ 
+\ Copyright (C) 2003 Patrick Mauritz, Stefan Reinauer
+\ 
+\ See the file "COPYING" for further information about
+\ the copyright and warranty status of this work.
+\ 
+
+include bootstrap.fs        \ all base words
+include interpreter.fs      \ interpreter
+include builtin.fs          \ builtin terminal.
+
+: include ( >filename<eol> -- )
+  linefeed parse $include
+;
+
+: encode-file ( >filename< > -- dictptr size )
+  parse-word $encode-file
+;
+
+: bye 
+  s" Farewell!" cr type cr cr 
+  0 rdepth! 
+  ;
+
+\ quit starts the outer interpreter of the forth system.
+\ zech describes quit as being the outer interpreter, but
+\ we split it apart to keep the interpreter elsewhere.
+
+: quit                      ( -- )
+  2 rdepth!
+  outer-interpreter
+;
+
+\ initialize is the first forth word run by the kernel.
+\ this word is automatically executed by the C core on start 
+\ and it's never left unless something goes really wrong or
+\ the user decides to leave the engine.
+
+variable init-chain
+
+\ :noname <definition> ; initializer
+: initializer ( xt -- )
+  here swap , 0 ,            \ xt, next
+  init-chain
+  begin dup @ while @ na1+ repeat
+  !
+;
+
+: initialize-forth          ( startmem endmem -- )
+  over - init-mem
+  init-pockets
+  init-tmp-comp
+  init-builtin-terminal
+
+  init-chain @              \ execute initializers
+  begin dup while
+    dup @ execute
+    na1+ @
+  repeat
+  drop
+;
+
+\ compiler entrypoint
+: initialize                ( startmem endmem -- )
+  initialize-forth
+  s" OpenBIOS kernel started." type cr
+  quit
+;