Support mutually recursive functions

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, _) -> "#<primitive:" ^ name ^ ">"
-  | Quote expr -> "'" ^ string_object expr
-  | Closure (_, _, _) -> "#<closure>"
-;;

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"
 ;;
 

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 =

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, _) -> "#<primitive:" ^ name ^ ">"
+  | Quote expr -> "'" ^ string_object expr
+  | Closure (_, _, _) -> "#<closure>"
+;;    

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)"))
 ;;

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
 ;;

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,19 +89,23 @@ module Reader = struct
 end
 
 module Eval = struct
-  type runtime_error = 
+  type runtime_error =
     | Not_found of string
     | Unspecified_value of string
 
   exception Runtime_error_exn of runtime_error
 end
 
 module Error = struct
-  type error_info = {
-    file_name : string;
-    line_number : int;
-    column_number : int;
-    message : string;
-    help : string
-  }
-end
+  type error_info =
+    { file_name : string
+    ; line_number : int
+    ; column_number : int
+    ; message : string
+    ; help : string
+    }
+end
+
+module Repl = struct
+  let prompt_tip = ">"
+end

mlisp

@@ -1 +1 @@
-/usr/local/bin/rlwrap /usr/bin/origin_mlisp
+/usr/local/bin/rlwrap /usr/bin/origin_mlisp $1

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))