--- /dev/null
+\ 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
Code Review / kvmfornfv.git / blobdiff