Removed irrelevant comment

lib/ast.ml

@@ -19,6 +19,7 @@ type lisp_val =
   that it receives all of its arguments completely unevaluated
   in a compiled lisp this would probably make more of a difference *)
   | LMacro of string * environment * lisp_val * lisp_val
+  | LUnnamedMacro of environment * lisp_val * lisp_val
   | LQuoted of lisp_val
 and environment = (string, lisp_val) Hashtbl.t list
 
@@ -59,7 +60,9 @@ let rec dbg_print_one v =
     (dbg_print_one args)
   | LFunction (name, _, args, _) -> pf "<function: '%s' lambda-list: %s>" 
     name (dbg_print_one args)
-  | LMacro (name, _, args, _) -> pf "<function '%s' lambda-list: %s>"
+  | LUnnamedMacro (_, args, _) -> pf "<unnamed macro, lambda-list: %s>"
+    (dbg_print_one args)
+  | LMacro (name, _, args, _) -> pf "<macro '%s' lambda-list: %s>"
     name (dbg_print_one args)
   | LQuoted v -> pf "<quote: %s>" (dbg_print_one v)
   (*| _ -> "<Something else>"*)

lib/eval.ml

@@ -8,12 +8,6 @@ let add_builtin s f =
   env_set_global default_env s (LBuiltinFunction (s, f))
 let add_special s f =
   env_set_global default_env s (LBuiltinSpecial (s, f))
-let () = add_builtin "+" iadd
-let () = add_builtin "-" isub
-let () = add_builtin "car" car
-let () = add_builtin "cdr" cdr
-let () = add_builtin "bind-symbol" bind_symbol 
-let () = add_special "lambda" lambda
 
 let make_env () = [Hashtbl.copy (List.hd default_env)]
 
@@ -52,12 +46,16 @@ and eval_body env body =
 and err s = raise (Invalid_argument s)
 and bind_args env = function
   | LNil -> (function
-      | LNil -> () | _ -> err "bind_args")
+      | LNil -> ()
+      | _ -> err "cannot bind arguments")
+  | LSymbol s ->
+    (function
+      | v -> env_set_local env s v; ())
   | LCons (LSymbol hl, tl) -> (function
       | LCons (ha, ta) -> 
         env_set_local env hl ha;
         bind_args env tl ta;
-      | _ -> err "bind_args")
+      | _ -> err "cannot bind arguments")
   | _ -> fun _ -> err "bind_args"
   
 and eval_apply args = function
@@ -66,6 +64,7 @@ and eval_apply args = function
     let lexical_env = env_new_lexical e in
     bind_args lexical_env l args;
     eval_body lexical_env b
+  | LUnnamedMacro (e, l, b)
   | LMacro (_, e, l, b) ->
     let lexical_env = env_new_lexical e in
     bind_args lexical_env l args;
@@ -86,10 +85,60 @@ and eval_call env func args =
   | LFunction _ -> eval_apply (eval_list env args) func
   (* Macros are the same, they just return code that *will* be evaluated
   in the calling environment *)
-  | LMacro _ -> eval_apply args func
+  | LUnnamedMacro _
+  | LMacro _ -> eval_one env (eval_apply args func)
   | v -> raise (Invalid_argument 
-        (Printf.sprintf "eval_apply: cannot call non-function object %s" (dbg_print_one v)));;
+                  (Printf.sprintf "eval_apply: cannot call non-function object %s" (dbg_print_one v)))
+
+and (* This only creates a *local* binding, contained to the body given. *)
+  bind_local env =
+  function
+  | LCons (LSymbol s, LCons (v, body)) ->
+    let e = env_new_lexical env in
+    env_set_local e s v;
+    eval_body e body
+  | _ -> invalid_arg "invalid argument to bind-local"
+and lisp_if env = function
+  | LCons (cond, LCons (if_true, LNil)) ->
+    (match eval_one env cond with
+     | LNil -> LNil
+     | _ -> eval_one env if_true)
+  | LCons (cond, LCons (if_true, LCons (if_false, LNil))) ->
+    (match eval_one env cond with
+     | LNil -> eval_one env if_false
+     | _ -> eval_one env if_true)
+  | _ -> invalid_arg "invalid argument list passed to if!"
 
 let eval_all env vs =
   let ev v = eval_one env v in
   List.map ev vs
