interpreter: minor fixes, changes to the main binary to actually interpret some source code

bin/comp.ml

@@ -1,22 +1,16 @@
-
-let def = Parser.parse_str "(define (f)
-                             (let ((x 5))
-                              (if t (set! x (+ x 1)))))
-                            (define (f)
-                              (define (g y) (* y 2))
-                              (or (g 5) (g 6)))
-                            (cond
-                             ((> 1 2) 0)
-                             ((> 3 2) 3)
-                             (t -1))";;
-
 let ( let* ) = Result.bind;;
-let e =
-  (*let def = Parser.parse_str "(lambda () (+ x 1) (+ x 1))" in
-   *)
-  let* top = Compiler.Syntactic_ast.make (List.hd def) in
-  Ok (Printf.printf "%s\n" (Compiler.Syntactic_ast.print top))
 
-let _ = match e with
+(* Try to interpret some test source code. *)
-  | Error s -> Printf.printf "%s\n" s
+let some_source = "(define (+ a b) b)
+                   (+ 1 2)";;
+(* I don't have any built-in functions at all rn, so we just use a dummy function *)
+
+let bruh =
+  let* res = Interpreter.Main.interpret_src some_source in
+  match res with
+  | Int x -> Printf.printf "got %d as result\n" x; Ok ()
+  | _ -> Printf.printf "got something else\n" ; Ok ()
+let _ =
+  match bruh with
+  | Error s -> Printf.printf "%s" s
   | _ -> ()

bin/dune

@@ -1,9 +1,3 @@
-(executable
- (name inter)
- (public_name ollisp-inter)
- (libraries str unix interpreter)
- (package ollisp))
-
 (executable
  (name comp)
  (public_name ollisp)

bin/inter.ml

@@ -1,31 +0,0 @@
-open Interpreter.Ast;;
-open Printf;;
-open Interpreter;;
-open Env;;
-open Eval;;
-
-let () = Stdlib.init_default_env ()
-
-let rec repl env c =
-  let () = printf ">>> "; Out_channel.flush Out_channel.stdout; in
-  match In_channel.input_line c with
-  | None -> ()
-  | Some "exit" -> ()
-  | Some l ->
-    try
-      let vals = (read_from_str l) in
-      (* dbg_print_all vals; *)
-      pretty_print_all (eval_all env vals);
-      Out_channel.flush Out_channel.stdout;
-      repl env c
-    with
-    | Invalid_argument s ->
-      printf "%s\nResuming repl\n" s;
-      repl env c
-    | Parser.Parse.Error ->
-      printf "Expression '%s' couldn't be parsed, try again\n" l;
-      repl env c
-;;
-
-
-let () = repl (make_env ()) (In_channel.stdin)

lib/compiler/core_ast.ml

@@ -1,4 +1,6 @@
 
+let traverse = Util.traverse
+
 type literal =
   | Int of int
   | Double of float
@@ -121,3 +123,7 @@ and of_syntactic : Syntactic_ast.top_level -> top_level = function
 let of_sexpr x =
   Result.bind (Syntactic_ast.make x)
     (fun x -> Ok (of_syntactic x))
+
+let of_src src =
+  let sexprs = Parser.parse_str src in
+  traverse of_sexpr sexprs

lib/compiler/scope_analysis.ml

@@ -0,0 +1,142 @@
+
+
+module SymbolTable = Map.Make(String);;
+
+let ( let* ) = Result.bind
+let traverse = Util.traverse
+
+(* literals are not modified. *)
+type literal = Core_ast.literal
+
+(* Note:
+   all symbol accesses are replaced with either a local or global access.
+   Local accesses a symbol in the local scope.
+   Global accesses a symbol in the global scope.
+
+   Lambda expressions are stripped of the symbol name of their single parameter.
+   This name is not needed at runtime, as all symbol accesses will be resolved
+   into an index into either the local scope linked list or the global symbol table.
+
+   Set is also split into its global and local versions, just like Var. 
+
+   The rest aren't modified at all.
+ *)
+type expression =
+  | Literal of literal
+  | Local of int
+  | Global of int
+  | Apply of expression * expression
+  | Lambda of expression
+  | If of expression * expression * expression
+  | SetLocal of int * expression
+  | SetGlobal of int * expression
+  | Begin of expression list
+
+
+(* extract all defined global symbols, given the top-level expressions
+   and definitions of a program
+
+   The returned table maps symbol names to unique integers, representing
+   an index into a global array where the values of all global symbols will
+   be kept at runtime.
+ *)
+let extract_globals (top : Core_ast.top_level list) =
+  let id_counter = (ref (-1)) in
+  let id () =
+    id_counter := !id_counter + 1; !id_counter in
+  let rec aux tbl = function
+    | [] -> tbl
+    | Core_ast.Define (sym, _) :: rest ->
+       aux (SymbolTable.add sym (id ()) tbl) rest
+    | Expr _ :: rest ->
+       aux tbl rest
+  in aux SymbolTable.empty top
+
+(* The current lexical scope is simply a linked list of entries,
+   and each symbol access will be resolved as an access to an index
+   in this linked list. The symbol names are erased before runtime.
+   During this analysis we keep the lexical scope as a linked list of
+   symbols, and we find the index by traversing this linked list.
+ *)
+
+let resolve_global tbl sym =
+  match SymbolTable.find_opt sym tbl with
+  | Some x -> Ok (Global x)
+  | None -> Error ("symbol " ^ sym ^ " is not defined!")
+
+let resolve_lexical tbl env sym =
+  let rec aux counter = function
+    | [] -> resolve_global tbl sym
+    | x :: _ when String.equal x sym -> Ok (Local counter)
+    | _ :: rest -> aux (counter + 1) rest
+  in aux 0 env
+
+let resolve_symbol tbl env sym =
+  resolve_lexical tbl env sym
+
+let resolve_set tbl env sym expr =
+  let* sym = resolve_symbol tbl env sym in
+  match sym with
+  | Local i -> Ok (SetLocal (i, expr))
+  | Global i -> Ok (SetGlobal (i, expr))
+  | _ -> Error "resolve_set: symbol resolution returned something invalid."
+
+(* We need to do some more sophisticated analysis to detect cases where
+   a symbol is accessed before it is defined.
+   If a symbol is accessed in a lambda body, that is fine, since that computation
+   is delayed, but for top-level forms that are directly executed we must be strict.
+
+   This function is strict by default, until it encounters a lambda, at which
+   point it switches to resolving against all symbols.
+   global_tbl is a table that contains ALL defined symbols,
+   tbl is a table that contains symbols defined only until this point.
+
+   NOTE: because we currently convert all let expressions into lambdas, things like
+   this won't immediately be rejected by the compiler:
+
+   (let ((a 5))
+     b)
+   (define b 5)
+
+   I may consider adding special support for let forms, as this is pretty annoying.
+ *)
+let convert program =
+  let global_tbl = extract_globals program in
+  let id_counter = (ref (-1)) in
+  let id () =
+    id_counter := !id_counter + 1; !id_counter in
+  let rec analyze tbl current = function
+    | Core_ast.Literal s -> Ok (Literal s)
+    | Var sym -> resolve_symbol tbl current sym
+    | Set (sym, expr) ->
+       let* inner = analyze tbl current expr in
+       resolve_set tbl current sym inner
+    | Lambda (s, body) ->
+       let* body = (analyze global_tbl (s :: current) body) in
+       Ok (Lambda body)
+    | Apply (f, e) ->
+       let* f = analyze tbl current f in
+       let* e = analyze tbl current e in
+       Ok (Apply (f, e))
+    | If (test, pos, neg) ->
+       let* test = analyze tbl current test in
+       let* pos = analyze tbl current pos in
+       let* neg = analyze tbl current neg in
+       Ok (If (test, pos, neg))
+    | Begin el ->
+       let* body = traverse (analyze tbl current) el in
+       Ok (Begin body)
+  in
+  let[@tail_mod_cons] rec aux tbl = function
+    | [] -> []
+    | (Core_ast.Expr e) :: rest -> (analyze tbl [] e) :: (aux tbl rest)
+    | (Define (s, e)) :: rest ->
+       let tbl = SymbolTable.add s (id ()) tbl in
+       (analyze tbl [] (Set (s, e))) :: (aux tbl rest)
+  in
+  let* program = traverse (fun x -> x) (aux SymbolTable.empty program) in
+  Ok (program, global_tbl)
+
+let of_src src =
+  let* core = (Core_ast.of_src src) in
+  convert core

lib/compiler/syntactic_ast.ml

@@ -34,13 +34,7 @@ type top_level =
 
 (* we use result here to make things nicer *)
 let ( let* ) = Result.bind
-let traverse f l =
+let traverse = Util.traverse
-  let rec aux acc = function
-    | x :: xs ->
-       let* result = f x in
-       aux (result :: acc) xs
-    | [] -> Ok (List.rev acc) in
-  aux [] l
 let map = List.map
 
 

lib/compiler/util.ml

@@ -0,0 +1,9 @@
+let ( let* ) = Result.bind
+
+let traverse f l =
+  let rec aux acc = function
+    | x :: xs ->
+       let* result = f x in
+       aux (result :: acc) xs
+    | [] -> Ok (List.rev acc) in
+  aux [] l

lib/interpreter/ast.ml

@@ -1,142 +0,0 @@
-
-(* This is different from the lisp_ast data returned by the parser!
-   We will first need to translate that into this in order to use it.
-   This representation includes things that can only occur during runtime,
-   like the various kinds of functions and macros.
-
-   Additionally, since this is an interpreter, macros tend to be a little
-   awkward in that they behave exactly like the macro gets expanded just
-   before the result gets executed. This is different from the compiled
-   behaviour where the macro is evaluated at compile time.
-
-   Though of course, with the dynamic nature of lisp, and its capability
-   to compile more code at runtime, there will naturally be complications.
- *)
-type lisp_val = 
-  | LInt of int 
-  | LDouble of float 
-  | LCons of lisp_val * lisp_val
-  | LNil
-  | LSymbol of string
-  | LString of string
-  
-  (* a builtin function is expressed as a name and the ocaml function
-  that performs the operation. The function should take a list of arguments.
-  generally, builtin functions should handle their arguments directly,
-  and eval forms in the environment as necessary. *)
-  | LBuiltinFunction of string * (environment -> lisp_val -> lisp_val)
-  | LBuiltinSpecial of string * (environment -> lisp_val -> lisp_val)
-  (* a function is a name, captured environment, a parameter list, and function body. *)
-  | LFunction of string * environment * lisp_val * lisp_val
-  | LLambda of environment * lisp_val * lisp_val
-  (* a macro is exactly the same as a function, with the distinction
-     that it receives all of its arguments completely unevaluated
-   *)
-  | LMacro of string * environment * lisp_val * lisp_val
-  | LUnnamedMacro of environment * lisp_val * lisp_val
-  | LQuoted of lisp_val
-(* the environment type needs to be defined here, as it is mutually
- recursive with lisp_val *)
-and environment = (string, lisp_val) Hashtbl.t list
-
-(* It is clear that we need some primitives for working with the lisp
-   data structures.
-
-   For example, the LCons and LNil values, together, form a linked list.
-   This is the intended form of all source code in lisp, yet because
-   we are using our own implementation of a linked list instead of
-   ocaml's List, we can not use its many functions.
-
-   It may be tempting to switch to a different implementation.
-   Remember however, that classic lisp semantics allow for the
-   CDR component of a cons cell (the part that would point to the
-   next member) to be of a type other than the list itself.
- *)
-
-let reverse vs =
-  let rec aux prev = function
-    | LNil -> prev
-    | LCons (v, next) -> aux (LCons (v, prev)) next
-    | _ -> invalid_arg "cannot reverse non-list!"
-  in aux LNil vs
-
-let map f =
-  let rec aux accum = function
-    | LNil -> reverse accum
-    | LCons (v, next) -> aux (LCons (f v, accum)) next
-    | _ -> invalid_arg "cannot map over non-list!"
-  in aux LNil
-
-let reduce init f =
-  let rec aux accum = function
-    | LNil -> accum
-    | LCons (v, next) -> aux (f accum v) next
-    | _ -> invalid_arg "cannot reduce over non-list!"
-  in aux init
-
-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 "<nil>"
-  | LCons _ -> pf "<list: (%s)>" (dbg_print_list v) 
-  | LDouble d -> pf "<double: %f>" d
-  | LBuiltinSpecial (name, _)
-  | LBuiltinFunction (name, _) -> pf "<builtin: %s>" name
-  | LLambda (_, args, _) -> pf "<unnamed function, lambda-list: %s>"
-    (dbg_print_one args)
-  | LFunction (name, _, args, _) -> pf "<function: '%s' lambda-list: %s>" 
-    name (dbg_print_one args)
-  | 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>"*)
-
-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
-
-
-let rec convert_one = function
-  | Parser.Ast.LInt x -> LInt x
-  | Parser.Ast.LDouble x -> LDouble x
-  | Parser.Ast.LNil -> LNil
-  | Parser.Ast.LString s -> LString s
-  | Parser.Ast.LSymbol s -> LSymbol s
-  | Parser.Ast.LCons (a, b) -> LCons (convert_one a, convert_one b)
-
-
-let read_from_str s =
-  List.map convert_one (Parser.parse_str s)

lib/interpreter/dune

@@ -1,4 +1,3 @@
 (library
  (name interpreter)
- (libraries parser)
+ (libraries compiler))
- (package ollisp))

lib/interpreter/env.ml

@@ -1,38 +0,0 @@
-open Ast
-(* the type `environment` is defined in Ast *)
-
-let default_env: environment = [Hashtbl.create 1024];;
-
-let copy (env : environment) : environment =
-  List.map Hashtbl.copy env
-
-let make_env () = copy default_env
-
-let new_lexical (env : environment) : environment = 
-  let h = Hashtbl.create 16 in
-  h :: env
-
-let set_local (env : environment) (s : string) (v : lisp_val) : unit =
-  match env with
-  | [] -> ()
-  | e1 :: _ -> Hashtbl.replace e1 s v
-
-let rec update (env : environment) s v =
-  match env with
-  | [] -> ()
-  | e1 :: erest ->
-     match Hashtbl.find_opt e1 s with
-     | None -> update erest s v
-     | Some _ -> Hashtbl.replace e1 s v
-
-let rec get_root (env : environment) =
-  match env with
-  | [] -> raise (Invalid_argument "Empty environment passed to env_root!")
-  | e :: [] -> e
-  | _ :: t -> get_root t
-
-let set_global (env : environment) s v =
-  Hashtbl.replace (get_root env) s v
-
-let set_default s v =
-  set_global default_env s v

lib/interpreter/eval.ml

@@ -1,76 +0,0 @@
-open Ast;;
-
-
-(* the type annotations are unnecessary, but help constrain us from a
-potentially more general function here *)
-let rec eval_sym (env: environment) (s: string) =
-  match env with
-  | [] -> raise (Invalid_argument (Printf.sprintf "eval_sym: symbol %s has no value in current scope" s))
-  | e :: rest ->
-    match Hashtbl.find_opt e s with
-    | None -> eval_sym rest s
-    | Some v -> v
-
-let rec eval_one env = function
-  | LSymbol s -> eval_sym env s
-  | LCons (func, args) -> eval_call env (eval_one env func) args
-  | LQuoted v -> v
-  | v -> v (* All other forms are self-evaluating *)
-
-(* Evaluate a list of values, without evaluating the resulting
-function or macro call. Since macros and functions inherently
-look similar, they share a lot of code, which is extracted here *)
-and eval_list env l =
-  match l with
-  | LNil -> LNil
-  | LCons (a, b) -> LCons (eval_one env a, eval_list env b)
-  | _ -> raise (Invalid_argument "eval_list: cannot process non-list")
-
-and eval_body env body =
-  match body with
-  | LNil -> LNil
-  | LCons (form, LNil) -> eval_one env form
-  | LCons (form, next) -> ignore (eval_one env form); eval_body env next
-  | _ -> LNil
-
-and bind_args env = function
-  | (LNil, LNil) -> ()
-  | (LSymbol s, v) -> Env.set_local env s v
-  | (LCons (LSymbol hl, tl), LCons (ha, ta)) -> Env.set_local env hl ha; bind_args env (tl, ta)
-  | _ -> invalid_arg "cannot bind argument list for function"
-
-and eval_apply args = function
-  | LLambda (e, l, b)
-  | LFunction (_, e, l, b) ->
-    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);
-    eval_body lexical_env b
-  | v ->
-    invalid_arg ("Non-macro non-function value passed to eval_apply "
-        ^ dbg_print_one v)
-
-and eval_call env func args =
-  match func with
-  | LBuiltinSpecial (_, f) -> f env args
-  | LBuiltinFunction (_, f) -> f env (eval_list env args)
-  (* The function calls don't happen in the calling environment,
-     so it makes no sense to pass env to a call. *)
-  | LLambda _
-  | LFunction _ -> eval_apply (eval_list env args) func
-  (* Macros are the same, they just return code that *will* be evaluated
-  in the calling environment *)
-  | 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)))
-
-let eval_all env vs =
-  let ev v = eval_one env v in
-  List.map ev vs;;
-
-

