diff options
Diffstat (limited to 'qemu/roms/openbios/forth/bootstrap')
| -rw-r--r-- | qemu/roms/openbios/forth/bootstrap/bootstrap.fs | 1590 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/bootstrap/build.xml | 16 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/bootstrap/builtin.fs | 28 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/bootstrap/hayes.fs | 1064 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/bootstrap/interpreter.fs | 175 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/bootstrap/memory.fs | 216 | ||||
| -rw-r--r-- | qemu/roms/openbios/forth/bootstrap/start.fs | 69 |
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 +; |