| \ 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 - ; |
| : 4+ 4 + ; |
| : 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 |