Skip to content

Commit aeab5b5

Browse files
goldfireregoldfirere
committed
Refactor is_local_returning_function; improve error
1 parent a29bf62 commit aeab5b5

File tree

2 files changed

+135
-108
lines changed

2 files changed

+135
-108
lines changed

‎ocaml/testsuite/tests/typing-local/local.ml

Lines changed: 6 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -2730,15 +2730,12 @@ let foo = function
27302730
| false -> local_ 5
27312731
| true -> 6
27322732
2733-
(* Poor error message: really this should complain about the inconsistency
2734-
of local_ annotations. Note that the type is a mode-crossing type, and
2735-
so that makes this error message even worse. *)
27362733
[%%expect{|
2737-
Line 2, characters 13-21:
2738-
2 | | false -> local_ 5
2739-
^^^^^^^^
2740-
Error: This local value escapes its region
2741-
Hint: Cannot return local value without an "exclave_" annotation
2734+
Line 3, characters 12-13:
2735+
3 | | true -> 6
2736+
^
2737+
Error: This function return is not annotated with "local_"
2738+
whilst other returns were.
27422739
|}]
27432740
27442741
(* test that [assert false] can mix with other returns being [local_] *)
@@ -2754,3 +2751,4 @@ Line 3, characters 7-19:
27542751
Error: This function return is not annotated with "local_"
27552752
whilst other returns were.
27562753
|}]
2754+

‎ocaml/typing/typecore.ml

Lines changed: 129 additions & 100 deletions
Original file line numberDiff line numberDiff line change
@@ -3647,72 +3647,135 @@ let check_recursive_class_bindings env ids exprs =
36473647
raise(Error(expr.cl_loc, env, Illegal_class_expr)))
36483648
exprs
36493649

