0 echo !
+
+cr .( ⓪ )
+
: 2drop drop drop ;
: (
')' parse 2drop ; immediate
: REPEAT ( c:orig c:dest -- )
postpone AGAIN postpone THEN ; immediate
-: s"
- postpone $lit '"' parse here over 1+ allot place ; immediate
+: s" ( ccc" -- c-addr u ) \ compile only
+ postpone $lit
+ '"' parse
+ dup 0= -39 and throw
+ here over 1+ allot place ; immediate
+
+cr .( ① )
+cr
: :noname ( -- xt )
new ] ;
: nr>-test ( x1 x2 -- x1 x2 n ) >r >r 2 >r nr> ;
t{ 3 4 nr>-test -> 3 4 2 }t
+: 2rot ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 )
+ 2>r 2swap 2r> 2swap ;
+
+t{ 1 2 3 4 5 6 2rot -> 3 4 5 6 1 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
cr cr words cr
cr .( ready )
+cr .( ② )
\ : test s" xlerb" evaluate ;
t{ 10 fib -> 55 }t
+: sqr ( u -- u^2 ) dup * ;
+
+: u/ ( u1 u2 -- u3 ) >r 0 r> um/mod nip ;
+
+: sqrt ( u^2 -- u )
+ dup 0= ?exit
+ dup >r dup
+ BEGIN ( xi-1 xi )
+ nip dup
+ \ x = (x + n//x) // 2
+ r@ over u/ + u2/ ( xi xi+1 )
+ 2dup over 1+ over = >r = r> or
+ UNTIL ( xi xi+1 )
+ drop r> drop ;
+
+t{ 15 sqrt -> 3 }t
+t{ 16 sqrt -> 4 }t
+
+: pyth ( a b -- c )
+ swap sqr swap sqr + sqrt ;
+
+t{ 3 4 pyth -> 5 }t
+t{ 65535 dup * sqrt -> 65535 }t
+
+
\ remove headers from dictionary
| : unlink-header ( addr name -- ) 2dup ." unlink " . .
: visible hidden hidden ;
+
+: save-mem ( c-addr1 u1 -- c-addr2 u2 )
+ dup >r allocate throw swap over r@ cmove r> ;
+
+: s( ( -- c-addr u )
+ ')' parse save-mem ; immediate
+
+cr .( ③ )
+
+\ : Marker ( <name> -- )
+\ Create here , hp @ , Does> 2@ here - allot hp ! ;
+\ Cannot access hp what about dictionary headers?
+
\ remove-headers
: package ( <name> -- ) parse-name 2drop ;
: c a b ." c" ;
end-package
+t{ s( abc) s( abc) compare -> 0 }t
+t{ s( abc) s( ab) compare -> 1 }t
+t{ s( ab) s( abc) compare -> -1 }t
+t{ s( abc) s( def) compare -> -1 }t
+t{ s( def) s( abc) compare -> 1 }t
+
+: Defer ( <name> -- )
+ Create 0 , Does> @ execute ;
+
+Defer %defer ' %defer >body 1 cells - @ Constant dodefer
+
+
+\ highly implementation specific
+: backpatch ( xt1 xt2 -- ) >body >r
+ >body 1 cells - r@ !
+ [ ' exit ] Literal >body 1 cells - r> cell+ ! ;
+
+: hallo ." hallo" ;
+: moin hallo hallo ;
+
+: abc ." abc" ;
+
+' abc ' hallo backpatch
+
+: FOR ( n -- )
+ postpone BEGIN
+ postpone >r ; immediate
+
+: NEXT ( -- )
+ postpone r>
+ postpone 1-
+ postpone dup
+ postpone 0<
+ postpone UNTIL
+ postpone drop ; immediate
+
+: cntdwn 65535 FOR r@ . NEXT ;
+
+: sqr ;
+: √ sqrt ;
+
+: ⟼ -> ;
+
+: testall ( -- ) \ see if sqrt works for all 32 bit numbers
+ 65535 FOR
+ t{ r@ ² √ ⟼ r@ }t
+ NEXT ." ⚑" ;
+
+cr .( ➍ )
+
+Variable Δ
+
+: ❤️ ." love" ;
+: ♩ ." pling" ;
+: :smile: ." 😀" ;
+
+
+"well " type
+
+: lalelu "la" "le" "lu" 2rot type 2swap type type ; lalelu
+
echo on
+
\ String comparison
: compare ( c-addr1 u1 c-addr2 u2 -- n )
rot
- BEGIN \ ( c-addr1 c-addr2 u1 u2 )
+ BEGIN \ ( c-addr1 c-addr2 u2 u1 )
over
- WHILE
+ WHILE \ ( c-addr1 c-addr2 u2 u1 )
dup
- WHILE
- >r >r over c@ over c@ - ?dup IF 0< dup + 1 + nip nip r> drop r> drop exit THEN
+ WHILE \ ( c-addr1 c-addr2 u2 u1 )
+ >r >r over c@ over c@ - ?dup IF 0< 2* 1+ ( -1 | 1 ) nip nip r> drop r> drop exit THEN
1+ swap 1+ swap
r> 1- r> 1-
- REPEAT
- -1
- ELSE
+ REPEAT \ ( c-addr1 c-addr2 u2>0 0 )
+ -1
+ ELSE \ ( c-addr1 c-addr2 0 u1 )
dup 0= IF 0 ELSE 1 THEN
THEN >r 2drop 2drop r> ;
: !flags ( x -- )
last @ _flags c! ;
-128 Constant #immediate
-
-: immediate? ( addr -- f )
- _flags @ #immediate and 0<> ;
-
-: immediate ( -- )
- @flags #immediate or !flags ;
-
-64 Constant #headerless
-
-: headerless? ( addr -- f )
- _flags @ #headerless and 0<> ;
-
-: headerless ( -- )
- @flags #headerless or !flags ;
+Definer Header-flag ( x <name> -- )
+ create >r , r> does> ( -- ) @ @flags or !flags ;
+Definer Header-flag? ( x <name> -- )
+ create >r , r> does> ( addr -- f ) @ swap _flags @ and 0<> ;
+128 dup Header-flag immediate Header-flag? immediate?
+ 64 dup Header-flag headerless Header-flag? headerless?
: pad ( -- addr )
here 100 + ;
' reveal has-header reveal
' hide has-header hide
' pad has-header pad
+' >body has-header >body
' allocate has-header allocate
' free has-header free
' headerless has-header headerless
' headerless? has-header headerless?
-
\ ' "header has-header "header
\ ' link has-header link
\ ' _xt has-header _xt
-
Macro :noname
seed new
seed compiler
: compile ( -- )
r> dup cell+ >r @ , ;
-
\ Macro compile
\ seed [
\ seed '
' dot-paren has-header .( immediate
+: match ( c-addr1 u1 header -- f )
+ _name count compare 0= ;
: find-name ( c-addr u link -- header|0 )
\ >r 2dup lowercase r>
dup
WHILE ( c-addr u link )
>r 2dup r> dup >r
- _name count compare 0= IF 2drop r> exit THEN
+ match IF 2drop r> exit THEN
r> @
REPEAT
nip nip ;
' find-name has-header find-name
: (postpone) ( <name> -- )
- parse-name last @ find-name dup 0= -13 and throw
+ parse-name last @ find-name dup 0= -13 and throw
dup immediate? IF
_xt @ compile,
ELSE
?'x' dup ?exit
lit [ ' lit , ] compile, rot , ;
-
: ?word ( c-addr1 u1 | i*x c-addr2 u2 )
dup 0= ?exit
- 2dup context @ find-name ?dup IF nip nip _xt @ execute 0 0 THEN
+ 2dup context @ find-name ?dup IF
+ nip nip _xt @ execute 0 0
+ THEN
;
: (interpreters ( c-addr1 u1 | i*x c-addr2 u2 )
?word
?#
?'x'
- over IF space type '?' emit space -13 throw THEN
+ over IF space type ( '?' emit ) space -13 throw THEN
;
: ,word ( c-addr1 u1 | i*x c-addr2 u2 )
dup 0= ?exit
2dup context @ find-name ?dup
- IF nip nip dup immediate? IF _xt @ execute ELSE _xt @ compile, THEN 0 0 THEN
+ IF
+ nip nip dup immediate? IF _xt @ execute ELSE _xt @ compile, THEN 0 0
+ THEN
;
: (compilers ( c-addr u1 | i*x c-addr2 u2 )
' | has-header |
' heads has-header heads
-
: interpret ( -- )
BEGIN ( )
parse-name dup
' echo has-header echo
+\ ANSI terminal colors
+
+: esc ( -- ) 27 emit ;
+: bold ( -- ) esc ." [1m" ;
+: normal ( -- ) esc ." [0m" ;
+: black ( -- ) esc ." [30m" ;
+: red ( -- ) esc ." [31m" ;
+: green ( -- ) esc ." [32m" ;
+: yellow ( -- ) esc ." [33m" ;
+: blue ( -- ) esc ." [34m" ;
+
+: compiling? ( -- f )
+ handlers @ compilers @ = ;
+
+' compiling? has-header compiling?
+
: prompt ( -- )
echo @ IF
- cr .s handlers @ compilers @ = IF ']' ELSE '>' THEN emit space
+ cr blue bold .s normal black compiling? IF ']' ELSE '>' THEN emit space
THEN ;
-: .ok ( -- ) echo @ IF ." ok" THEN ;
+
+: .ok ( -- )
+ echo @ IF space bold green ." ok 🙂" normal black THEN ; \ 🆗
+
+: ?stack ( -- )
+ depth 0< -4 and throw ;
: restart ( -- )
tib 0 'source 2!
([)
BEGIN
- prompt query 0 >in ! interpret .ok
+ prompt query 0 >in ! interpret ?stack .ok
0 UNTIL ;
: warm ( -- )
cr ." seedForth/interactive " .version
cr ." ---------------------------" cr ;
+: .error# ( n -- )
+ dup -4 = IF drop ." stack underflow" exit THEN
+ dup -13 = IF drop ." not found" exit THEN
+ dup -16 = IF drop ." attempt to use zero-length string as a name" exit THEN
+ dup -39 = IF drop ." unexpected end of file" exit THEN
+ ." error " . ;
+
+: .error ( n -- )
+ red bold .error# normal black ." 🤔 " ;
+
: boot ( -- )
key drop \ skip 0 of boot program
.banner
BEGIN
- [ ' warm ] Literal catch ?dup IF ." error " . cr THEN
+ [ ' warm ] Literal catch ?dup IF .error cr THEN
AGAIN ;
' boot has-header boot
public / preForth.git / commitdiff