-# Things Todo
+# Things to do
+
+- wordlists, search order
+
+- number output with given base <# # #s hold #> u. u.r . .r um/mod /mod / mod
+
+- Assembler (proof of concept) i386 stm8 ...
+
+- | based on allocated headers
+
+- packages à la swiftForth
+
+- dual xt headers
+
+- high level multi tasker definitions
+
+- more Standard words (at least CORE words w/ exceptions such as BASE STATE)
+
+- umbilical Block-Interface
+
+- file interface open-file read read-line write close-file
+
+- interleaved tokenizer and token-interpreting seedForth (another flavor of interactivity)
+
+- extension tokens 01 - 0F
+
+- relative branches
+
+- DO LOOP FOR NEXT
+
+- more arithmetic log2 ...
+
+- experiments with redefinition and recursion
+
+ | name found during definition | redefinition replaces definition with same name | comment
+ |------------------------------|---------------------------------------------------|--------------
+ | yes | yes | no defer, lisp style
+ | no | yes |
+ | yes | no | natural recursion
+ | no ] no | classic
+
+- interpretive conditionals
+
+- intermediate definitions (forgettable)
+
+- dictionary experiments
+ hash names to cell look for value find xt in other table (à la colorForth)
+
+- OOF
- Standard non-extensible modern text interpreter/compiler (w/ or without STATE)
+
- FIG Forth style non-exensible text interpreter/compiler
+
- Recognizers based text interpreter/compiler (based on new terms)
+
')' parse 2drop ; immediate
: \
- source nip >in ! ;
-
-
-cr .( hi - doing some test )
-t{ 3 4 + -> 7 }t
-t{ 3 -> }t
-t{ 3 4 + -> 8 }t
-
-
-
-: on ( addr -- ) -1 swap ! ;
-: off ( addr -- ) 0 swap ! ;
+ source nip >in ! ; immediate
+\ cr .( hi - doing some test )
+\ t{ 3 4 + -> 7 }t \ pass
+\ t{ 3 -> }t \ wrong number of results
+\ t{ 3 4 + -> 8 }t \ incorrect result
: AHEAD ( -- c:orig )
postpone branch here 0 , ; immediate
: Constant ( x <name> -- )
Create , Does> @ ;
+0 Constant false
+false invert Constant true
+
+
+: on ( addr -- ) true swap ! ;
+: off ( addr -- ) false swap ! ;
+
+
+: fill ( c-addr u x -- )
+ >r BEGIN ( c-addr u )
+ dup
+ WHILE ( c-addr u )
+ r@ third c!
+ 1 /string
+ REPEAT ( c-addr u )
+ 2drop r> drop
+;
+
+: 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{ 0 0> -> 0 }t
+t{ -10 0> -> 0 }t
+
+: 2>r ( x1 x2 -- r:x1 r:x2 )
+ swap r> swap >r swap >r >r ;
+
+: 2r> ( r:x1 r:x2 -- x1 x2 )
+ r> r> swap r> swap >r swap ;
+
+: 2r@ ( r:x1 r:x2 -- r:x1 r:x2 x1 x2 )
+ r> r> r> 2dup >r >r swap rot >r ;
+
+: 2>r-test ( x1 x2 -- x1 x2 ) 2>r r> r> swap ;
+t{ 3 4 2>r-test -> 3 4 }t
+
+: 2r>-test ( x1 x2 -- x1 x2 ) swap >r >r 2r> ;
+t{ 3 4 2r>-test -> 3 4 }t
+
+: 2r@-test ( x1 x2 -- x1 x2 ) 2>r 2r@ 2r> 2drop ;
+t{ 3 4 2r@-test -> 3 4 }t
+
+
+: n>r ( x1 ... xn -- r: xn ... x1 n )
+ dup \ --
+ BEGIN ( xn ... x1 n n' )
+ ?dup
+ WHILE ( xn ... x1 n n' )
+ rot r> swap >r >r ( xn ... n n' ) ( R: ... x1 )
+ 1- ( xn ... n n' ) ( R: ... x1 )
+ REPEAT ( n )
+ r> swap >r >r ;
+
+: nr> ( R: x1 .. xn n -- xn .. x1 n )
+\ Pull N items and count off the return stack.
+ r> r> swap >r dup
+ BEGIN
+ ?dup
+ WHILE
+ r> r> swap >r -rot
+ 1-
+ REPEAT ;
+
+: n>r-test ( x1 x2 -- n x1 x2 ) 2 n>r r> r> r> ;
+t{ 3 4 n>r-test -> 2 3 4 }t
+
+: nr>-test ( x1 x2 -- x1 x2 n ) >r >r 2 >r nr> ;
+t{ 3 4 nr>-test -> 3 4 2 }t
+
+: lshift ( x u -- ) BEGIN ?dup WHILE swap 2* swap 1- REPEAT ;
+
+\ if we don't have u2/ but only 2* and 0< we need to implement u2/ with a loop. Candidate for primitive
+: u2/ ( x1 -- x2 )
+ 0 8 cells 1- \ for every bit
+ BEGIN ( x q n )
+ ?dup
+ WHILE ( x q n )
+ >r 2* over 0< IF 1+ THEN >r 2* r> r> 1-
+ REPEAT ( x q n )
+ nip ;
+
+t{ -1 u2/ dup 1+ u< -> -1 }t
+t{ -1 u2/ 10 + dup 10 + u< -> -1 }t
+
+
+: rshift ( x u -- ) BEGIN ?dup WHILE swap u2/ swap 1- REPEAT ;
+
+: s>d ( n -- d ) dup 0< ;
+
+t{ 1 3 lshift -> 8 }t
+\ t{ 48 3 rshift -> 6 }t
+
+: <> ( x1 x2 -- f ) = 0= ;
+t{ 3 3 <> -> 0 }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
+
+: recursive ( -- ) reveal ; immediate
+
+: roll ( xn-1 ... x0 i -- xn-1 ... xi-1 xi+1 ... x0 xi )
+ recursive ?dup IF swap >r 1- roll r> swap THEN ;
+
+t{ 10 20 30 1 roll -> 10 30 20 }t
+
+Variable (to) (to) off
+
+: Value ( x -- )
+ Create ,
+ Does>
+ (to) @ IF ! (to) off ELSE @ THEN ;
+
+: to ( x <name> -- ) (to) on ;
+
+5 Value val
+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< ;
+
+t{ 2 3 5 within -> false }t
+t{ 3 3 5 within -> true }t
+t{ 4 3 5 within -> true }t
+t{ 5 3 5 within -> false }t
+t{ 6 3 5 within -> false }t
+
Variable up
: User ( x -- )
Create cells , Does> @ up @ + ;
-
0 User u1
1 User u2
2 User u3
cr cr words cr
cr .( ready )
+\ : test s" xlerb" evaluate ;
+
+: * ( n1 n2 -- )
+ 2dup xor 0< >r abs swap abs um* drop r> IF negate THEN ;
+
+: fac ( n -- ) recursive
+ dup 0= IF drop 1 exit THEN
+ dup 1- fac * ;
+
+t{ 6 fac -> 720 }t
+
+: fib ( n1 -- n2 ) recursive
+ dup 0= IF exit THEN
+ dup 1 = IF exit THEN
+ dup 1- fib swap 2 - fib + ;
+
+t{ 10 fib -> 55 }t
+
+
+\ remove headers from dictionary
+: unlink-header ( addr name -- ) 2dup ." unlink " . .
+ dup >r ( _link ) @ swap ! r> free throw ;
+
+: remove-headers ( -- )
+ context dup @
+ BEGIN ( addr name )
+ dup
+ WHILE ( addr name )
+ dup headerless? IF over >r unlink-header r> dup ELSE nip dup THEN
+ @
+ REPEAT
+ 2drop ;
+
+| : hidden ." still there - " ;
+
+: visible hidden hidden ;
+
+remove-headers
+
echo on
Definer Variable ( <name> -- ) create ( x ) drop 0 , ;
Definer Constant ( x <name> -- ) create ( x ) >r , r> does> @ ;
+Macro Literal
+ seed lit
+ seed [
+ seed ,
+ seed ]
+end-macro
+
\ Missing primitives
: over ( x1 x2 -- x1 x2 x1 )
>r dup r> swap ;
: rot ( a b c -- b c a )
>r swap r> swap ;
+: -rot ( a b c -- c a b )
+ swap >r swap r> ;
+
: /string ( x1 x2 x3 -- x4 x5 )
swap over - >r + r> ;
: 2dup ( x1 x2 -- x1 x2 x1 x2 )
over over ;
+: 2swap ( x1 x2 x3 x4 -- x3 x4 x1 x2 )
+ >r -rot r> -rot ;
+
+: 2over ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 )
+ >r >r 2dup r> r> 2swap ;
+
: 1+ ( x1 -- x2 )
1 + ;
: 1- ( x1 -- x2 )
1 - ;
+: invert ( x1 x2 -- x3 )
+ negate 1- ;
+
: nip ( x1 x2 -- x2 )
swap drop ;
: count ( addr -- c-addr u )
dup 1+ swap c@ ;
-: < ( n1 n2 -- f )
- - 0< ;
+: xor ( x1 x2 -- x3 )
+ 2dup or >r invert swap invert or r> and ;
+
+: u< ( u1 u2 -- f )
+ 2dup xor 0< IF nip 0< exit THEN - 0< ;
+
+: < ( n1 n2 -- f )
+ 2dup xor 0< IF drop 0< exit THEN - 0< ;
: > ( n1 n2 -- f )
swap < ;
\ output
32 Constant bl
-: cr ( -- )
+: cr ( -- )
10 emit ;
: type ( c-addr u -- )
: r@ ( -- x )
r> r> dup >r swap >r ;
+: abs ( n -- +n )
+ dup 0< IF negate THEN ;
+
: cmove ( c-addr1 c-addr2 u -- )
BEGIN
?dup
: place ( c-addr1 u c-addr2 -- )
2dup >r >r 1+ swap cmove r> r> c! ;
-Macro Literal
- seed lit
- seed [
- seed ,
- seed ]
-end-macro
-
-
-
\ Tester
: empty-stack ( i*x -- )
BEGIN depth 0< WHILE 0 REPEAT
t{ 0 0< -> 0 }t
t{ 1 0< -> 0 }t
t{ 2 0< -> 0 }t
+
t{ 1 negate 0< -> -1 }t
t{ 2 negate 0< -> -1 }t
+t{ 0 negate -> 0 }t
+t{ -1 negate 0< -> 0 }t
+t{ -2 negate 0< -> 0 }t
+
+
t{ 10 20 30 third -> 10 20 30 10 }t
+t{ 1 2 3 rot -> 2 3 1 }t
+t{ 1 2 3 -rot -> 3 1 2 }t
+
t{ 3 4 max -> 4 }t
t{ 3 4 min -> 3 }t
t{ -1 4 max -> 4 }t
t{ -1 4 min -> -1 }t
+t{ 1 2 2drop -> }t
+t{ 1 2 2dup -> 1 2 1 2 }t
+
+t{ 1 2 3 4 2swap -> 3 4 1 2 }t
+t{ 1 2 3 4 2over -> 1 2 3 4 1 2 }t
+
+t{ 10 abs -> 10 }t
+t{ -10 abs -> 10 }t
+
+t{ 15 10 xor -> 5 }t
+t{ 21845 dup xor -> 0 }t \ $5555
+t{ 21845 dup 2* xor -> 65535 }t
+
+t{ -2147483648 2147483647 < -> -1 }t \ 32bit $80000000 $7FFFFFFF
+t{ -2147483648 0 < -> -1 }t \ 32bit $80000000 0
+t{ 0 -2147483648 < -> 0 }t \ 32bit 0 $80000000
+
+\ both positive
+t{ 10 10 < -> 0 }t
+t{ 10 1000 < -> -1 }t
+t{ 1000 10 < -> 0 }t
+
+\ both negative
+t{ -10 -10 < -> 0 }t
+t{ -10 -1000 < -> 0 }t
+t{ -1000 -10 < -> -1 }t
+
+\ left negative
+t{ -10 10 < -> -1 }t
+t{ -10 1000 < -> -1 }t
+t{ -1000 10 < -> -1 }t
+
+\ right negative
+t{ 10 -10 < -> 0 }t
+t{ 10 -1000 < -> 0 }t
+t{ 1000 -10 < -> 0 }t
+: minint ( -- n )
+ 1 BEGIN dup 2* dup WHILE nip REPEAT drop ;
+minint 1- Constant maxint
+
+t{ minint negate -> minint }t
+t{ minint maxint < -> -1 }t
+t{ maxint minint < -> 0 }t
+
+
+t{ 0 1 u< -> -1 }t
+t{ 1 0 u< -> 0 }t
+t{ -1 0 u< -> 0 }t
+t{ 0 -1 u< -> -1 }t
: skip ( c-addr1 u1 c -- c-addr2 u2 )
BEGIN
>r 1 /string r>
REPEAT THEN drop ;
-\ hex number output
-
-: .hexdigit ( n -- )
- dup 9 > IF lit [ 'A' 10 - , ] ELSE '0' THEN + emit ;
-
-\ if we don't have u2/ but only 2* and 0< we need to implement u2/ with a loop. Candidate for primitive
-: u2/ ( x1 -- x2 )
- 0 8 cells 1- BEGIN ?dup WHILE >r 2* over 0< IF 1+ THEN >r 2* r> r> 1- REPEAT nip ;
-
-: odd? ( x1 -- f )
- dup u2/ 2* = 0= ;
-
-: 2/mod ( x1 -- x2 r ) \ swapped results
- dup u2/ swap odd? negate ;
-
-: 16/mod ( x -- x r ) \ swapped results
- 2/mod >r 2/mod >r 2/mod >r 2/mod 2* r> + 2* r> + 2* r> + ;
-
-: #### ( x -- )
- 16/mod >r 16/mod >r 16/mod >r 16/mod >r 16/mod >r 16/mod >r 16/mod >r
- .hexdigit r> .hexdigit r> .hexdigit r> .hexdigit r> .hexdigit
- r> .hexdigit r> .hexdigit r> .hexdigit space ;
-
-: (.) ( x -- )
- ?dup IF 16/mod >r (.) r> .hexdigit THEN ;
-
-: hex-u. ( x -- )
- ?dup IF (.) ELSE '0' emit THEN space ;
-
-: hex. ( n -- )
- dup 0< IF '-' emit negate THEN hex-u. ;
-
-
\ decimal output
\ --------------
-: (/mod ( n d q0 -- r d q )
- >r 2dup < r> swap ?exit
- >r swap over - swap r> 1+ (/mod ;
-
+\ : (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 + + ;
-: (10u/mod ( n q d -- r q d )
- third over > 0= ?exit \ ( n q d )
- dup >r 10* \ ( n q 10*d ) ( R: d )
- (10u/mod \ ( r q d )
- swap >r 0 (/mod nip r> 10* + r> ;
+\ : 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 ( n -- r q )
- 0 1 (10u/mod drop ;
+\ : 10u/mod ( u -- r q )
+\ 0 1 (10u/mod drop ;
: (u. ( u1 -- )
- ?dup IF 10u/mod (u. .digit THEN ;
+ ?dup IF 0 10 um/mod (u. .digit THEN ;
\ display unsigned number
: u. ( u -- )
\ dynamic memory
\ -------------------------------------
: 256* ( x1 -- x2 ) 2* 2* 2* 2* 2* 2* 2* 2* ;
-: u< < ;
Variable anchor
\ : dispose ( addr -- )
\ drop ;
+\ for the input stream a struct could be defined that generally handles terminal input, evaluate, file input and others.
+
Create tib 80 allot
-Variable #tib
+
+Create 'source here 0 , tib , \ ' source is normally ^tib #tib is set to c-addr u for evaluate
+Constant #tib
: accept ( c-addr u1 -- u2 )
>r
: immediate ( -- )
@flags #immediate or !flags ;
+
+64 Constant #headerless
+
+: headerless? ( addr -- f )
+ _flags @ #headerless and 0<> ;
+
+: headerless ( -- )
+ @flags #headerless or !flags ;
+
+
+
: pad ( -- addr )
here 100 + ;
Variable context
: words ( -- )
- context @ BEGIN ?dup WHILE dup _name count type space @ REPEAT ;
+ context @ BEGIN ?dup WHILE dup dup headerless? IF '|' emit THEN _name count type space @ REPEAT ;
: hide ( -- )
last @ @ context ! ;
' $lit has-header $lit \ 50 32
' num has-header num \ 51 33
-' over has-header over
+' over has-header over
+' rot has-header rot
+' -rot has-header -rot
' /string has-header /string
-' type has-header type
-' 2dup has-header 2dup
+' type has-header type
+' 2drop has-header 2drop
+' 2dup has-header 2dup
+' 2swap has-header 2swap
+' 2over has-header 2over
+' xor has-header xor
+' minint has-header minint
+' maxint has-header maxint
+
' cr has-header cr
' .s has-header .s
' t{ has-header t{
' -> has-header ->
' }t has-header }t
+' bl has-header bl
' space has-header space
' spaces has-header spaces
' 1+ has-header 1+
-' 1- has-header 1-
-' nip has-header nip
+' 1- has-header 1-
+' invert has-header invert
+' nip has-header nip
+' u< has-header u<
' < has-header <
' > has-header >
' = has-header =
' count has-header count
-' 2* has-header 2*
+' 2* has-header 2*
+' um* has-header um*
+' um/mod has-header um/mod
+' abs has-header abs
+' r@ has-header r@
+' third has-header third
' cmove has-header cmove
' cell+ has-header cell+
' place has-header place
' skip has-header skip
' scan has-header scan
-' . has-header .
-' words has-header words
+' . has-header .
+' u. has-header u.
+' words has-header words
+' context has-header context
' immediate has-header immediate
+' reveal has-header reveal
+' hide has-header hide
' pad has-header pad
' allocate has-header allocate
' free has-header free
' ?memory has-header ?memory
+' headerless has-header headerless
+' headerless? has-header headerless?
\ ' "header has-header "header
' >in has-header >in
-: source ( -- c-addr u )
- tib #tib @ ;
+: source ( -- c-addr u ) 'source 2@ ;
' source has-header source
' parse has-header parse
' parse-name has-header parse-name
+Variable heads -1 heads !
+
+: | ( -- ) 1 heads ! ;
+
+: head? ( -- f )
+ heads @ dup IF -1 heads ! -1 = exit THEN ;
+
+
: (Create) ( <name> -- )
- parse-name "header dup link-header create swap _xt ! reveal ;
+ parse-name "header dup link-header create swap _xt ! reveal
+ head? ?exit headerless
+;
' (Create) has-header Create
interpreters @ handlers ! ;
: Header ( <name> -- addr )
- parse-name "header dup link-header reveal ;
+ parse-name "header dup link-header reveal
+ head? ?exit headerless ;
: (:) ( <name> -- )
- Header new swap _xt ! hide (]) ;
+ Header new swap _xt ! hide (]) ;
: (;) ( -- )
lit [ ' exit , ] compile, reveal ([) ;
' (]) has-header ]
' ([) has-header [ immediate
' (;) has-header ; immediate
-' (:) has-header :
+' (:) has-header :
+' | has-header |
+' heads has-header heads
: interpret ( -- )
REPEAT
2drop ;
+: evaluate ( c-addr u -- )
+ 'source 2@ >r >r 'source 2!
+ >in @ >r 0 >in !
+ \ ['] interpret catch
+ [ ' interpret ] Literal catch
+ r> >in !
+ r> r> 'source 2!
+ throw
+;
+
+' evaluate has-header evaluate
+
Variable echo -1 echo !
' echo has-header echo
: .ok ( -- ) echo @ IF ." ok" THEN ;
: restart ( -- )
+ tib 0 'source 2!
([)
BEGIN
prompt query 0 >in ! interpret .ok
' boot has-header boot
+cr
+t{ -> }t
+
0 echo !
reveal
boot
public / preForth.git / commitdiff