flambda-backend: Disable the local keyword in typing (oxcaml#540)

stedolan · web-flow · commit ac496bf52e7c · 2022-02-21T16:26:49.000Z
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
@@ -240,7 +240,10 @@ let uchar_for_uchar_escape lexbuf =
       illegal_escape lexbuf
         (Printf.sprintf "%X is not a Unicode scalar value" cp)
 
-let is_keyword name = Hashtbl.mem keyword_table name
+let is_keyword name =
+  match lookup_keyword name with
+  | LIDENT _ -> false
+  | _ -> true
 
 let check_label_name lexbuf name =
   if is_keyword name then error lexbuf (Keyword_as_label name)
diff --git a/typing/typecore.ml b/typing/typecore.ml
@@ -461,9 +461,17 @@ let extract_label_names env ty =
   with Not_found ->
     assert false
 
-let has_local_attr_pat ppat = Builtin_attributes.has_local ppat.ppat_attributes
+let has_local_attr loc attrs =
+  let present = Builtin_attributes.has_local attrs in
+  if present && not (Clflags.Extension.is_enabled Local) then
+    raise(Typetexp.Error(loc, Env.empty, Local_not_enabled));
+  present
 
-let has_local_attr_exp pexp = Builtin_attributes.has_local pexp.pexp_attributes
+let has_local_attr_pat ppat =
+  has_local_attr ppat.ppat_loc ppat.ppat_attributes
+
+let has_local_attr_exp pexp =
+  has_local_attr pexp.pexp_loc pexp.pexp_attributes
 
 (* Typing of patterns *)
 
@@ -3452,6 +3460,8 @@ and type_expect_
   | Pexp_apply
       ({ pexp_desc = Pexp_extension({txt = "extension.local"}, PStr []) },
        [Nolabel, sbody]) ->
+      if not (Clflags.Extension.is_enabled Local) then
+        raise (Typetexp.Error (loc, Env.empty, Local_not_enabled));
       submode ~loc ~env Value_mode.local expected_mode;
       let exp =
         type_expect ?in_function ~recarg env mode_local sbody
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
@@ -47,6 +47,7 @@ type error =
   | Method_mismatch of string * type_expr * type_expr
   | Opened_object of Path.t option
   | Not_an_object of type_expr
+  | Local_not_enabled
 
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
@@ -156,20 +157,21 @@ let transl_type_param env styp =
   Builtin_attributes.warning_scope styp.ptyp_attributes
     (fun () -> transl_type_param env styp)
 
+let get_alloc_mode styp =
+  if Builtin_attributes.has_local styp.ptyp_attributes then begin
+    if not (Clflags.Extension.is_enabled Local) then
+      raise (Error(styp.ptyp_loc, Env.empty, Local_not_enabled));
+    Alloc_mode.Local
+  end else
+    Alloc_mode.Global
+
 let rec extract_params styp =
   let final styp =
-    let ret_mode =
-      if Builtin_attributes.has_local styp.ptyp_attributes then Alloc_mode.Local
-      else Alloc_mode.Global
-    in
-    [], styp, ret_mode
+    [], styp, get_alloc_mode styp
   in
   match styp.ptyp_desc with
   | Ptyp_arrow (l, a, r) ->
-      let arg_mode =
-        if Builtin_attributes.has_local a.ptyp_attributes then Alloc_mode.Local
-        else Alloc_mode.Global
-      in
+      let arg_mode = get_alloc_mode a in
       let params, ret, ret_mode =
         if Builtin_attributes.has_curry r.ptyp_attributes then final r
         else extract_params r
@@ -841,6 +843,9 @@ let report_error env ppf = function
   | Not_an_object ty ->
       fprintf ppf "@[The type %a@ is not an object type@]"
         Printtyp.type_expr ty
+  | Local_not_enabled ->
+      fprintf ppf "@[The local extension is disabled@ \
+                     To enable it, pass the '-extension local' flag@]"
 
 let () =
   Location.register_error_of_exn
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
@@ -64,6 +64,7 @@ type error =
   | Method_mismatch of string * type_expr * type_expr
   | Opened_object of Path.t option
   | Not_an_object of type_expr
+  | Local_not_enabled
 
 exception Error of Location.t * Env.t * error
 
