diff --git a/lib/ast.ml b/lib/ast.ml index bc961bc..da43209 100644 --- a/lib/ast.ml +++ b/lib/ast.ml @@ -83,59 +83,3 @@ and cond_to_if = function If (build_ast cond, build_ast res, cond_to_if condpairs) | _ -> raise (Parse_error_exn (Type_error "(cond conditions)")) ;; - -let spacesep ns = String.concat " " ns - -let rec string_expr = - let spacesep_exp es = spacesep (List.map string_expr es) in - let string_of_binding (n, e) = "(" ^ n ^ " " ^ string_expr e ^ ")" in - function - | Literal e -> string_object e - | Var n -> n - | If (c, t, f) -> - "(if " ^ string_expr c ^ " " ^ string_expr t ^ " " ^ string_expr f ^ ")" - | And (c0, c1) -> "(and " ^ string_expr c0 ^ " " ^ string_expr c1 ^ ")" - | Or (c0, c1) -> "(or " ^ string_expr c0 ^ " " ^ string_expr c1 ^ ")" - | Apply (f, e) -> "(apply " ^ string_expr f ^ " " ^ string_expr e ^ ")" - | Call (f, es) -> - if List.length es == 0 - then "(" ^ string_expr f ^ spacesep_exp es ^ ")" - else "(" ^ string_expr f ^ " " ^ spacesep_exp es ^ ")" - | Lambda (args, body) -> "(lambda (" ^ spacesep args ^ ") " ^ string_expr body ^ ")" - | Defexpr (Setq (n, e)) -> "(setq " ^ n ^ " " ^ string_expr e ^ ")" - | Defexpr (Defun (n, ns, e)) -> - "(defun " ^ n ^ "(" ^ spacesep ns ^ ") " ^ string_expr e ^ ")" - | Defexpr (Expr e) -> string_expr e - | Let (kind, bs, e) -> - let str = - match kind with - | LET -> "let" - | LETSTAR -> "let*" - | LETREC -> "letrec" - in - let bindings = spacesep (List.map string_of_binding bs) in - "(" ^ str ^ " (" ^ bindings ^ ") " ^ string_expr e ^ ")" - -and string_object e = - let rec string_list l = - match l with - | Pair (a, Nil) -> string_object a - | Pair (a, b) -> string_object a ^ " " ^ string_list b - | _ -> raise This_can't_happen_exn - in - let string_pair p = - match p with - | Pair (a, b) -> string_object a ^ " . " ^ string_object b - | _ -> raise This_can't_happen_exn - in - match e with - | Fixnum v -> string_of_int v - | Boolean b -> if b then "#t" else "#f" - | String s -> "\"" ^ s ^ "\"" - | Symbol s -> s - | Nil -> "nil" - | Pair (_, _) -> "(" ^ (if Object.is_list e then string_list e else string_pair e) ^ ")" - | Primitive (name, _) -> "#" - | Quote expr -> "'" ^ string_object expr - | Closure (_, _, _) -> "#" -;; diff --git a/lib/error.ml b/lib/error.ml index 86f294b..404e17b 100644 --- a/lib/error.ml +++ b/lib/error.ml @@ -35,6 +35,10 @@ let message = function | Unique_error p -> "Unique error : " ^ p | Type_error x -> "Type error : " ^ x | Poorly_formed_expression -> "Poorly formed expression.") + | Runtime_error_exn e -> + (match e with + | Not_found e -> "Not found : " ^ e + | Unspecified_value e -> "Unspecified value : " ^ e) | _ -> "None" ;; @@ -46,13 +50,17 @@ let help = function | Invalid_boolean_literal _ -> "Raised by incorrect boolean literals.") | Parse_error_exn e -> (match e with - | Unique_error _ -> "A conflict error caused by duplicate parameter names when defining closure." - | Type_error _ -> "Possible type error due to a function call with parameters of a type different from that specified in the function definition." + | Unique_error _ -> + "A conflict error caused by duplicate parameter names when defining closure." + | Type_error _ -> + "Possible type error due to a function call with parameters of a type different \ + from that specified in the function definition." | Poorly_formed_expression -> "Syntactically incorrect or redundant elements.") - | Runtime_error_exn e -> - (match e with - | Not_found _ -> "Accessing an identifier that has not been defined in the context." - | Unspecified_value _ -> "Accessing an identifier that is not explicitly defined in the context.") + | Runtime_error_exn e -> + (match e with + | Not_found _ -> "Accessing an identifier that has not been defined in the context." + | Unspecified_value _ -> + "Accessing an identifier that is not explicitly defined in the context.") | _ -> "None" ;; diff --git a/lib/eval.ml b/lib/eval.ml index 4e0c3cd..96ff0af 100644 --- a/lib/eval.ml +++ b/lib/eval.ml @@ -70,14 +70,14 @@ let rec eval_expr expr env = in eval expr -and eval_apply fn_expr args _env = +and eval_apply fn_expr args env = match fn_expr with | Primitive (_, fn) -> fn args - | Closure (names, expr, clenv) -> eval_closure names expr args clenv + | Closure (names, expr, clenv) -> eval_closure names expr args clenv env | _ -> raise (Parse_error_exn (Type_error "(apply prim '(args)) or (prim args)")) -and eval_closure names expr args clenv = - eval_expr expr (Environment.bind_list names args clenv) +and eval_closure names expr args clenv env = + eval_expr expr (extend (Environment.bind_list names args clenv) env) ;; let eval_def def env = diff --git a/lib/object.ml b/lib/object.ml index 35a27bf..4040e2e 100644 --- a/lib/object.ml +++ b/lib/object.ml @@ -62,3 +62,59 @@ let rec pair_to_list pair = ;; let string_of_char a_char = String.make 1 a_char + +let spacesep ns = String.concat " " ns + +let rec string_expr = + let spacesep_exp es = spacesep (List.map string_expr es) in + let string_of_binding (n, e) = "(" ^ n ^ " " ^ string_expr e ^ ")" in + function + | Literal e -> string_object e + | Var n -> n + | If (c, t, f) -> + "(if " ^ string_expr c ^ " " ^ string_expr t ^ " " ^ string_expr f ^ ")" + | And (c0, c1) -> "(and " ^ string_expr c0 ^ " " ^ string_expr c1 ^ ")" + | Or (c0, c1) -> "(or " ^ string_expr c0 ^ " " ^ string_expr c1 ^ ")" + | Apply (f, e) -> "(apply " ^ string_expr f ^ " " ^ string_expr e ^ ")" + | Call (f, es) -> + if List.length es == 0 + then "(" ^ string_expr f ^ spacesep_exp es ^ ")" + else "(" ^ string_expr f ^ " " ^ spacesep_exp es ^ ")" + | Lambda (args, body) -> "(lambda (" ^ spacesep args ^ ") " ^ string_expr body ^ ")" + | Defexpr (Setq (n, e)) -> "(setq " ^ n ^ " " ^ string_expr e ^ ")" + | Defexpr (Defun (n, ns, e)) -> + "(defun " ^ n ^ "(" ^ spacesep ns ^ ") " ^ string_expr e ^ ")" + | Defexpr (Expr e) -> string_expr e + | Let (kind, bs, e) -> + let str = + match kind with + | LET -> "let" + | LETSTAR -> "let*" + | LETREC -> "letrec" + in + let bindings = spacesep (List.map string_of_binding bs) in + "(" ^ str ^ " (" ^ bindings ^ ") " ^ string_expr e ^ ")" + +and string_object e = + let rec string_list l = + match l with + | Pair (a, Nil) -> string_object a + | Pair (a, b) -> string_object a ^ " " ^ string_list b + | _ -> raise This_can't_happen_exn + in + let string_pair p = + match p with + | Pair (a, b) -> string_object a ^ " . " ^ string_object b + | _ -> raise This_can't_happen_exn + in + match e with + | Fixnum v -> string_of_int v + | Boolean b -> if b then "#t" else "#f" + | String s -> "\"" ^ s ^ "\"" + | Symbol s -> s + | Nil -> "nil" + | Pair (_, _) -> "(" ^ (if is_list e then string_list e else string_pair e) ^ ")" + | Primitive (name, _) -> "#" + | Quote expr -> "'" ^ string_object expr + | Closure (_, _, _) -> "#" +;; diff --git a/lib/primitives.ml b/lib/primitives.ml index d65a68a..ebce2ed 100644 --- a/lib/primitives.ml +++ b/lib/primitives.ml @@ -65,7 +65,7 @@ let getchar = function let print = function | [ v ] -> - let () = print_string @@ Ast.string_object v in + let () = print_string @@ Object.string_object v in Symbol "ok" | _ -> raise (Parse_error_exn (Type_error "(print object)")) ;; diff --git a/lib/repl.ml b/lib/repl.ml index de0345a..ea45333 100644 --- a/lib/repl.ml +++ b/lib/repl.ml @@ -17,19 +17,37 @@ (****************************************************************************) open Types.Reader +open Types.Ast +open Types.Eval +open Types.Repl + +let print_prompt () = + Printf.printf "%s " prompt_tip; + flush_all (); +;; + +let print_result result = + Printf.printf "- : %s\n" result; + flush_all (); +;; let rec repl a_stream env = try - if a_stream.stdin - then ( - print_string "# "; - flush stdout); + if a_stream.stdin then print_prompt (); let ast = Ast.build_ast (Reader.read_sexpr a_stream) in let result, env' = Eval.eval ast env in - if a_stream.stdin then print_endline (Ast.string_object result); + if a_stream.stdin then print_result (Object.string_object result); repl a_stream env' with - | Stream.Failure -> () - | Syntax_error_exn e -> Error.print_error a_stream (Syntax_error_exn e); if a_stream.stdin then repl a_stream env else () + | Stream.Failure -> if a_stream.stdin then print_newline () else () + | Syntax_error_exn e -> + Error.print_error a_stream (Syntax_error_exn e); + if a_stream.stdin then repl a_stream env else () + | Parse_error_exn e -> + Error.print_error a_stream (Parse_error_exn e); + if a_stream.stdin then repl a_stream env else () + | Runtime_error_exn e -> + Error.print_error a_stream (Runtime_error_exn e); + if a_stream.stdin then repl a_stream env else () | e -> raise e ;; diff --git a/lib/types.ml b/lib/types.ml index 7673550..eeea137 100644 --- a/lib/types.ml +++ b/lib/types.ml @@ -61,22 +61,21 @@ module Object = struct end module Ast = struct - exception Undefined_symbol_exn of string - type parse_error = + type parse_error = | Unique_error of string | Type_error of string | Poorly_formed_expression - exception Parse_error_exn of parse_error + exception Parse_error_exn of parse_error end module Reader = struct type syntax_error = | Invalid_boolean_literal of string | Unexcepted_character of string - + exception Syntax_error_exn of syntax_error type 'a stream = @@ -90,7 +89,7 @@ module Reader = struct end module Eval = struct - type runtime_error = + type runtime_error = | Not_found of string | Unspecified_value of string @@ -98,11 +97,15 @@ module Eval = struct end module Error = struct - type error_info = { - file_name : string; - line_number : int; - column_number : int; - message : string; - help : string - } -end \ No newline at end of file + type error_info = + { file_name : string + ; line_number : int + ; column_number : int + ; message : string + ; help : string + } +end + +module Repl = struct + let prompt_tip = ">" +end diff --git a/mlisp b/mlisp index 3a324e3..a902652 100755 --- a/mlisp +++ b/mlisp @@ -1 +1 @@ -/usr/local/bin/rlwrap /usr/bin/origin_mlisp \ No newline at end of file +/usr/local/bin/rlwrap /usr/bin/origin_mlisp $1 \ No newline at end of file diff --git a/test/05_mutually_recursive_functions.mlisp b/test/05_mutually_recursive_functions.mlisp new file mode 100644 index 0000000..279f4df --- /dev/null +++ b/test/05_mutually_recursive_functions.mlisp @@ -0,0 +1,11 @@ +(defun f (x) + (if (< x 2) + 1 + (g (- x 1)))) + +(defun g (x) + (if (< x 2) + 3 + (f (- x 2)))) + +(println (f 10)) \ No newline at end of file diff --git a/test/04_normal_test.mlisp b/test/end_normal_test.mlisp similarity index 100% rename from test/04_normal_test.mlisp rename to test/end_normal_test.mlisp