# Things to do
-- wordlists, search order
++ wordlists, search order, vocabulary split into traditional (Vocabulary only/also) and modern word set (get-order)
-- number output with given base <# # #s hold #> u. u.r . .r um/mod /mod / mod
++ number output with given base <# # #s hold #> u. u.r . .r um/mod /mod / mod currently using globals BASE, HLD and PAD
- Assembler (proof of concept) i386 stm8 ...
- interpretive conditionals
+- conditional compilation
+
+- source code library WANT
+
- intermediate definitions (forgettable)
- dictionary experiments
+ ANS error codes
-- and XCHARS wordset
+- and XCHARS wordset and support for unicode characters such as '∆' -> U+0394
+
+- file i/o and include
+
+- (interactive) decompiler
+
+- dump
+
+- State machine / decision table using graphics characters
+
++ Cursor positioning AT-XY
+
++ Status line
+
+- AT?
+
+- String Stack
+
+- locals
+
+- generalize linked list handling (map/filter)
+
+
+
: REPEAT ( c:orig c:dest -- )
postpone AGAIN postpone THEN ; immediate
+\ are these necessary?
+\ you can use the phrase dup x = IF drop instead of x case? IF or x OF
+: case? ( n1 n2 -- true | n1 false )
+ over = dup IF nip THEN ;
+
+: OF ( n1 n2 -- n1 | )
+ postpone case? postpone IF ; immediate
+
: s" ( ccc" -- c-addr u ) \ compile only
postpone $lit
'"' parse
: n' parse-name find-name ;
-cr cr words cr
+\ cr cr words cr
cr .( ready )
cr .( ② )
\ remove headers from dictionary
-| : unlink-header ( addr name -- ) 2dup ." unlink " . .
+| : unlink-header ( addr name -- ) \ 2dup ." unlink " . .
dup >r ( _link ) @ swap ! r> dispose ;
: remove-headers ( -- )
REPEAT
2drop ;
-| : hidden ." still there - " ;
+| : hidden-word ." still there - " ;
-: visible hidden hidden ;
+: visible-word ( -- ) hidden-word hidden-word ;
: save-mem ( c-addr1 u1 -- c-addr2 u2 )
: Defer ( <name> -- )
Create 0 , Does> @ execute ;
-Defer %defer ' %defer >body 1 cells - @ Constant dodefer
+Defer %defer ' %defer >body 2 cells - @ Constant dodefer
+ ' %defer >body 1 cells - @ Constant dodoes
\ highly implementation specific
-: backpatch ( xt1 xt2 -- ) >body >r
+: backpatch1 ( xt1 xt2 -- ) >body >r
>body 1 cells - r@ !
[ ' exit ] Literal >body 1 cells - r> cell+ ! ;
-: hallo ." hallo" ;
+: dp! ( addr -- ) here - allot ;
+
+: backpatch ( xt1 xt2 -- )
+ here >r >body dp! compile, postpone exit r> dp! ;
+
+: hallo ." original" ;
: moin hallo hallo ;
-: abc ." abc" ;
+: abc ." backpatched" ;
' abc ' hallo backpatch
+
+
+
: FOR ( n -- )
postpone BEGIN
postpone >r ; immediate
Variable ∆t
+Variable voc-link 0 voc-link !
+
+: Vocabulary ( <name> -- )
+ wordlist Create here voc-link @ , voc-link ! last @ , ,
+ Does> 2 cells + @ >r get-order nip r> swap set-order ;
+
+: .voc ( wid -- )
+ dup forth-wordlist = IF drop ." Forth " exit THEN
+ voc-link @
+ BEGIN ( wid link )
+ dup
+ WHILE ( wid link )
+ 2dup 2 cells + @ = IF nip cell+ @ _name count type space exit THEN
+ @
+ REPEAT ( wid 0 )
+ drop u. ;
+
+' .voc ' .wordlist backpatch
+
+
+: recurse ( -- ) last @ _xt @ compile, ; immediate
+
+: cntd ( n -- ) ?dup 0= ?exit dup . 1- recurse '.' emit ;
+
+
+\ number output: <# # #s #> sign hold holds base . u. .r u.r
+
+Variable base
+Variable hld
+
+: hold ( c -- ) -1 hld +! hld @ c! ;
+
+\ : holds ( c-addr u -- ) recursive
+\ dup 0= IF 2drop exit THEN
+\ over c@ >r 1 /string holds r> hold ;
+
+: holds ( c-addr u -- )
+ BEGIN dup WHILE 1- 2dup + c@ hold REPEAT 2drop ;
+
+: mu/mod ( d n1 -- rem d.quot )
+ >r 0 r@ um/mod r> swap >r um/mod r> ;
+
+: <# ( -- ) pad hld ! ;
+
+: # ( ud1 -- ud2 )
+ base @ mu/mod rot 9 over < IF [ 'A' '9' 1+ - ] Literal + THEN '0' + hold ;
+
+: #s ( ud1 -- d.0 ) BEGIN # 2dup or 0= UNTIL ;
+
+: #> ( ud -- c-addr u ) 2drop hld @ pad over - ;
+
+: sign ( n -- ) 0< IF '-' hold THEN ;
+
+: decimal ( -- ) 10 base ! ; decimal
+: hex ( -- ) 16 base ! ;
+
+| : (.) ( n -- ) dup abs 0 <# #s rot sign #> ;
+: dot ( n -- ) (.) type space ; ' dot ' . backpatch
+: .r ( n l -- ) >r (.) r> over - 0 max spaces type ;
+
+| : (u.) ( u -- ) 0 <# #s #> ;
+: u. ( u -- ) (u.) type space ;
+: u.r ( u l -- ) >r (u.) r> over - 0 max spaces type ;
+
+: at-xy ( u1 u2 -- ) \ col row
+ esc ." [" 1+ 0 u.r ." ;" 1+ 0 u.r ." H" ;
+
+\ : at? CSI 6n
+
+: clreol ( -- )
+ esc ." [K" ;
+
+: save-cursor-position ( -- ) 27 emit '7' emit ;
+: restore-cursor-position ( -- ) 27 emit '8' emit ;
+
+: show-status ( -- )
+ save-cursor-position reverse
+ base @ >r decimal
+ 0 1 at-xy clreol 80 spaces 0 1 at-xy
+ ." seedForth 😉 "
+ ." | order: " order
+ ." | base: " r@ .
+ ." | stack: " .s
+ r> base !
+ normal restore-cursor-position ;
+
+' show-status ' .status >body !
+
+only Forth also definitions
+Vocabulary root
+
+: only ( -- ) only root ;
+
+root definitions
+
+: order order ;
+: definitions definitions ;
+: words words ;
+: Forth Forth ;
+: only only ;
+: also also ;
+: bye bye ;
+
+only Forth also definitions order
+
+: mod ( u1 u2 -- u3 ) 0 swap um/mod drop ;
+
+: prime? ( u -- f )
+ dup 2 = IF drop true exit THEN
+ dup 2 mod 0= IF drop false exit THEN
+ 3 BEGIN ( u i )
+ 2dup dup * < 0=
+ WHILE ( u i )
+ 2dup mod 0= IF 2drop false exit THEN
+ 2+
+ REPEAT ( u i )
+ 2drop true
+;
+
+: th.prime ( u -- )
+ 1 BEGIN over WHILE 1+ dup prime? IF swap 1- swap THEN REPEAT nip ;
+
+cr cr cr .( The ) 10001 dup . .( st prime is ) th.prime .
+
echo on
sub esp, 16
and esp, 0xfffffff0
mov dword [esp+8], 7 ; rwx
- mov eax, memtop
+ mov eax, _memtop
sub eax, origin
mov dword [esp+4], eax
mov dword [esp], origin
: throw ( i*x 0 | i*x err -- j*x err )
?dup 0= ?exit lit frame @ rp! r> swap >r sp! drop r> r> lit frame ! ;
+: unused ( -- u )
+ lit memtop here - ;
: cold ( -- )
's' emit 'e' dup emit emit 'd' emit 10 emit
lit num h, \ 51 33
lit um* h, \ 52 34
lit um/mod h, \ 53 35
+ lit unused h, \ 54 36
interpreter bye ;
pre
_start: DB 43
DD 10000 dup (0)
- memtop: DD 0
+ _memtop: DD 0
;
( 40 $28 ) Token new Token couple Token and Token or
( 44 $2C ) Token catch Token throw Token sp@ Token sp!
( 48 $30 ) Token rp@ Token rp! Token $lit Token num
-( 52 $34 ) Token um* Token um/mod
+( 52 $34 ) Token um* Token um/mod Token unused
\ generate token sequences for numbers
: 1+ ( x1 -- x2 )
1 + ;
+: 2+ ( x1 -- x2 )
+ 2 + ;
+
: 1- ( x1 -- x2 )
1 - ;
: cell+ ( addr1 -- addr2 )
1 cells + ;
+: cell- ( addr1 -- addr2 )
+ -1 cells + ;
+
: 2@ ( addr -- x1 x2 )
dup cell+ @ swap @ ;
Constant #header
-Variable last 0 last !
+Variable last
: "header ( c-addr u -- addr )
\ 2dup lowercase
r@ _name place
r> ;
+
+Variable current
+
: link-header ( addr -- )
- last @ swap _link dup last ! ! ;
+ current @ @ swap _link dup last ! dup current @ ! ! ;
: @flags ( -- x )
last @ _flags c@ ;
: wordlist ( -- wid ) here 0 , ;
-Variable current
-Variable context wordlist dup context ! current !
+: 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 )
+ search-order dup @ dup >r cells + r@
+ BEGIN ( addr n )
+ dup
+ WHILE ( addr n )
+ >r dup >r @ r> cell- r> 1-
+ REPEAT ( wid0 wid1 wid2 ... widn addr 0 )
+ 2drop r> ;
+
+: set-order ( wid0 wid1 wid2 ... widn n )
+ dup search-order !
+ search-order cell+ swap
+ BEGIN ( wid0 wid1 ... widn addr n )
+ dup
+ WHILE ( wid0 wid1 ... widn addr n )
+ >r swap over ! cell+ r> 1-
+ REPEAT ( addr 0 )
+ 2drop ;
+
+: get-current ( -- wid ) current @ ;
+: set-current ( wid -- ) current ! ;
+
+: context ( -- addr ) search-order cell+ ;
+
+wordlist Constant forth-wordlist
+
+: Forth ( -- ) get-order nip forth-wordlist swap set-order ;
+: also ( -- ) get-order over swap 1+ set-order ;
+: previous ( -- ) get-order nip 1- set-order ;
+: only ( -- ) forth-wordlist 1 set-order ;
+: definitions ( -- ) get-order over set-current set-order ;
+\ : OnlyForth ( -- ) only Forth also definitions ;
-: words ( -- )
- context @ @ BEGIN ?dup WHILE dup dup headerless? IF '|' emit THEN _name count type space @ REPEAT ;
+only Forth also definitions
+
+: .wordlist ( wid -- )
+ dup forth-wordlist = IF drop ." Forth " exit THEN
+ u. ;
+
+: order ( -- )
+ search-order dup cell+ swap @
+ BEGIN ( addr n )
+ dup
+ WHILE ( addr n )
+ >r dup @ .wordlist
+ cell+ r> 1-
+ REPEAT ( addr n )
+ 2drop
+ space current @ .wordlist ;
+
+: words ( -- ) 0 >r
+ context @ @
+ BEGIN ?dup WHILE dup dup headerless? IF '|' emit THEN _name count type space @ r> 1+ >r REPEAT
+ r> space . ." words" ;
: hide ( -- )
last @ @ current @ ! ;
' 2swap has-header 2swap
' 2over has-header 2over
' xor has-header xor
+' max has-header max
+' min has-header min
' minint has-header minint
' maxint has-header maxint
' dispose has-header dispose
' alloc has-header alloc
+' unused has-header unused
+
' cr has-header cr
' .s has-header .s
' t{ has-header t{
' space has-header space
' spaces has-header spaces
-' 1+ has-header 1+
+' 1+ has-header 1+
+' 2+ has-header 2+
' 1- has-header 1-
' invert has-header invert
' nip has-header nip
' r@ has-header r@
' third has-header third
' cmove has-header cmove
-' cell+ has-header cell+
+' cell+ has-header cell+
+' cell- has-header cell-
' place has-header place
' compare has-header compare
' 2@ has-header 2@
' headerless has-header headerless
' headerless? has-header headerless?
+' set-current has-header set-current
+' get-current has-header get-current
+' set-order has-header set-order
+' get-order has-header get-order
+' wordlist has-header wordlist
+' only has-header only
+' also has-header also
+' previous has-header previous
+' order has-header order
+' forth-wordlist has-header forth-wordlist
+' Forth has-header Forth
+' definitions has-header definitions
+' only has-header only
+\ ' OnlyForth has-header OnlyForth
+' .wordlist has-header .wordlist
+
\ ' "header has-header "header
\ ' link has-header link
\ ' _xt has-header _xt
\ ' find-name-in has-header find-name-in
: find-name ( c-addr u -- header|0 )
- context @ @ find-name-in ;
+ search-order dup cell+ swap @
+ BEGIN ( c-addr u addr n )
+ dup
+ WHILE ( c-addr u addr n )
+ >r >r
+ 2dup r@ @ find-name-in ?dup IF nip nip r> drop r> drop exit THEN
+ r> cell+ r> 1-
+ REPEAT ( c-addr u addr n )
+ 2drop 2drop 0 ;
' find-name has-header find-name
\ ANSI terminal colors
-: esc ( -- ) 27 emit ;
+: esc ( -- ) 27 emit ; ' esc has-header esc
: bold ( -- ) esc ." [1m" ;
-: normal ( -- ) esc ." [0m" ;
+: normal ( -- ) esc ." [0m" ; ' normal has-header normal
+: reverse ( -- ) esc ." [7m" ; ' reverse has-header reverse
\ : black ( -- ) esc ." [30m" ;
: red ( -- ) esc ." [31m" ;
: green ( -- ) esc ." [32m" ;
\ : yellow ( -- ) esc ." [33m" ;
: blue ( -- ) esc ." [34m" ;
: reset-colors ( -- ) esc ." [39;49m" ;
+: page ( -- ) esc ." [2J" esc ." [H" ;
+
+' blue has-header blue
+' page has-header page
: compiling? ( -- f )
handlers @ compilers @ = ;
' compiling? has-header compiling?
+Defer .status : noop ; ' noop is .status
+
+' .status has-header .status
+
: prompt ( -- )
echo @ IF
cr blue bold .s normal reset-colors compiling? IF ']' ELSE '>' THEN emit space
THEN ;
-
: .ok ( -- )
echo @ IF space bold green ." ok 🙂" normal reset-colors THEN ; \ 🆗
tib 0 'source 2!
([)
BEGIN
- prompt query 0 >in ! interpret ?stack .ok
+ .status prompt query 0 >in ! interpret ?stack .ok
0 UNTIL ;
: warm ( -- )
: .banner ( -- )
cr ." seedForth/interactive " .version
- cr ." ---------------------------" cr ;
+ cr ." ---------------------------"
+ cr unused . ." bytes free" cr ;
: .error# ( n -- )
dup -4 = IF drop ." stack underflow" exit THEN
: .error ( n -- )
red bold .error# normal reset-colors ." 🤔 " ;
+
: boot ( -- )
key drop \ skip 0 of boot program
.banner
colored-header count "header dup link-header
\ --------
+Macro ninelit
+ seed lit
+ seed [
+ 9
+ seed ,
+ seed ]
+end-macro
+
+: nine ninelit ;
+
+' nine has-header nine
+
cr
t{ -> }t
public / preForth.git / commitdiff