3650-
(* Is the return value annotated with "local_" *)
3651-
let is_local_returning_expr e =
3652-
let combine (local1, loc1) (local2, loc2) =
3653-
match local1, local2 with
3654-
| true, true -> true, loc1
3655-
| false, false -> false, loc1
3656-
| false, true ->
3657-
raise(Error(loc1, Env.empty, Local_return_annotation_mismatch loc2))
3658-
| true, false ->
3659-
raise(Error(loc2, Env.empty, Local_return_annotation_mismatch loc1))
3660-
in
3661-
let rec loop e =
3662-
match Jane_syntax.Expression.of_ast e with
3663-
| Some (jexp, _attrs) -> begin
3664-
match jexp with
3665-
| Jexp_comprehension _ -> false, e.pexp_loc
3666-
| Jexp_immutable_array _ -> false, e.pexp_loc
3667-
| Jexp_layout (Lexp_constant _) -> false, e.pexp_loc
3668-
| Jexp_layout (Lexp_newtype (_, _, e)) -> loop e
3669-
| Jexp_n_ary_function _ -> false, e.pexp_loc
3670-
end
3671-
| None ->
3672-
match e.pexp_desc with
3673-
| Pexp_apply
3674-
({ pexp_desc = Pexp_extension(
3675-
{txt = "extension.local"|"ocaml.local"|"local"}, PStr []) },
3676-
[Nolabel, _]) ->
3677-
true, e.pexp_loc
3678-
| Pexp_apply
3679-
({ pexp_desc = Pexp_extension(
3680-
{txt = "extension.unique"|"ocaml.unique"|"unique"}, PStr []) },
3681-
[Nolabel, exp]) ->
3682-
loop exp
3683-
| Pexp_apply
3684-
({ pexp_desc = Pexp_extension(
3685-
{txt = "extension.once" | "ocaml.once" | "once"}, PStr []) },
3686-
[Nolabel, exp]) ->
3687-
loop exp
3688-
| Pexp_ident _ | Pexp_constant _ | Pexp_apply _ | Pexp_tuple _
3689-
| Pexp_construct _ | Pexp_variant _ | Pexp_record _ | Pexp_field _
3690-
| Pexp_setfield _ | Pexp_array _ | Pexp_while _ | Pexp_for _ | Pexp_send _
3691-
| Pexp_new _ | Pexp_setinstvar _ | Pexp_override _ | Pexp_assert _
3692-
| Pexp_lazy _ | Pexp_object _ | Pexp_pack _ | Pexp_function _ | Pexp_fun _
3693-
| Pexp_letop _ | Pexp_extension _ | Pexp_unreachable ->
3694-
false, e.pexp_loc
3695-
| Pexp_let(_, _, e) | Pexp_sequence(_, e) | Pexp_constraint(e, _)
3696-
| Pexp_coerce(e, _, _) | Pexp_letmodule(_, _, e) | Pexp_letexception(_, e)
3697-
| Pexp_poly(e, _) | Pexp_newtype(_, e) | Pexp_open(_, e)
3698-
| Pexp_ifthenelse(_, e, None)->
3699-
loop e
3700-
| Pexp_ifthenelse(_, e1, Some e2)-> combine (loop e1) (loop e2)
3701-
| Pexp_match(_, cases) -> begin
3702-
match cases with
3703-
| [] -> false, e.pexp_loc
3704-
| first :: rest ->
3705-
List.fold_left
3706-
(fun acc pc -> combine acc (loop pc.pc_rhs))
3707-
(loop first.pc_rhs) rest
3650+
module Is_local_returning : sig
3651+
val function_ : Parsetree.case list -> bool
3652+
end = struct
3653+
3654+
(* Is the return value annotated with "local_"?
3655+
[assert false] can work either way *)
3656+
3657+
type local_returning_flag =
3658+
| Local of Location.t (* location of a local return *)
3659+
| Not of Location.t (* location of a non-local return *)
3660+
| Either
3661+
[@@warning "-unused-constructor"]
3662+
3663+
let combine flag1 flag2 =
3664+
match flag1, flag2 with
3665+
| (Local _ as flag), Local _
3666+
| (Local _ as flag), Either
3667+
| (Not _ as flag), Not _
3668+
| (Not _ as flag), Either
3669+
| Either, (Local _ as flag)
3670+
| Either, (Not _ as flag)
3671+
| (Either as flag), Either ->
3672+
flag
3673+
3674+
| Local local_loc, Not not_local_loc
3675+
| Not not_local_loc, Local local_loc ->
3676+
raise(Error(not_local_loc, Env.empty,
3677+
Local_return_annotation_mismatch local_loc))
3678+
3679+
let expr e =
3680+
let rec loop e =
3681+
match Jane_syntax.Expression.of_ast e with
3682+
| Some (jexp, _attrs) -> begin
3683+
match jexp with
3684+
| Jexp_comprehension _ -> Not e.pexp_loc
3685+
| Jexp_immutable_array _ -> Not e.pexp_loc
3686+
| Jexp_layout (Lexp_constant _) -> Not e.pexp_loc
3687+
| Jexp_layout (Lexp_newtype (_, _, e)) -> loop e
3688+
| Jexp_n_ary_function _ -> Not e.pexp_loc
3689+
end
3690+
| None ->
3691+
match e.pexp_desc with
3692+
| Pexp_apply
3693+
({ pexp_desc = Pexp_extension(
3694+
{txt = "extension.local"|"ocaml.local"|"local"}, PStr []) },
3695+
[Nolabel, _]) ->
3696+
Local e.pexp_loc
3697+
| Pexp_apply
3698+
({ pexp_desc = Pexp_extension(
3699+
{txt = "extension.unique"|"ocaml.unique"|"unique"}, PStr []) },
3700+
[Nolabel, exp]) ->
3701+
loop exp
3702+
| Pexp_apply
3703+
({ pexp_desc = Pexp_extension(
3704+
{txt = "extension.once" | "ocaml.once" | "once"}, PStr []) },
3705+
[Nolabel, exp]) ->
3706+
loop exp
3707+
| Pexp_ident _ | Pexp_constant _ | Pexp_apply _ | Pexp_tuple _
3708+
| Pexp_construct _ | Pexp_variant _ | Pexp_record _ | Pexp_field _
3709+
| Pexp_setfield _ | Pexp_array _ | Pexp_while _ | Pexp_for _ | Pexp_send _
3710+
| Pexp_new _ | Pexp_setinstvar _ | Pexp_override _ | Pexp_assert _
3711+
| Pexp_lazy _ | Pexp_object _ | Pexp_pack _ | Pexp_function _ | Pexp_fun _
3712+
| Pexp_letop _ | Pexp_extension _ | Pexp_unreachable ->
3713+
Not e.pexp_loc
3714+
| Pexp_let(_, _, e) | Pexp_sequence(_, e) | Pexp_constraint(e, _)
3715+
| Pexp_coerce(e, _, _) | Pexp_letmodule(_, _, e) | Pexp_letexception(_, e)
3716+
| Pexp_poly(e, _) | Pexp_newtype(_, e) | Pexp_open(_, e)
3717+
| Pexp_ifthenelse(_, e, None)->
3718+
loop e
3719+
| Pexp_ifthenelse(_, e1, Some e2)-> combine (loop e1) (loop e2)
3720+
| Pexp_match(_, cases) -> begin
3721+
match cases with
3722+
| [] -> Not e.pexp_loc
3723+
| first :: rest ->
3724+
List.fold_left
3725+
(fun acc pc -> combine acc (loop pc.pc_rhs))
3726+
(loop first.pc_rhs) rest
3727+
end
3728+
| Pexp_try(e, cases) ->
3729+
List.fold_left
3730+
(fun acc pc -> combine acc (loop pc.pc_rhs))
3731+
(loop e) cases
3732+
in
3733+
loop e
3734+
3735+
let function_ cases =
3736+
let rec loop_cases cases =
3737+
match cases with
3738+
| [] -> Misc.fatal_error "empty cases in function_"
3739+
| [{pc_lhs = _; pc_guard = None; pc_rhs = e}] ->
3740+
loop_body e
3741+
| case :: cases ->
3742+
let is_local_returning_case case =
3743+
expr case.pc_rhs
3744+
in
3745+
List.fold_left
3746+
(fun acc case -> combine acc (is_local_returning_case case))
3747+
(is_local_returning_case case) cases
3748+
and loop_body e =
3749+
if Builtin_attributes.has_curry e.pexp_attributes then
3750+
expr e
3751+
else begin
3752+
match Jane_syntax.Expression.of_ast e with
3753+
| Some (jexp, _attrs) -> begin
3754+
match jexp with
3755+
| Jexp_n_ary_function (_, _, Pfunction_cases (cases, _, _)) ->
3756+
loop_cases cases
3757+
| Jexp_n_ary_function (_, _, Pfunction_body body) ->
3758+
loop_body body
3759+
| Jexp_comprehension _ | Jexp_immutable_array _ ->
3760+
expr e
3761+
| Jexp_layout (Lexp_constant _ | Lexp_newtype _) ->
3762+
Not e.pexp_loc
3763+
end
3764+
| None -> match e.pexp_desc, e.pexp_attributes with
3765+
| Pexp_fun(_, _, _, e), _ -> loop_body e
3766+
| Pexp_function cases, _ -> loop_cases cases
3767+
| Pexp_constraint (e, _), _ -> loop_body e
3768+
| Pexp_let (Nonrecursive, _, e),
3769+
[{Parsetree.attr_name = {txt="#default"};_}] -> loop_body e
3770+
| _ -> expr e
37083771
end
3709-
| Pexp_try(e, cases) ->
3710-
List.fold_left
3711-
(fun acc pc -> combine acc (loop pc.pc_rhs))
3712-
(loop e) cases
3713-
in
3714-
let local, _ = loop e in
3715-
local
3772+
in
3773+
match loop_cases cases with
3774+
| Local _ -> true
3775+
| Either | Not _ -> false
3776+
(* [fun _ -> assert false] must not be local-returning for
3777+
backward compatibility *)
3778+
end
37163779

