Big changes:

Compiler and VM are now working well enough to support larger programs.
A test program is included and executed immediately upon running
the executable.

A more feature complete read-eval-print loop is planned.

lib/compiler/core_ast.ml

@@ -5,6 +5,7 @@ type literal =
   | Int of int
   | Double of float
   | String of string
+  | Symbol of string
   | Nil
   | Cons of literal * literal
 
@@ -96,6 +97,7 @@ and of_literal : Syntactic_ast.literal -> literal  = function
   | LitString x -> String x
   | LitCons (a, b) -> Cons (of_literal a, of_literal b)
   | LitNil -> Nil
+  | LitSymbol s -> Symbol s
   
 and of_expr : Syntactic_ast.expr -> expression = function
   | Literal l -> Literal (of_literal l)

lib/compiler/emit.ml

@@ -47,6 +47,7 @@ let rec compile_one p = function
   | Literal Nil -> emit_constant p (Vm.Types.Nil)
   | Literal (Double x) -> emit_constant p (Vm.Types.Double x)
   | Literal (String s) -> emit_constant p (Vm.Types.String s)
+  | Literal (Symbol s) -> emit_constant p (Vm.Types.Symbol s)
   | Literal (Cons (a, b)) ->
      let* _ = compile_one p (Literal a) in
      let* _ = compile_one p (Literal b) in
@@ -90,6 +91,7 @@ let rec compile_one p = function
      compile_one p e1
   | Begin (e1 :: e2 :: rest) ->
      let* _ = compile_one p e1 in
+     let* _ = emit_instr p Vm.Types.Pop in
      compile_one p (Begin (e2 :: rest))
 
 and compile_all p exprs =
@@ -136,7 +138,6 @@ let compile (exprs : expression list) (tbl : int SymbolTable.t) =
   let* _ = emit_instr program End in
   let* _ = backpatch program in
   let final_instrs = smooth_instrs program in
-  print_endline (string_of_int (SymbolTable.cardinal tbl));
   Ok (Vm.make_vm final_instrs (Dynarray.to_array program.constants) ((SymbolTable.cardinal tbl) + 1))
 
 let compile_src src =

lib/compiler/syntactic_ast.ml

@@ -9,6 +9,7 @@ type literal =
   | LitDouble of float
   | LitString of string
   | LitCons of literal * literal
+  | LitSymbol of string
   | LitNil
 
 type lambda_list = string list * string option
@@ -203,6 +204,18 @@ and builtin_set cons =
   let* expr = unwrap_exp (transform expr) in
   exp (Set (sym, expr))
 
+and builtin_quote cons =
+  let* expr = sexpr_cadr cons in
+  let lit x = exp (Literal x) in
+  let rec aux = function
+    | LSymbol s -> (LitSymbol s)
+    | LInt x -> (LitInt x)
+    | LDouble x -> (LitDouble x)
+    | LString x -> (LitString x)
+    | LCons (a, b) -> (LitCons (aux a, aux b))
+    | LNil -> (LitNil) in
+  lit (aux expr)
+
 and apply f args =
   let* args = list_of_sexpr args in
   let* args = traverse (fun x -> unwrap_exp (transform x)) args in
@@ -217,6 +230,7 @@ and builtin_symbol = function
   | "cond" -> builtin_cond
   | "if" -> builtin_if
   | "set!" -> builtin_set
+  | "quote" -> builtin_quote
   | _ -> (function
        | LCons (f, args) -> apply f args
        | _ -> Error "Invalid function application!")
@@ -236,7 +250,8 @@ and transform : lisp_ast -> (top_level, string) result = function
 let make (expr : Parser.Ast.lisp_ast) : (top_level, string) result =
   transform expr
 
-
+let of_src s =
+  Util.traverse make (Parser.parse_str s)
 
 (* Printing, for debug purposes *)
 let pf = Printf.sprintf
