mirror of
https://github.com/kanaka/mal.git
synced 2024-08-16 17:20:23 +03:00
step 4 scaffolding
This commit is contained in:
parent
2cde1f602f
commit
ed899eb7a7
@ -1,4 +1,4 @@
|
||||
STEP_BINS = step0_repl step1_read_print step2_eval step3_env
|
||||
STEP_BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do
|
||||
|
||||
all: $(STEP_BINS)
|
||||
|
||||
@ -14,6 +14,9 @@ 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
|
||||
mlton -output $@ $<
|
||||
|
||||
clean:
|
||||
rm -f $(STEP_BINS)
|
||||
|
||||
|
11
impls/sml/step4_if_fn_do.mlb
Normal file
11
impls/sml/step4_if_fn_do.mlb
Normal file
@ -0,0 +1,11 @@
|
||||
local
|
||||
$(SML_LIB)/basis/basis.mlb
|
||||
util.sml
|
||||
types.sml
|
||||
printer.sml
|
||||
reader.sml
|
||||
env.sml
|
||||
step4_if_fn_do.sml
|
||||
in
|
||||
main.sml
|
||||
end
|
79
impls/sml/step4_if_fn_do.sml
Normal file
79
impls/sml/step4_if_fn_do.sml
Normal file
@ -0,0 +1,79 @@
|
||||
exception NotDefined of string
|
||||
exception NotApplicable of string
|
||||
|
||||
fun read s =
|
||||
readStr s
|
||||
|
||||
fun eval e (LIST (SYMBOL "def!"::args)) = evalDef e args
|
||||
| eval e (LIST (SYMBOL "let*"::args)) = evalLet 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)
|
||||
|
||||
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)
|
||||
| evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate"
|
||||
|
||||
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))
|
||||
|
||||
and evalSymbol e s = valOrElse (lookup e s)
|
||||
(fn _ => raise NotDefined ("symbol '" ^ s ^ "' not found"))
|
||||
|
||||
and bind (SYMBOL s::v::rest) e = def s (eval' e v) e |> bind rest
|
||||
| bind [] e = e
|
||||
| bind _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs"
|
||||
|
||||
fun print f =
|
||||
prStr f
|
||||
|
||||
fun rep e s =
|
||||
s |> read |> eval e |> (fn (e, v) => (e, print v))
|
||||
handle Nothing => (e, "")
|
||||
| SyntaxError msg => (e, "SYNTAX ERROR: " ^ msg)
|
||||
| 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")
|
||||
]
|
||||
|
||||
fun repl () = repl' initEnv
|
||||
|
||||
and repl' e =
|
||||
let open TextIO
|
||||
in (
|
||||
print("user> ");
|
||||
case inputLine(stdIn) of
|
||||
SOME(line) =>
|
||||
let val (e', s) = rep e line
|
||||
val _ = print(s ^ "\n")
|
||||
in
|
||||
repl' e'
|
||||
end
|
||||
| NONE => ()
|
||||
) end
|
Loading…
Reference in New Issue
Block a user