kanaka/mal
1
1
Fork 0
mirror of https://github.com/kanaka/mal.git synced 2024-11-13 01:43:50 +03:00
Code Issues Projects Releases Wiki Activity

forth: Finish step 9

Browse Source
This commit is contained in:
Chouser 2015-02-18 19:57:39 -05:00
parent 580c4eef9d
commit 224e09ed42
4 changed files with 260 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

131
forth/core.fs
View File

@ -24,14 +24,16 @@ defcore <= args-as-native <= mal-bool ;;
defcore >= args-as-native >= mal-bool ;;
defcore list { argv argc }
MalList new { list }
argc cells allocate throw { start }
argv start argc cells cmove
argc list MalList/count !
start list MalList/start !
list ;;
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 list? drop @ mal-type @ MalList = mal-bool ;;
defcore empty? drop @ empty? ;;
defcore count drop @ mal-count ;;
@ -83,19 +85,66 @@ defcore cons ( argv[item,coll] argc )
to-list conj ;;
defcore concat { 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
MalList new
start over MalList/start !
count over MalList/count ! ;;
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 )
@ -119,3 +168,51 @@ defcore first ( argv[coll] argc )
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 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 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. ;;

29
forth/printer.fs
View File

@ -5,7 +5,6 @@ require types.fs
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 )
def-protocol-method pr-pairs-buf ( readably? str-addr str-len this -- str-addr str-len )
: pr-str { obj }
true new-str obj pr-buf rot drop ;
@ -39,15 +38,6 @@ MalList
start i cells + @ pr-buf
loop
endif ;;
extend pr-pairs-buf { list }
list MalList/start @ { start }
start @ pr-buf a-space start cell+ @ pr-buf
list MalList/count @ 2 / 1 ?do
s" , " str-append
a-space
start i 2 * cells + @ pr-buf a-space
start i 2 * 1+ cells + @ pr-buf
loop ;;
drop
MalVector
@ -62,7 +52,17 @@ MalMap
extend pr-buf
MalMap/list @
-rot s" {" str-append ( list str-addr str-len )
rot pr-pairs-buf
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
@ -105,3 +105,10 @@ MalString
str-append
endif ;;
drop
Atom
extend pr-buf { this }
s" (atom " str-append
this Atom/val @ pr-buf
s" )" str-append ;;
drop

76
forth/step9_try.fs
View File

@ -5,10 +5,13 @@ require core.fs
core MalEnv. constant repl-env
\ Fully evalutate any Mal object:
def-protocol-method mal-eval ( env ast -- val )
\ def-protocol-method mal-eval ( env ast -- val )
\ Invoke an object, given whole env and unevaluated argument forms:
def-protocol-method invoke ( argv argc mal-fn -- ... )
\ def-protocol-method eval-invoke ( env list obj -- ... )
\ Invoke a function, given parameter values
\ def-protocol-method invoke ( argv argc mal-fn -- ... )
99999999 constant TCO-eval
@ -28,7 +31,7 @@ def-protocol-method invoke ( argv argc mal-fn -- ... )
MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
MalKeyword
extend invoke { env list kw -- val }
extend eval-invoke { env list kw -- val }
0 kw env list MalList/start @ cell+ @ eval get
?dup 0= if
\ compute not-found value
@ -38,6 +41,15 @@ MalKeyword
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
@ -52,14 +64,15 @@ drop
target argc ;
MalNativeFn
extend invoke ( env list this -- list )
MalNativeFn/xt @ { xt }
eval-rest ( argv argc )
xt execute ( return-val ) ;;
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 invoke ( env list this -- list )
extend eval-invoke ( env list this -- list )
SpecialOp/xt @ execute ;;
drop
@ -191,12 +204,11 @@ s" &" MalSymbol. constant &-sym
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 !
argc i - { c }
c cells allocate throw { start }
argv i cells + start c cells cmove
env env/set
f-args i 1+ cells + @ ( more-args-symbol )
start c MalList. env env/set
leave
endif
argv i cells + @
@ -205,13 +217,16 @@ s" &" MalSymbol. constant &-sym
env ;
MalUserFn
extend invoke { call-env list mal-fn -- list }
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 invoke ;;
extend invoke ( argv argc mal-fn )
dup { mal-fn } new-user-fn-env { env }
mal-fn MalUserFn/is-macro? @ if
env mal-fn MalUserFn/body @ eval
@ -224,6 +239,7 @@ 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 ! ;;
@ -280,7 +296,7 @@ drop
MalList
extend mal-eval { env list -- val }
env list MalList/start @ @ eval
env list rot invoke ;;
env list rot eval-invoke ;;
drop
MalVector
@ -311,12 +327,30 @@ defcore eval ( argv argc )
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
buff 128 stdin read-line throw
if buff swap MalString. else mal-nil endif ;;
s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
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 drop
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 drop
create buff 128 allot
77777777777 constant stack-leak-detect
s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep drop
: repl ( -- )
begin
@ -326,7 +360,7 @@ create buff 128 allot
while ( num-bytes-read )
buff swap ( str-addr str-len )
['] rep
\ execute type
execute ['] nop \ uncomment to see stack traces
catch ?dup 0= if
safe-type cr
stack-leak-detect <> if ." --stack leak--" cr endif
@ -358,3 +392,5 @@ create buff 128 allot
main
cr
bye
4

79
forth/types.fs
View File

@ -59,6 +59,7 @@ require str.fs
struct
cell% field mal-type
cell% field mal-meta
\ cell% field ref-count \ Ha, right.
end-struct MalType%
@ -74,6 +75,7 @@ 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 )
@ -218,6 +220,7 @@ end-extend
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 -- )
@ -225,6 +228,20 @@ 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
@ -259,6 +276,11 @@ MalType%
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 )
@ -268,8 +290,22 @@ deftype MalList
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 }
@ -277,10 +313,7 @@ MalList
new-count 1 > if
old-list MalList/start @ new-start cell+ new-count 1- cells cmove
endif
MalList new
new-count over MalList/count !
new-start over MalList/start ! ;;
new-start new-count MalList. ;;
extend empty? MalList/count @ 0= mal-bool ;;
extend mal-count MalList/count @ MalInt. ;;
extend mal=
@ -306,9 +339,9 @@ drop
MalList new 0 over MalList/count ! constant MalList/Empty
: MalList/rest { list -- list }
MalList new
list MalList/start @ cell+ over MalList/start !
list MalList/count @ 1- over MalList/count ! ;
list MalList/start @ cell+
list MalList/count @ 1-
MalList. ;
MalType%
@ -316,6 +349,7 @@ MalType%
deftype MalVector
MalVector
extend sequential? drop mal-true ;;
extend to-list
MalVector/list @ ;;
extend empty?
@ -326,6 +360,15 @@ MalVector
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%
@ -346,6 +389,19 @@ MalMap
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 }
@ -377,12 +433,15 @@ MalDefault
extend as-native ;; ( obj -- obj )
extend to-list drop 0 ;;
extend empty? drop mal-true ;;
extend sequential? drop mal-false ;;
drop
MalNil
extend conj ( item nil -- mal-list )
drop MalList/Empty conj ;;
extend as-native drop 0 ;;
extend get drop 2drop mal-nil ;;
extend to-list drop MalList/Empty ;;
extend empty? drop mal-true ;;
extend mal-count drop 0 MalInt. ;;
extend mal= drop mal-nil = ;;
@ -499,3 +558,9 @@ deftype SpecialOp
: SpecialOp.
SpecialOp new swap over SpecialOp/xt ! ;
MalType%
cell% field Atom/val
deftype Atom
: Atom. Atom new swap over Atom/val ! ;