@@ -266,7 +281,7 @@ and print_literal = function
   | LitString x -> pf "\"%s\"" x
   | LitNil -> pf "nil"
   | LitCons (a, b) -> pf "(%s . %s)" (print_literal a) (print_literal b)
-
+  | LitSymbol s -> pf "'%s" s
 and print_expr = function
   | Literal l -> print_literal l
   | Lambda (ll, (defs, exprs)) ->

lib/interpreter/dune

@@ -1,3 +0,0 @@
-(library
- (name interpreter)
- (libraries compiler))

lib/interpreter/main.ml

@@ -1,76 +0,0 @@
-
-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
-  | Var (Local i) ->
-     (match (List.nth_opt env i) with
-      | None -> Error "Error while accessing local variable!"
-      | Some x -> Ok !x)
-  | Var (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)
-  | Set ((Local 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)
-  | Set ((Global 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/vm/native.ml

@@ -4,18 +4,9 @@
    here.
  *)
 open Types
+
 let builtin_print (v : Types.value) =
-  let p = Printf.sprintf in
-  let rec aux_print = function
-    | Int x -> p "%d" x
-    | Double x -> p "%f" x
-    | String x -> p "\"%s\"" x
-    | Nil -> p "'()"
-    | Cons (a, b) -> p "(%s . %s)" (aux_print a) (aux_print b)
-    | Symbol x -> p "'%s" x
-    | Closure (i, _) -> p "<closure %d>" i
-    | Native i -> p "<native %d>" i in
-  print_endline (aux_print v);
+  print_endline (print_value v);
   Types.Nil
 
 let table = [|

lib/vm/types.ml

@@ -39,6 +39,18 @@ type vm_state = {
 
 
 let p = Printf.sprintf 
+
+let rec print_value = function
+    | Int x -> p "%d" x
+    | Double x -> p "%f" x
+    | String x -> p "\"%s\"" x
+    | Nil -> p "'()"
+    | Cons (a, b) -> p "(%s . %s)" (print_value a) (print_value b)
+    | Symbol x -> p "'%s" x
+    | Closure (i, _) -> p "<closure %d>" i
+    | Native i -> p "<native %d>" i
+
+
 let print_one = function
     | Constant i -> p "CONSTANT %d\n" i
     | LoadLocal i -> p "LOCAL %d\n" i

lib/vm/vm.ml

@@ -20,6 +20,11 @@ let pop_one state =
 let push state v =
   state.stack <- (v :: state.stack)
 
+let trace state =
+  let stack () = List.fold_left (fun acc x -> acc ^ " " ^ (Types.print_value x)) "" state.stack in
+  let env () = List.fold_left (fun acc x -> acc ^ " " ^ (Types.print_value !x)) "" state.env in
+  Printf.printf "%d: \n\tstack: [%s ]\n\tenv:[%s]\n" state.i (stack ()) (env ())
+
 let rec do_apply state =
   let cur_env = state.env in
   let cur_i = state.i in
@@ -32,13 +37,11 @@ let rec do_apply state =
      state.env <- (ref arg) :: e;
      interpret state
   | Native x ->
-     push state (Native.table.(x) arg)
+     push state (Native.table.(x) arg);
+     interpret state
   | _ -> failwith "Cannot apply non-closure object"
 
 and interpret state =
-  (match state.stack with
-  | [] -> print_endline "empty"
-  | _ -> print_endline "nonempty");
   let i = state.i in
   state.i <- i + 1;
   (match state.instrs.(i) with
@@ -62,7 +65,7 @@ and interpret state =
   | End ->
      (match state.call_stack with
      | [] ->
-        print_endline "\nPROGRAM HAS SUCCESSFULLY TERMINATED\n"
+        print_endline "\nPROGRAM HAS SUCCESSFULLY TERMINATED"
      | (old_i, old_env) :: rest ->
         state.call_stack <- rest;
         state.env <- old_env;