summaryrefslogtreecommitdiffstats
path: root/qemu/roms/openbios/forth/bootstrap
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/bootstrap
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/bootstrap')
-rw-r--r--qemu/roms/openbios/forth/bootstrap/bootstrap.fs1590
-rw-r--r--qemu/roms/openbios/forth/bootstrap/build.xml16
-rw-r--r--qemu/roms/openbios/forth/bootstrap/builtin.fs28
-rw-r--r--qemu/roms/openbios/forth/bootstrap/hayes.fs1064
-rw-r--r--qemu/roms/openbios/forth/bootstrap/interpreter.fs175
-rw-r--r--qemu/roms/openbios/forth/bootstrap/memory.fs216
-rw-r--r--qemu/roms/openbios/forth/bootstrap/start.fs69
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
+;