lib/interpreter/main.ml

@@ -0,0 +1,76 @@
+
+let ( let* ) = Result.bind
+let traverse = Compiler.Util.traverse
+
+type runtime_value =
+  | Int of int
+  | Double of float
+  | String of string
+  | Nil
+  | Cons of runtime_value * runtime_value
+  | Symbol of string
+(* The rest can't appear as literal values, and are constructed in other ways *)
+  | Closure of Compiler.Scope_analysis.expression * (runtime_value ref list)
+
+let rec interpret_literal = function
+  | Compiler.Core_ast.Int x -> Ok (Int x)
+  | Double x -> Ok (Double x)
+  | String s -> Ok (String s)
+  | Cons (a, b) ->
+     let* a = interpret_literal a in
+     let* b = interpret_literal b in
+     Ok (Cons (a, b))
+  | Nil -> Ok (Nil)
+    
+
+let rec interpret_one expr env globals =
+  match expr with
+  | Compiler.Scope_analysis.Literal l -> interpret_literal l
+  | Local i ->
+     (match (List.nth_opt env i) with
+      | None -> Error "Error while accessing local variable!"
+      | Some x -> Ok !x)
+  | Global i ->
+     Ok (Array.get globals i)
+  | Apply (f, e) ->
+     let* f = interpret_one f env globals in
+     let* e = interpret_one e env globals in
+     (match f with
+      | Closure (body, inner_env) ->
+         let f_env = (ref e) :: inner_env in
+         interpret_one body f_env globals
+      | _ -> Error "Cannot apply an argument to non-closure value!")
+  | Lambda body ->
+     Ok (Closure (body, env))
+  | If (test, then_e, else_e) ->
+     let* test = interpret_one test env globals in
+     (match test with
+      | Nil -> interpret_one else_e env globals
+      | _ -> interpret_one then_e env globals)
+  | SetLocal (i, e) ->
+     (match (List.nth_opt env i) with
+      | None -> Error "Error while setting local variable!"
+      | Some r ->
+         let* e = interpret_one e env globals in
+         r := e; Ok e)
+  | SetGlobal (i, e) ->
+     let* e = interpret_one e env globals in
+     Array.set globals i e; Ok e
+  | Begin [] -> Ok Nil
+  | Begin [e] -> interpret_one e env globals
+  | Begin (e :: rest) ->
+     let* e = interpret_one e env globals in
+     ignore e; interpret_one (Begin rest) env globals
+
+let interpret program global_syms =
+  let count = Compiler.Scope_analysis.SymbolTable.cardinal global_syms in
+  let globals : runtime_value array = Array.make count Nil in
+  
+  interpret_one (Begin program) [] globals
+
+
+
+let interpret_src src =
+  let* (program, globals) = Compiler.Scope_analysis.of_src src in
+  interpret program globals
+

lib/interpreter/stdlib.ml

@@ -1,204 +0,0 @@
-open Ast;;
-
-(* I feel like the more I get into functional programming, the more insane my code
-   becomes. What the fuck is this? why do I have a set of functions that combine
-   binary operators over an arbitrarily long list? I have like. 4 operators. None
-   of this matters.
-
-   But it's just so... beautiful.
- *)
-let mathop_do_once int_op float_op = function
-  | (LDouble v1, LDouble v2) -> LDouble (float_op v1 v2)
-  | (LDouble v1, LInt v2) -> LDouble (float_op v1 (float_of_int v2))
-  | (LInt v1, LDouble v2) -> LDouble (float_op (float_of_int v1) v2)
-  | (LInt v1, LInt v2) -> LInt (int_op v1 v2)
-  | _ -> invalid_arg "invalid arguments to mathematical operator"
-
-let mathop_do_once_curried int_op float_op =
-  let f = mathop_do_once int_op float_op in
-  fun x -> fun y -> f (x, y)
-
-let mathop_reduce fi ff init vs =
-  let curried = mathop_do_once_curried fi ff in
-  reduce init curried vs
-
-let cast_int_to_double = function
-  | LInt x -> LDouble (float x)
-  | LDouble x -> LDouble x
-  | _ -> invalid_arg "can't cast_int_to_double!"
-
-let add _ vs =
-  mathop_reduce (+) (+.) (LInt 0) vs
-let sub _ = function
-  | LCons (x, LNil) -> ((mathop_do_once (-) (-.)) (LInt 0, x))
-  | LCons (x, rest) -> mathop_reduce (-) (-.) x rest
-  | _ -> invalid_arg "invalid argument list passed to (-)"
-let mul _ vs =
-  mathop_reduce ( * ) ( *. ) (LInt 1) vs
-let div _ vs =
-  let div_one = mathop_do_once ( / ) ( /. ) in
-  match vs with
-    (* (/ x) is equal to 1 / x  *)
-  | LCons (x, LNil) -> div_one (LDouble 1., cast_int_to_double x)
-  | LCons (x, LCons (y, LNil)) -> div_one (cast_int_to_double x, y)
-  | _ -> invalid_arg "invalid argument list passed to (/)"
-
-let rem _ = function
-  | LCons (x, LCons (y, LNil)) ->
-     mathop_do_once (mod) (mod_float) (cast_int_to_double x, cast_int_to_double y)
-  | _ -> invalid_arg "invalid argument list passed to (rem)"
-
-
-let car _ = function
-  | LCons (a, _) -> a
-  | _ -> invalid_arg "car: non-cons"
-let cdr _ = function
-  | LCons (_, d) -> d
-  | _ -> invalid_arg "cdr: non-cons"
-let cons _ a b = LCons (a, b)
-let lisp_list _ vs = vs
-
-(* builtin function that updates an existing binding *)
-let lisp_set env sym v =
-  match sym with
-  | LSymbol s -> Env.update env s v; v
-  | _ -> invalid_arg ("cannot set non-symbol " ^ dbg_print_one sym)
-let lambda env = function
-  | LCons (l, body) ->
-    LLambda (env, l, body)
-  | 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)
-  | 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
-  | LCons (LNil, LNil) -> LSymbol "t"
-  | _ -> LNil;;
-
-(* This only creates a *local* binding, contained to the body given. *)
-let bind_local env = function
-  | LCons (LSymbol s, LCons (v, body)) ->
-    let e = Env.new_lexical env in
-    Env.set_local e s (Eval.eval_one env v);
-    Eval.eval_body e body
-  | _ -> invalid_arg "invalid argument to bind-local"
-
-(* special form that creates a global binding *)
-let lisp_define env = function
-  | LCons (LSymbol s, LCons (v, LNil)) ->
-     let evaluated = Eval.eval_one env v in
-     Env.set_global env s evaluated;
-     evaluated
-  | _ -> invalid_arg "invalid args to def"
-
-let lisp_if env = function
-  | LCons (cond, LCons (if_true, LNil)) ->
-    (match Eval.eval_one env cond with
-     | LNil -> LNil
-     | _ -> Eval.eval_one env if_true)
-  | LCons (cond, LCons (if_true, LCons (if_false, LNil))) ->
-    (match Eval.eval_one env cond with
-     | LNil -> Eval.eval_one env if_false
-     | _ -> Eval.eval_one env if_true)
-  | _ -> invalid_arg "invalid argument list passed to if!"
-
-
-open Env;;
-
-
-let bf s f = s, LBuiltinFunction (s, f)
-let bf1 s f =
-  let aux e = function
-    | LCons (v, LNil) -> f e v
-    | _ -> invalid_arg ("invalid argument to " ^ s)
-  in bf s aux
-let bf2 s f =
-  let aux e = function
-    | LCons (v1, LCons (v2, LNil)) -> f e v1 v2
-    | _ -> invalid_arg ("invalid argument to " ^ s)
-  in bf s aux
-
-let sp s f = s, LBuiltinSpecial (s, f)
-let sp1 s f =
-  let aux e = function
-    | LCons (v, LNil) -> f e v
-    | _ -> invalid_arg ("invalid argument to " ^ s)
-  in sp s aux
-let sp2 s f =
-  let aux e = function
-    | LCons (v1, LCons (v2, LNil)) -> f e v1 v2
-    | _ -> invalid_arg ("invalid argument to " ^ s)
-  in sp s aux
- 
-
-let add_builtins bs =
-  List.iter (fun (s, f) -> set_default s f) bs
-
-(*
-(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)
-         (if (nil? l) acc (helper (cdr l) (if (f (car l)) (cons (car l) acc) acc))))
-     (helper l '())))
-";;
-
-let init_default_env () =
-  add_builtins [
-      bf "+" add; bf "-" sub;
-      bf "*" mul; bf "/" div;
-      bf1 "car" car;
-      bf1 "cdr" cdr;
-      bf2 "cons" cons;
-      bf "rem" rem;
-      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);
-      sp "if" lisp_if;
-    ];
-
-  (*let () = add_builtin "print" lisp_prin *)
-
-  (* I know this looks insane. please trust me.
-     Idea: maybe put this in a file instead of putting
-     literally the entire standard library in a constant string
-   *)
-  ignore (Eval.eval_all default_env (read_from_str init_script));
-  ()