mirror of
https://github.com/kanaka/mal.git
synced 2024-09-20 18:18:51 +03:00
forth: Add step 3
This commit is contained in:
parent
9da223a35a
commit
69972a8399
45
forth/env.fs
Normal file
45
forth/env.fs
Normal file
@ -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
|
@ -2,7 +2,7 @@ require printer.fs
|
||||
|
||||
\ === basic testing util === /
|
||||
: test=
|
||||
2dup = if
|
||||
2dup m= if
|
||||
2drop
|
||||
else
|
||||
cr ." assert failed on line " sourceline# .
|
||||
@ -52,20 +52,38 @@ mal-nil
|
||||
23 MalInt. mal-nil conj conj conj
|
||||
pr-str s" (nil (20 (42) 10) 23)" str= -1 test=
|
||||
|
||||
\ MalArray tests
|
||||
|
||||
here 1 MalInt. , 2 MalInt. , 3 MalInt. , here>MalArray
|
||||
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. mal= -1 test=
|
||||
s" one" MalString. s" x" MalString. mal= 0 test=
|
||||
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. mal= -1 test=
|
||||
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
|
||||
@ -74,8 +92,6 @@ mal-nil
|
||||
1 MalInt. swap conj
|
||||
2 MalInt. swap conj
|
||||
3 MalInt. swap conj
|
||||
~~
|
||||
mal-eval
|
||||
~~
|
||||
|
||||
bye
|
||||
|
@ -149,6 +149,11 @@ MalFn
|
||||
drop s" #<fn>" str-append ;;
|
||||
drop
|
||||
|
||||
SpecialOp
|
||||
extend pr-buf
|
||||
drop s" #<op>" str-append ;;
|
||||
drop
|
||||
|
||||
MalSymbol
|
||||
extend pr-buf
|
||||
unpack-sym str-append ;;
|
||||
|
@ -135,9 +135,10 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
|
||||
;
|
||||
|
||||
: read-wrapped ( buf-addr buf-len quote-char sym-addr sym-len -- buf-addr buf-len char mal-list )
|
||||
MalSymbol. { sym } ( buf-addr buf-len char )
|
||||
read-form mal-nil conj ( buf-addr buf-len char mal-list )
|
||||
sym swap conj ;
|
||||
here { old-here }
|
||||
MalSymbol. , ( buf-addr buf-len char )
|
||||
read-form , ( buf-addr buf-len char )
|
||||
old-here here>MalArray ;
|
||||
|
||||
: read-form2 ( str-addr str-len char -- str-addr str-len char mal-obj )
|
||||
begin
|
||||
@ -145,7 +146,7 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
|
||||
dup mal-digit? if read-int else
|
||||
dup [char] ( = if [char] ) read-array else
|
||||
dup [char] [ = if [char] ] read-array MalVector new tuck MalVector/list ! else
|
||||
dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else
|
||||
dup [char] { = if [char] } read-array MalMap new tuck MalMap/list ! else
|
||||
dup [char] " = if read-string-literal else
|
||||
dup [char] ; = if read-comment else
|
||||
dup [char] : = if drop adv-str read-symbol-str MalKeyword. else
|
||||
|
@ -15,9 +15,23 @@ value repl-env
|
||||
|
||||
def-protocol-method mal-eval ( env ast -- val )
|
||||
def-protocol-method mal-eval-ast ( env ast -- val )
|
||||
def-protocol-method invoke ( argv argc mal-fn -- ... )
|
||||
|
||||
MalDefault extend mal-eval nip ;; drop
|
||||
|
||||
MalKeyword
|
||||
extend invoke { argv argc kw -- val }
|
||||
argc 1 > if argv cell+ @ else mal-nil endif \ not-found
|
||||
kw \ key
|
||||
argv @ \ map
|
||||
get ;;
|
||||
drop
|
||||
|
||||
MalFn
|
||||
extend invoke ( ... mal-fn -- ... )
|
||||
MalFn/xt @ execute ;;
|
||||
drop
|
||||
|
||||
MalSymbol
|
||||
extend mal-eval { env sym -- val }
|
||||
0 sym env get
|
||||
|
160
forth/step3_env.fs
Normal file
160
forth/step3_env.fs
Normal file
@ -0,0 +1,160 @@
|
||||
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. ; MalFn. repl-env env/set
|
||||
s" -" MalSymbol. :noname args-as-native - MalInt. ; MalFn. repl-env env/set
|
||||
s" *" MalSymbol. :noname args-as-native * MalInt. ; MalFn. repl-env env/set
|
||||
s" /" MalSymbol. :noname args-as-native / MalInt. ; MalFn. repl-env env/set
|
||||
|
||||
def-protocol-method mal-eval ( env ast -- val )
|
||||
def-protocol-method mal-eval-ast ( env ast -- val )
|
||||
def-protocol-method invoke+ ( env arty -- ... )
|
||||
def-protocol-method invoke ( argv argc mal-fn -- ... )
|
||||
|
||||
MalDefault extend mal-eval nip ;; drop
|
||||
|
||||
MalKeyword
|
||||
extend invoke { argv argc kw -- val }
|
||||
argc 1 > if argv cell+ @ else mal-nil endif \ not-found
|
||||
kw \ key
|
||||
argv @ \ map
|
||||
get ;;
|
||||
drop
|
||||
|
||||
MalFn
|
||||
extend invoke ( ... mal-fn -- ... )
|
||||
MalFn/xt @ execute ;;
|
||||
|
||||
extend invoke+ { env ary this -- ary }
|
||||
\ Pass args on dictionary stack (!)
|
||||
\ TODO: consider allocate and free of a real MalArray instead
|
||||
\ Normal list, evaluate and invoke
|
||||
here { val-start }
|
||||
ary MalArray/start @ { expr-start }
|
||||
ary MalArray/count @ 1 ?do
|
||||
env expr-start i cells + @ mal-eval ,
|
||||
loop
|
||||
val-start here val-start - cell / this ( argv argc MalFn )
|
||||
invoke
|
||||
val-start here - allot ;;
|
||||
drop
|
||||
|
||||
SpecialOp
|
||||
extend invoke+ ( env ary this -- ary )
|
||||
SpecialOp/xt @ execute ;;
|
||||
drop
|
||||
|
||||
s" quote" MalSymbol. :noname ( env ary -- form )
|
||||
nip MalArray/start @ cell+ @
|
||||
; SpecialOp. repl-env env/set
|
||||
|
||||
s" def!" MalSymbol. :noname { env ary -- }
|
||||
ary MalArray/start @ cell+ { arg0 }
|
||||
arg0 @ ( key )
|
||||
env arg0 cell+ @ mal-eval dup { val } ( key val )
|
||||
env env/set
|
||||
val
|
||||
; SpecialOp. repl-env env/set
|
||||
|
||||
s" let*" MalSymbol. :noname { old-env ary -- }
|
||||
old-env MalEnv. { env }
|
||||
ary MalArray/start @ cell+ dup { arg0 }
|
||||
@ to-array
|
||||
dup MalArray/start @ { bindings-start } ( ary )
|
||||
MalArray/count @ 0 +do
|
||||
bindings-start i cells + dup @ swap cell+ @ ( sym expr )
|
||||
env swap mal-eval
|
||||
env env/set
|
||||
2 +loop
|
||||
env arg0 cell+ @ mal-eval
|
||||
\ TODO: dec refcount of env
|
||||
; SpecialOp. repl-env env/set
|
||||
|
||||
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
|
||||
|
||||
MalArray
|
||||
extend mal-eval { env ary -- val }
|
||||
env ary MalArray/start @ @ mal-eval
|
||||
env ary rot invoke+ ;;
|
||||
|
||||
extend mal-eval-ast { env ary -- ary }
|
||||
here
|
||||
ary MalArray/start @ { expr-start }
|
||||
ary MalArray/count @ 0 ?do
|
||||
env expr-start i cells + @ mal-eval ,
|
||||
loop
|
||||
here>MalArray ;;
|
||||
drop
|
||||
|
||||
MalList
|
||||
extend mal-eval-ast { env list -- ary }
|
||||
here
|
||||
list
|
||||
begin ( list )
|
||||
dup mal-nil <>
|
||||
while
|
||||
env over MalList/car @ mal-eval ,
|
||||
MalList/cdr @
|
||||
repeat
|
||||
drop here>MalArray ;;
|
||||
drop
|
||||
|
||||
MalVector
|
||||
extend mal-eval ( env vector -- vector )
|
||||
MalVector/list @ mal-eval-ast
|
||||
MalVector new swap over MalVector/list ! ;;
|
||||
drop
|
||||
|
||||
MalMap
|
||||
extend mal-eval ( env map -- map )
|
||||
MalMap/list @ mal-eval-ast
|
||||
MalMap new swap over MalMap/list ! ;;
|
||||
drop
|
||||
|
||||
: read read-str ;
|
||||
: eval ( env obj ) mal-eval ;
|
||||
: print
|
||||
\ ." Type: " dup mal-type @ type-name safe-type cr
|
||||
pr-str ;
|
||||
|
||||
: rep ( str -- val )
|
||||
read
|
||||
repl-env swap eval
|
||||
print ;
|
||||
|
||||
create buff 128 allot
|
||||
|
||||
: read-lines
|
||||
begin
|
||||
." user> "
|
||||
42042042042
|
||||
buff 128 stdin read-line throw
|
||||
while
|
||||
buff swap
|
||||
['] rep
|
||||
execute safe-type
|
||||
\ catch 0= if safe-type else ." Caught error" endif
|
||||
cr
|
||||
42042042042 <> if ." --stack leak--" cr endif
|
||||
repeat ;
|
||||
|
||||
read-lines
|
||||
cr
|
||||
bye
|
@ -200,6 +200,20 @@ end-extend
|
||||
|
||||
\ === Mal types and protocols === /
|
||||
|
||||
def-protocol-method conj ( obj this -- this )
|
||||
def-protocol-method assoc ( k v 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-array ( obj -- mal-array )
|
||||
|
||||
: m= ( a b -- bool )
|
||||
2dup = if
|
||||
2drop -1
|
||||
else
|
||||
mal=
|
||||
endif ;
|
||||
|
||||
MalType%
|
||||
cell% field MalList/car
|
||||
cell% field MalList/cdr
|
||||
@ -225,48 +239,63 @@ deftype MalArray
|
||||
0 bytes - allot \ pop array contents from dictionary stack
|
||||
;
|
||||
|
||||
def-protocol-method conj ( obj this -- this )
|
||||
def-protocol-method assoc ( k v 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 invoke ( argv argc mal-fn -- ... )
|
||||
MalArray
|
||||
extend to-array ;;
|
||||
extend conj { elem old-ary -- ary }
|
||||
old-ary MalArray/count @ 1+ { new-count }
|
||||
new-count cells allocate throw { new-start }
|
||||
elem new-start !
|
||||
new-count 1 > if
|
||||
old-ary MalArray/start @ new-start cell+ new-count 1- cells cmove
|
||||
endif
|
||||
|
||||
MalArray new
|
||||
new-count over MalArray/count !
|
||||
new-start over MalArray/start ! ;;
|
||||
drop
|
||||
|
||||
MalArray new 0 over MalArray/count ! constant MalArray/Empty
|
||||
|
||||
MalType%
|
||||
cell% field MalVector/list
|
||||
deftype MalVector
|
||||
|
||||
MalVector
|
||||
extend to-array
|
||||
MalVector/list @ to-array ;;
|
||||
drop
|
||||
|
||||
MalType%
|
||||
cell% field MalMap/list
|
||||
deftype MalMap
|
||||
|
||||
MalMap new mal-nil over MalMap/list ! constant MalMap/Empty
|
||||
MalMap new MalArray/Empty over MalMap/list ! constant MalMap/Empty
|
||||
|
||||
MalMap
|
||||
extend conj ( kv map -- map )
|
||||
MalMap/list @ \ get list
|
||||
over MalList/cdr @ MalList/car @ conj \ add value
|
||||
swap MalList/car @ conj \ add key
|
||||
MalMap new MalMap/list ! \ put back in map
|
||||
over MalArray/start @ cell+ @ swap conj \ add value
|
||||
swap MalArray/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
|
||||
conj conj
|
||||
MalMap new dup -rot MalMap/list ! \ put back in map
|
||||
;;
|
||||
extend get ( not-found k map -- value )
|
||||
-rot { not-found k }
|
||||
MalMap/list @ \ get list
|
||||
extend get { not-found k map -- value }
|
||||
map MalMap/list @
|
||||
dup MalArray/start @ { start }
|
||||
MalArray/count @ { count }
|
||||
0
|
||||
begin
|
||||
dup MalList/cdr @
|
||||
swap MalList/car @ k mal= if
|
||||
MalList/car @ -1 \ found it
|
||||
dup count >= if
|
||||
drop not-found -1
|
||||
else
|
||||
MalList/cdr @
|
||||
dup mal-nil = if
|
||||
not-found -1
|
||||
start over cells + @ k m= if
|
||||
start swap cells + cell+ @ -1 \ found it ( value -1 )
|
||||
else
|
||||
0
|
||||
2 + 0
|
||||
endif
|
||||
endif
|
||||
until ;;
|
||||
@ -297,6 +326,13 @@ deftype MalInt
|
||||
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
|
||||
@ -345,11 +381,6 @@ MalKeyword
|
||||
2drop 0
|
||||
endif ;;
|
||||
' as-native ' unpack-keyword extend-method*
|
||||
extend invoke { argv argc kw -- val }
|
||||
argc 1 > if argv cell+ @ else mal-nil endif \ not-found
|
||||
kw \ key
|
||||
argv @ \ map
|
||||
get ;;
|
||||
drop
|
||||
|
||||
: MalKeyword. { str-addr str-len -- mal-keyword }
|
||||
@ -396,8 +427,14 @@ deftype MalFn
|
||||
mal-fn ;
|
||||
|
||||
MalFn
|
||||
extend invoke ( ... mal-fn -- ... )
|
||||
MalFn/xt @ execute ;;
|
||||
extend as-native
|
||||
MalFn/xt @ ;;
|
||||
drop
|
||||
|
||||
|
||||
MalType%
|
||||
cell% field SpecialOp/xt
|
||||
deftype SpecialOp
|
||||
|
||||
: SpecialOp.
|
||||
SpecialOp new swap over SpecialOp/xt ! ;
|
||||
|
Loading…
Reference in New Issue
Block a user