Evaluation is now performed properly, mimicking Common Lisp, and basic defun and defmacro definitions are provided (automatically executed on startup)

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,45 @@ 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"
+
 
 let eval_all env vs =
   let ev v = eval_one env v in
   List.map ev vs
+
+let () = add_builtin "+" iadd
+let () = add_builtin "-" isub
+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 "lambda" lambda
+let () = add_special "lambda-macro" lambda_macro
+let () = add_special "let-one" bind_local
+let () = add_special "quote" (fun _ -> function
+    | LCons (x, LNil) -> x
+                         | _ -> invalid_arg "hmm")
+
+(* I know this looks insane. please trust me. *)
+let _ = eval_all default_env (Read.parse_str "
+(bind-symbol 'defun
+  (lambda-macro (name lm . body)
+    (list 'bind-symbol (list 'quote name) (cons 'lambda (cons lm body)))))
+(bind-symbol 'defmacro
+  (lambda-macro (name lm . body)
+    (list 'bind-symbol (list 'quote name) (cons 'lambda-macro (cons lm body)))))")
+

lib/interpreterStdlib.ml

@@ -44,6 +44,13 @@ 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!"
+
+let lisp_list _ vs = vs
+
 
 (* This is the special built-in function that allows us to create
 a new function.
@@ -57,16 +64,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) }
 ;