Skip to content

Commit ac496bf

Browse files
authored
flambda-backend: Disable the local keyword in typing (#540)
1 parent 7d46712 commit ac496bf

File tree

4 files changed

+31
-12
lines changed

4 files changed

+31
-12
lines changed

parsing/lexer.mll

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -240,7 +240,10 @@ let uchar_for_uchar_escape lexbuf =
240240
illegal_escape lexbuf
241241
(Printf.sprintf "%X is not a Unicode scalar value" cp)
242242

243-
let is_keyword name = Hashtbl.mem keyword_table name
243+
let is_keyword name =
244+
match lookup_keyword name with
245+
| LIDENT _ -> false
246+
| _ -> true
244247

245248
let check_label_name lexbuf name =
246249
if is_keyword name then error lexbuf (Keyword_as_label name)

typing/typecore.ml

Lines changed: 12 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -461,9 +461,17 @@ let extract_label_names env ty =
461461
with Not_found ->
462462
assert false
463463

464-
let has_local_attr_pat ppat = Builtin_attributes.has_local ppat.ppat_attributes
464+
let has_local_attr loc attrs =
465+
let present = Builtin_attributes.has_local attrs in
466+
if present && not (Clflags.Extension.is_enabled Local) then
467+
raise(Typetexp.Error(loc, Env.empty, Local_not_enabled));
468+
present
465469

466-
let has_local_attr_exp pexp = Builtin_attributes.has_local pexp.pexp_attributes
470+
let has_local_attr_pat ppat =
471+
has_local_attr ppat.ppat_loc ppat.ppat_attributes
472+
473+
let has_local_attr_exp pexp =
474+
has_local_attr pexp.pexp_loc pexp.pexp_attributes
467475

468476
(* Typing of patterns *)
469477

@@ -3452,6 +3460,8 @@ and type_expect_
34523460
| Pexp_apply
34533461
({ pexp_desc = Pexp_extension({txt = "extension.local"}, PStr []) },
34543462
[Nolabel, sbody]) ->
3463+
if not (Clflags.Extension.is_enabled Local) then
3464+
raise (Typetexp.Error (loc, Env.empty, Local_not_enabled));
34553465
submode ~loc ~env Value_mode.local expected_mode;
34563466
let exp =
34573467
type_expect ?in_function ~recarg env mode_local sbody

typing/typetexp.ml

Lines changed: 14 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -47,6 +47,7 @@ type error =
4747
| Method_mismatch of string * type_expr * type_expr
4848
| Opened_object of Path.t option
4949
| Not_an_object of type_expr
50+
| Local_not_enabled
5051

5152
exception Error of Location.t * Env.t * error
5253
exception Error_forward of Location.error
@@ -156,20 +157,21 @@ let transl_type_param env styp =
156157
Builtin_attributes.warning_scope styp.ptyp_attributes
157158
(fun () -> transl_type_param env styp)
158159

160+
let get_alloc_mode styp =
161+
if Builtin_attributes.has_local styp.ptyp_attributes then begin
162+
if not (Clflags.Extension.is_enabled Local) then
163+
raise (Error(styp.ptyp_loc, Env.empty, Local_not_enabled));
164+
Alloc_mode.Local
165+
end else
166+
Alloc_mode.Global
167+
159168
let rec extract_params styp =
160169
let final styp =
161-
let ret_mode =
162-
if Builtin_attributes.has_local styp.ptyp_attributes then Alloc_mode.Local
163-
else Alloc_mode.Global
164-
in
165-
[], styp, ret_mode
170+
[], styp, get_alloc_mode styp
166171
in
167172
match styp.ptyp_desc with
168173
| Ptyp_arrow (l, a, r) ->
169-
let arg_mode =
170-
if Builtin_attributes.has_local a.ptyp_attributes then Alloc_mode.Local
171-
else Alloc_mode.Global
172-
in
174+
let arg_mode = get_alloc_mode a in
173175
let params, ret, ret_mode =
174176
if Builtin_attributes.has_curry r.ptyp_attributes then final r
175177
else extract_params r
@@ -841,6 +843,9 @@ let report_error env ppf = function
841843
| Not_an_object ty ->
842844
fprintf ppf "@[The type %a@ is not an object type@]"
843845
Printtyp.type_expr ty
846+
| Local_not_enabled ->
847+
fprintf ppf "@[The local extension is disabled@ \
848+
To enable it, pass the '-extension local' flag@]"
844849

845850
let () =
846851
Location.register_error_of_exn

typing/typetexp.mli

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -64,6 +64,7 @@ type error =
6464
| Method_mismatch of string * type_expr * type_expr
6565
| Opened_object of Path.t option
6666
| Not_an_object of type_expr
67+
| Local_not_enabled
6768

6869
exception Error of Location.t * Env.t * error
6970

0 commit comments

Comments
 (0)