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, 0 insertions, 1590 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 |