cr .( ⓪ )
-: 2drop drop drop ;
: (
')' parse 2drop ; immediate
: OF ( n1 n2 -- n1 | )
postpone case? postpone IF ; immediate
-: s" ( ccc" -- c-addr u ) \ compile only
- postpone $lit
- '"' parse
- dup 0= -39 and throw
- here over 1+ allot place ; immediate
-
cr .( ① )
cr
: erase ( c-addr u -- ) 0 fill ;
: blank ( c-addr u -- ) bl fill ;
-\ : xor ( x1 x2 -- x3 )
-\ 2dup or >r invert swap invert or r> and ;
-\
-\ t{ 15 10 xor -> 5 }t
-\ t{ 21845 dup xor -> 0 }t \ $5555
-\ t{ 21845 dup 2* xor -> 65535 }t
-
: 0> ( n -- f ) 0 > ;
t{ 10 0> -> -1 }t
t{ 'x' 'u' <> -> -1 }t
-
: pick ( xn ... xi ... x0 i -- xn ... xi ... x0 xi )
1+ cells sp@ + @ ;
t{ 10 20 30 1 pick -> 10 20 30 20 }t
t{ val 42 to val val -> 5 42 }t
-\ : u< ( u1 u2 -- f )
-\ over 0< IF dup 0< IF < exit THEN \ both large
-\ 2drop false exit THEN \ u1 is larger
-\ dup 0< IF 2drop true exit THEN \ u2 is larger
-\ < \ both small
-\ ;
-
-
: within ( test low high -- flag )
over - >r - r> u< ;
REPEAT
2drop ;
+: clear ( -- ) remove-headers ;
+
| : hidden-word ." still there - " ;
: visible-word ( -- ) hidden-word hidden-word ;
' do-counter t1 activate
-\ : multi-key ( -- c )
-\ BEGIN pause key? UNTIL key ;
-
100 cells 100 cells task Constant counter-display
: ctr ( -- x ) counter @ 13 rshift ;
AGAIN ;
' .counter counter-display activate
-: multikey ( -- c) BEGIN key? 0= WHILE pause REPEAT key ;
+: multikey ( -- c) BEGIN pause key? UNTIL key ;
: multi ( -- ) [ ' multikey ] Literal [ ' getkey >body ] Literal ! ;
: single ( -- ) [ ' key ] Literal [ ' getkey >body ] Literal ! ;
: -rot ( a b c -- c a b )
swap >r swap r> ;
+: under+ ( x1 x2 x3 -- x1+x3 x2 )
+ rot + swap ;
+
+: tuck ( x1 x2 -- x2 x1 x2 )
+ swap over ;
+
: /string ( x1 x2 x3 -- x4 x5 )
swap over - >r + r> ;
: place ( c-addr1 u c-addr2 -- )
2dup >r >r 1+ swap cmove r> r> c! ;
-
\ Exception handling
Variable frame ( -- addr )
?dup 0= ?exit frame @ rp! r> swap >r sp! drop
r> r> frame ! ;
+\ tests: see later when ' is defined
\ Tester
: empty-stack ( i*x -- )
>r 1 /string r>
REPEAT THEN drop ;
-\ decimal output
-\ --------------
-
-\ : (u/mod ( u d q0 -- r d q )
-\ >r
-\ BEGIN ( u d r:q0 )
-\ 2dup u< 0=
-\ WHILE ( u d )
-\ swap over - swap ( u' d r:q0 )
-\ r> 1+ >r
-\ REPEAT ( u' d r:q0 )
-\ r> ;
-\
-: 10* ( x1 -- x2 )
- dup + dup dup + dup + + ;
-
-\ : 10* ( x1 -- x2 ) 10 um* drop ;
-
-\ : (10u/mod ( u q d -- r q d )
-\ third over swap u< 0= ?exit \ ( u q d )
-\ dup >r 10* \ ( u q 10*d ) ( R: d )
-\ (10u/mod \ ( r q d )
-\ swap >r 0 (u/mod nip r> 10* + r> ;
-
-\ : 10u/mod ( u -- r q )
-\ 0 1 (10u/mod drop ;
-
: (u. ( u1 -- )
?dup IF 0 10 um/mod (u. .digit THEN ;
: is ( xt -- ) \ only interactive
' >body ! ;
+\ catch and throw tests
+
+t{ 10 ' dup catch -> 10 10 0 }t
+
+: err99 ( x -- ) dup 9 = IF 99 throw THEN 1 + ;
+
+t{ 1 ' err99 catch -> 2 0 }t
+t{ 5 9 ' err99 catch nip -> 5 99 }t
+
+
\ String comparison
: compare ( c-addr1 u1 c-addr2 u2 -- n )
rot
\ dynamic memory
\ -------------------------------------
-: 256* ( x1 -- x2 ) 2* 2* 2* 2* 2* 2* 2* 2* ;
-
Variable anchor
50 Constant waste
-128 256* 256* 256* ( 32bit ) Constant #free \ sign bit
-#free 1 - ( 31bit ) Constant #max
-
+minint Constant #free \ sign bit
+maxint Constant #max
: size ( mem -- size ) 1 cells - @ #max and ;
: unlink ( mem -- ) setanchor @links 2dup ! swap cell+ ! ;
-
: allocate ( size -- mem ior )
3 cells max dup >r fits? ?dup 0= IF r> -8 exit THEN ( "dictionary overflow" )
addr&size r@ - dup waste u<
Defer getkey ' key is getkey
-\ : getkey key ;
-
Variable input-echo -1 input-echo !
: accept ( c-addr u1 -- u2 )
: wordlist ( -- wid ) here 0 , ;
-\ : under+ ( x1 x2 x3 -- x1+x3 x2 ) rot + swap ;
-\ : tuck ( x1 x2 -- x2 x1 x2 ) swap over ;
-
Create search-order 0 , 10 cells allot
: get-order ( -- wid0 wid1 wid2 ... widn n )
' getkey has-header getkey
' frame has-header frame
-\ ' "header has-header "header
-\ ' link has-header link
-\ ' _xt has-header _xt
+' "header has-header "header
+' link-header has-header link-header
+' _xt has-header _xt
Macro :noname
seed new
seed compiler
end-macro
-\ :noname 10 ;
-
-
: compile ( -- )
r> dup cell+ >r @ , ;
-\ Macro compile
-\ seed [
-\ seed '
-\
-\ seed ]
-\ seed compile,
-\ end-macro
-
-\ lit [ ' ?branch , ] compile,
-
-
-\ : (IF) ( -- c:orig )
-\ [ ' ?branch ] Literal compile, here 0 , ;
-\
-\ : (AHEAD) ( -- c:orig )
-\ [ ' branch ] Literal compile, here 0 , ;
-\
-\ : (THEN) ( c:orig -- )
-\ here swap ! ;
-\
-\ : (ELSE) ( c:orig1 -- c:orig2 )
-\ [ ' branch ] Literal compile, here 0 , swap (THEN) ;
-\
-\ : (WHILE) ( c: orig -- c:dest c:orig )
-\ (IF) swap ;
-\
-\ : (AGAIN) ( c:orig -- )
-\ [ ' branch ] Literal compile, , ;
-\
-\ : (UNTIL)
-\ [ ' ?branch ] Literal compile, , ;
-
-\ : (REPEAT) ( c:orig c:dest -- )
-\ (AGAIN) (THEN) ;
-
-\ ' (IF) has-header IF immediate
-\ ' (ELSE) has-header ELSE immediate
-\ ' (THEN) has-header THEN immediate
-\ ' (AHEAD) has-header AHEAD immediate
-
-\ ' here has-header BEGIN immediate
-\ ' (WHILE) has-header WHILE immediate
-\ ' (AGAIN) has-header AGAIN immediate
-\ ' (UNTIL) has-header UNTIL immediate
-\ ' (REPEAT) has-header REPEAT immediate
-
Variable >in ( -- addr )
[ ' $lit ] Literal compile,
'"' parse here over 1+ allot place ;
-\ ' (s") has-header s" immediate
+' (s") has-header s" immediate
: (.") ( ccc" -- )
(s")
REPEAT
nip nip ;
-\ ' find-name-in has-header find-name-in
+' find-name-in has-header find-name-in
: find-name ( c-addr u -- header|0 )
search-order dup cell+ swap @
dup
WHILE
over c@ dup digit? 0= IF drop r> drop r> drop 2drop exit THEN
- '0' - r> 10* + >r
+ '0' - r> 10 um* drop + >r
1 /string
REPEAT
2drop 2drop r> r> IF negate THEN 0 0 ;
colored-header count "header dup link-header
\ --------
-' token has-header token
+\ ' token has-header token
cr
t{ -> }t