diff --git a/bin/comp.ml b/bin/comp.ml index e4cddd7..e0e1720 100644 --- a/bin/comp.ml +++ b/bin/comp.ml @@ -3,15 +3,20 @@ let ( let* ) = Result.bind;; (* Try to interpret some test source code. *) -let some_source = "(define (+ a b) b) - (print 1)";; +let some_source = "(define (print-three a b c) + (print a) + (print b) + (print c)) + (print-three 'hello 'world 'there)";; (* I don't have any built-in functions at all rn, so we just use a dummy function *) let bruh = let* vm = Compiler.Emit.compile_src some_source in + print_endline "=== PROGRAM DISASSEMBLY"; Vm.Types.print_instrs vm.instrs; + print_endline "=== PROGRAM OUTPUT"; Vm.interpret vm; - Ok (print_endline "hello") + Ok () let _ = match bruh with | Ok _ -> () diff --git a/bin/dune b/bin/dune index 3c961c2..b19a136 100644 --- a/bin/dune +++ b/bin/dune @@ -1,4 +1,4 @@ (executable (name comp) (public_name ollisp) - (libraries str unix compiler vm interpreter)) + (libraries str unix compiler vm)) diff --git a/lib/compiler/core_ast.ml b/lib/compiler/core_ast.ml index f72279e..ae65db6 100644 --- a/lib/compiler/core_ast.ml +++ b/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) diff --git a/lib/compiler/emit.ml b/lib/compiler/emit.ml index 259d89b..644ac09 100644 --- a/lib/compiler/emit.ml +++ b/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 = diff --git a/lib/compiler/syntactic_ast.ml b/lib/compiler/syntactic_ast.ml index 23be618..970c09e 100644 --- a/lib/compiler/syntactic_ast.ml +++ b/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)) -> diff --git a/lib/interpreter/dune b/lib/interpreter/dune deleted file mode 100644 index 7fb2ee8..0000000 --- a/lib/interpreter/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library - (name interpreter) - (libraries compiler)) \ No newline at end of file diff --git a/lib/interpreter/main.ml b/lib/interpreter/main.ml deleted file mode 100644 index ac7b09b..0000000 --- a/lib/interpreter/main.ml +++ /dev/null @@ -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 - diff --git a/lib/vm/native.ml b/lib/vm/native.ml index 047f553..1f53fed 100644 --- a/lib/vm/native.ml +++ b/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 "" i - | Native i -> p "" i in - print_endline (aux_print v); + print_endline (print_value v); Types.Nil let table = [| diff --git a/lib/vm/types.ml b/lib/vm/types.ml index ce9de93..5559d21 100644 --- a/lib/vm/types.ml +++ b/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 "" i + | Native i -> p "" i + + let print_one = function | Constant i -> p "CONSTANT %d\n" i | LoadLocal i -> p "LOCAL %d\n" i diff --git a/lib/vm/vm.ml b/lib/vm/vm.ml index f193b53..ca8a565 100644 --- a/lib/vm/vm.ml +++ b/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;