+
+let () = add_builtin "+" add
+let () = add_builtin "-" sub
+let () = add_builtin "car" car
+let () = add_builtin "cdr" cdr
+let () = add_builtin "cons" cons
+let () = add_builtin "bind-symbol" bind_symbol 
+let () = add_builtin "list" lisp_list
+let () = add_special "fn" lambda
+let () = add_special "fn-macro" lambda_macro
+let () = add_special "let-one" bind_local
+let () = add_special "quote" (fun _ -> function
+    | LCons (x, LNil) -> x
+                         | _ -> invalid_arg "hmm")
+let () = add_special "if" lisp_if
+(*let () = add_builtin "print" lisp_prin *)
+
+(* I know this looks insane. please trust me. *)
+let _ = eval_all default_env (Read.parse_str "
+(bind-symbol 'defn
+  (fn-macro (name lm . body)
+    (list 'bind-symbol (list 'quote name) (cons 'fn (cons lm body)))))
+(bind-symbol 'defmacro
+  (fn-macro (name lm . body)
+    (list 'bind-symbol (list 'quote name) (cons 'fn-macro (cons lm body)))))
+(defmacro def
+  (var val)
+  (list 'bind-symbol (list 'quote var) val))
+()")
+

lib/interpreterStdlib.ml

@@ -1,37 +1,33 @@
 open Ast;;
 
-let iadd _ vs : lisp_val =
-  let rec auxi vs accum = 
-    match vs with
-    | LCons (LInt a, b) -> (auxi b (accum + a))
-    | LCons (LDouble a, b) -> (auxf b ((float_of_int accum) +. a))
-    | _ -> LInt accum
-  and auxf vs accum =
-    match vs with
-    | LCons (LInt a, b) -> (auxf b (accum +. (float_of_int a)))
-    | LCons (LDouble a, b) -> (auxf b (accum +. a))
-    | _ -> LDouble accum
-  in (auxi vs 0);;
-let isub _ vs =
-  let rec auxi vs accum = 
-    match vs with
-    | LNil -> LInt accum
-    | LCons (LInt a, b) -> auxi b (accum - a)
-    | LCons (LDouble a, b) -> auxf b ((float_of_int accum) -. a)
-    | _ -> raise (Invalid_argument "-: invalid argument to subtraction operator")
-  and auxf vs accum = 
-    match vs with
-    | LNil -> LDouble accum
-    | LCons (LInt a, b) -> auxf b (accum -. (float_of_int a))
-    | LCons (LDouble a, b) -> auxf b (accum -. a)
-    | _ -> raise (Invalid_argument "-: invalid argument to subtraction operator")
-  in
-  match vs with
-  | LCons (LInt a, LNil) -> LInt (-a)
-  | LCons (LInt a, b) -> auxi b a
-  | LCons (LDouble a, LNil) -> LDouble (-. a)
-  | LCons (LDouble a, b) -> auxf b a
-  | _ -> auxi vs 0;;
+let add _ vs =
+  let rec aux accum = function
+    | LCons (a, b) ->
+      (match accum, a with
+       | LInt x , LInt y -> aux (LInt (x + y)) b
+       | LDouble x, LInt y -> aux (LDouble (x +. (float_of_int y))) b
+       | LInt x, LDouble y -> aux (LDouble ((float_of_int x) +. y)) b
+       | LDouble x, LDouble y -> aux (LDouble (x +. y)) b
+       | _ -> invalid_arg "invalid args to +")
+    | LNil -> accum
+    | _ -> invalid_arg "invalid args to +"
+  in aux (LInt 0) vs
+let sub _ vs =
+  let rec aux accum = function
+    | LNil -> accum
+    | LCons (a, b) -> (match accum, a, b with
+        | LNil, LDouble x, LNil -> LDouble (-. x)
+        | LNil, LInt x, LNil -> LInt (-x)
+        | LNil, LDouble _, _
+        | LNil, LInt _, _ -> aux a b
+        | LInt x, LInt y, _ -> aux (LInt (x - y)) b
+        | LInt x, LDouble y, _ -> aux (LDouble ((float_of_int x) -. y)) b
+        | LDouble x, LDouble y, _ -> aux (LDouble (x -. y)) b
+        | LDouble x, LInt y, _ -> aux (LDouble (x -. (float_of_int y))) b
+        | _ -> invalid_arg "invalid argument to -")
+    | _ -> invalid_arg "argument to -"
+  in aux LNil vs
+      
 
 
 let car _ vs =
@@ -44,12 +40,12 @@ let cdr _ vs =
   | LCons (LCons (_, b), LNil) -> b
   | _ -> raise (Invalid_argument "cdr: invalid argument")
 
+let cons _ vs =
+  match vs with
+  | LCons (a, LCons (b, LNil)) -> LCons (a, b)
+  | _ -> invalid_arg "invalid args to cons!"
 
-(* This is the special built-in function that allows us to create
-a new function.
-
-(bind-function 'sym '(a b) '(+ a b))
-*)
+let lisp_list _ vs = vs
 
 (* Binds any value to a symbol, in the *global environment*. *)
 let bind_symbol env =
@@ -57,16 +53,23 @@ let bind_symbol env =
   (* Special case for setting a function to a symbol, if the function
      is a lambda then we turn it into a real "function" by giving it this
      new name *)
+  | LCons (LQuoted (LSymbol s), LCons (LLambda (e, l, b), LNil))
   | LCons (LSymbol s, LCons (LLambda (e, l, b), LNil)) ->
     let f = LFunction (s, e, l, b) in
     env_set_global env s f;
     f
+  | LCons (LQuoted (LSymbol s), LCons (v, LNil))
   | LCons (LSymbol s, LCons (v, LNil)) ->
     env_set_global env s v;
     v
   | _ -> raise (Invalid_argument "invalid args to set!")
+           
 
 let lambda env = function
   | LCons (l, body) ->
     LLambda (env, l, body)
   | _ -> raise (Invalid_argument "invalid args to lambda!")
+
+let lambda_macro env = function
+  | LCons (l, body) -> LUnnamedMacro (env, l, body)
+  | _ -> invalid_arg "invalid args to lambda-macro"

lib/lexer.mll

@@ -11,7 +11,6 @@ let number_sign = '-' | '+'
 let int = number_sign? digit+
 let double = digit* '.' digit+ | digit+ '.' digit*
 
-
 let white = [' ' '\t']+
 let newline = '\r' | '\n' | "\r\n"
 
@@ -31,5 +30,6 @@ rule read =
     | '(' { LPAREN }
     | ')' { RPAREN }
     | '\'' { QUOTE }
+    | '.' { DOT }
     | _ { raise (SyntaxError ("Unexpected char: " ^ Lexing.lexeme lexbuf))}
     | eof { EOF }

lib/parser.mly

@@ -9,6 +9,7 @@
 %token LPAREN
 %token RPAREN
 %token QUOTE
+%token DOT
 %token EOF
 
 %start <Ast.lisp_val option> prog
@@ -25,10 +26,11 @@ expr:
   | s = SYM { LSymbol s }
   | s = STR { LString (String.uppercase_ascii s) }
   | LPAREN; l = lisp_list_rest { l }
-  | QUOTE; e = expr { LQuoted e}
+  | QUOTE; e = expr { LCons (LSymbol "quote", LCons (e, LNil)) }
 ;
 
 lisp_list_rest:
   | RPAREN { LNil }
+  | DOT; e = expr; RPAREN { e }
   | e = expr; lr = lisp_list_rest { LCons (e, lr) }
 ;