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, 0 insertions, 3158 deletions
diff --git a/qemu/roms/openbios/forth/bootstrap/bootstrap.fs b/qemu/roms/openbios/forth/bootstrap/bootstrap.fs deleted file mode 100644 index 0668cf7d8..000000000 --- a/qemu/roms/openbios/forth/bootstrap/bootstrap.fs +++ /dev/null @@ -1,1590 +0,0 @@ -\ 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 deleted file mode 100644 index d950a46df..000000000 --- a/qemu/roms/openbios/forth/bootstrap/build.xml +++ /dev/null @@ -1,16 +0,0 @@ -<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 deleted file mode 100644 index 03f5fde1f..000000000 --- a/qemu/roms/openbios/forth/bootstrap/builtin.fs +++ /dev/null @@ -1,28 +0,0 @@ -\ 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 deleted file mode 100644 index e5a46f406..000000000 --- a/qemu/roms/openbios/forth/bootstrap/hayes.fs +++ /dev/null @@ -1,1064 +0,0 @@ -\ 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 deleted file mode 100644 index 51870581f..000000000 --- a/qemu/roms/openbios/forth/bootstrap/interpreter.fs +++ /dev/null @@ -1,175 +0,0 @@ -\ 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 deleted file mode 100644 index 6fa4a2cc7..000000000 --- a/qemu/roms/openbios/forth/bootstrap/memory.fs +++ /dev/null @@ -1,216 +0,0 @@ -\ 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 deleted file mode 100644 index 9aabfa2c4..000000000 --- a/qemu/roms/openbios/forth/bootstrap/start.fs +++ /dev/null @@ -1,69 +0,0 @@ -\ 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 -; |