SML: Step 2

impls/sml/Makefile

@@ -1,4 +1,4 @@
-STEP_BINS = step0_repl step1_read_print
+STEP_BINS = step0_repl step1_read_print step2_eval
 
 all: $(STEP_BINS)
 
@@ -8,6 +8,9 @@ step0_repl: step0_repl.mlb step0_repl.sml main.sml
 step1_read_print: step1_read_print.mlb step1_read_print.sml reader.sml printer.sml types.sml util.sml main.sml
 	mlton -output $@ $<
 
+step2_eval: step2_eval.mlb step2_eval.sml env.sml reader.sml printer.sml types.sml util.sml main.sml
+	mlton -output $@ $<
+
 clean:
 	rm -f $(STEP_BINS)
 

impls/sml/env.sml

@@ -0,0 +1,5 @@
+datatype mal_env = ENV of (string * mal_type) list
+
+fun lookup (ENV fs) s =
+    fs |> List.find (eq s o #1)
+       |> Option.map #2

impls/sml/printer.sml

@@ -4,3 +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>"

impls/sml/step2_eval.mlb

@@ -0,0 +1,11 @@
+local
+    $(SML_LIB)/basis/basis.mlb
+    util.sml
+    types.sml
+    printer.sml
+    reader.sml
+    env.sml
+    step2_eval.sml
+in
+    main.sml
+end

impls/sml/step2_eval.sml

@@ -0,0 +1,68 @@
+exception NotDefined of string
+exception NotApplicable of string
+
+fun READ s =
+    readStr s
+
+fun EVAL e ast =
+    case ast of
+        LIST [] => ast
+        | LIST l => eval_apply e ast
+        | _    => eval_ast e ast
+
+and eval_ast e ast =
+    case ast of
+        SYMBOL s => (case lookup e s of SOME v => v | NONE => raise NotDefined ("unable to resolve symbol '" ^ s ^ "'"))
+        | LIST l => LIST (List.map (EVAL e) l)
+        | _      => ast
+
+and eval_apply e ast =
+    case eval_ast e ast of
+        LIST ((FN f)::args) => f args
+        | _ => raise NotApplicable "eval_apply needs a non-empty list"
+
+fun PRINT f =
+    prStr 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
+
+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 [
+    ("+", FN (foldl malPlus (INT 0))),
+    ("*", FN (foldl malTimes (INT 1))),
+    ("-", FN (
+        fn [x]   => malMinus (x, INT 0)
+         | x::xs => foldr malMinus x xs
+         | _ => raise NotApplicable "'-' requires at least one argument"
+    )),
+    ("/", FN (
+        fn [x]   => malDiv (x, INT 1)
+         | x::xs => foldr malDiv x xs
+         | _ => raise NotApplicable "'/' requires at least one argument"
+    ))
+]
+
+fun repl () =
+    let open TextIO
+    in (
+        print("user> ");
+        case inputLine(stdIn) of
+            SOME(line) => (
+                print((rep initEnv line) ^ "\n");
+                repl ()
+            )
+            | NONE => ()
+    ) end

impls/sml/types.sml

@@ -3,3 +3,4 @@ datatype mal_type = NIL
                   | BOOL of bool
                   | INT of int
                   | LIST of mal_type list
+                  | FN of mal_type list -> mal_type

impls/sml/util.sml

@@ -3,3 +3,5 @@ and takeWhile' f acc []      = rev acc
   | takeWhile' f acc (x::xs) = if f x then takeWhile' f (x::acc) xs else rev acc
 
 infix 3 |> fun x |> f = f x
+
+fun eq a b = a = b