Added pretty-printing.

bin/main.ml

@@ -16,7 +16,7 @@ let rec repl env c =
     try
       let vals = (parse_str l) in
       (* dbg_print_all vals; *)
-      dbg_print_all (eval_all env vals);
+      pretty_print_all (eval_all env vals);
       Out_channel.flush Out_channel.stdout;
       repl env c
     with

lib/ast.ml

@@ -60,14 +60,21 @@ let reduce init f =
     | _ -> invalid_arg "cannot reduce over non-list!"
   in aux init
 
-let rec dbg_print_one v =
+let rec dbg_print_list =
+  let pf = Printf.sprintf in
+  function
+  | LCons (v, LNil) -> pf "%s" (dbg_print_one v)
+  | LCons (v, rest) -> (pf "%s " (dbg_print_one v)) ^ (dbg_print_list rest)
+  | v -> pf ". %s" (dbg_print_one v)
+
+and dbg_print_one v =
   let pf = Printf.sprintf in
   match v with
   | LInt x ->  pf "<int: %d>" x
   | LSymbol s -> pf "<symbol: '%s'>" s
   | LString s -> pf "<string: '%s'>" s
-  | LNil -> pf "()"
+  | LNil -> pf "<nil>"
-  | LCons (a, b) -> pf "(%s . %s)" (dbg_print_one a) (dbg_print_one b)
+  | LCons _ -> pf "<list: (%s)>" (dbg_print_list v) 
   | LDouble d -> pf "<double: %f>" d
   | LBuiltinSpecial (name, _)
   | LBuiltinFunction (name, _) -> pf "<builtin: %s>" name
@@ -82,6 +89,27 @@ let rec dbg_print_one v =
   | LQuoted v -> pf "<quote: %s>" (dbg_print_one v)
   (*| _ -> "<Something else>"*)
 
+let rec pretty_print_one v =
+  let pf = Printf.sprintf in
+  match v with
+  | LInt x -> pf "%d" x
+  | LSymbol s -> pf "%s" s
+  | LString s -> pf "\"%s\"" s
+  | LNil -> pf "()"
+  | LCons (a, b) -> pf "(%s)" (dbg_print_list (LCons (a,b)))
+  | LDouble d -> pf "%f" d
+  | LQuoted v -> pf "'%s" (pretty_print_one v)
+  | LBuiltinSpecial _
+  | LBuiltinFunction _ 
+  | LLambda _
+  | LFunction _
+  | LUnnamedMacro _
+  | LMacro _  -> dbg_print_one v
+
+let pretty_print_all vs =
+  let pr v = Printf.printf "%s\n" (pretty_print_one v) in
+  List.iter pr vs
+
 let dbg_print_all vs =
   let pr v = Printf.printf "%s\n" (dbg_print_one v) in
   List.iter pr vs

lib/interpreterStdlib.ml

@@ -59,20 +59,28 @@ let cons _ a b = LCons (a, b)
 let lisp_list _ vs = vs
 
 (* builtin function that updates an existing binding *)
-let lisp_set env = function
+let lisp_set env sym v =
-  | LCons (LSymbol s, LCons (v, LNil)) ->
+  match sym with
-     Env.update env s v;
+  | LSymbol s -> Env.update env s v; v
-     v
+  | _ -> invalid_arg ("cannot set non-symbol " ^ dbg_print_one sym)
-  | _ -> invalid_arg "invalid args to set"
-
 let lambda env = function
   | LCons (l, body) ->
     LLambda (env, l, body)
-  | _ -> raise (Invalid_argument "invalid args to lambda!")
+  | args -> invalid_arg ("invalid args to fn! " ^ (dbg_print_one args)) 
+let defn env = function
+  | LCons (LSymbol s, LCons (l, body)) ->
+     let f = LFunction (s, env, l, body) in
+     Env.set_global env s f; f
+  | args -> invalid_arg ("cannot define function! " ^ (dbg_print_one args))
 
 let lambda_macro env = function
   | LCons (l, body) -> LUnnamedMacro (env, l, body)
-  | _ -> invalid_arg "invalid args to lambda-macro";;
+  | args -> invalid_arg ("invalid args to fn-macro! " ^ (dbg_print_one args)) 
+let defmacro env = function
+  | LCons (LSymbol s, LCons (l, body)) ->
+     let f = LMacro (s, env, l, body) in
+     Env.set_global env s f; f
+  | args -> invalid_arg ("cannot define macro! " ^ (dbg_print_one args))
 
 
 let lisp_not _ = function
@@ -83,7 +91,7 @@ let lisp_not _ = function
 let bind_local env = function
   | LCons (LSymbol s, LCons (v, body)) ->
     let e = Env.new_lexical env in
-    Env.set_local e s v;
+    Env.set_local e s (Eval.eval_one env v);
     Eval.eval_body e body
   | _ -> invalid_arg "invalid argument to bind-local"
 
@@ -107,7 +115,6 @@ let lisp_if env = function
   | _ -> invalid_arg "invalid argument list passed to if!"
 
 
-
 open Env;;
 
 
@@ -139,21 +146,24 @@ let sp2 s f =
 let add_builtins bs =
   List.iter (fun (s, f) -> set_default s f) bs
 
-
+(*
-let init_script = "
 (def defn
   (fn-macro (name lm . body)
     (list 'def name (cons 'fn (cons lm body)))))
 (def defmacro
   (fn-macro (name lm . body)
     (list 'def name (cons 'fn-macro (cons lm body)))))
+ *)
 
+let init_script =
+"
 (defmacro setq (sym val)
  (list 'set (list 'quote sym) val))
 (defmacro letfn (sym fun . body)
  (cons 'let-one (cons sym (cons '() (cons (list 'setq sym fun) body)))))
 
-
+(defn mapcar (f l)
+ (if l))
 (defn filter (f l)
    (letfn helper
        (fn (l acc)
@@ -162,27 +172,6 @@ let init_script = "
 ";;
 
 let init_default_env () =
-  (*
-  add_builtin "+" add;
-  add_builtin "-" sub;
-  add_builtin "*" mul;
-  add_builtin "/" div;
-  add_builtin "car" car;
-  add_builtin "cdr" cdr;
-  add_builtin "rem" rem;
-  add_builtin "cons" cons;
-  add_special "def" lisp_define;
-  add_builtin "set" lisp_set;
-  add_builtin "list" lisp_list;
-  add_special "fn" lambda;
-  add_special "fn-macro" lambda_macro;
-  add_special "let-one" bind_local;
-  add_special "quote" (fun _ -> function
-      | LCons (x, LNil) -> x
-      | _ -> invalid_arg "hmm");
-  add_special "if" lisp_if;
-  add_builtin "nil?" lisp_not;
-  add_builtin "not" lisp_not; (* Yes, these are the same thing *) *)
   add_builtins [
       bf "+" add; bf "-" sub;
       bf "*" mul; bf "/" div;
@@ -190,13 +179,15 @@ let init_default_env () =
       bf1 "cdr" cdr;
       bf2 "cons" cons;
       bf "rem" rem;
-      bf "set" lisp_set;
+      bf2 "set" lisp_set;
       bf "list" lisp_list;
       bf "nil?" lisp_not;
       bf "not" lisp_not;
       
       sp "fn" lambda;
+      sp "defn" defn;
       sp "fn-macro" lambda_macro;
+      sp "defmacro" defmacro;
       sp "let-one" bind_local;
       sp "def" lisp_define;
       sp1 "quote" (fun _ x -> x);