mirror of
https://github.com/kanaka/mal.git
synced 2024-08-16 17:20:23 +03:00
if and fn* work
This commit is contained in:
parent
ed899eb7a7
commit
2c68746267
@ -14,7 +14,7 @@ step2_eval: step2_eval.mlb step2_eval.sml env.sml reader.sml printer.sml types.s
|
||||
step3_env: step3_env.mlb step3_env.sml env.sml reader.sml printer.sml types.sml util.sml main.sml
|
||||
mlton -output $@ $<
|
||||
|
||||
step4_if_fn_do: step4_if_fn_do.mlb step4_if_fn_do.sml env.sml reader.sml printer.sml types.sml util.sml main.sml
|
||||
step4_if_fn_do: step4_if_fn_do.mlb step4_if_fn_do.sml core.sml env.sml reader.sml printer.sml types.sml util.sml main.sml
|
||||
mlton -output $@ $<
|
||||
|
||||
clean:
|
||||
|
33
impls/sml/core.sml
Normal file
33
impls/sml/core.sml
Normal file
@ -0,0 +1,33 @@
|
||||
exception NotDefined of string
|
||||
exception NotApplicable of string
|
||||
|
||||
fun malPlus (INT a, INT b) = INT (a + b)
|
||||
| malPlus _ = raise NotApplicable "can only add integers"
|
||||
fun malTimes (INT a, INT b) = INT (a * b)
|
||||
| malTimes _ = raise NotApplicable "can only multiply integers"
|
||||
fun malMinus (INT b, INT a) = INT (a - b)
|
||||
| malMinus _ = raise NotApplicable "can only subtract integers"
|
||||
fun malDiv (INT b, INT a) = INT (a div b)
|
||||
| malDiv _ = raise NotApplicable "can only divide integers"
|
||||
|
||||
val coreMath = [
|
||||
SYMBOL "+",
|
||||
FN (foldl malPlus (INT 0)),
|
||||
|
||||
SYMBOL "*",
|
||||
FN (foldl malTimes (INT 1)),
|
||||
|
||||
SYMBOL "-",
|
||||
FN (fn [x] => malMinus (x, INT 0)
|
||||
| x::xs => foldr malMinus x xs
|
||||
| _ => raise NotApplicable "'-' requires arguments"),
|
||||
|
||||
SYMBOL "/",
|
||||
FN (fn [x] => malDiv (x, INT 1)
|
||||
| x::xs => foldr malDiv x xs
|
||||
| _ => raise NotApplicable "'/' requires arguments")
|
||||
]
|
||||
|
||||
val coreNs = List.concat [
|
||||
coreMath
|
||||
]
|
@ -4,4 +4,4 @@ fun prStr NIL = "nil"
|
||||
| prStr (BOOL false) = "false"
|
||||
| prStr (INT i) = if i >= 0 then Int.toString i else "-" ^ (Int.toString (Int.abs i))
|
||||
| prStr (LIST l) = "(" ^ (String.concatWith " " (map prStr l)) ^ ")" (* N.B. not tail recursive *)
|
||||
| prStr (FN f) = "<function>"
|
||||
| prStr (FN f) = "#<function>"
|
||||
|
@ -5,6 +5,7 @@ local
|
||||
printer.sml
|
||||
reader.sml
|
||||
env.sml
|
||||
core.sml
|
||||
step4_if_fn_do.sml
|
||||
in
|
||||
main.sml
|
||||
|
@ -1,11 +1,12 @@
|
||||
exception NotDefined of string
|
||||
exception NotApplicable of string
|
||||
|
||||
fun read s =
|
||||
readStr s
|
||||
|
||||
(* TODO def! evaluated inside other forms *)
|
||||
fun eval e (LIST (SYMBOL "def!"::args)) = evalDef e args
|
||||
| eval e (LIST (SYMBOL "let*"::args)) = evalLet e args
|
||||
| eval e (LIST (SYMBOL "let*"::args)) = (e, evalLet e args)
|
||||
| eval e (LIST (SYMBOL "do"::args)) = (e, evalDo e args)
|
||||
| eval e (LIST (SYMBOL "if"::args)) = (e, evalIf e args)
|
||||
| eval e (LIST (SYMBOL "fn*"::args)) = (e, evalFn e args)
|
||||
| eval e (LIST (a::args)) = (e, evalApply e (eval' e a) args)
|
||||
| eval e (SYMBOL s) = (e, evalSymbol e s)
|
||||
| eval e ast = (e, ast)
|
||||
@ -15,9 +16,19 @@ and eval' e ast = (#2 o eval e) ast
|
||||
and evalDef e [SYMBOL s, ast] = let val v = eval' e ast in (def s v e, v) end
|
||||
| evalDef _ _ = raise NotApplicable "def! needs a symbol and a form to evaluate"
|
||||
|
||||
and evalLet e [LIST bs, ast] = (e, eval' (bind bs e) ast)
|
||||
and evalLet e [LIST bs, ast] = eval' (bind bs e) ast
|
||||
| evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate"
|
||||
|
||||
and evalDo e (args as _::_) = map (eval' e) args |> List.last
|
||||
| evalDo _ _ = raise NotApplicable "do needs at least one argument"
|
||||
|
||||
and evalIf e [c,a,b] = if truthy (eval' e c) then (eval' e a) else (eval' e b)
|
||||
| evalIf e [c,a] = if truthy (eval' e c) then (eval' e a) else NIL
|
||||
| evalIf _ _ = raise NotApplicable "if needs two or three arguments"
|
||||
|
||||
and evalFn e [(LIST binds),body] = FN (fn (exprs) => eval' (bind (interleave binds exprs) e) body)
|
||||
| evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body"
|
||||
|
||||
and evalApply e (FN f) args = f (map (eval' e) args)
|
||||
| evalApply _ a args = raise NotApplicable (prStr a ^ " is not applicable on " ^ prStr (LIST args))
|
||||
|
||||
@ -38,29 +49,7 @@ fun rep e s =
|
||||
| NotApplicable msg => (e, "CANNOT APPLY: " ^ msg)
|
||||
| NotDefined msg => (e, "NOT DEFINED: " ^ msg)
|
||||
|
||||
fun malPlus (INT a, INT b) = INT (a + b)
|
||||
| malPlus _ = raise NotApplicable "can only add integers"
|
||||
fun malTimes (INT a, INT b) = INT (a * b)
|
||||
| malTimes _ = raise NotApplicable "can only multiply integers"
|
||||
fun malMinus (INT b, INT a) = INT (a - b)
|
||||
| malMinus _ = raise NotApplicable "can only subtract integers"
|
||||
fun malDiv (INT b, INT a) = INT (a div b)
|
||||
| malDiv _ = raise NotApplicable "can only divide integers"
|
||||
|
||||
val initEnv = ENV [] |> bind [
|
||||
SYMBOL "+",
|
||||
FN (foldl malPlus (INT 0)),
|
||||
SYMBOL "*",
|
||||
FN (foldl malTimes (INT 1)),
|
||||
SYMBOL "-",
|
||||
FN (fn [x] => malMinus (x, INT 0)
|
||||
| x::xs => foldr malMinus x xs
|
||||
| _ => raise NotApplicable "'-' requires arguments"),
|
||||
SYMBOL "/",
|
||||
FN (fn [x] => malDiv (x, INT 1)
|
||||
| x::xs => foldr malDiv x xs
|
||||
| _ => raise NotApplicable "'/' requires arguments")
|
||||
]
|
||||
val initEnv = ENV [] |> bind coreNs
|
||||
|
||||
fun repl () = repl' initEnv
|
||||
|
||||
|
@ -4,3 +4,7 @@ datatype mal_type = NIL
|
||||
| INT of int
|
||||
| LIST of mal_type list
|
||||
| FN of mal_type list -> mal_type
|
||||
|
||||
fun truthy (BOOL false) = false
|
||||
| truthy NIL = false
|
||||
| truthy _ = true
|
||||
|
@ -11,3 +11,6 @@ fun optOrElse NONE b = b ()
|
||||
|
||||
fun valOrElse (SOME x) _ = x
|
||||
| valOrElse a b = b ()
|
||||
|
||||
fun interleave (x::xs) (y::ys) = x :: y :: interleave xs ys
|
||||
| interleave _ _ = []
|
||||
|
Loading…
Reference in New Issue
Block a user