From f7c5b3df43571b41b743ebc2c47f1bb90ab127a6 Mon Sep 17 00:00:00 2001 From: Leandro Ostera Date: Fri, 30 Oct 2020 17:53:29 +0100 Subject: [PATCH] compiler: preliminary support for guards. Proper support for guards will take a lot more than this, I think, since guards can have any level of nested expressions son long as it follows the rules outlined here: https://erlang.org/doc/reference_manual/expressions.html#guard-expressions This makes it more likely that we will need to generate an expression, and traverse it with a function like `is_guard_safe : Erlang.Ast.expression -> bool`. For the time being, this should allow most common guards to be written. We'll improve support after v0.1. Closes #17 --- src/compiler/ocaml_to_erlang/error.ml | 9 +++++ src/compiler/ocaml_to_erlang/fun.ml | 19 ++++++++- src/compiler/ocaml_to_erlang/names.ml | 40 +++++++++++++++++++ src/erlang/erl_printer.ml | 16 +++++++- .../compiler/functions.t/guard_unsupported.ml | 9 +++++ tests/compiler/functions.t/guards.ml | 10 +++++ tests/compiler/functions.t/run.t | 30 ++++++++++++++ 7 files changed, 129 insertions(+), 4 deletions(-) create mode 100644 tests/compiler/functions.t/guard_unsupported.ml create mode 100644 tests/compiler/functions.t/guards.ml diff --git a/src/compiler/ocaml_to_erlang/error.ml b/src/compiler/ocaml_to_erlang/error.ml index fa753a394b..ba1b2bd94b 100644 --- a/src/compiler/ocaml_to_erlang/error.ml +++ b/src/compiler/ocaml_to_erlang/error.ml @@ -20,6 +20,15 @@ This is currently not supported. |}; exit 1 +let unsupported_guard_expression () = + Format.fprintf ppf + {|We have found a guard expression that is not one of the allowlisted Erlang BIFs. + +This is currently not supported. +\n +|}; + exit 1 + let unsupported_let_shadowing name = Format.fprintf ppf {|We have found that the variable name %s is being shadowed. diff --git a/src/compiler/ocaml_to_erlang/fun.ml b/src/compiler/ocaml_to_erlang/fun.ml index 530f0f145f..3959634eb1 100644 --- a/src/compiler/ocaml_to_erlang/fun.ml +++ b/src/compiler/ocaml_to_erlang/fun.ml @@ -299,16 +299,31 @@ and mk_expression exp ~var_names ~modules ~functions ~module_name = let expr = mk_expression expr ~var_names ~modules ~functions ~module_name in - (* NOTE: match on c_guard here to translate guards *) let branches = List.map (fun c -> let lhs = mk_pattern ~var_names c.c_lhs in let var_names = collect_var_names [ lhs ] @ var_names in + let guard = + match c.c_guard with + | None -> None + | Some expr -> + let expr = + mk_expression expr ~var_names ~modules ~functions + ~module_name + in + Erlang.Ast.( + match expr with + | Expr_apply { fa_name = Expr_name name; _ } + when Names.is_guard name -> + () + | _ -> Error.unsupported_guard_expression ()); + Some [ expr ] + in let rhs = mk_expression c.c_rhs ~var_names ~modules ~functions ~module_name in - FunDecl.case ~lhs:[ lhs ] ~guard:None ~rhs) + FunDecl.case ~lhs:[ lhs ] ~guard ~rhs) branches in Erlang.Ast.Expr_case (expr, branches) diff --git a/src/compiler/ocaml_to_erlang/names.ml b/src/compiler/ocaml_to_erlang/names.ml index 29164bcef3..d4a8076cf1 100644 --- a/src/compiler/ocaml_to_erlang/names.ml +++ b/src/compiler/ocaml_to_erlang/names.ml @@ -1,5 +1,44 @@ open Erlang.Ast_helper +let erlang = Name.atom (Atom.mk "erlang") + +let guards = + [ + Name.atom (Atom.mk "!"); + Name.atom (Atom.mk "*"); + Name.atom (Atom.mk "+"); + Name.atom (Atom.mk "++"); + Name.atom (Atom.mk "-"); + Name.atom (Atom.mk "--"); + Name.atom (Atom.mk "/"); + Name.atom (Atom.mk "/="); + Name.atom (Atom.mk ":="); + Name.atom (Atom.mk "=/="); + Name.atom (Atom.mk "=:="); + Name.atom (Atom.mk "=<"); + Name.atom (Atom.mk "=="); + Name.atom (Atom.mk ">"); + Name.atom (Atom.mk ">="); + Name.atom (Atom.mk "is_atom"); + Name.atom (Atom.mk "is_binary"); + Name.atom (Atom.mk "is_bitstring"); + Name.atom (Atom.mk "is_boolean"); + Name.atom (Atom.mk "is_float"); + Name.atom (Atom.mk "is_integer"); + Name.atom (Atom.mk "is_list"); + Name.atom (Atom.mk "is_map"); + Name.atom (Atom.mk "is_number"); + Name.atom (Atom.mk "is_pid"); + Name.atom (Atom.mk "is_port"); + Name.atom (Atom.mk "is_process_alive"); + Name.atom (Atom.mk "is_reference"); + Name.atom (Atom.mk "is_tuple"); + Name.atom (Atom.mk "is_tuple"); + ] + |> List.concat_map (fun f -> [ f; Name.qualified ~m:erlang ~f ]) + +let is_guard guard = List.mem guard guards + let translation_table : (Erlang.Ast.name, Erlang.Ast.name) Hashtbl.t = let h = Hashtbl.create 1024 in [ (("list", "length"), ("erlang", "length")) ] @@ -114,6 +153,7 @@ let ocaml_to_erlang_primitive_op t = ~m:(Name.atom (Atom.mk "caramel")) ~f:(Name.atom (Atom.mk "binary_concat")) | "<>" -> to_erl_op "=/=" + | "<=" -> to_erl_op "=<" | "=" -> to_erl_op "=:=" | "==" -> to_erl_op "==" | "@" -> to_erl_op "++" diff --git a/src/erlang/erl_printer.ml b/src/erlang/erl_printer.ml index 626a719ed1..b342dec734 100644 --- a/src/erlang/erl_printer.ml +++ b/src/erlang/erl_printer.ml @@ -280,12 +280,23 @@ and pp_if_case_branches prefix ppf branches ~module_ = (pp_if_case_branch prefix ~module_) ppf branches +and pp_case_guard ppf guard ~module_ = + match guard with + | None -> () + | Some exprs -> + Format.fprintf ppf " when "; + Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf " ,") + (fun ppf expr -> pp_expression "" ppf expr ~module_) + ppf exprs + and pp_case_branches prefix ppf branches ~module_ = match branches with - | { c_lhs = [ c_lhs ]; c_rhs; _ } :: bs -> ( + | { c_lhs = [ c_lhs ]; c_rhs; c_guard } :: bs -> ( let prefix = prefix ^ " " in Format.fprintf ppf "\n%s" prefix; pp_pattern_match ppf c_lhs; + pp_case_guard ppf c_guard ~module_; Format.fprintf ppf " -> "; pp_expression "" ppf c_rhs ~module_; match bs with @@ -293,9 +304,10 @@ and pp_case_branches prefix ppf branches ~module_ = | bs -> bs |> List.iter (function - | { c_lhs = [ c_lhs ]; c_rhs; _ } -> + | { c_lhs = [ c_lhs ]; c_rhs; c_guard } -> Format.fprintf ppf ";\n%s" prefix; pp_pattern_match ppf c_lhs; + pp_case_guard ppf c_guard ~module_; Format.fprintf ppf " -> "; pp_expression "" ppf c_rhs ~module_ | _ -> raise Invalid_case_branch) ) diff --git a/tests/compiler/functions.t/guard_unsupported.ml b/tests/compiler/functions.t/guard_unsupported.ml new file mode 100644 index 0000000000..2e41e61446 --- /dev/null +++ b/tests/compiler/functions.t/guard_unsupported.ml @@ -0,0 +1,9 @@ +open Erlang + +let g _ = false + +let f x = + match x with + | y when (g y) -> 3 + | _ -> 4 + diff --git a/tests/compiler/functions.t/guards.ml b/tests/compiler/functions.t/guards.ml new file mode 100644 index 0000000000..1740962cf7 --- /dev/null +++ b/tests/compiler/functions.t/guards.ml @@ -0,0 +1,10 @@ +open Erlang + +let f x = + match x with + | y when (is_number y) -> 3 + | y when Erlang.is_binary y -> 3 + | y when y > 3 -> 3 + | y when y <= 3 -> 3 + | _ -> 4 + diff --git a/tests/compiler/functions.t/run.t b/tests/compiler/functions.t/run.t index d18c1c50d2..f5917e927e 100644 --- a/tests/compiler/functions.t/run.t +++ b/tests/compiler/functions.t/run.t @@ -1,5 +1,7 @@ $ ls *.ml *.mli basic.ml + guard_unsupported.ml + guards.ml hello_joe.ml ignored_arguments.ml labeled_arguments.ml @@ -318,3 +320,31 @@ $ cat redefine.erl cat: redefine.erl: No such file or directory [1] + $ caramelc compile guards.ml + Compiling guards.erl OK + $ cat guards.erl + % Source code generated with Caramel. + -module(guards). + + -export([f/1]). + + -spec f(integer()) -> integer(). + f(X) -> + case X of + Y when is_number(Y) -> 3; + Y when erlang:is_binary(Y) -> 3; + Y when erlang:'>'(Y, 3) -> 3; + Y when erlang:'=<'(Y, 3) -> 3; + _ -> 4 + end. + + + $ caramelc compile guard_unsupported.ml + We have found a guard expression that is not one of the allowlisted Erlang BIFs. + + This is currently not supported. + \n + [1] + $ cat guard_unsupported.erl + cat: guard_unsupported.erl: No such file or directory + [1]