From e160b83391743cf67f6fb3f34392d1ba4ae896a9 Mon Sep 17 00:00:00 2001 From: Fabian Date: Thu, 1 Apr 2021 18:12:41 +0200 Subject: [PATCH] make envs mutable --- impls/sml/core.sml | 9 +++--- impls/sml/env.sml | 15 +++++++-- impls/sml/printer.sml | 3 +- impls/sml/step2_eval.sml | 4 +-- impls/sml/step3_env.sml | 32 +++++++++--------- impls/sml/step4_if_fn_do.sml | 46 +++++++++++++------------- impls/sml/step6_file.sml | 63 ++++++++++++++++++------------------ impls/sml/types.sml | 8 +++-- 8 files changed, 92 insertions(+), 88 deletions(-) diff --git a/impls/sml/core.sml b/impls/sml/core.sml index a15ff2e2..3562464d 100644 --- a/impls/sml/core.sml +++ b/impls/sml/core.sml @@ -24,7 +24,7 @@ val coreList = [ (* N.B. adds extra newline at end *) fun slurp lines strm = case TextIO.inputLine strm of SOME l => slurp (l::lines) strm - | NONE => rev lines + | NONE => (TextIO.closeIn strm; rev lines) fun malPrint s = ( TextIO.print (s ^ "\n"); @@ -107,10 +107,9 @@ val coreAtom = [ | _ => raise NotApplicable "'reset!' requires an atom argument"), SYMBOL "swap!", - FN6 (fn e => (fn (ATOM a::(FN f)::args) => let val x = f ((!a)::args) in (a := x; (e, x)) end - | (ATOM a::(FN4 f)::args) => let val x = f e ((!a)::args) in (a := x; (e, x)) end - | (ATOM a::(FN6 f)::args) => let val (e',x) = f e ((!a)::args) in (a := x; (e', x)) end - | _ => raise NotApplicable "'reset!' requires an atom argument")) + CLOSURE (fn e => (fn (ATOM a::(FN f)::args) => let val x = f ((!a)::args) in (a := x; x) end + | (ATOM a::(CLOSURE f)::args) => let val x = f e ((!a)::args) in (a := x; x) end + | _ => raise NotApplicable "'reset!' requires an atom argument")) ] val coreNs = List.concat [ diff --git a/impls/sml/env.sml b/impls/sml/env.sml index 0f37d29d..1ebcbb2f 100644 --- a/impls/sml/env.sml +++ b/impls/sml/env.sml @@ -1,5 +1,14 @@ -fun def s v (ENV d) = (s, v) :: (d |> List.filter (not o eq s o #1)) |> ENV +fun set s v (NS d) = d := (s, v) :: (!d |> List.filter (not o eq s o #1)) -fun lookup (ENV d) s = d |> List.find (eq s o #1) |> Option.map #2 +fun get (NS d) s = !d |> List.find (eq s o #1) |> Option.map #2 -fun wrap (ENV outer) (ENV inner) = ENV (inner @ outer) +fun def s v (ENV ns) = set s v ns + | def s v (INNER (ns, _)) = set s v ns + +fun lookup (ENV ns) s = get ns s + | lookup (INNER (ns, outer)) s = optOrElse (get ns s) (fn () => lookup outer s) + +fun wrap outer (ENV ns) = INNER (ns, outer) + | wrap outer (INNER (ns, inner)) = INNER (ns, wrap outer inner) + +fun inside outer = INNER (NS (ref []), outer) diff --git a/impls/sml/printer.sml b/impls/sml/printer.sml index b7a2e5a9..954cd075 100644 --- a/impls/sml/printer.sml +++ b/impls/sml/printer.sml @@ -7,8 +7,7 @@ fun prStr NIL = "nil" | prStr (STRING s) = s | prStr (LIST l) = "(" ^ (String.concatWith " " (map prStr l)) ^ ")" (* N.B. not tail recursive *) | prStr (FN _) = "#" - | prStr (FN4 _) = "#" - | prStr (FN6 _) = "#" + | prStr (CLOSURE _) = "#" fun prReadableStr (STRING s) = "\"" ^ (malEscape s) ^ "\"" | prReadableStr (ATOM x) = "(atom " ^ (prReadableStr (!x)) ^ ")" diff --git a/impls/sml/step2_eval.sml b/impls/sml/step2_eval.sml index f60639e3..02f8c316 100644 --- a/impls/sml/step2_eval.sml +++ b/impls/sml/step2_eval.sml @@ -40,7 +40,7 @@ fun malMinus (INT b, INT a) = INT (a - b) fun malDiv (INT b, INT a) = INT (a div b) | malDiv _ = raise NotApplicable "can only divide integers" -val initEnv = ENV [ +val initEnv = ENV (NS (ref [ ("+", FN (foldl malPlus (INT 0))), ("*", FN (foldl malTimes (INT 1))), ("-", FN ( @@ -53,7 +53,7 @@ val initEnv = ENV [ | x::xs => foldr malDiv x xs | _ => raise NotApplicable "'/' requires at least one argument" )) -] +])) fun repl () = let open TextIO diff --git a/impls/sml/step3_env.sml b/impls/sml/step3_env.sml index d98c9a3b..f48a8254 100644 --- a/impls/sml/step3_env.sml +++ b/impls/sml/step3_env.sml @@ -6,25 +6,23 @@ fun read 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) + | eval e (LIST (a::args)) = evalApply e (eval e a) args + | eval e (SYMBOL s) = evalSymbol e s + | eval e ast = 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 +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 (inside 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) +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 +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" @@ -32,11 +30,11 @@ 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) + s |> read |> eval e |> print + handle Nothing => "" + | SyntaxError msg => "SYNTAX ERROR: " ^ msg + | NotApplicable msg => "CANNOT APPLY: " ^ msg + | NotDefined msg => "NOT DEFINED: " ^ msg fun malPlus (INT a, INT b) = INT (a + b) | malPlus _ = raise NotApplicable "can only add integers" @@ -47,7 +45,7 @@ fun malMinus (INT b, INT a) = INT (a - b) fun malDiv (INT b, INT a) = INT (a div b) | malDiv _ = raise NotApplicable "can only divide integers" -val initEnv = ENV [] |> bind [ +val initEnv = ENV (NS (ref [])) |> bind [ SYMBOL "+", FN (foldl malPlus (INT 0)), SYMBOL "*", @@ -68,10 +66,10 @@ fun repl e = print("user> "); case inputLine(stdIn) of SOME(line) => - let val (e', s) = rep e line + let val s = rep e line val _ = print(s ^ "\n") in - repl e' + repl e end | NONE => () ) end diff --git a/impls/sml/step4_if_fn_do.sml b/impls/sml/step4_if_fn_do.sml index ee39cecd..00aa79f3 100644 --- a/impls/sml/step4_if_fn_do.sml +++ b/impls/sml/step4_if_fn_do.sml @@ -2,40 +2,38 @@ 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 "let*"::args)) = (e, evalLet 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) + | eval e (LIST (SYMBOL "fn*"::args)) = evalFn e args + | eval e (LIST (a::args)) = evalApply e (eval e a) args + | eval e (SYMBOL s) = evalSymbol e s + | eval e ast = 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 +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 e) ast +and evalLet e [LIST 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, (e,_)) => eval e x) (eval e x) xs +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] = eval e c |> (fn (e,c) => eval e (if truthy c then a else b)) +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 c [(LIST binds),body] = FN4 (fn (e) => fn (exprs) => eval' (bind (interleave binds exprs) (wrap e c)) body) +and evalFn c [(LIST binds),body] = CLOSURE (fn (e) => fn (exprs) => eval (bind (interleave binds exprs) (inside (wrap e c))) body) | evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body" -and evalApply e (FN4 (f)) args = f e (map (eval' e) args) - | 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 evalApply e (CLOSURE (f)) args = f e (map (eval e) args) + | 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 +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" @@ -43,13 +41,13 @@ 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) + 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 [] |> bind coreNs +val initEnv = ENV (NS (ref [])) |> bind coreNs fun repl e = let open TextIO @@ -57,10 +55,10 @@ fun repl e = print("user> "); case inputLine(stdIn) of SOME(line) => - let val (e', s) = rep e line + let val s = rep e line val _ = print(s ^ "\n") in - repl e' + repl e end | NONE => () ) end diff --git a/impls/sml/step6_file.sml b/impls/sml/step6_file.sml index 87099aa2..9e7b60ed 100644 --- a/impls/sml/step6_file.sml +++ b/impls/sml/step6_file.sml @@ -2,42 +2,38 @@ 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 "let*"::args)) = (e, evalLet e args) - | eval e (LIST (SYMBOL "fn*"::args)) = (e, evalFn e args) - | eval e (LIST (a::args)) = evalApply e (eval' e a) args - | eval e (SYMBOL s) = (e, evalSymbol e s) - | eval e ast = (e, ast) + | eval e (LIST (SYMBOL "fn*"::args)) = evalFn e args + | eval e (LIST (a::args)) = evalApply e (eval e a) args + | eval e (SYMBOL s) = evalSymbol e s + | eval e ast = 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 +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 e) ast +and evalLet e [LIST 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, (e,_)) => eval e x) (eval e x) xs +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] = eval e c |> (fn (e,c) => eval e (if truthy c then a else b)) +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" -(* TODO: Wrapping, binding, and mutating an env must be separate things *) -and evalFn c [(LIST binds),body] = FN6 (fn (e) => fn (exprs) => eval (bind (interleave binds exprs) (wrap e c)) body) +and evalFn c [(LIST binds),body] = CLOSURE (fn (e) => fn (exprs) => eval (bind (interleave binds exprs) (inside (wrap e c))) body) | evalFn _ _ = raise NotApplicable "fn* needs a list of bindings and a body" -and evalApply e (FN4 (f)) args = (e, f e (map (eval' e) args)) - | evalApply e (FN6 (f)) args = f e (map (eval' e) args) - | evalApply e (FN f) args = (e, f (map (eval' e) args)) - | evalApply _ x args = raise NotApplicable (prStr x ^ " is not applicable on " ^ prStr (LIST args)) +and evalApply e (CLOSURE (f)) args = f e (map (eval e) args) + | 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 +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" @@ -45,18 +41,13 @@ fun print f = prReadableStr 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) + 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 [] |> bind coreNs - |> bind [ - SYMBOL "eval", - FN6 (fn (e) => fn ([x]) => eval e x - | _ => raise NotApplicable "'eval' requires one argument") - ] +val initEnv = ENV (NS (ref [])) |> bind coreNs fun repl e = let open TextIO @@ -64,10 +55,10 @@ fun repl e = print("user> "); case inputLine(stdIn) of SOME(line) => - let val (e', s) = rep e line + let val s = rep e line val _ = print(s ^ "\n") in - repl e' + repl e end | NONE => () ) end @@ -78,4 +69,12 @@ val prelude = " \ \ (fn* (f) \ \ (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" -fun main () = (rep initEnv prelude) |> #1 |> repl +fun main () = ( + bind [ + SYMBOL "eval", + FN (fn ([x]) => eval initEnv x + | _ => raise NotApplicable "'eval' requires one argument") + ] initEnv; + rep initEnv prelude; + repl initEnv +) diff --git a/impls/sml/types.sml b/impls/sml/types.sml index de805b31..10937b1a 100644 --- a/impls/sml/types.sml +++ b/impls/sml/types.sml @@ -6,10 +6,12 @@ datatype mal_type = NIL | LIST of mal_type list | ATOM of mal_type ref | FN of mal_type list -> mal_type - | FN4 of mal_env -> mal_type list -> mal_type - | FN6 of mal_env -> mal_type list -> (mal_env * mal_type) + | CLOSURE of mal_env -> mal_type list -> mal_type -and mal_env = ENV of (string * mal_type) list +and mal_ns = NS of (string * mal_type) list ref + +and mal_env = ENV of mal_ns + | INNER of mal_ns * mal_env fun truthy (BOOL false) = false | truthy NIL = false