make envs mutable

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
+    CLOSURE (fn e => (fn (ATOM a::(FN f)::args)      => let val x = f   ((!a)::args) in (a := x; x)  end
-                   | (ATOM a::(FN4 f)::args) => let val x      = f e ((!a)::args) in (a := x; (e, x))  end
+                       | (ATOM a::(CLOSURE f)::args) => let val x = f e ((!a)::args) in (a := x; 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"))
-                   | _ => raise NotApplicable "'reset!' requires an atom argument"))
 ]
 
 val coreNs = List.concat [

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)

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 _)       = "#<function>"
-  | prStr (FN4 _)      = "#<function>"
+  | prStr (CLOSURE _)  = "#<function>"
-  | prStr (FN6 _)      = "#<function>"
 
 fun prReadableStr (STRING s) = "\"" ^ (malEscape s) ^ "\""
   | prReadableStr (ATOM x)   = "(atom " ^ (prReadableStr (!x)) ^ ")"

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

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 (LIST (a::args))             = evalApply e (eval e a) args
-  | eval e (SYMBOL s)                   = (e, evalSymbol e s)
+  | eval e (SYMBOL s)                   = evalSymbol e s
-  | eval e ast                          = (e, ast)
+  | 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))
+    s |> read |> eval e |> print
-    handle Nothing           => (e, "")
+    handle Nothing           => ""
-         | SyntaxError msg   => (e, "SYNTAX ERROR: " ^ msg)
+         | SyntaxError msg   => "SYNTAX ERROR: " ^ msg
-         | NotApplicable msg => (e, "CANNOT APPLY: " ^ msg)
+         | NotApplicable msg => "CANNOT APPLY: " ^ msg
-         | NotDefined msg    => (e, "NOT DEFINED: " ^ 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

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))  = evalFn 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 (LIST (a::args))             = (e, evalApply e (eval' e a) args)
+  | eval e (SYMBOL s)                   = evalSymbol e s
-  | eval e (SYMBOL s)                   = (e, evalSymbol e s)
+  | eval e ast                          = ast
-  | 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
-
-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)
+and evalApply e (CLOSURE (f)) args = f e (map (eval e) args)
-  | evalApply e (FN f)    args = f (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))
+  | 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))
+    s |> read |> eval e |> print
-    handle Nothing           => (e, "")
+    handle Nothing           => ""
-         | SyntaxError msg   => (e, "SYNTAX ERROR: " ^ msg)
+         | SyntaxError msg   => "SYNTAX ERROR: " ^ msg
-         | NotApplicable msg => (e, "CANNOT APPLY: " ^ msg)
+         | NotApplicable msg => "CANNOT APPLY: " ^ msg
-         | NotDefined msg    => (e, "NOT DEFINED: " ^ 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

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))  = evalFn 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 (LIST (a::args))             = evalApply e (eval' e a) args
+  | eval e (SYMBOL s)                   = evalSymbol e s
-  | eval e (SYMBOL s)                   = (e, evalSymbol e s)
+  | eval e ast                          = ast
-  | 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
-
-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] = CLOSURE (fn (e) => fn (exprs) => eval (bind (interleave binds exprs) (inside (wrap e c))) body)
-and evalFn c [(LIST binds),body] = FN6 (fn (e) => fn (exprs) => eval (bind (interleave binds exprs) (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))
+and evalApply e (CLOSURE (f)) args = f e (map (eval e) args)
-  | evalApply e (FN6 (f)) args = f e (map (eval' e) args)
+  | evalApply e (FN f)        args = f (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))
-  | 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))
+    s |> read |> eval e |> print
-    handle Nothing           => (e, "")
+    handle Nothing           => ""
-         | SyntaxError msg   => (e, "SYNTAX ERROR: " ^ msg)
+         | SyntaxError msg   => "SYNTAX ERROR: " ^ msg
-         | NotApplicable msg => (e, "CANNOT APPLY: " ^ msg)
+         | NotApplicable msg => "CANNOT APPLY: " ^ msg
-         | NotDefined msg    => (e, "NOT DEFINED: " ^ msg)
+         | NotDefined msg    => "NOT DEFINED: " ^ msg
 
-val initEnv = ENV [] |> bind coreNs
+val initEnv = ENV (NS (ref [])) |> bind coreNs
-  |> bind [
-    SYMBOL "eval",
-    FN6 (fn (e) => fn ([x]) => eval e x
-                    | _ => raise NotApplicable "'eval' requires one argument")
-  ]
 
 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
+)

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
+                  | CLOSURE of mal_env -> mal_type list -> mal_type
-                  | FN6 of mal_env -> mal_type list -> (mal_env * 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