diff options
Diffstat (limited to 'qemu/roms/openbios/forth/bootstrap/bootstrap.fs')
| -rw-r--r-- | qemu/roms/openbios/forth/bootstrap/bootstrap.fs | 1590 |
1 files changed, 1590 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 |