37173780
let rec is_an_uncurried_function e =
37183781
if Builtin_attributes.has_curry e.pexp_attributes then false
@@ -3729,40 +3792,6 @@ let rec is_an_uncurried_function e =
37293792
| _ -> false
37303793
end
37313794

3732-
let is_local_returning_function cases =
3733-
let rec loop_cases cases =
3734-
match cases with
3735-
| [] -> false
3736-
| [{pc_lhs = _; pc_guard = None; pc_rhs = e}] ->
3737-
loop_body e
3738-
| cases ->
3739-
List.for_all (fun case -> is_local_returning_expr case.pc_rhs) cases
3740-
and loop_body e =
3741-
if Builtin_attributes.has_curry e.pexp_attributes then
3742-
is_local_returning_expr e
3743-
else begin
3744-
match Jane_syntax.Expression.of_ast e with
3745-
| Some (jexp, _attrs) -> begin
3746-
match jexp with
3747-
| Jexp_n_ary_function (_, _, Pfunction_cases (cases, _, _)) ->
3748-
loop_cases cases
3749-
| Jexp_n_ary_function (_, _, Pfunction_body body) ->
3750-
loop_body body
3751-
| Jexp_comprehension _ | Jexp_immutable_array _ ->
3752-
is_local_returning_expr e
3753-
| Jexp_layout (Lexp_constant _ | Lexp_newtype _) -> false
3754-
end
3755-
| None -> match e.pexp_desc, e.pexp_attributes with
3756-
| Pexp_fun(_, _, _, e), _ -> loop_body e
3757-
| Pexp_function cases, _ -> loop_cases cases
3758-
| Pexp_constraint (e, _), _ -> loop_body e
3759-
| Pexp_let (Nonrecursive, _, e),
3760-
[{Parsetree.attr_name = {txt="#default"};_}] -> loop_body e
3761-
| _ -> is_local_returning_expr e
3762-
end
3763-
in
3764-
loop_cases cases
3765-
37663795
(* The "rest of the function" extends from the start of the first parameter
37673796
to the end of the overall function. The parser does not construct such
37683797
a location so we forge one for type errors.
@@ -6154,7 +6183,7 @@ and type_function
61546183
match in_function with
61556184
| Some (_, _, region_locked) -> env, region_locked
61566185
| None ->
6157-
let region_locked = not (is_local_returning_function caselist) in
6186+
let region_locked = not (Is_local_returning.function_ caselist) in
61586187
let env =
61596188
Env.add_closure_lock
61606189
?closure_context:expected_mode.closure_context

0 commit comments

Comments
 (0)