aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoel Martin <github@martintribe.org>2015-02-21 15:58:41 -0600
committerJoel Martin <github@martintribe.org>2015-02-21 15:58:41 -0600
commit2a42d8274072c44dd2d83762cc27cd810f5b8452 (patch)
treec778c4319f93c89b85879c0dd60914813c4cf3db
parent5a5edd508d20775fddcb5931f263042d8e0d8fef (diff)
parent9603289087755c880fbb16b7e36eedef940237be (diff)
downloadmal-2a42d8274072c44dd2d83762cc27cd810f5b8452.tar.gz
mal-2a42d8274072c44dd2d83762cc27cd810f5b8452.zip
Merge pull request #7 from Chouser/forth-pr
Add Forth
Diffstat
-rw-r--r--Makefile4
-rw-r--r--README.md10
-rw-r--r--forth/core.fs224
-rw-r--r--forth/env.fs45
-rw-r--r--forth/misc-tests.fs93
-rw-r--r--forth/printer.fs114
-rw-r--r--forth/reader.fs147
-rw-r--r--forth/step0_repl.fs23
-rw-r--r--forth/step1_read_print.fs34
-rw-r--r--forth/step2_eval.fs117
-rw-r--r--forth/step3_env.fs154
-rw-r--r--forth/step4_if_fn_do.fs214
-rw-r--r--forth/step5_tco.fs225
-rw-r--r--forth/step6_file.fs252
-rw-r--r--forth/step7_quote.fs294
-rw-r--r--forth/step8_macros.fs324
-rw-r--r--forth/step9_try.fs379
-rw-r--r--forth/stepA_interop.fs381
-rw-r--r--forth/str.fs73
-rw-r--r--forth/types.fs574
20 files changed, 3679 insertions, 2 deletions
diff --git a/Makefile b/Makefile
index 9a9054c..8d13bce 100644
--- a/Makefile
+++ b/Makefile
@@ -10,7 +10,7 @@ PYTHON = python
# Settings
#
-IMPLS = bash c clojure coffee cs go haskell java js lua make mal \
+IMPLS = bash c clojure coffee cs forth go haskell java js lua make mal \
ocaml matlab perl php ps python r racket ruby rust scala vb
step0 = step0_repl
@@ -54,6 +54,7 @@ c_STEP_TO_PROG = c/$($(1))
clojure_STEP_TO_PROG = clojure/src/$($(1)).clj
coffee_STEP_TO_PROG = coffee/$($(1)).coffee
cs_STEP_TO_PROG = cs/$($(1)).exe
+forth_STEP_TO_PROG = forth/$($(1)).fs
go_STEP_TO_PROG = go/$($(1))
java_STEP_TO_PROG = java/src/main/java/mal/$($(1)).java
haskell_STEP_TO_PROG = haskell/$($(1))
@@ -84,6 +85,7 @@ c_RUNSTEP = ../$(2) $(3)
clojure_RUNSTEP = lein with-profile +$(1) trampoline run $(3)
coffee_RUNSTEP = coffee ../$(2) $(3)
cs_RUNSTEP = mono ../$(2) --raw $(3)
+forth_RUNSTEP = gforth ../$(2) $(3)
go_RUNSTEP = ../$(2) $(3)
haskell_RUNSTEP = ../$(2) $(3)
java_RUNSTEP = mvn -quiet exec:java -Dexec.mainClass="mal.$($(1))" -Dexec.args="--raw$(if $(3), $(3),)"
diff --git a/README.md b/README.md
index eab655c..c444b27 100644
--- a/README.md
+++ b/README.md
@@ -4,13 +4,14 @@
Mal is an Clojure inspired Lisp interpreter.
-Mal is implemented in 24 different languages:
+Mal is implemented in 25 different languages:
* Bash shell
* C
* C#
* Clojure
* CoffeeScript
+* Forth
* Go
* Haskell
* Java
@@ -105,6 +106,13 @@ cd coffee
coffee ./stepX_YYY
```
+### Forth
+
+```
+cd forth
+gforth stepX_YYY.fs
+```
+
### Go
You Go implementation of mal requires that go is installed on on the
diff --git a/forth/core.fs b/forth/core.fs
new file mode 100644
index 0000000..1a1cc4d
--- /dev/null
+++ b/forth/core.fs
@@ -0,0 +1,224 @@
+require env.fs
+
+0 MalEnv. constant core
+
+: args-as-native { argv argc -- entry*argc... }
+ argc 0 ?do
+ argv i cells + @ as-native
+ loop ;
+
+: defcore* ( sym xt )
+ MalNativeFn. core env/set ;
+
+: defcore
+ parse-allot-name MalSymbol. ( xt )
+ ['] defcore* :noname ;
+
+defcore + args-as-native + MalInt. ;;
+defcore - args-as-native - MalInt. ;;
+defcore * args-as-native * MalInt. ;;
+defcore / args-as-native / MalInt. ;;
+defcore < args-as-native < mal-bool ;;
+defcore > args-as-native > mal-bool ;;
+defcore <= args-as-native <= mal-bool ;;
+defcore >= args-as-native >= mal-bool ;;
+
+defcore list { argv argc }
+ argc cells allocate throw { start }
+ argv start argc cells cmove
+ start argc MalList. ;;
+
+defcore vector { argv argc }
+ argc cells allocate throw { start }
+ argv start argc cells cmove
+ start argc MalList.
+ MalVector new swap over MalVector/list ! ;;
+
+defcore empty? drop @ empty? ;;
+defcore count drop @ mal-count ;;
+
+defcore = drop dup @ swap cell+ @ swap m= mal-bool ;;
+defcore not
+ drop @
+ dup mal-nil = if
+ drop mal-true
+ else
+ mal-false = if
+ mal-true
+ else
+ mal-false
+ endif
+ endif ;;
+
+: pr-str-multi ( readably? argv argc )
+ ?dup 0= if drop 0 0
+ else
+ { argv argc }
+ new-str
+ argv @ pr-buf
+ argc 1 ?do
+ a-space
+ argv i cells + @ pr-buf
+ loop
+ endif ;
+
+defcore prn true -rot pr-str-multi type cr drop mal-nil ;;
+defcore pr-str true -rot pr-str-multi MalString. nip ;;
+defcore println false -rot pr-str-multi type cr drop mal-nil ;;
+defcore str ( argv argc )
+ dup 0= if
+ MalString.
+ else
+ { argv argc }
+ false new-str
+ argc 0 ?do
+ argv i cells + @ pr-buf
+ loop
+ MalString. nip
+ endif ;;
+
+defcore read-string drop @ unpack-str read-str ;;
+defcore slurp drop @ unpack-str slurp-file MalString. ;;
+
+defcore cons ( argv[item,coll] argc )
+ drop dup @ swap cell+ @ ( item coll )
+ to-list conj ;;
+
+defcore concat { lists argc }
+ MalList new
+ lists over MalList/start !
+ argc over MalList/count !
+ MalList/concat ;;
+
+defcore conj { argv argc }
+ argv @ ( coll )
+ argc 1 ?do
+ argv i cells + @ swap conj
+ loop ;;
+
+defcore assoc { argv argc }
+ argv @ ( coll )
+ argv argc cells + argv cell+ +do
+ i @ \ key
+ i cell+ @ \ val
+ rot assoc
+ 2 cells +loop ;;
+
+defcore keys ( argv argc )
+ drop @ MalMap/list @
+ dup MalList/start @ swap MalList/count @ { start count }
+ here
+ start count cells + start +do
+ i @ ,
+ 2 cells +loop
+ here>MalList ;;
+
+defcore vals ( argv argc )
+ drop @ MalMap/list @
+ dup MalList/start @ swap MalList/count @ { start count }
+ here
+ start count cells + start cell+ +do
+ i @ ,
+ 2 cells +loop
+ here>MalList ;;
+
+defcore dissoc { argv argc }
+ argv @ \ coll
+ argv argc cells + argv cell+ +do
+ i @ swap dissoc
+ cell +loop ;;
+
+defcore hash-map { argv argc }
+ MalMap/Empty
+ argc cells argv + argv +do
+ i @ i cell+ @ rot assoc
+ 2 cells +loop ;;
+
+defcore get { argv argc }
+ argc 3 < if mal-nil else argv cell+ cell+ @ endif
+ argv cell+ @ \ key
+ argv @ \ coll
+ get ;;
+
+defcore contains? { argv argc }
+ 0
+ argv cell+ @ \ key
+ argv @ \ coll
+ get 0 <> mal-bool ;;
+
+defcore nth ( argv[coll,i] argc )
+ drop dup @ to-list ( argv list )
+ swap cell+ @ MalInt/int @ ( list i )
+ over MalList/count @ ( list i count )
+ 2dup >= if { i count }
+ 0 0
+ new-str i int>str str-append s\" \040>= " count int>str
+ s" nth out of bounds: " ...throw-str
+ endif drop ( list i )
+ cells swap ( c-offset list )
+ MalList/start @ + @ ;;
+
+defcore first ( argv[coll] argc )
+ drop @ to-list
+ dup MalList/count @ 0= if
+ drop mal-nil
+ else
+ MalList/start @ @
+ endif ;;
+
+defcore rest ( argv[coll] argc )
+ drop @ to-list MalList/rest ;;
+
+defcore meta ( argv[obj] argc )
+ drop @ mal-meta @
+ ?dup 0= if mal-nil endif ;;
+
+defcore with-meta ( argv[obj,meta] argc )
+ drop ( argv )
+ dup cell+ @ swap @ ( meta obj )
+ dup mal-type @ MalTypeType-struct @ ( meta obj obj-size )
+ dup allocate throw { new-obj } ( meta obj obj-size )
+ new-obj swap cmove ( meta )
+ new-obj mal-meta ! ( )
+ new-obj ;;
+
+defcore atom ( argv[val] argc )
+ drop @ Atom. ;;
+
+defcore deref ( argv[atom] argc )
+ drop @ Atom/val @ ;;
+
+defcore reset! ( argv[atom,val] argc )
+ drop dup cell+ @ ( argv val )
+ dup -rot swap @ Atom/val ! ;;
+
+defcore apply { argv argc -- val }
+ \ argv is (fn args... more-args)
+ argv argc 1- cells + @ to-list { more-args }
+ argc 2 - { list0len }
+ more-args MalList/count @ list0len + { final-argc }
+ final-argc cells allocate throw { final-argv }
+ argv cell+ final-argv list0len cells cmove
+ more-args MalList/start @ final-argv list0len cells + final-argc list0len - cells cmove
+ final-argv final-argc argv @ invoke ;;
+
+defcore throw ( argv argc -- )
+ drop @ to exception-object
+ 1 throw ;;
+
+defcore map? drop @ mal-type @ MalMap = mal-bool ;;
+defcore list? drop @ mal-type @ MalList = mal-bool ;;
+defcore vector? drop @ mal-type @ MalVector = mal-bool ;;
+defcore keyword? drop @ mal-type @ MalKeyword = mal-bool ;;
+defcore symbol? drop @ mal-type @ MalSymbol = mal-bool ;;
+defcore atom? drop @ mal-type @ Atom = mal-bool ;;
+defcore true? drop @ mal-true = mal-bool ;;
+defcore false? drop @ mal-false = mal-bool ;;
+defcore nil? drop @ mal-nil = mal-bool ;;
+
+defcore sequential? drop @ sequential? ;;
+
+defcore keyword drop @ unpack-str MalKeyword. ;;
+defcore symbol drop @ unpack-str MalSymbol. ;;
+
+defcore time-ms 2drop utime d>s 1000 / MalInt. ;;
diff --git a/forth/env.fs b/forth/env.fs
new file mode 100644
index 0000000..1b5a362
--- /dev/null
+++ b/forth/env.fs
@@ -0,0 +1,45 @@
+require types.fs
+
+MalType%
+ cell% field MalEnv/outer
+ cell% field MalEnv/data
+deftype MalEnv
+
+: MalEnv. { outer -- env }
+ MalEnv new { env }
+ outer env MalEnv/outer !
+ MalMap/Empty env MalEnv/data !
+ env ;
+
+: env/set { key val env -- }
+ key val env MalEnv/data @ assoc
+ env MalEnv/data ! ;
+
+: env/find { key env -- env-or-0 }
+ env
+ begin ( env )
+ dup 0 key rot MalEnv/data @ get ( env val-or-0 )
+ 0= if ( env )
+ MalEnv/outer @ dup 0= ( env-or-0 done-looping? )
+ else
+ -1 \ found it! ( env -1 )
+ endif
+ until ;
+
+MalEnv
+ extend get { not-found key env -- }
+ key env env/find ( env-or-0 )
+ ?dup 0= if
+ not-found
+ else ( env )
+ not-found key rot MalEnv/data @ get
+ endif ;;
+ extend pr-buf { env }
+ env MalEnv/data @ pr-buf
+ a-space s" outer: " str-append
+ env MalEnv/outer @ ?dup 0= if
+ s" <none>" str-append
+ else
+ pr-buf
+ endif ;;
+drop
diff --git a/forth/misc-tests.fs b/forth/misc-tests.fs
new file mode 100644
index 0000000..35e665b
--- /dev/null
+++ b/forth/misc-tests.fs
@@ -0,0 +1,93 @@
+require printer.fs
+
+\ === basic testing util === /
+: test=
+ 2dup m= if
+ 2drop
+ else
+ cr ." assert failed on line " sourceline# .
+ swap cr ." | got " . cr ." | expected " . cr
+ endif ;
+
+\ array function tests
+create za 2 , 6 , 7 , 10 , 15 , 80 , 81 ,
+
+7 za 2 array-find -1 test= 0 test=
+7 za 6 array-find -1 test= 1 test=
+7 za 10 array-find -1 test= 3 test=
+7 za 81 array-find -1 test= 6 test=
+7 za 12 array-find 0 test= 4 test=
+7 za 8 array-find 0 test= 3 test=
+7 za 100 array-find 0 test= 7 test=
+7 za 1 array-find 0 test= 0 test=
+6 za 81 array-find 0 test= 6 test=
+
+10 new-array
+1 swap 0 5 array-insert
+2 swap 1 7 array-insert
+3 swap 3 12 array-insert
+4 swap 4 15 array-insert
+5 swap 5 20 array-insert
+
+dup 0 cells + @ 5 test=
+dup 1 cells + @ 7 test=
+dup 2 cells + @ 10 test=
+dup 3 cells + @ 12 test=
+dup 4 cells + @ 15 test=
+dup 5 cells + @ 20 test=
+
+
+\ Protocol tests
+
+mal-nil
+42 MalInt. mal-nil conj
+10 MalInt. mal-nil conj conj
+20 MalInt. swap conj
+23 MalInt. mal-nil conj conj conj
+pr-str s" (nil (20 (42) 10) 23)" str= -1 test=
+
+1500 MalInt. 1500 MalInt. test=
+
+\ MalList tests
+
+here 1 MalInt. , 2 MalInt. , 3 MalInt. , here>MalList
+4 MalInt. swap conj
+5 MalInt. swap conj
+pr-str s" (5 4 1 2 3)" str= -1 test=
+
+\ map tests
+
+s" one" MalString. s" one" MalString. test=
+s" one" MalString. s" x" MalString. m= 0 test=
+
+MalMap/Empty
+1000 MalInt. 1100 rot assoc
+2000 MalInt. 2100 rot assoc
+3000 MalInt. 3100 rot assoc
+
+dup 99 2000 MalInt. rot get 2100 test=
+dup 99 4000 MalInt. rot get 99 test=
+drop
+
+MalMap/Empty
+s" one" MalString. s" first" MalString. rot assoc
+s" two" MalString. s" second" MalString. rot assoc
+s" three" MalString. s" third" MalString. rot assoc
+
+dup 99 s" two" MalString. rot get s" second" MalString. test=
+dup 99 s" none" MalString. rot get 99 test=
+drop
+
+99 MalInt. 10 MalInt. MalMap/Empty get 99 MalInt. test=
+
+\ eval tests
+
+require step2_eval.fs
+
+mal-nil
+ 1 MalInt. swap conj
+ 2 MalInt. swap conj
+ 3 MalInt. swap conj
+mal-eval
+
+bye
diff --git a/forth/printer.fs b/forth/printer.fs
new file mode 100644
index 0000000..85f88a0
--- /dev/null
+++ b/forth/printer.fs
@@ -0,0 +1,114 @@
+require str.fs
+require types.fs
+
+\ === printer protocol and implementations === /
+
+def-protocol-method pr-buf ( readably? str-addr str-len this -- str-addr str-len )
+def-protocol-method pr-seq-buf ( readably? str-addr str-len this -- str-addr str-len )
+
+: pr-str { obj }
+ true new-str obj pr-buf rot drop ;
+
+\ Examples of extending existing protocol methods to existing type
+MalDefault
+ extend pr-buf
+ { this }
+ s" #<" str-append
+ this mal-type @ type-name str-append
+ a-space
+ this int>str str-append
+ s" >" str-append ;;
+drop
+
+MalNil extend pr-buf drop s" nil" str-append ;; drop
+MalTrue extend pr-buf drop s" true" str-append ;; drop
+MalFalse extend pr-buf drop s" false" str-append ;; drop
+
+MalList
+ extend pr-buf
+ -rot s" (" str-append ( list str-addr str-len )
+ rot pr-seq-buf
+ s" )" str-append ;;
+ extend pr-seq-buf { list }
+ list MalList/count @ 0 > if
+ list MalList/start @ { start }
+ start @ pr-buf
+ list MalList/count @ 1 ?do
+ a-space
+ start i cells + @ pr-buf
+ loop
+ endif ;;
+drop
+
+MalVector
+ extend pr-buf
+ MalVector/list @
+ -rot s" [" str-append ( list str-addr str-len )
+ rot pr-seq-buf
+ s" ]" str-append ;;
+drop
+
+MalMap
+ extend pr-buf
+ MalMap/list @
+ -rot s" {" str-append ( list str-addr str-len )
+ rot { list }
+ list MalList/count @ { count }
+ count 0 > if
+ list MalList/start @ { start }
+ start @ pr-buf a-space start cell+ @ pr-buf
+ count 2 / 1 ?do
+ s" , " str-append
+ start i 2 * cells + @ pr-buf a-space
+ start i 2 * 1+ cells + @ pr-buf
+ loop
+ endif
+ s" }" str-append ;;
+drop
+
+MalInt
+ extend pr-buf
+ MalInt/int @ int>str str-append ;;
+drop
+
+MalSymbol
+ extend pr-buf
+ unpack-sym str-append ;;
+drop
+
+MalKeyword
+ extend pr-buf { kw }
+ s" :" str-append
+ kw unpack-keyword str-append ;;
+drop
+
+: escape-str { addr len }
+ s\" \"" str-append
+ addr len + addr ?do
+ i c@ case
+ [char] " of s\" \\\"" str-append endof
+ [char] \ of s\" \\\\" str-append endof
+ 10 of s\" \\n" str-append endof
+ 13 of s\" \\r" str-append endof
+ -rot i 1 str-append rot
+ endcase
+ loop
+ s\" \"" str-append ;
+
+MalString
+ extend pr-buf
+ dup MalString/str-addr @
+ swap MalString/str-len @
+ 4 pick if
+ escape-str
+ else
+ str-append
+ endif ;;
+drop
+
+Atom
+ extend pr-buf { this }
+ s" (atom " str-append
+ this Atom/val @ pr-buf
+ s" )" str-append ;;
+drop \ No newline at end of file
diff --git a/forth/reader.fs b/forth/reader.fs
new file mode 100644
index 0000000..134749b
--- /dev/null
+++ b/forth/reader.fs
@@ -0,0 +1,147 @@
+require types.fs
+require printer.fs
+
+\ Drop a char off the front of string by advancing the addr and
+\ decrementing the length, and fetch next char
+: adv-str ( str-addr str-len -- str-addr str-len char )
+ swap 1+ swap 1-
+ dup 0= if 0 ( eof )
+ else over c@ endif ;
+
+: mal-digit? ( char -- flag )
+ dup [char] 9 <= if
+ [char] 0 >=
+ else
+ drop 0
+ endif ;
+
+: char-in-str? ( char str-addr str-len )
+ rot { needle }
+ false -rot
+ over + swap ?do
+ i c@ needle = if drop true leave endif
+ loop ;
+
+: sym-char? ( char -- flag )
+ s\" \n\r\t\000[]{}()'\"`,; " char-in-str? 0= ;
+
+: skip-spaces ( str-addr str-len char -- str-addr str-len non-space-char )
+ begin
+ begin
+ dup s\" \n\r\t, " char-in-str?
+ while ( str-addr str-len space-char )
+ drop adv-str
+ repeat
+ dup [char] ; = if
+ drop
+ begin
+ adv-str s\" \n\r\000" char-in-str?
+ until
+ adv-str false
+ else
+ true
+ endif
+ until ;
+
+defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
+
+: read-int ( str-addr str-len digit-char -- str-addr str-len non-digit-char mal-int )
+ 0 { int }
+ begin ( str-addr str-len digit-char )
+ [char] 0 - int 10 * + to int ( str-addr str-len )
+ adv-str dup mal-digit? 0= ( str-addr str-len digit-char )
+ until
+ int MalInt. ;
+
+: read-symbol-str ( str-addr str-len sym-char -- str-addr str-len char sym-addr sym-len )
+ new-str { sym-addr sym-len }
+ begin ( str-addr str-len sym-char )
+ sym-addr sym-len rot str-append-char to sym-len to sym-addr
+ adv-str dup sym-char? 0=
+ until
+ sym-addr sym-len ;
+
+: read-string-literal ( in-addr in-len quote-char -- in-addr in-len mal-string )
+ new-str { out-addr out-len }
+ drop \ drop leading quote
+ begin ( in-addr in-len )
+ adv-str over 0= if
+ 2drop 0 0 s\" expected '\"', got EOF" ...throw-str
+ endif
+ dup [char] " <>
+ while
+ dup [char] \ = if
+ drop adv-str
+ dup [char] n = if drop 10 endif
+ dup [char] r = if drop 13 endif
+ endif
+ out-addr out-len rot str-append-char to out-len to out-addr
+ repeat
+ drop adv-str \ skip trailing quote
+ out-addr out-len MalString. ;
+
+: read-list ( str-addr str-len open-paren-char close-paren-char
+ -- str-addr str-len non-paren-char mal-list )
+ here { close-char old-here }
+ drop adv-str
+ begin ( str-addr str-len char )
+ skip-spaces ( str-addr str-len non-space-char )
+ over 0= if
+ drop 2drop 0 0 s" ', got EOF"
+ close-char pad ! pad 1
+ s" expected '" ...throw-str
+ endif
+ dup close-char <>
+ while ( str-addr str-len non-space-non-paren-char )
+ read-form ,
+ repeat
+ drop adv-str
+ old-here here>MalList ;
+
+s" deref" MalSymbol. constant deref-sym
+s" quote" MalSymbol. constant quote-sym
+s" quasiquote" MalSymbol. constant quasiquote-sym
+s" splice-unquote" MalSymbol. constant splice-unquote-sym
+s" unquote" MalSymbol. constant unquote-sym
+
+: read-wrapped ( buf-addr buf-len quote-char sym-addr sym-len -- buf-addr buf-len char mal-list )
+ here { old-here }
+ , ( buf-addr buf-len char )
+ read-form , ( buf-addr buf-len char )
+ old-here here>MalList ;
+
+: read-form2 ( str-addr str-len char -- str-addr str-len char mal-obj )
+ skip-spaces
+ dup mal-digit? if read-int else
+ dup [char] ( = if [char] ) read-list else
+ dup [char] [ = if [char] ] read-list MalVector new tuck MalVector/list ! else
+ dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else
+ dup [char] " = if read-string-literal else
+ dup [char] : = if drop adv-str read-symbol-str MalKeyword. else
+ dup [char] @ = if drop adv-str deref-sym read-wrapped else
+ dup [char] ' = if drop adv-str quote-sym read-wrapped else
+ dup [char] ` = if drop adv-str quasiquote-sym read-wrapped else
+ dup [char] ~ = if
+ drop adv-str
+ dup [char] @ = if drop adv-str splice-unquote-sym read-wrapped
+ else unquote-sym read-wrapped
+ endif
+ else
+ dup [char] ^ = if
+ drop adv-str
+ read-form { meta } read-form { obj }
+ meta mal-nil conj
+ obj swap conj
+ s" with-meta" MalSymbol. swap conj
+ else
+ read-symbol-str
+ 2dup s" true" str= if 2drop mal-true
+ else 2dup s" false" str= if 2drop mal-false
+ else 2dup s" nil" str= if 2drop mal-nil
+ else
+ MalSymbol.
+ endif endif endif endif endif endif endif endif endif endif endif endif endif endif ;
+' read-form2 is read-form
+
+: read-str ( str-addr str-len - mal-obj )
+ over c@ read-form { obj } drop 2drop obj ;
diff --git a/forth/step0_repl.fs b/forth/step0_repl.fs
new file mode 100644
index 0000000..2483c12
--- /dev/null
+++ b/forth/step0_repl.fs
@@ -0,0 +1,23 @@
+require types.fs
+
+: read ;
+: eval ;
+: print ;
+
+: rep
+ read
+ eval
+ print ;
+
+create buff 128 allot
+
+: read-lines
+ begin
+ ." user> "
+ buff 128 stdin read-line throw
+ while
+ buff swap
+ rep type cr
+ repeat ;
+
+read-lines \ No newline at end of file
diff --git a/forth/step1_read_print.fs b/forth/step1_read_print.fs
new file mode 100644
index 0000000..9e42995
--- /dev/null
+++ b/forth/step1_read_print.fs
@@ -0,0 +1,34 @@
+require reader.fs
+require printer.fs
+
+: read read-str ;
+: eval ;
+: print
+ \ ." Type: " dup mal-type @ type-name safe-type cr
+ pr-str ;
+
+: rep ( str-addr str-len -- str-addr str-len )
+ read
+ eval
+ print ;
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: read-lines
+ begin
+ ." user> "
+ stack-leak-detect
+ buff 128 stdin read-line throw
+ while ( num-bytes-read )
+ buff swap ( str-addr str-len )
+ ['] rep
+ \ execute safe-type
+ catch ?dup 0= if safe-type else ." Caught error " . endif
+ cr
+ stack-leak-detect <> if ." --stack leak--" cr endif
+ repeat ;
+
+read-lines
+cr
+bye
diff --git a/forth/step2_eval.fs b/forth/step2_eval.fs
new file mode 100644
index 0000000..2b55ce0
--- /dev/null
+++ b/forth/step2_eval.fs
@@ -0,0 +1,117 @@
+require reader.fs
+require printer.fs
+
+: args-as-native { argv argc -- entry*argc... }
+ argc 0 ?do
+ argv i cells + @ as-native
+ loop ;
+
+MalMap/Empty
+ s" +" MalSymbol. :noname args-as-native + MalInt. ; MalNativeFn. rot assoc
+ s" -" MalSymbol. :noname args-as-native - MalInt. ; MalNativeFn. rot assoc
+ s" *" MalSymbol. :noname args-as-native * MalInt. ; MalNativeFn. rot assoc
+ s" /" MalSymbol. :noname args-as-native / MalInt. ; MalNativeFn. rot assoc
+value repl-env
+
+: read read-str ;
+: eval ( env obj ) mal-eval ;
+: print
+ \ ." Type: " dup mal-type @ type-name safe-type cr
+ pr-str ;
+
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
+
+MalKeyword
+ extend eval-invoke { env list kw -- val }
+ 0 kw env list MalList/start @ cell+ @ eval get
+ ?dup 0= if
+ \ compute not-found value
+ list MalList/count @ 1 > if
+ env list MalList/start @ 2 cells + @ eval
+ else
+ mal-nil
+ endif
+ endif ;;
+drop
+
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+ list MalList/start @ cell+ { expr-start }
+ list MalList/count @ 1- { argc }
+ argc cells allocate throw { target }
+ argc 0 ?do
+ env expr-start i cells + @ eval
+ target i cells + !
+ loop
+ target argc ;
+
+MalNativeFn
+ extend eval-invoke ( env list this -- list )
+ MalNativeFn/xt @ { xt }
+ eval-rest ( argv argc )
+ xt execute ( return-val ) ;;
+drop
+
+MalSymbol
+ extend mal-eval { env sym -- val }
+ 0 sym env get
+ dup 0= if
+ drop
+ ." Symbol '"
+ sym as-native safe-type
+ ." ' not found." cr
+ 1 throw
+ endif ;;
+drop
+
+: eval-ast { env list -- list }
+ here
+ list MalList/start @ { expr-start }
+ list MalList/count @ 0 ?do
+ env expr-start i cells + @ eval ,
+ loop
+ here>MalList ;
+
+MalList
+ extend mal-eval { env list -- val }
+ env list MalList/start @ @ eval
+ env list rot eval-invoke ;;
+drop
+
+MalVector
+ extend mal-eval ( env vector -- vector )
+ MalVector/list @ eval-ast
+ MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+ extend mal-eval ( env map -- map )
+ MalMap/list @ eval-ast
+ MalMap new swap over MalMap/list ! ;;
+drop
+
+: rep ( str-addr str-len -- str-addr str-len )
+ read
+ repl-env swap eval
+ print ;
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: read-lines
+ begin
+ ." user> "
+ stack-leak-detect
+ buff 128 stdin read-line throw
+ while ( num-bytes-read )
+ buff swap ( str-addr str-len )
+ ['] rep
+ \ execute safe-type
+ catch ?dup 0= if safe-type else ." Caught error " . endif
+ cr
+ stack-leak-detect <> if ." --stack leak--" cr endif
+ repeat ;
+
+read-lines
+cr
+bye
diff --git a/forth/step3_env.fs b/forth/step3_env.fs
new file mode 100644
index 0000000..676bfcc
--- /dev/null
+++ b/forth/step3_env.fs
@@ -0,0 +1,154 @@
+require reader.fs
+require printer.fs
+require env.fs
+
+: args-as-native { argv argc -- entry*argc... }
+ argc 0 ?do
+ argv i cells + @ as-native
+ loop ;
+
+0 MalEnv. constant repl-env
+s" +" MalSymbol. :noname args-as-native + MalInt. ; MalNativeFn. repl-env env/set
+s" -" MalSymbol. :noname args-as-native - MalInt. ; MalNativeFn. repl-env env/set
+s" *" MalSymbol. :noname args-as-native * MalInt. ; MalNativeFn. repl-env env/set
+s" /" MalSymbol. :noname args-as-native / MalInt. ; MalNativeFn. repl-env env/set
+
+: read read-str ;
+: eval ( env obj ) mal-eval ;
+: print
+ \ ." Type: " dup mal-type @ type-name safe-type cr
+ pr-str ;
+
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
+
+MalKeyword
+ extend eval-invoke { env list kw -- val }
+ 0 kw env list MalList/start @ cell+ @ eval get
+ ?dup 0= if
+ \ compute not-found value
+ list MalList/count @ 1 > if
+ env list MalList/start @ 2 cells + @ eval
+ else
+ mal-nil
+ endif
+ endif ;;
+drop
+
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+ list MalList/start @ cell+ { expr-start }
+ list MalList/count @ 1- { argc }
+ argc cells allocate throw { target }
+ argc 0 ?do
+ env expr-start i cells + @ eval
+ target i cells + !
+ loop
+ target argc ;
+
+MalNativeFn
+ extend eval-invoke ( env list this -- list )
+ MalNativeFn/xt @ { xt }
+ eval-rest ( argv argc )
+ xt execute ( return-val ) ;;
+drop
+
+SpecialOp
+ extend eval-invoke ( env list this -- list )
+ SpecialOp/xt @ execute ;;
+drop
+
+: install-special ( symbol xt )
+ SpecialOp. repl-env env/set ;
+
+: defspecial
+ parse-allot-name MalSymbol.
+ ['] install-special
+ :noname
+ ;
+
+defspecial quote ( env list -- form )
+ nip MalList/start @ cell+ @ ;;
+
+defspecial def! { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ arg0 @ ( key )
+ env arg0 cell+ @ eval dup { val } ( key val )
+ env env/set val ;;
+
+defspecial let* { old-env list -- val }
+ old-env MalEnv. { env }
+ list MalList/start @ cell+ dup { arg0 }
+ @ to-list
+ dup MalList/start @ { bindings-start } ( list )
+ MalList/count @ 0 +do
+ bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+ env swap eval
+ env env/set
+ 2 +loop
+ env arg0 cell+ @ eval
+ \ TODO: dec refcount of env
+ ;;
+
+MalSymbol
+ extend mal-eval { env sym -- val }
+ 0 sym env get
+ dup 0= if
+ drop
+ ." Symbol '"
+ sym as-native safe-type
+ ." ' not found." cr
+ 1 throw
+ endif ;;
+drop
+
+: eval-ast { env list -- list }
+ here
+ list MalList/start @ { expr-start }
+ list MalList/count @ 0 ?do
+ env expr-start i cells + @ eval ,
+ loop
+ here>MalList ;
+
+MalList
+ extend mal-eval { env list -- val }
+ env list MalList/start @ @ eval
+ env list rot eval-invoke ;;
+drop
+
+MalVector
+ extend mal-eval ( env vector -- vector )
+ MalVector/list @ eval-ast
+ MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+ extend mal-eval ( env map -- map )
+ MalMap/list @ eval-ast
+ MalMap new swap over MalMap/list ! ;;
+drop
+
+: rep ( str-addr str-len -- str-addr str-len )
+ read
+ repl-env swap eval
+ print ;
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: read-lines
+ begin
+ ." user> "
+ stack-leak-detect
+ buff 128 stdin read-line throw
+ while ( num-bytes-read )
+ buff swap ( str-addr str-len )
+ ['] rep
+ \ execute safe-type
+ catch ?dup 0= if safe-type else ." Caught error " . endif
+ cr
+ stack-leak-detect <> if ." --stack leak--" cr endif
+ repeat ;
+
+read-lines
+cr
+bye
diff --git a/forth/step4_if_fn_do.fs b/forth/step4_if_fn_do.fs
new file mode 100644
index 0000000..4fd277e
--- /dev/null
+++ b/forth/step4_if_fn_do.fs
@@ -0,0 +1,214 @@
+require reader.fs
+require printer.fs
+require core.fs
+
+core MalEnv. constant repl-env
+
+: read read-str ;
+: eval ( env obj ) mal-eval ;
+: print
+ \ ." Type: " dup mal-type @ type-name safe-type cr
+ pr-str ;
+
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
+
+MalKeyword
+ extend eval-invoke { env list kw -- val }
+ 0 kw env list MalList/start @ cell+ @ eval get
+ ?dup 0= if
+ \ compute not-found value
+ list MalList/count @ 1 > if
+ env list MalList/start @ 2 cells + @ eval
+ else
+ mal-nil
+ endif
+ endif ;;
+drop
+
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+ list MalList/start @ cell+ { expr-start }
+ list MalList/count @ 1- { argc }
+ argc cells allocate throw { target }
+ argc 0 ?do
+ env expr-start i cells + @ eval
+ target i cells + !
+ loop
+ target argc ;
+
+MalNativeFn
+ extend eval-invoke ( env list this -- list )
+ MalNativeFn/xt @ { xt }
+ eval-rest ( argv argc )
+ xt execute ( return-val ) ;;
+drop
+
+SpecialOp
+ extend eval-invoke ( env list this -- list )
+ SpecialOp/xt @ execute ;;
+drop
+
+: install-special ( symbol xt )
+ SpecialOp. repl-env env/set ;
+
+: defspecial
+ parse-allot-name MalSymbol.
+ ['] install-special
+ :noname
+ ;
+
+defspecial quote ( env list -- form )
+ nip MalList/start @ cell+ @ ;;
+
+defspecial def! { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ arg0 @ ( key )
+ env arg0 cell+ @ eval dup { val } ( key val )
+ env env/set val ;;
+
+defspecial let* { old-env list -- val }
+ old-env MalEnv. { env }
+ list MalList/start @ cell+ dup { arg0 }
+ @ to-list
+ dup MalList/start @ { bindings-start } ( list )
+ MalList/count @ 0 +do
+ bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+ env swap eval
+ env env/set
+ 2 +loop
+ env arg0 cell+ @ eval
+ \ TODO: dec refcount of env
+ ;;
+
+defspecial do { env list -- val }
+ list MalList/start @
+ 0
+ list MalList/count @ 1 ?do
+ drop
+ dup i cells + @ env swap eval
+ loop
+ nip ;;
+
+defspecial if { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ env arg0 @ eval ( test-val )
+ dup mal-false = if
+ drop -1
+ else
+ mal-nil =
+ endif
+ if
+ \ branch to false
+ list MalList/count @ 3 > if
+ env arg0 cell+ cell+ @ eval
+ else
+ mal-nil
+ endif
+ else
+ \ branch to true
+ env arg0 cell+ @ eval
+ endif ;;
+
+s" &" MalSymbol. constant &-sym
+
+MalUserFn
+ extend eval-invoke { call-env list mal-fn -- list }
+ call-env list eval-rest { argv argc }
+
+ mal-fn MalUserFn/formal-args @ { f-args-list }
+ mal-fn MalUserFn/env @ MalEnv. { env }
+
+ f-args-list MalList/start @ { f-args }
+ f-args-list MalList/count @ ?dup 0= if else
+ \ pass nil for last arg, unless overridden below
+ 1- cells f-args + @ mal-nil env env/set
+ endif
+ argc 0 ?do
+ f-args i cells + @
+ dup &-sym m= if
+ drop
+ f-args i 1+ cells + @ ( more-args-symbol )
+ MalList new ( sym more-args )
+ argc i - dup { c } over MalList/count !
+ c cells allocate throw dup { start } over MalList/start !
+ argv i cells + start c cells cmove
+ env env/set
+ leave
+ endif
+ argv i cells + @
+ env env/set
+ loop
+
+ env mal-fn MalUserFn/body @ eval ;;
+drop
+
+defspecial fn* { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ MalUserFn new
+ env over MalUserFn/env !
+ arg0 @ to-list over MalUserFn/formal-args !
+ arg0 cell+ @ over MalUserFn/body ! ;;
+
+MalSymbol
+ extend mal-eval { env sym -- val }
+ 0 sym env get
+ dup 0= if
+ drop
+ ." Symbol '"
+ sym as-native safe-type
+ ." ' not found." cr
+ 1 throw
+ endif ;;
+drop
+
+: eval-ast { env list -- list }
+ here
+ list MalList/start @ { expr-start }
+ list MalList/count @ 0 ?do
+ env expr-start i cells + @ eval ,
+ loop
+ here>MalList ;
+
+MalList
+ extend mal-eval { env list -- val }
+ env list MalList/start @ @ eval
+ env list rot eval-invoke ;;
+drop
+
+MalVector
+ extend mal-eval ( env vector -- vector )
+ MalVector/list @ eval-ast
+ MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+ extend mal-eval ( env map -- map )
+ MalMap/list @ eval-ast
+ MalMap new swap over MalMap/list ! ;;
+drop
+
+: rep ( str-addr str-len -- str-addr str-len )
+ read
+ repl-env swap eval
+ print ;
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: read-lines
+ begin
+ ." user> "
+ stack-leak-detect
+ buff 128 stdin read-line throw
+ while ( num-bytes-read )
+ buff swap ( str-addr str-len )
+ ['] rep
+ \ execute safe-type
+ catch ?dup 0= if safe-type else ." Caught error " . endif
+ cr
+ stack-leak-detect <> if ." --stack leak--" cr endif
+ repeat ;
+
+read-lines
+cr
+bye
diff --git a/forth/step5_tco.fs b/forth/step5_tco.fs
new file mode 100644
index 0000000..f7372db
--- /dev/null
+++ b/forth/step5_tco.fs
@@ -0,0 +1,225 @@
+require reader.fs
+require printer.fs
+require core.fs
+
+core MalEnv. constant repl-env
+
+99999999 constant TCO-eval
+
+: read read-str ;
+: eval ( env obj )
+ begin
+ \ ." eval-> " dup pr-str safe-type cr
+ mal-eval
+ dup TCO-eval =
+ while
+ drop
+ repeat ;
+: print
+ \ ." Type: " dup mal-type @ type-name safe-type cr
+ pr-str ;
+
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
+
+MalKeyword
+ extend eval-invoke { env list kw -- val }
+ 0 kw env list MalList/start @ cell+ @ eval get
+ ?dup 0= if
+ \ compute not-found value
+ list MalList/count @ 1 > if
+ env list MalList/start @ 2 cells + @ TCO-eval
+ else
+ mal-nil
+ endif
+ endif ;;
+drop
+
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+ list MalList/start @ cell+ { expr-start }
+ list MalList/count @ 1- { argc }
+ argc cells allocate throw { target }
+ argc 0 ?do
+ env expr-start i cells + @ eval
+ target i cells + !
+ loop
+ target argc ;
+
+MalNativeFn
+ extend eval-invoke ( env list this -- list )
+ MalNativeFn/xt @ { xt }
+ eval-rest ( argv argc )
+ xt execute ( return-val ) ;;
+drop
+
+SpecialOp
+ extend eval-invoke ( env list this -- list )
+ SpecialOp/xt @ execute ;;
+drop
+
+: install-special ( symbol xt )
+ SpecialOp. repl-env env/set ;
+
+: defspecial
+ parse-allot-name MalSymbol.
+ ['] install-special
+ :noname
+ ;
+
+defspecial quote ( env list -- form )
+ nip MalList/start @ cell+ @ ;;
+
+defspecial def! { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ arg0 @ ( key )
+ env arg0 cell+ @ eval dup { val } ( key val )
+ env env/set val ;;
+
+defspecial let* { old-env list -- val }
+ old-env MalEnv. { env }
+ list MalList/start @ cell+ dup { arg0 }
+ @ to-list
+ dup MalList/start @ { bindings-start } ( list )
+ MalList/count @ 0 +do
+ bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+ env swap eval
+ env env/set
+ 2 +loop
+ env arg0 cell+ @ TCO-eval
+ \ TODO: dec refcount of env
+ ;;
+
+defspecial do { env list -- val }
+ list MalList/start @ { start }
+ list MalList/count @ dup 1- { last } 1 ?do
+ env start i cells + @
+ i last = if
+ TCO-eval
+ else
+ eval drop
+ endif
+ loop ;;
+
+defspecial if { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ env arg0 @ eval ( test-val )
+ dup mal-false = if
+ drop -1
+ else
+ mal-nil =
+ endif
+ if
+ \ branch to false
+ list MalList/count @ 3 > if
+ env arg0 cell+ cell+ @ TCO-eval
+ else
+ mal-nil
+ endif
+ else
+ \ branch to true
+ env arg0 cell+ @ TCO-eval
+ endif ;;
+
+s" &" MalSymbol. constant &-sym
+
+MalUserFn
+ extend eval-invoke { call-env list mal-fn -- list }
+ call-env list eval-rest { argv argc }
+
+ mal-fn MalUserFn/formal-args @ { f-args-list }
+ mal-fn MalUserFn/env @ MalEnv. { env }
+
+ f-args-list MalList/start @ { f-args }
+ f-args-list MalList/count @ ?dup 0= if else
+ \ pass nil for last arg, unless overridden below
+ 1- cells f-args + @ mal-nil env env/set
+ endif
+ argc 0 ?do
+ f-args i cells + @
+ dup &-sym m= if
+ drop
+ f-args i 1+ cells + @ ( more-args-symbol )
+ MalList new ( sym more-args )
+ argc i - dup { c } over MalList/count !
+ c cells allocate throw dup { start } over MalList/start !
+ argv i cells + start c cells cmove
+ env env/set
+ leave
+ endif
+ argv i cells + @
+ env env/set
+ loop
+
+ env mal-fn MalUserFn/body @ TCO-eval ;;
+drop
+
+defspecial fn* { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ MalUserFn new
+ env over MalUserFn/env !
+ arg0 @ to-list over MalUserFn/formal-args !
+ arg0 cell+ @ over MalUserFn/body ! ;;
+
+MalSymbol
+ extend mal-eval { env sym -- val }
+ 0 sym env get
+ dup 0= if
+ drop
+ ." Symbol '"
+ sym as-native safe-type
+ ." ' not found." cr
+ 1 throw
+ endif ;;
+drop
+
+: eval-ast { env list -- list }
+ here
+ list MalList/start @ { expr-start }
+ list MalList/count @ 0 ?do
+ env expr-start i cells + @ eval ,
+ loop
+ here>MalList ;
+
+MalList
+ extend mal-eval { env list -- val }
+ env list MalList/start @ @ eval
+ env list rot eval-invoke ;;
+drop
+
+MalVector
+ extend mal-eval ( env vector -- vector )
+ MalVector/list @ eval-ast
+ MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+ extend mal-eval ( env map -- map )
+ MalMap/list @ eval-ast
+ MalMap new swap over MalMap/list ! ;;
+drop
+
+: rep ( str-addr str-len -- str-addr str-len )
+ read
+ repl-env swap eval
+ print ;
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: read-lines
+ begin
+ ." user> "
+ stack-leak-detect
+ buff 128 stdin read-line throw
+ while ( num-bytes-read )
+ buff swap ( str-addr str-len )
+ ['] rep
+ \ execute safe-type
+ catch ?dup 0= if safe-type else ." Caught error " . endif
+ cr
+ stack-leak-detect <> if ." --stack leak--" cr endif
+ repeat ;
+
+read-lines
+cr
+bye
diff --git a/forth/step6_file.fs b/forth/step6_file.fs
new file mode 100644
index 0000000..b3945ad
--- /dev/null
+++ b/forth/step6_file.fs
@@ -0,0 +1,252 @@
+require reader.fs
+require printer.fs
+require core.fs
+
+core MalEnv. constant repl-env
+
+99999999 constant TCO-eval
+
+: read read-str ;
+: eval ( env obj )
+ begin
+ \ ." eval-> " dup pr-str safe-type cr
+ mal-eval
+ dup TCO-eval =
+ while
+ drop
+ repeat ;
+: print
+ \ ." Type: " dup mal-type @ type-name safe-type cr
+ pr-str ;
+
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
+
+MalKeyword
+ extend eval-invoke { env list kw -- val }
+ 0 kw env list MalList/start @ cell+ @ eval get
+ ?dup 0= if
+ \ compute not-found value
+ list MalList/count @ 1 > if
+ env list MalList/start @ 2 cells + @ TCO-eval
+ else
+ mal-nil
+ endif
+ endif ;;
+drop
+
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+ list MalList/start @ cell+ { expr-start }
+ list MalList/count @ 1- { argc }
+ argc cells allocate throw { target }
+ argc 0 ?do
+ env expr-start i cells + @ eval
+ target i cells + !
+ loop
+ target argc ;
+
+MalNativeFn
+ extend eval-invoke ( env list this -- list )
+ MalNativeFn/xt @ { xt }
+ eval-rest ( argv argc )
+ xt execute ( return-val ) ;;
+drop
+
+SpecialOp
+ extend eval-invoke ( env list this -- list )
+ SpecialOp/xt @ execute ;;
+drop
+
+: install-special ( symbol xt )
+ SpecialOp. repl-env env/set ;
+
+: defspecial
+ parse-allot-name MalSymbol.
+ ['] install-special
+ :noname
+ ;
+
+defspecial quote ( env list -- form )
+ nip MalList/start @ cell+ @ ;;
+
+defspecial def! { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ arg0 @ ( key )
+ env arg0 cell+ @ eval dup { val } ( key val )
+ env env/set val ;;
+
+defspecial let* { old-env list -- val }
+ old-env MalEnv. { env }
+ list MalList/start @ cell+ dup { arg0 }
+ @ to-list
+ dup MalList/start @ { bindings-start } ( list )
+ MalList/count @ 0 +do
+ bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+ env swap eval
+ env env/set
+ 2 +loop
+ env arg0 cell+ @ TCO-eval
+ \ TODO: dec refcount of env
+ ;;
+
+defspecial do { env list -- val }
+ list MalList/start @ { start }
+ list MalList/count @ dup 1- { last } 1 ?do
+ env start i cells + @
+ i last = if
+ TCO-eval
+ else
+ eval drop
+ endif
+ loop ;;
+
+defspecial if { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ env arg0 @ eval ( test-val )
+ dup mal-false = if
+ drop -1
+ else
+ mal-nil =
+ endif
+ if
+ \ branch to false
+ list MalList/count @ 3 > if
+ env arg0 cell+ cell+ @ TCO-eval
+ else
+ mal-nil
+ endif
+ else
+ \ branch to true
+ env arg0 cell+ @ TCO-eval
+ endif ;;
+
+s" &" MalSymbol. constant &-sym
+
+MalUserFn
+ extend eval-invoke { call-env list mal-fn -- list }
+ call-env list eval-rest { argv argc }
+
+ mal-fn MalUserFn/formal-args @ { f-args-list }
+ mal-fn MalUserFn/env @ MalEnv. { env }
+
+ f-args-list MalList/start @ { f-args }
+ f-args-list MalList/count @ ?dup 0= if else
+ \ pass nil for last arg, unless overridden below
+ 1- cells f-args + @ mal-nil env env/set
+ endif
+ argc 0 ?do
+ f-args i cells + @
+ dup &-sym m= if
+ drop
+ f-args i 1+ cells + @ ( more-args-symbol )
+ MalList new ( sym more-args )
+ argc i - dup { c } over MalList/count !
+ c cells allocate throw dup { start } over MalList/start !
+ argv i cells + start c cells cmove
+ env env/set
+ leave
+ endif
+ argv i cells + @
+ env env/set
+ loop
+
+ env mal-fn MalUserFn/body @ TCO-eval ;;
+drop
+
+defspecial fn* { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ MalUserFn new
+ env over MalUserFn/env !
+ arg0 @ to-list over MalUserFn/formal-args !
+ arg0 cell+ @ over MalUserFn/body ! ;;
+
+MalSymbol
+ extend mal-eval { env sym -- val }
+ 0 sym env get
+ dup 0= if
+ drop
+ ." Symbol '"
+ sym as-native safe-type
+ ." ' not found." cr
+ 1 throw
+ endif ;;
+drop
+
+: eval-ast { env list -- list }
+ here
+ list MalList/start @ { expr-start }
+ list MalList/count @ 0 ?do
+ env expr-start i cells + @ eval ,
+ loop
+ here>MalList ;
+
+MalList
+ extend mal-eval { env list -- val }
+ env list MalList/start @ @ eval
+ env list rot eval-invoke ;;
+drop
+
+MalVector
+ extend mal-eval ( env vector -- vector )
+ MalVector/list @ eval-ast
+ MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+ extend mal-eval ( env map -- map )
+ MalMap/list @ eval-ast
+ MalMap new swap over MalMap/list ! ;;
+drop
+
+defcore eval ( argv argc )
+ drop @ repl-env swap eval ;;
+
+: rep ( str-addr str-len -- str-addr str-len )
+ read
+ repl-env swap eval
+ print ;
+
+: mk-args-list ( -- )
+ here
+ begin
+ next-arg 2dup 0 0 d<> while
+ MalString. ,
+ repeat
+ 2drop here>MalList ;
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep 2drop
+
+: repl ( -- )
+ begin
+ ." user> "
+ stack-leak-detect
+ buff 128 stdin read-line throw
+ while ( num-bytes-read )
+ buff swap ( str-addr str-len )
+ ['] rep
+ \ execute type
+ catch ?dup 0= if safe-type else ." Caught error " . endif
+ cr
+ stack-leak-detect <> if ." --stack leak--" cr endif
+ repeat ;
+
+: main ( -- )
+ mk-args-list { args-list }
+ args-list MalList/count @ 0= if
+ s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set
+ repl
+ else
+ args-list MalList/start @ @ { filename }
+ s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set
+
+ repl-env
+ here s" load-file" MalSymbol. , filename , here>MalList
+ eval print
+ endif ;
+
+main
+cr
+bye
diff --git a/forth/step7_quote.fs b/forth/step7_quote.fs
new file mode 100644
index 0000000..0c6b909
--- /dev/null
+++ b/forth/step7_quote.fs
@@ -0,0 +1,294 @@
+require reader.fs
+require printer.fs
+require core.fs
+
+core MalEnv. constant repl-env
+
+99999999 constant TCO-eval
+
+: read read-str ;
+: eval ( env obj )
+ begin
+ \ ." eval-> " dup pr-str safe-type cr
+ mal-eval
+ dup TCO-eval =
+ while
+ drop
+ repeat ;
+: print
+ \ ." Type: " dup mal-type @ type-name safe-type cr
+ pr-str ;
+
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
+
+MalKeyword
+ extend eval-invoke { env list kw -- val }
+ 0 kw env list MalList/start @ cell+ @ eval get
+ ?dup 0= if
+ \ compute not-found value
+ list MalList/count @ 1 > if
+ env list MalList/start @ 2 cells + @ TCO-eval
+ else
+ mal-nil
+ endif
+ endif ;;
+drop
+
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+ list MalList/start @ cell+ { expr-start }
+ list MalList/count @ 1- { argc }
+ argc cells allocate throw { target }
+ argc 0 ?do
+ env expr-start i cells + @ eval
+ target i cells + !
+ loop
+ target argc ;
+
+MalNativeFn
+ extend eval-invoke ( env list this -- list )
+ MalNativeFn/xt @ { xt }
+ eval-rest ( argv argc )
+ xt execute ( return-val ) ;;
+drop
+
+SpecialOp
+ extend eval-invoke ( env list this -- list )
+ SpecialOp/xt @ execute ;;
+drop
+
+: install-special ( symbol xt )
+ SpecialOp. repl-env env/set ;
+
+: defspecial
+ parse-allot-name MalSymbol.
+ ['] install-special
+ :noname
+ ;
+
+: is-pair? ( obj -- bool )
+ empty? mal-false = ;
+
+defspecial quote ( env list -- form )
+ nip MalList/start @ cell+ @ ;;
+
+s" concat" MalSymbol. constant concat-sym
+s" cons" MalSymbol. constant cons-sym
+
+defer quasiquote
+: quasiquote0 { ast -- form }
+ ast is-pair? 0= if
+ here quote-sym , ast , here>MalList
+ else
+ ast to-list MalList/start @ { ast-start }
+ ast-start @ { ast[0] }
+ ast[0] unquote-sym m= if
+ ast-start cell+ @
+ else
+ ast[0] is-pair? if
+ ast[0] to-list MalList/start @ { ast[0]-start }
+ ast[0]-start @ splice-unquote-sym m= if
+ here
+ concat-sym ,
+ ast[0]-start cell+ @ ,
+ ast to-list MalList/rest quasiquote ,
+ here>MalList
+ false
+ else true endif
+ else true endif
+ if
+ here
+ cons-sym ,
+ ast[0] quasiquote ,
+ ast to-list MalList/rest quasiquote ,
+ here>MalList
+ endif
+ endif
+ endif ;
+' quasiquote0 is quasiquote
+
+defspecial quasiquote ( env list )
+ MalList/start @ cell+ @ ( ast )
+ quasiquote TCO-eval ;;
+
+defspecial def! { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ arg0 @ ( key )
+ env arg0 cell+ @ eval dup { val } ( key val )
+ env env/set val ;;
+
+defspecial let* { old-env list -- val }
+ old-env MalEnv. { env }
+ list MalList/start @ cell+ dup { arg0 }
+ @ to-list
+ dup MalList/start @ { bindings-start } ( list )
+ MalList/count @ 0 +do
+ bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+ env swap eval
+ env env/set
+ 2 +loop
+ env arg0 cell+ @ TCO-eval
+ \ TODO: dec refcount of env
+ ;;
+
+defspecial do { env list -- val }
+ list MalList/start @ { start }
+ list MalList/count @ dup 1- { last } 1 ?do
+ env start i cells + @
+ i last = if
+ TCO-eval
+ else
+ eval drop
+ endif
+ loop ;;
+
+defspecial if { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ env arg0 @ eval ( test-val )
+ dup mal-false = if
+ drop -1
+ else
+ mal-nil =
+ endif
+ if
+ \ branch to false
+ list MalList/count @ 3 > if
+ env arg0 cell+ cell+ @ TCO-eval
+ else
+ mal-nil
+ endif
+ else
+ \ branch to true
+ env arg0 cell+ @ TCO-eval
+ endif ;;
+
+s" &" MalSymbol. constant &-sym
+
+MalUserFn
+ extend eval-invoke { call-env list mal-fn -- list }
+ call-env list eval-rest { argv argc }
+
+ mal-fn MalUserFn/formal-args @ { f-args-list }
+ mal-fn MalUserFn/env @ MalEnv. { env }
+
+ f-args-list MalList/start @ { f-args }
+ f-args-list MalList/count @ ?dup 0= if else
+ \ pass nil for last arg, unless overridden below
+ 1- cells f-args + @ mal-nil env env/set
+ endif
+ argc 0 ?do
+ f-args i cells + @
+ dup &-sym m= if
+ drop
+ f-args i 1+ cells + @ ( more-args-symbol )
+ MalList new ( sym more-args )
+ argc i - dup { c } over MalList/count !
+ c cells allocate throw dup { start } over MalList/start !
+ argv i cells + start c cells cmove
+ env env/set
+ leave
+ endif
+ argv i cells + @
+ env env/set
+ loop
+
+ env mal-fn MalUserFn/body @ TCO-eval ;;
+drop
+
+defspecial fn* { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ MalUserFn new
+ env over MalUserFn/env !
+ arg0 @ to-list over MalUserFn/formal-args !
+ arg0 cell+ @ over MalUserFn/body ! ;;
+
+MalSymbol
+ extend mal-eval { env sym -- val }
+ 0 sym env get
+ dup 0= if
+ drop
+ ." Symbol '"
+ sym as-native safe-type
+ ." ' not found." cr
+ 1 throw
+ endif ;;
+drop
+
+: eval-ast { env list -- list }
+ here
+ list MalList/start @ { expr-start }
+ list MalList/count @ 0 ?do
+ env expr-start i cells + @ eval ,
+ loop
+ here>MalList ;
+
+MalList
+ extend mal-eval { env list -- val }
+ env list MalList/start @ @ eval
+ env list rot eval-invoke ;;
+drop
+
+MalVector
+ extend mal-eval ( env vector -- vector )
+ MalVector/list @ eval-ast
+ MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+ extend mal-eval ( env map -- map )
+ MalMap/list @ eval-ast
+ MalMap new swap over MalMap/list ! ;;
+drop
+
+defcore eval ( argv argc )
+ drop @ repl-env swap eval ;;
+
+: rep ( str-addr str-len -- str-addr str-len )
+ read
+ repl-env swap eval
+ print ;
+
+: mk-args-list ( -- )
+ here
+ begin
+ next-arg 2dup 0 0 d<> while
+ MalString. ,
+ repeat
+ 2drop here>MalList ;
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep 2drop
+
+: repl ( -- )
+ begin
+ ." user> "
+ stack-leak-detect
+ buff 128 stdin read-line throw
+ while ( num-bytes-read )
+ buff swap ( str-addr str-len )
+ ['] rep
+ \ execute type
+ catch ?dup 0= if safe-type else ." Caught error " . endif
+ cr
+ stack-leak-detect <> if ." --stack leak--" cr endif
+ repeat ;
+
+: main ( -- )
+ mk-args-list { args-list }
+ args-list MalList/count @ 0= if
+ s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set
+ repl
+ else
+ args-list MalList/start @ @ { filename }
+ s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set
+
+ repl-env
+ here s" load-file" MalSymbol. , filename , here>MalList
+ eval print
+ endif ;
+
+main
+cr
+bye
diff --git a/forth/step8_macros.fs b/forth/step8_macros.fs
new file mode 100644
index 0000000..f01f3a9
--- /dev/null
+++ b/forth/step8_macros.fs
@@ -0,0 +1,324 @@
+require reader.fs
+require printer.fs
+require core.fs
+
+core MalEnv. constant repl-env
+
+99999999 constant TCO-eval
+
+: read read-str ;
+: eval ( env obj )
+ begin
+ \ ." eval-> " dup pr-str safe-type cr
+ mal-eval
+ dup TCO-eval =
+ while
+ drop
+ repeat ;
+: print
+ \ ." Type: " dup mal-type @ type-name safe-type cr
+ pr-str ;
+
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
+
+MalKeyword
+ extend eval-invoke { env list kw -- val }
+ 0 kw env list MalList/start @ cell+ @ eval get
+ ?dup 0= if
+ \ compute not-found value
+ list MalList/count @ 1 > if
+ env list MalList/start @ 2 cells + @ TCO-eval
+ else
+ mal-nil
+ endif
+ endif ;;
+drop
+
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+ list MalList/start @ cell+ { expr-start }
+ list MalList/count @ 1- { argc }
+ argc cells allocate throw { target }
+ argc 0 ?do
+ env expr-start i cells + @ eval
+ target i cells + !
+ loop
+ target argc ;
+
+MalNativeFn
+ extend eval-invoke ( env list this -- list )
+ MalNativeFn/xt @ { xt }
+ eval-rest ( argv argc )
+ xt execute ( return-val ) ;;
+drop
+
+SpecialOp
+ extend eval-invoke ( env list this -- list )
+ SpecialOp/xt @ execute ;;
+drop
+
+: install-special ( symbol xt )
+ SpecialOp. repl-env env/set ;
+
+: defspecial
+ parse-allot-name MalSymbol.
+ ['] install-special
+ :noname
+ ;
+
+: is-pair? ( obj -- bool )
+ empty? mal-false = ;
+
+defspecial quote ( env list -- form )
+ nip MalList/start @ cell+ @ ;;
+
+s" concat" MalSymbol. constant concat-sym
+s" cons" MalSymbol. constant cons-sym
+
+defer quasiquote
+: quasiquote0 { ast -- form }
+ ast is-pair? 0= if
+ here quote-sym , ast , here>MalList
+ else
+ ast to-list MalList/start @ { ast-start }
+ ast-start @ { ast[0] }
+ ast[0] unquote-sym m= if
+ ast-start cell+ @
+ else
+ ast[0] is-pair? if
+ ast[0] to-list MalList/start @ { ast[0]-start }
+ ast[0]-start @ splice-unquote-sym m= if
+ here
+ concat-sym ,
+ ast[0]-start cell+ @ ,
+ ast to-list MalList/rest quasiquote ,
+ here>MalList
+ false
+ else true endif
+ else true endif
+ if
+ here
+ cons-sym ,
+ ast[0] quasiquote ,
+ ast to-list MalList/rest quasiquote ,
+ here>MalList
+ endif
+ endif
+ endif ;
+' quasiquote0 is quasiquote
+
+defspecial quasiquote ( env list )
+ MalList/start @ cell+ @ ( ast )
+ quasiquote TCO-eval ;;
+
+defspecial def! { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ arg0 @ ( key )
+ env arg0 cell+ @ eval dup { val } ( key val )
+ env env/set val ;;
+
+defspecial defmacro! { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ arg0 @ ( key )
+ env arg0 cell+ @ eval { val }
+ true val MalUserFn/is-macro? !
+ val env env/set
+ val ;;
+
+defspecial let* { old-env list -- val }
+ old-env MalEnv. { env }
+ list MalList/start @ cell+ dup { arg0 }
+ @ to-list
+ dup MalList/start @ { bindings-start } ( list )
+ MalList/count @ 0 +do
+ bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+ env swap eval
+ env env/set
+ 2 +loop
+ env arg0 cell+ @ TCO-eval
+ \ TODO: dec refcount of env
+ ;;
+
+defspecial do { env list -- val }
+ list MalList/start @ { start }
+ list MalList/count @ dup 1- { last } 1 ?do
+ env start i cells + @
+ i last = if
+ TCO-eval
+ else
+ eval drop
+ endif
+ loop ;;
+
+defspecial if { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ env arg0 @ eval ( test-val )
+ dup mal-false = if
+ drop -1
+ else
+ mal-nil =
+ endif
+ if
+ \ branch to false
+ list MalList/count @ 3 > if
+ env arg0 cell+ cell+ @ TCO-eval
+ else
+ mal-nil
+ endif
+ else
+ \ branch to true
+ env arg0 cell+ @ TCO-eval
+ endif ;;
+
+s" &" MalSymbol. constant &-sym
+
+: new-user-fn-env { argv argc mal-fn -- env }
+ mal-fn MalUserFn/formal-args @ { f-args-list }
+ mal-fn MalUserFn/env @ MalEnv. { env }
+
+ f-args-list MalList/start @ { f-args }
+ f-args-list MalList/count @ ?dup 0= if else
+ \ pass nil for last arg, unless overridden below
+ 1- cells f-args + @ mal-nil env env/set
+ endif
+ argc 0 ?do
+ f-args i cells + @
+ dup &-sym m= if
+ drop
+ f-args i 1+ cells + @ ( more-args-symbol )
+ MalList new ( sym more-args )
+ argc i - dup { c } over MalList/count !
+ c cells allocate throw dup { start } over MalList/start !
+ argv i cells + start c cells cmove
+ env env/set
+ leave
+ endif
+ argv i cells + @
+ env env/set
+ loop
+ env ;
+
+MalUserFn
+ extend eval-invoke { call-env list mal-fn -- list }
+ mal-fn MalUserFn/is-macro? @ if
+ list MalList/start @ cell+ list MalList/count @ 1-
+ else
+ call-env list eval-rest
+ endif
+ mal-fn new-user-fn-env { env }
+
+ mal-fn MalUserFn/is-macro? @ if
+ env mal-fn MalUserFn/body @ eval
+ env swap TCO-eval
+ else
+ env mal-fn MalUserFn/body @ TCO-eval
+ endif ;;
+drop
+
+defspecial fn* { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ MalUserFn new
+ env over MalUserFn/env !
+ arg0 @ to-list over MalUserFn/formal-args !
+ arg0 cell+ @ over MalUserFn/body ! ;;
+
+defspecial macroexpand ( env list[_,form] -- form )
+ MalList/start @ cell+ @ swap over ( form env form )
+ MalList/start @ @ ( form env macro-name-expr )
+ eval { macro-fn } ( form )
+ dup MalList/start @ cell+ swap MalList/count @ 1- macro-fn ( argv argc fn )
+ new-user-fn-env ( env )
+ macro-fn MalUserFn/body @ TCO-eval ;;
+
+MalSymbol
+ extend mal-eval { env sym -- val }
+ 0 sym env get
+ dup 0= if
+ drop
+ ." Symbol '"
+ sym as-native safe-type
+ ." ' not found." cr
+ 1 throw
+ endif ;;
+drop
+
+: eval-ast { env list -- list }
+ here
+ list MalList/start @ { expr-start }
+ list MalList/count @ 0 ?do
+ env expr-start i cells + @ eval ,
+ loop
+ here>MalList ;
+
+MalList
+ extend mal-eval { env list -- val }
+ env list MalList/start @ @ eval
+ env list rot eval-invoke ;;
+drop
+
+MalVector
+ extend mal-eval ( env vector -- vector )
+ MalVector/list @ eval-ast
+ MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+ extend mal-eval ( env map -- map )
+ MalMap/list @ eval-ast
+ MalMap new swap over MalMap/list ! ;;
+drop
+
+defcore eval ( argv argc )
+ drop @ repl-env swap eval ;;
+
+: rep ( str-addr str-len -- str-addr str-len )
+ read
+ repl-env swap eval
+ print ;
+
+: mk-args-list ( -- )
+ here
+ begin
+ next-arg 2dup 0 0 d<> while
+ MalString. ,
+ repeat
+ 2drop here>MalList ;
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep 2drop
+s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep 2drop
+s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep 2drop
+
+: repl ( -- )
+ begin
+ ." user> "
+ stack-leak-detect
+ buff 128 stdin read-line throw
+ while ( num-bytes-read )
+ buff swap ( str-addr str-len )
+ ['] rep
+ \ execute type
+ catch ?dup 0= if safe-type else ." Caught error " . endif
+ cr
+ stack-leak-detect <> if ." --stack leak--" cr endif
+ repeat ;
+
+: main ( -- )
+ mk-args-list { args-list }
+ args-list MalList/count @ 0= if
+ s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set
+ repl
+ else
+ args-list MalList/start @ @ { filename }
+ s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set
+
+ repl-env
+ here s" load-file" MalSymbol. , filename , here>MalList
+ eval print
+ endif ;
+
+main
+cr
+bye
diff --git a/forth/step9_try.fs b/forth/step9_try.fs
new file mode 100644
index 0000000..e11c691
--- /dev/null
+++ b/forth/step9_try.fs
@@ -0,0 +1,379 @@
+require reader.fs
+require printer.fs
+require core.fs
+
+core MalEnv. constant repl-env
+
+99999999 constant TCO-eval
+
+: read read-str ;
+: eval ( env obj )
+ begin
+ \ ." eval-> " dup pr-str safe-type cr
+ mal-eval
+ dup TCO-eval =
+ while
+ drop
+ repeat ;
+: print
+ \ ." Type: " dup mal-type @ type-name safe-type cr
+ pr-str ;
+
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
+
+MalKeyword
+ extend eval-invoke { env list kw -- val }
+ 0 kw env list MalList/start @ cell+ @ eval get
+ ?dup 0= if
+ \ compute not-found value
+ list MalList/count @ 1 > if
+ env list MalList/start @ 2 cells + @ TCO-eval
+ else
+ mal-nil
+ endif
+ endif ;;
+ extend invoke { argv argc kw -- val }
+ 0 kw argv @ get
+ ?dup 0= if
+ argc 1 > if
+ argv cell+ @
+ else
+ mal-nil
+ endif
+ endif ;;
+drop
+
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+ list MalList/start @ cell+ { expr-start }
+ list MalList/count @ 1- { argc }
+ argc cells allocate throw { target }
+ argc 0 ?do
+ env expr-start i cells + @ eval
+ target i cells + !
+ loop
+ target argc ;
+
+MalNativeFn
+ extend eval-invoke { env list this -- list }
+ env list eval-rest ( argv argc )
+ this invoke ;;
+ extend invoke ( argv argc this -- val )
+ MalNativeFn/xt @ execute ;;
+drop
+
+SpecialOp
+ extend eval-invoke ( env list this -- list )
+ SpecialOp/xt @ execute ;;
+drop
+
+: install-special ( symbol xt )
+ SpecialOp. repl-env env/set ;
+
+: defspecial
+ parse-allot-name MalSymbol.
+ ['] install-special
+ :noname
+ ;
+
+: is-pair? ( obj -- bool )
+ empty? mal-false = ;
+
+defspecial quote ( env list -- form )
+ nip MalList/start @ cell+ @ ;;
+
+s" concat" MalSymbol. constant concat-sym
+s" cons" MalSymbol. constant cons-sym
+
+defer quasiquote
+: quasiquote0 { ast -- form }
+ ast is-pair? 0= if
+ here quote-sym , ast , here>MalList
+ else
+ ast to-list MalList/start @ { ast-start }
+ ast-start @ { ast[0] }
+ ast[0] unquote-sym m= if
+ ast-start cell+ @
+ else
+ ast[0] is-pair? if
+ ast[0] to-list MalList/start @ { ast[0]-start }
+ ast[0]-start @ splice-unquote-sym m= if
+ here
+ concat-sym ,
+ ast[0]-start cell+ @ ,
+ ast to-list MalList/rest quasiquote ,
+ here>MalList
+ false
+ else true endif
+ else true endif
+ if
+ here
+ cons-sym ,
+ ast[0] quasiquote ,
+ ast to-list MalList/rest quasiquote ,
+ here>MalList
+ endif
+ endif
+ endif ;
+' quasiquote0 is quasiquote
+
+defspecial quasiquote ( env list )
+ MalList/start @ cell+ @ ( ast )
+ quasiquote TCO-eval ;;
+
+defspecial def! { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ arg0 @ ( key )
+ env arg0 cell+ @ eval dup { val } ( key val )
+ env env/set val ;;
+
+defspecial defmacro! { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ arg0 @ ( key )
+ env arg0 cell+ @ eval { val }
+ true val MalUserFn/is-macro? !
+ val env env/set
+ val ;;
+
+defspecial let* { old-env list -- val }
+ old-env MalEnv. { env }
+ list MalList/start @ cell+ dup { arg0 }
+ @ to-list
+ dup MalList/start @ { bindings-start } ( list )
+ MalList/count @ 0 +do
+ bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+ env swap eval
+ env env/set
+ 2 +loop
+ env arg0 cell+ @ TCO-eval
+ \ TODO: dec refcount of env
+ ;;
+
+defspecial do { env list -- val }
+ list MalList/start @ { start }
+ list MalList/count @ dup 1- { last } 1 ?do
+ env start i cells + @
+ i last = if
+ TCO-eval
+ else
+ eval drop
+ endif
+ loop ;;
+
+defspecial if { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ env arg0 @ eval ( test-val )
+ dup mal-false = if
+ drop -1
+ else
+ mal-nil =
+ endif
+ if
+ \ branch to false
+ list MalList/count @ 3 > if
+ env arg0 cell+ cell+ @ TCO-eval
+ else
+ mal-nil
+ endif
+ else
+ \ branch to true
+ env arg0 cell+ @ TCO-eval
+ endif ;;
+
+s" &" MalSymbol. constant &-sym
+
+: new-user-fn-env { argv argc mal-fn -- env }
+ mal-fn MalUserFn/formal-args @ { f-args-list }
+ mal-fn MalUserFn/env @ MalEnv. { env }
+
+ f-args-list MalList/start @ { f-args }
+ f-args-list MalList/count @ ?dup 0= if else
+ \ pass nil for last arg, unless overridden below
+ 1- cells f-args + @ mal-nil env env/set
+ endif
+ argc 0 ?do
+ f-args i cells + @
+ dup &-sym m= if
+ drop
+ argc i - { c }
+ c cells allocate throw { start }
+ argv i cells + start c cells cmove
+ f-args i 1+ cells + @ ( more-args-symbol )
+ start c MalList. env env/set
+ leave
+ endif
+ argv i cells + @
+ env env/set
+ loop
+ env ;
+
+MalUserFn
+ extend eval-invoke { call-env list mal-fn -- list }
+ mal-fn MalUserFn/is-macro? @ if
+ list MalList/start @ cell+ \ argv
+ list MalList/count @ 1- \ argc
+ mal-fn new-user-fn-env { env }
+ env mal-fn MalUserFn/body @ eval
+ call-env swap TCO-eval
+ else
+ call-env list eval-rest
+ mal-fn invoke
+ endif ;;
+
+ extend invoke ( argv argc mal-fn )
+ dup { mal-fn } new-user-fn-env { env }
+ env mal-fn MalUserFn/body @ TCO-eval ;;
+drop
+
+defspecial fn* { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ MalUserFn new
+ false over MalUserFn/is-macro? !
+ env over MalUserFn/env !
+ arg0 @ to-list over MalUserFn/formal-args !
+ arg0 cell+ @ over MalUserFn/body ! ;;
+
+defspecial macroexpand ( env list[_,form] -- form )
+ MalList/start @ cell+ @ swap over ( form env form )
+ MalList/start @ @ ( form env macro-name-expr )
+ eval { macro-fn } ( form )
+ dup MalList/start @ cell+ swap MalList/count @ 1- macro-fn ( argv argc fn )
+ new-user-fn-env ( env )
+ macro-fn MalUserFn/body @ TCO-eval ;;
+
+5555555555 constant pre-try
+
+defspecial try* { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ pre-try
+ env arg0 @ ['] eval catch ?dup 0= if
+ nip
+ else { errno }
+ begin pre-try = until
+ errno 1 <> if
+ s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
+ to exception-object
+ endif
+ arg0 cell+ @ ( list[catch*,sym,form] )
+ MalList/start @ cell+ { catch0 }
+ env MalEnv. { catch-env }
+ catch0 @ exception-object catch-env env/set
+ catch-env catch0 cell+ @ TCO-eval
+ endif ;;
+
+MalSymbol
+ extend mal-eval { env sym -- val }
+ 0 sym env get
+ dup 0= if
+ drop
+ 0 0 s" ' not found" sym as-native s" '" ...throw-str
+ endif ;;
+drop
+
+: eval-ast { env list -- list }
+ here
+ list MalList/start @ { expr-start }
+ list MalList/count @ 0 ?do
+ env expr-start i cells + @ eval ,
+ loop
+ here>MalList ;
+
+MalList
+ extend mal-eval { env list -- val }
+ env list MalList/start @ @ eval
+ env list rot eval-invoke ;;
+drop
+
+MalVector
+ extend mal-eval ( env vector -- vector )
+ MalVector/list @ eval-ast
+ MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+ extend mal-eval ( env map -- map )
+ MalMap/list @ eval-ast
+ MalMap new swap over MalMap/list ! ;;
+drop
+
+defcore eval ( argv argc )
+ drop @ repl-env swap eval ;;
+
+: rep ( str-addr str-len -- str-addr str-len )
+ read
+ repl-env swap eval
+ print ;
+
+: mk-args-list ( -- )
+ here
+ begin
+ next-arg 2dup 0 0 d<> while
+ MalString. ,
+ repeat
+ 2drop here>MalList ;
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: nop ;
+
+defcore map ( argv argc -- list )
+ drop dup @ swap cell+ @ to-list { fn list }
+ here
+ list MalList/start @ list MalList/count @ cells over + swap +do
+ i 1 fn invoke
+ dup TCO-eval = if drop eval endif
+ ,
+ cell +loop
+ here>MalList ;;
+
+defcore readline ( argv argc -- mal-string )
+ drop @ unpack-str type stdout flush-file drop
+ buff 128 stdin read-line throw
+ if buff swap MalString. else drop mal-nil endif ;;
+
+s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep 2drop
+s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep 2drop
+s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep 2drop
+s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep 2drop
+
+: repl ( -- )
+ begin
+ ." user> "
+ stack-leak-detect
+ buff 128 stdin read-line throw
+ while ( num-bytes-read )
+ buff swap ( str-addr str-len )
+ ['] rep
+ \ execute ['] nop \ uncomment to see stack traces
+ catch ?dup 0= if
+ safe-type cr
+ stack-leak-detect <> if ." --stack leak--" cr endif
+ else { errno }
+ begin stack-leak-detect = until
+ errno 1 <> if
+ s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
+ to exception-object
+ endif
+ ." Uncaught exception: "
+ exception-object pr-str safe-type cr
+ endif
+ repeat ;
+
+: main ( -- )
+ mk-args-list { args-list }
+ args-list MalList/count @ 0= if
+ s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set
+ repl
+ else
+ args-list MalList/start @ @ { filename }
+ s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set
+
+ repl-env
+ here s" load-file" MalSymbol. , filename , here>MalList
+ eval print
+ endif ;
+
+main
+cr
+bye
diff --git a/forth/stepA_interop.fs b/forth/stepA_interop.fs
new file mode 100644
index 0000000..0a4050a
--- /dev/null
+++ b/forth/stepA_interop.fs
@@ -0,0 +1,381 @@
+require reader.fs
+require printer.fs
+require core.fs
+
+core MalEnv. constant repl-env
+
+99999999 constant TCO-eval
+
+: read read-str ;
+: eval ( env obj )
+ begin
+ \ ." eval-> " dup pr-str safe-type cr
+ mal-eval
+ dup TCO-eval =
+ while
+ drop
+ repeat ;
+: print
+ \ ." Type: " dup mal-type @ type-name safe-type cr
+ pr-str ;
+
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
+
+MalKeyword
+ extend eval-invoke { env list kw -- val }
+ 0 kw env list MalList/start @ cell+ @ eval get
+ ?dup 0= if
+ \ compute not-found value
+ list MalList/count @ 1 > if
+ env list MalList/start @ 2 cells + @ TCO-eval
+ else
+ mal-nil
+ endif
+ endif ;;
+ extend invoke { argv argc kw -- val }
+ 0 kw argv @ get
+ ?dup 0= if
+ argc 1 > if
+ argv cell+ @
+ else
+ mal-nil
+ endif
+ endif ;;
+drop
+
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+ list MalList/start @ cell+ { expr-start }
+ list MalList/count @ 1- { argc }
+ argc cells allocate throw { target }
+ argc 0 ?do
+ env expr-start i cells + @ eval
+ target i cells + !
+ loop
+ target argc ;
+
+MalNativeFn
+ extend eval-invoke { env list this -- list }
+ env list eval-rest ( argv argc )
+ this invoke ;;
+ extend invoke ( argv argc this -- val )
+ MalNativeFn/xt @ execute ;;
+drop
+
+SpecialOp
+ extend eval-invoke ( env list this -- list )
+ SpecialOp/xt @ execute ;;
+drop
+
+: install-special ( symbol xt )
+ SpecialOp. repl-env env/set ;
+
+: defspecial
+ parse-allot-name MalSymbol.
+ ['] install-special
+ :noname
+ ;
+
+: is-pair? ( obj -- bool )
+ empty? mal-false = ;
+
+defspecial quote ( env list -- form )
+ nip MalList/start @ cell+ @ ;;
+
+s" concat" MalSymbol. constant concat-sym
+s" cons" MalSymbol. constant cons-sym
+
+defer quasiquote
+: quasiquote0 { ast -- form }
+ ast is-pair? 0= if
+ here quote-sym , ast , here>MalList
+ else
+ ast to-list MalList/start @ { ast-start }
+ ast-start @ { ast[0] }
+ ast[0] unquote-sym m= if
+ ast-start cell+ @
+ else
+ ast[0] is-pair? if
+ ast[0] to-list MalList/start @ { ast[0]-start }
+ ast[0]-start @ splice-unquote-sym m= if
+ here
+ concat-sym ,
+ ast[0]-start cell+ @ ,
+ ast to-list MalList/rest quasiquote ,
+ here>MalList
+ false
+ else true endif
+ else true endif
+ if
+ here
+ cons-sym ,
+ ast[0] quasiquote ,
+ ast to-list MalList/rest quasiquote ,
+ here>MalList
+ endif
+ endif
+ endif ;
+' quasiquote0 is quasiquote
+
+defspecial quasiquote ( env list )
+ MalList/start @ cell+ @ ( ast )
+ quasiquote TCO-eval ;;
+
+defspecial def! { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ arg0 @ ( key )
+ env arg0 cell+ @ eval dup { val } ( key val )
+ env env/set val ;;
+
+defspecial defmacro! { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ arg0 @ ( key )
+ env arg0 cell+ @ eval { val }
+ true val MalUserFn/is-macro? !
+ val env env/set
+ val ;;
+
+defspecial let* { old-env list -- val }
+ old-env MalEnv. { env }
+ list MalList/start @ cell+ dup { arg0 }
+ @ to-list
+ dup MalList/start @ { bindings-start } ( list )
+ MalList/count @ 0 +do
+ bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+ env swap eval
+ env env/set
+ 2 +loop
+ env arg0 cell+ @ TCO-eval
+ \ TODO: dec refcount of env
+ ;;
+
+defspecial do { env list -- val }
+ list MalList/start @ { start }
+ list MalList/count @ dup 1- { last } 1 ?do
+ env start i cells + @
+ i last = if
+ TCO-eval
+ else
+ eval drop
+ endif
+ loop ;;
+
+defspecial if { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ env arg0 @ eval ( test-val )
+ dup mal-false = if
+ drop -1
+ else
+ mal-nil =
+ endif
+ if
+ \ branch to false
+ list MalList/count @ 3 > if
+ env arg0 cell+ cell+ @ TCO-eval
+ else
+ mal-nil
+ endif
+ else
+ \ branch to true
+ env arg0 cell+ @ TCO-eval
+ endif ;;
+
+s" &" MalSymbol. constant &-sym
+
+: new-user-fn-env { argv argc mal-fn -- env }
+ mal-fn MalUserFn/formal-args @ { f-args-list }
+ mal-fn MalUserFn/env @ MalEnv. { env }
+
+ f-args-list MalList/start @ { f-args }
+ f-args-list MalList/count @ ?dup 0= if else
+ \ pass nil for last arg, unless overridden below
+ 1- cells f-args + @ mal-nil env env/set
+ endif
+ argc 0 ?do
+ f-args i cells + @
+ dup &-sym m= if
+ drop
+ argc i - { c }
+ c cells allocate throw { start }
+ argv i cells + start c cells cmove
+ f-args i 1+ cells + @ ( more-args-symbol )
+ start c MalList. env env/set
+ leave
+ endif
+ argv i cells + @
+ env env/set
+ loop
+ env ;
+
+MalUserFn
+ extend eval-invoke { call-env list mal-fn -- list }
+ mal-fn MalUserFn/is-macro? @ if
+ list MalList/start @ cell+ \ argv
+ list MalList/count @ 1- \ argc
+ mal-fn new-user-fn-env { env }
+ env mal-fn MalUserFn/body @ eval
+ call-env swap TCO-eval
+ else
+ call-env list eval-rest
+ mal-fn invoke
+ endif ;;
+
+ extend invoke ( argv argc mal-fn )
+ dup { mal-fn } new-user-fn-env { env }
+ env mal-fn MalUserFn/body @ TCO-eval ;;
+drop
+
+defspecial fn* { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ MalUserFn new
+ false over MalUserFn/is-macro? !
+ env over MalUserFn/env !
+ arg0 @ to-list over MalUserFn/formal-args !
+ arg0 cell+ @ over MalUserFn/body ! ;;
+
+defspecial macroexpand ( env list[_,form] -- form )
+ MalList/start @ cell+ @ swap over ( form env form )
+ MalList/start @ @ ( form env macro-name-expr )
+ eval { macro-fn } ( form )
+ dup MalList/start @ cell+ swap MalList/count @ 1- macro-fn ( argv argc fn )
+ new-user-fn-env ( env )
+ macro-fn MalUserFn/body @ TCO-eval ;;
+
+5555555555 constant pre-try
+
+defspecial try* { env list -- val }
+ list MalList/start @ cell+ { arg0 }
+ pre-try
+ env arg0 @ ['] eval catch ?dup 0= if
+ nip
+ else { errno }
+ begin pre-try = until
+ errno 1 <> if
+ s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
+ to exception-object
+ endif
+ arg0 cell+ @ ( list[catch*,sym,form] )
+ MalList/start @ cell+ { catch0 }
+ env MalEnv. { catch-env }
+ catch0 @ exception-object catch-env env/set
+ catch-env catch0 cell+ @ TCO-eval
+ endif ;;
+
+MalSymbol
+ extend mal-eval { env sym -- val }
+ 0 sym env get
+ dup 0= if
+ drop
+ 0 0 s" ' not found" sym as-native s" '" ...throw-str
+ endif ;;
+drop
+
+: eval-ast { env list -- list }
+ here
+ list MalList/start @ { expr-start }
+ list MalList/count @ 0 ?do
+ env expr-start i cells + @ eval ,
+ loop
+ here>MalList ;
+
+MalList
+ extend mal-eval { env list -- val }
+ env list MalList/start @ @ eval
+ env list rot eval-invoke ;;
+drop
+
+MalVector
+ extend mal-eval ( env vector -- vector )
+ MalVector/list @ eval-ast
+ MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+ extend mal-eval ( env map -- map )
+ MalMap/list @ eval-ast
+ MalMap new swap over MalMap/list ! ;;
+drop
+
+defcore eval ( argv argc )
+ drop @ repl-env swap eval ;;
+
+: rep ( str-addr str-len -- str-addr str-len )
+ read
+ repl-env swap eval
+ print ;
+
+: mk-args-list ( -- )
+ here
+ begin
+ next-arg 2dup 0 0 d<> while
+ MalString. ,
+ repeat
+ 2drop here>MalList ;
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: nop ;
+
+defcore map ( argv argc -- list )
+ drop dup @ swap cell+ @ to-list { fn list }
+ here
+ list MalList/start @ list MalList/count @ cells over + swap +do
+ i 1 fn invoke
+ dup TCO-eval = if drop eval endif
+ ,
+ cell +loop
+ here>MalList ;;
+
+defcore readline ( argv argc -- mal-string )
+ drop @ unpack-str type stdout flush-file drop
+ buff 128 stdin read-line throw
+ if buff swap MalString. else drop mal-nil endif ;;
+
+s\" (def! *host-language* \"forth\")" rep 2drop
+s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep 2drop
+s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep 2drop
+s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep 2drop
+s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep 2drop
+
+: repl ( -- )
+ s\" (println (str \"Mal [\" *host-language* \"]\"))" rep 2drop
+ begin
+ ." user> "
+ stack-leak-detect
+ buff 128 stdin read-line throw
+ while ( num-bytes-read )
+ buff swap ( str-addr str-len )
+ ['] rep
+ \ execute ['] nop \ uncomment to see stack traces
+ catch ?dup 0= if
+ safe-type cr
+ stack-leak-detect <> if ." --stack leak--" cr endif
+ else { errno }
+ begin stack-leak-detect = until
+ errno 1 <> if
+ s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
+ to exception-object
+ endif
+ ." Uncaught exception: "
+ exception-object pr-str safe-type cr
+ endif
+ repeat ;
+
+: main ( -- )
+ mk-args-list { args-list }
+ args-list MalList/count @ 0= if
+ s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set
+ repl
+ else
+ args-list MalList/start @ @ { filename }
+ s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set
+
+ repl-env
+ here s" load-file" MalSymbol. , filename , here>MalList
+ eval print
+ endif ;
+
+main
+cr
+bye
diff --git a/forth/str.fs b/forth/str.fs
new file mode 100644
index 0000000..20aef32
--- /dev/null
+++ b/forth/str.fs
@@ -0,0 +1,73 @@
+: safe-type ( str-addr str-len -- )
+ dup 256 > if
+ drop 256 type ." ...<lots more>"
+ else
+ type
+ endif ;
+
+\ === mutable string buffer === /
+\ string buffer that maintains an allocation larger than the current
+\ string size. When appending would cause the string size exceed the
+\ current allocation, resize is used to double the allocation. The
+\ current allocation is not stored anywhere, but computed based on
+\ current string size or str-base-size, whichever is larger.
+64 constant str-base-size
+
+: new-str ( -- addr length )
+ str-base-size allocate throw 0 ;
+
+: round-up ( n -- n )
+ 2
+ begin
+ 1 lshift 2dup <
+ until
+ nip ;
+
+: str-append { buf-addr buf-str-len str-addr str-len }
+ buf-str-len str-len +
+ { new-len }
+ new-len str-base-size >= if
+ buf-str-len new-len xor buf-str-len > if
+ buf-addr new-len round-up resize throw
+ to buf-addr
+ endif
+ endif
+ str-addr buf-addr buf-str-len + str-len cmove
+ buf-addr new-len ;
+
+\ define a-space, to append a space char to a string
+bl c,
+here constant space-str
+: a-space space-str 1 str-append ;
+
+: str-append-char ( buf-addr buf-str-len char -- buf-addr buf-str-len )
+ pad ! pad 1 str-append ;
+
+\ from gforth docs, there named 'my-.'
+: int>str ( num -- str-addr str-len )
+ \ handling negatives.. behaves like Standard .
+ s>d \ convert to signed double
+ swap over dabs \ leave sign byte followed by unsigned double
+ <<# \ start conversion
+ #s \ convert all digits
+ rot sign \ get at sign byte, append "-" if needed
+ #> \ complete conversion
+ #>> ; \ release hold area
+
+defer MalString.
+
+: ...str
+ new-str
+ begin
+ 2swap
+ over 0 <>
+ while
+ str-append
+ repeat
+ 2drop MalString. ;
+
+nil value exception-object
+
+: ...throw-str
+ ...str to exception-object
+ 1 throw ;
diff --git a/forth/types.fs b/forth/types.fs
new file mode 100644
index 0000000..2c4c8e0
--- /dev/null
+++ b/forth/types.fs
@@ -0,0 +1,574 @@
+require str.fs
+
+\ === sorted-array === /
+\ Here are a few utility functions useful for creating and maintaining
+\ the deftype* method tables. The keys array is kept in sorted order,
+\ and the methods array is maintained in parallel so that an index into
+\ one corresponds to an index in the other.
+
+\ Search a sorted array for key, returning the index of where it was
+\ found. If key is not in the array, return the index where it would
+\ be if added.
+: array-find { a-length a-addr key -- index found? }
+ 0 a-length ( start end )
+ begin
+ \ cr 2dup . .
+ 2dup + 2 / dup ( start end middle middle )
+ cells a-addr + @ ( start end middle mid-val )
+ dup key < if
+ drop rot ( end middle start )
+ 2dup = if
+ 2drop dup ( end end )
+ else
+ drop swap ( middle end )
+ endif
+ else
+ key > if ( start end middle )
+ nip ( start middle )
+ else
+ -rot 2drop dup ( middle middle )
+ endif
+ endif
+ 2dup = until
+ dup a-length = if
+ drop false
+ else
+ cells a-addr + @ key =
+ endif ;
+
+\ Create a new array, one cell in length, initialized the provided value
+: new-array { value -- array }
+ cell allocate throw value over ! ;
+
+\ Resize a heap-allocated array to be one cell longer, inserting value
+\ at idx, and shifting the tail of the array as necessary. Returns the
+\ (possibly new) array address
+: array-insert { old-array-length old-array idx value -- array }
+ old-array old-array-length 1+ cells resize throw
+ { a }
+ a idx cells + dup cell+ old-array-length idx - cells cmove>
+ value a idx cells + !
+ a
+ ;
+
+
+\ === deftype* -- protocol-enabled structs === /
+\ Each type has MalTypeType% struct allocated on the stack, with
+\ mutable fields pointing to all class-shared resources, specifically
+\ the data needed to allocate new instances, and the table of protocol
+\ methods that have been extended to the type.
+\ Use 'deftype*' to define a new type, and 'new' to create new
+\ instances of that type.
+
+struct
+ cell% field mal-type
+ cell% field mal-meta
+ \ cell% field ref-count \ Ha, right.
+end-struct MalType%
+
+struct
+ cell% 2 * field MalTypeType-struct
+ cell% field MalTypeType-methods
+ cell% field MalTypeType-method-keys
+ cell% field MalTypeType-method-vals
+ cell% field MalTypeType-name-addr
+ cell% field MalTypeType-name-len
+end-struct MalTypeType%
+
+: new ( MalTypeType -- obj )
+ dup MalTypeType-struct 2@ %allocate throw ( MalTypeType obj ) \ create struct
+ dup -rot mal-type ! ( obj ) \ set struct's type pointer to this type
+ nil over mal-meta !
+ ;
+
+: deftype* ( struct-align struct-len -- MalTypeType )
+ MalTypeType% %allot ( s-a s-l MalTypeType )
+ dup 2swap rot ( MalTypeType s-a s-l MalTypeType )
+ MalTypeType-struct 2! ( MalTypeType ) \ store struct info
+ dup MalTypeType-methods 0 swap ! ( MalTypeType )
+ dup MalTypeType-method-keys nil swap ! ( MalTypeType )
+ dup MalTypeType-method-vals nil swap ! ( MalTypeType )
+ dup MalTypeType-name-len 0 swap ! ( MalTypeType )
+ ;
+
+\ parse-name uses temporary space, so copy into dictionary stack:
+: parse-allot-name { -- new-str-addr str-len }
+ parse-name { str-addr str-len }
+ here { new-str-addr } str-len allot
+ str-addr new-str-addr str-len cmove
+ new-str-addr str-len ;
+
+: deftype ( struct-align struct-len R:type-name -- )
+ parse-allot-name { name-addr name-len }
+
+ \ allot and initialize type structure
+ deftype* { mt }
+ name-addr mt MalTypeType-name-addr !
+ name-len mt MalTypeType-name-len !
+ \ ." Defining " mt MalTypeType-name-addr @ mt MalTypeType-name-len @ type cr
+ mt name-addr name-len nextname 1 0 const-does> ;
+
+: type-name ( mal-type )
+ dup MalTypeType-name-addr @ ( mal-type name-addr )
+ swap MalTypeType-name-len @ ( name-addr name-len )
+ ;
+
+MalType% deftype MalDefault
+
+\ nil type and instance to support extending protocols to it
+MalType% deftype MalNil MalNil new constant mal-nil
+MalType% deftype MalTrue MalTrue new constant mal-true
+MalType% deftype MalFalse MalFalse new constant mal-false
+
+: mal-bool
+ 0= if mal-false else mal-true endif ;
+
+: not-object? ( obj -- bool )
+ dup 7 and 0 <> if
+ drop true
+ else
+ 1000000 <
+ endif ;
+
+\ === protocol methods === /
+
+0 constant trace
+
+\ Used by protocol methods to find the appropriate implementation of
+\ themselves for the given object, and then execute that implementation.
+: execute-method { obj pxt -- }
+ obj not-object? if
+ 0 0 obj int>str s" ' on non-object: " pxt >name name>string
+ s" Refusing to invoke protocol fn '" ...throw-str
+ endif
+ obj mal-type @ dup MalTypeType-methods 2@ swap ( type methods method-keys )
+ dup 0= if \ No protocols extended to this type; check for a default
+ 2drop drop MalDefault MalTypeType-methods 2@ swap
+ endif
+
+ pxt array-find ( type idx found? )
+ dup 0= if \ No implementation found for this method; check for a default
+ 2drop drop MalDefault dup MalTypeType-methods 2@ swap
+ pxt array-find ( type idx found? )
+ endif
+ 0= if ( type idx )
+ 2drop
+ 0 0 s" '" obj mal-type @ type-name s" ' extended to type '"
+ pxt >name name>string s" No protocol fn '" ...throw-str
+ endif
+ trace if ." Calling '" pxt >name name>string type ." ' on " obj mal-type @ type-name type cr endif
+
+ cells swap MalTypeType-method-vals @ + @ ( xt )
+ obj swap execute ;
+
+\ Extend a type with a protocol method. This mutates the MalTypeType
+\ object that represents the MalType being extended.
+: extend-method* { type pxt ixt -- type }
+ type MalTypeType-methods 2@ swap ( methods method-keys )
+ dup 0= if \ no protocols extended to this type
+ 2drop
+ 1 type MalTypeType-methods !
+ pxt new-array type MalTypeType-method-keys !
+ ixt new-array type MalTypeType-method-vals !
+ else
+ pxt array-find { idx found? }
+ found? if \ overwrite
+ ." Warning: overwriting protocol method implementation '"
+ pxt >name name>string safe-type ." ' on " type type-name safe-type ." , " idx . found? . cr
+
+ type MalTypeType-method-vals @ idx cells + ixt !
+ else \ resize
+ type MalTypeType-methods dup @ 1+ dup rot ! ( new-count )
+ 1- dup type MalTypeType-method-keys @ idx pxt array-insert ( old-count new-array )
+ type MalTypeType-method-keys ! ( old-count )
+ type MalTypeType-method-vals @ idx ixt array-insert ( new-array )
+ type MalTypeType-method-vals !
+ endif
+ endif
+ type
+ ;
+
+
+\ def-protocol-method pr-str ...can be written:
+\ : pr-str ( obj -- str ) [ latestxt ] literal execute-method ;
+: def-protocol-method ( "name" -- )
+ create latestxt ,
+ does> ( ??? obj xt-ref -- ??? )
+ @ execute-method ;
+
+: extend ( type -- type pxt install-xt <noname...>)
+ parse-name find-name name>int ( type pxt )
+ ['] extend-method*
+ :noname
+ ;
+
+: ;; ( type pxt <noname...> -- type )
+ [compile] ; ( type pxt install-xt ixt )
+ swap execute
+ ; immediate
+
+(
+\ These whole-protocol names are only needed for 'satisfies?':
+protocol IPrintable
+ def-protocol-method pr-str
+end-protocol
+
+MalList IPrintable extend
+ ' pr-str :noname drop s" <unprintable>" ; extend-method*
+
+ extend-method pr-str
+ drop s" <unprintable>" ;;
+end-extend
+)
+
+\ === Mal types and protocols === /
+
+def-protocol-method conj ( obj this -- this )
+def-protocol-method assoc ( k v this -- this )
+def-protocol-method dissoc ( k this -- this )
+def-protocol-method get ( not-found k this -- value )
+def-protocol-method mal= ( a b -- bool )
+def-protocol-method as-native ( obj -- )
+
+def-protocol-method to-list ( obj -- mal-list )
+def-protocol-method empty? ( obj -- mal-bool )
+def-protocol-method mal-count ( obj -- mal-int )
+def-protocol-method sequential? ( obj -- mal-bool )
+
+
+\ Fully evalutate any Mal object:
+def-protocol-method mal-eval ( env ast -- val )
+
+\ Invoke an object, given whole env and unevaluated argument forms:
+def-protocol-method eval-invoke ( env list obj -- ... )
+
+\ Invoke a function, given parameter values
+def-protocol-method invoke ( argv argc mal-fn -- ... )
+
+
+: m= ( a b -- bool )
+ 2dup = if
+ 2drop true
+ else
+ mal=
+ endif ;
+
+
+MalType%
+ cell% field MalInt/int
+deftype MalInt
+
+: MalInt. { int -- mal-int }
+ MalInt new dup MalInt/int int swap ! ;
+
+MalInt
+ extend mal= ( other this -- bool )
+ over mal-type @ MalInt = if
+ MalInt/int @ swap MalInt/int @ =
+ else
+ 2drop 0
+ endif ;;
+
+ extend as-native ( mal-int -- int )
+ MalInt/int @ ;;
+drop
+
+
+MalType%
+ cell% field MalList/count
+ cell% field MalList/start
+deftype MalList
+
+: MalList. ( start count -- mal-list )
+ MalList new
+ swap over MalList/count ! ( start list )
+ swap over MalList/start ! ( list ) ;
+
+: here>MalList ( old-here -- mal-list )
+ here over - { bytes } ( old-here )
+ MalList new bytes ( old-here mal-list bytes )
+ allocate throw dup { target } over MalList/start ! ( old-here mal-list )
+ bytes cell / over MalList/count ! ( old-here mal-list )
+ swap target bytes cmove ( mal-list )
+ 0 bytes - allot \ pop list contents from dictionary stack
+ ;
+
+: MalList/concat ( list-of-lists )
+ dup MalList/start @ swap MalList/count @ { lists argc }
+ 0 lists argc cells + lists +do ( count )
+ i @ to-list MalList/count @ +
+ cell +loop { count }
+ count cells allocate throw { start }
+ start lists argc cells + lists +do ( target )
+ i @ to-list MalList/count @ cells 2dup i @ to-list MalList/start @ -rot ( target bytes src target bytes )
+ cmove ( target bytes )
+ + ( new-target )
+ cell +loop
+ drop start count MalList. ;
+
+MalList
+ extend to-list ;;
+ extend sequential? drop mal-true ;;
+ extend conj { elem old-list -- list }
+ old-list MalList/count @ 1+ { new-count }
+ new-count cells allocate throw { new-start }
+ elem new-start !
+ new-count 1 > if
+ old-list MalList/start @ new-start cell+ new-count 1- cells cmove
+ endif
+ new-start new-count MalList. ;;
+ extend empty? MalList/count @ 0= mal-bool ;;
+ extend mal-count MalList/count @ MalInt. ;;
+ extend mal=
+ over mal-nil = if
+ 2drop false
+ else
+ swap to-list dup 0= if
+ nip
+ else
+ 2dup MalList/count @ swap MalList/count @ over = if ( list-a list-b count )
+ -rot MalList/start @ swap MalList/start @ { start-b start-a }
+ true swap ( return-val count )
+ 0 ?do
+ start-a i cells + @
+ start-b i cells + @
+ m= if else
+ drop false leave
+ endif
+ loop
+ else
+ drop 2drop false
+ endif
+ endif
+ endif ;;
+drop
+
+MalList new 0 over MalList/count ! constant MalList/Empty
+
+: MalList/rest { list -- list }
+ list MalList/start @ cell+
+ list MalList/count @ 1-
+ MalList. ;
+
+
+MalType%
+ cell% field MalVector/list
+deftype MalVector
+
+MalVector
+ extend sequential? drop mal-true ;;
+ extend to-list
+ MalVector/list @ ;;
+ extend empty?
+ MalVector/list @
+ MalList/count @ 0= mal-bool ;;
+ extend mal-count
+ MalVector/list @
+ MalList/count @ MalInt. ;;
+ extend mal=
+ MalVector/list @ swap m= ;;
+ extend conj
+ MalVector/list @ { elem old-list }
+ old-list MalList/count @ { old-count }
+ old-count 1+ cells allocate throw { new-start }
+ elem new-start old-count cells + !
+ old-list MalList/start @ new-start old-count cells cmove
+ new-start old-count 1+ MalList.
+ MalVector new swap
+ over MalVector/list ! ;;
+drop
+
+MalType%
+ cell% field MalMap/list
+deftype MalMap
+
+MalMap new MalList/Empty over MalMap/list ! constant MalMap/Empty
+
+MalMap
+ extend conj ( kv map -- map )
+ MalMap/list @ \ get list
+ over MalList/start @ cell+ @ swap conj \ add value
+ swap MalList/start @ @ swap conj \ add key
+ MalMap new dup -rot MalMap/list ! \ put back in map
+ ;;
+ extend assoc ( k v map -- map )
+ MalMap/list @ \ get list
+ conj conj
+ MalMap new dup -rot MalMap/list ! \ put back in map
+ ;;
+ extend dissoc { k map -- map }
+ map MalMap/list @
+ dup MalList/start @ swap MalList/count @ { start count }
+ map \ return original if key not found
+ count 0 +do
+ start i cells + @ k mal= if
+ drop here
+ start i MalList. ,
+ start i 2 + cells + count i - 2 - MalList. ,
+ here>MalList MalList/concat
+ MalMap new dup -rot MalMap/list ! \ put back in map
+ endif
+ 2 +loop ;;
+ extend get { not-found k map -- value }
+ map MalMap/list @
+ dup MalList/start @ { start }
+ MalList/count @ { count }
+ 0
+ begin
+ dup count >= if
+ drop not-found true
+ else
+ start over cells + @ k m= if
+ start swap cells + cell+ @ true \ found it ( value true )
+ else
+ 2 + false
+ endif
+ endif
+ until ;;
+ extend empty?
+ MalMap/list @
+ MalList/count @ 0= mal-bool ;;
+ extend mal-count
+ MalMap/list @
+ MalList/count @ 2 / MalInt. ;;
+drop
+
+\ Examples of extending existing protocol methods to existing type
+MalDefault
+ extend conj ( obj this -- this )
+ nip ;;
+ extend as-native ;; ( obj -- obj )
+ extend to-list drop 0 ;;
+ extend empty? drop mal-true ;;
+ extend sequential? drop mal-false ;;
+ extend mal= = ;;
+drop
+
+MalNil
+ extend conj ( item nil -- mal-list )
+ drop MalList/Empty conj ;;
+ extend as-native drop 0 ;;
+ extend get 2drop ;;
+ extend to-list drop MalList/Empty ;;
+ extend empty? drop mal-true ;;
+ extend mal-count drop 0 MalInt. ;;
+ extend mal= drop mal-nil = ;;
+drop
+
+MalType%
+ cell% field MalSymbol/sym-addr
+ cell% field MalSymbol/sym-len
+ cell% field MalSymbol/meta
+deftype MalSymbol
+
+: MalSymbol. { str-addr str-len -- mal-sym }
+ MalSymbol new { sym }
+ str-addr sym MalSymbol/sym-addr !
+ str-len sym MalSymbol/sym-len !
+ MalMap/Empty sym MalSymbol/meta !
+ sym ;
+
+: unpack-sym ( mal-string -- addr len )
+ dup MalSymbol/sym-addr @
+ swap MalSymbol/sym-len @ ;
+
+MalSymbol
+ extend mal= ( other this -- bool )
+ over mal-type @ MalSymbol = if
+ unpack-sym rot unpack-sym str=
+ else
+ 2drop 0
+ endif ;;
+ ' as-native ' unpack-sym extend-method*
+drop
+
+MalType%
+ cell% field MalKeyword/str-addr
+ cell% field MalKeyword/str-len
+deftype MalKeyword
+
+: unpack-keyword ( mal-keyword -- addr len )
+ dup MalKeyword/str-addr @
+ swap MalKeyword/str-len @ ;
+
+MalKeyword
+ extend mal= ( other this -- bool )
+ over mal-type @ MalKeyword = if
+ unpack-keyword rot unpack-keyword str=
+ else
+ 2drop 0
+ endif ;;
+ ' as-native ' unpack-keyword extend-method*
+drop
+
+: MalKeyword. { str-addr str-len -- mal-keyword }
+ MalKeyword new { kw }
+ str-addr kw MalKeyword/str-addr !
+ str-len kw MalKeyword/str-len !
+ kw ;
+
+MalType%
+ cell% field MalString/str-addr
+ cell% field MalString/str-len
+deftype MalString
+
+: MalString.0 { str-addr str-len -- mal-str }
+ MalString new { str }
+ str-addr str MalString/str-addr !
+ str-len str MalString/str-len !
+ str ;
+' MalString.0 is MalString.
+
+: unpack-str ( mal-string -- addr len )
+ dup MalString/str-addr @
+ swap MalString/str-len @ ;
+
+MalString
+ extend mal= ( other this -- bool )
+ over mal-type @ MalString = if
+ unpack-str rot unpack-str str=
+ else
+ 2drop 0
+ endif ;;
+ ' as-native ' unpack-str extend-method*
+drop
+
+
+MalType%
+ cell% field MalNativeFn/xt
+ cell% field MalNativeFn/meta
+deftype MalNativeFn
+
+: MalNativeFn. { xt -- mal-fn }
+ MalNativeFn new { mal-fn }
+ xt mal-fn MalNativeFn/xt !
+ MalMap/Empty mal-fn MalNativeFn/meta !
+ mal-fn ;
+
+MalNativeFn
+ extend as-native
+ MalNativeFn/xt @ ;;
+drop
+
+
+MalType%
+ cell% field MalUserFn/is-macro?
+ cell% field MalUserFn/env
+ cell% field MalUserFn/formal-args
+ cell% field MalUserFn/var-arg
+ cell% field MalUserFn/body
+deftype MalUserFn
+
+
+MalType%
+ cell% field SpecialOp/xt
+deftype SpecialOp
+
+: SpecialOp.
+ SpecialOp new swap over SpecialOp/xt ! ;
+
+MalType%
+ cell% field Atom/val
+deftype Atom
+
+: Atom. Atom new swap over Atom/val ! ;
generated by cgit v1.2.3 (git 2.25.1) at 2026-01-05 04:37:00 +0000