diff --git a/impls/sml/Makefile b/impls/sml/Makefile index de08e5e4..ae46bada 100644 --- a/impls/sml/Makefile +++ b/impls/sml/Makefile @@ -1,4 +1,4 @@ -STEP_BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step6_file step7_quote +STEP_BINS = step0_repl step1_read_print step2_eval step3_env step4_if_fn_do step6_file step7_quote step8_macros sml_MODE_DEFAULT = polyml sml_MODE_CONFIG = .smlmode diff --git a/impls/sml/step8_macros.mlb b/impls/sml/step8_macros.mlb new file mode 100644 index 00000000..0c710cee --- /dev/null +++ b/impls/sml/step8_macros.mlb @@ -0,0 +1,12 @@ +local + $(SML_LIB)/basis/basis.mlb + util.sml + types.sml + printer.sml + reader.sml + env.sml + core.sml + step8_macros.sml +in + main.sml +end diff --git a/impls/sml/step8_macros.sml b/impls/sml/step8_macros.sml new file mode 100644 index 00000000..8ad9e692 --- /dev/null +++ b/impls/sml/step8_macros.sml @@ -0,0 +1,115 @@ +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 (SYMBOL "do"::args)) = evalDo e args + | eval e (LIST (SYMBOL "if"::args)) = evalIf e args + | eval e (LIST (SYMBOL "fn*"::args)) = evalFn e args + | eval e (LIST (SYMBOL "quote"::args)) = evalQuote e args + | eval e (LIST (SYMBOL "quasiquote"::args)) = eval e (expandQuasiquote args) + | eval e (LIST (SYMBOL "quasiquoteexpand"::args)) = expandQuasiquote args + | eval e (LIST (a::args)) = evalApply e (eval e a) args + | eval e (SYMBOL s) = evalSymbol e s + | eval e (VECTOR v) = VECTOR (map (eval e) v) + | eval e (MAP m) = MAP (List.map (fn (k, v) => (eval e k, eval e v)) m) + | eval e ast = 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] = eval (bind bs (inside e)) ast + | evalLet e [VECTOR bs, ast] = eval (bind bs (inside e)) ast + | evalLet _ _ = raise NotApplicable "let* needs a list of bindings and a form to evaluate" + +and evalDo e (x::xs) = foldl (fn (x, _) => eval e x) (eval e x) xs + | 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] = evalIf e [c,a,NIL] + | evalIf _ _ = raise NotApplicable "if needs two or three arguments" + +and evalFn e [(LIST binds),body] = makeFn e binds body + | evalFn e [(VECTOR binds),body] = makeFn e binds body + | evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body" +and makeFn e binds body = FN (fn (exprs) => eval (bind' binds exprs (inside e)) body) + +and evalQuote e [x] = x + | evalQuote _ _ = raise NotApplicable "quote needs one argument" + +and expandQuasiquote [LIST [SYMBOL "unquote", x]] = x + | expandQuasiquote [LIST l] = LIST (foldr quasiFolder [] l) + | expandQuasiquote [VECTOR v] = LIST [SYMBOL "vec", LIST (foldr quasiFolder [] v)] + | expandQuasiquote [m as MAP _] = LIST [SYMBOL "quote", m] + | expandQuasiquote [s as SYMBOL _] = LIST [SYMBOL "quote", s] + | expandQuasiquote [x] = x + | expandQuasiquote _ = raise NotApplicable "quasiquote needs one argument" +and quasiFolder (LIST [SYMBOL "splice-unquote", x], acc) = [SYMBOL "concat", x, LIST acc] + | quasiFolder (x, acc) = [SYMBOL "cons", expandQuasiquote [x], LIST acc] + +and evalApply e (FN f) args = f (map (eval e) args) + | evalApply _ x args = raise NotApplicable (prStr x ^ " 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 e) + | bind [] e = e + | bind _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs" + +and bind' [SYMBOL "&", SYMBOL s] vs e = (def s (LIST (map (eval e) vs)) e; e) + | bind' (SYMBOL s::bs) (v::vs) e = (def s (eval e v) e; bind' bs vs e) + | bind' [] _ e = e + | bind' _ _ _ = raise NotApplicable "bindings must be a list of symbol/form pairs" + +fun print f = + prReadableStr f + +fun rep e s = + s |> read |> eval e |> print + handle Nothing => "" + | SyntaxError msg => "SYNTAX ERROR: " ^ msg + | NotApplicable msg => "CANNOT APPLY: " ^ msg + | NotDefined msg => "NOT DEFINED: " ^ msg + +val initEnv = ENV (NS (ref [])) |> bind coreNs + +fun repl e = + let open TextIO + in ( + print("user> "); + case inputLine(stdIn) of + SOME(line) => + let val s = rep e line + val _ = print(s ^ "\n") + in + repl e + end + | NONE => () + ) end + +val prelude = " \ +\(def! not (fn* (a) (if a false true))) \ +\(def! \ +\ load-file \ +\ (fn* (f) \ +\ (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" + +fun main () = ( + bind [ + SYMBOL "eval", + FN (fn ([x]) => eval initEnv x + | _ => raise NotApplicable "'eval' requires one argument") + ] initEnv; + rep initEnv ("(do " ^ prelude ^ " nil)"); + case CommandLine.arguments () of + prog::args => ( + def "*ARGV*" (LIST (map STRING args)) initEnv; + rep initEnv ("(load-file \"" ^ prog ^ "\")"); + () + ) + | args => ( + def "*ARGV*" (LIST (map STRING args)) initEnv; + repl initEnv + ) +)