Ensure new local attributes are namespaced properly

stedolan · stedolan · commit b3447dbe5da0 · 2021-12-15T18:40:37.000Z
diff --git a/boot/menhir/parser.ml b/boot/menhir/parser.ml
diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml
@@ -400,8 +400,11 @@ let parse_standard_implementation_attributes attr =
   flambda_o3_attribute attr;
   flambda_oclassic_attribute attr
 
-let has_curry attr =
-  List.exists (check ["ocaml.curry"; "curry"]) attr
+(* curry/local are generated by the parser and not usually written directly,
+   so they do not have a short form. *)
+let has_curry attr = List.exists (check ["ocaml.curry"]) attr
+
+let has_local attr = List.exists (check ["ocaml.local"]) attr
 
 let has_local_opt attr =
   List.exists (check ["ocaml.local_opt"; "local_opt"]) attr
diff --git a/parsing/builtin_attributes.mli b/parsing/builtin_attributes.mli
@@ -92,4 +92,5 @@ val parse_standard_interface_attributes : Parsetree.attribute -> unit
 val parse_standard_implementation_attributes : Parsetree.attribute -> unit
 
 val has_curry: Parsetree.attributes -> bool
+val has_local: Parsetree.attributes -> bool
 val has_local_opt: Parsetree.attributes -> bool
diff --git a/parsing/parser.mly b/parsing/parser.mly
@@ -158,43 +158,44 @@ let mkuplus ~oploc name arg =
       Pexp_apply(mkoperator ~loc:oploc ("~" ^ name), [Nolabel, arg])
 
 
-let stack_loc = mknoloc "stack"
+let local_loc = mknoloc "ocaml.local"
+let local_ext_loc = mknoloc "extension.local"
 
-let stack_attr =
-  Attr.mk ~loc:Location.none stack_loc (PStr [])
+let local_attr =
+  Attr.mk ~loc:Location.none local_loc (PStr [])
 
-let stack_extension =
-  Exp.mk ~loc:Location.none (Pexp_extension(stack_loc, PStr []))
+let local_extension =
+  Exp.mk ~loc:Location.none (Pexp_extension(local_ext_loc, PStr []))
 
 let mkexp_stack ~loc exp =
-  ghexp ~loc (Pexp_apply(stack_extension, [Nolabel, exp]))
+  ghexp ~loc (Pexp_apply(local_extension, [Nolabel, exp]))
 
 let mkpat_stack pat =
-  {pat with ppat_attributes = stack_attr :: pat.ppat_attributes}
+  {pat with ppat_attributes = local_attr :: pat.ppat_attributes}
 
 let mktyp_stack typ =
-  {typ with ptyp_attributes = stack_attr :: typ.ptyp_attributes}
+  {typ with ptyp_attributes = local_attr :: typ.ptyp_attributes}
 
 let wrap_exp_stack exp =
-  {exp with pexp_attributes = stack_attr :: exp.pexp_attributes}
+  {exp with pexp_attributes = local_attr :: exp.pexp_attributes}
 
-let mkexp_stack_if p ~loc exp =
+let mkexp_local_if p ~loc exp =
   if p then mkexp_stack ~loc exp else exp
 
-let mkpat_stack_if p pat =
+let mkpat_local_if p pat =
   if p then mkpat_stack pat else pat
 
-let mktyp_stack_if p typ =
+let mktyp_local_if p typ =
   if p then mktyp_stack typ else typ
 
-let wrap_exp_stack_if p exp =
+let wrap_exp_local_if p exp =
   if p then wrap_exp_stack exp else exp
 
 let curry_attr =
-  Attr.mk ~loc:Location.none (mknoloc "curry") (PStr [])
+  Attr.mk ~loc:Location.none (mknoloc "ocaml.curry") (PStr [])
 
 let is_curry_attr attr =
-  attr.attr_name.txt = "curry"
+  attr.attr_name.txt = "ocaml.curry"
 
 let mkexp_curry exp =
   {exp with pexp_attributes = curry_attr :: exp.pexp_attributes}
@@ -209,12 +210,12 @@ let maybe_curry_typ typ =
       else mktyp_curry typ
   | _ -> typ
 
-let global_loc = mknoloc "global"
+let global_loc = mknoloc "ocaml.global"
 
 let global_attr =
   Attr.mk ~loc:Location.none global_loc (PStr [])
 
-let nonlocal_loc = mknoloc "nonlocal"
+let nonlocal_loc = mknoloc "ocaml.nonlocal"
 
 let nonlocal_attr =
   Attr.mk ~loc:Location.none nonlocal_loc (PStr [])
@@ -2171,15 +2172,15 @@ seq_expr:
 ;
 labeled_simple_pattern:
     QUESTION LPAREN optional_local label_let_pattern opt_default RPAREN
-      { (Optional (fst $4), $5, mkpat_stack_if $3 (snd $4)) }
+      { (Optional (fst $4), $5, mkpat_local_if $3 (snd $4)) }
   | QUESTION label_var
       { (Optional (fst $2), None, snd $2) }
   | OPTLABEL LPAREN optional_local let_pattern opt_default RPAREN
-      { (Optional $1, $5, mkpat_stack_if $3 $4) }
+      { (Optional $1, $5, mkpat_local_if $3 $4) }
   | OPTLABEL pattern_var
       { (Optional $1, None, $2) }
   | TILDE LPAREN optional_local label_let_pattern RPAREN
-      { (Labelled (fst $4), None, mkpat_stack_if $3 (snd $4)) }
+      { (Labelled (fst $4), None, mkpat_local_if $3 (snd $4)) }
   | TILDE label_var
       { (Labelled (fst $2), None, snd $2) }
   | LABEL simple_pattern
@@ -2559,11 +2560,11 @@ let_binding_body:
         let typ = ghtyp ~loc (Ptyp_poly([],t)) in
         let patloc = ($startpos($2), $endpos($3)) in
         let pat =
-          mkpat_stack_if $1 (ghpat ~loc:patloc (Ppat_constraint(v, typ)))
+          mkpat_local_if $1 (ghpat ~loc:patloc (Ppat_constraint(v, typ)))
         in
         let exp =
-          mkexp_stack_if $1 ~loc:$sloc
-            (wrap_exp_stack_if $1 (mkexp_constraint ~loc:$sloc $5 $3))
+          mkexp_local_if $1 ~loc:$sloc
+            (wrap_exp_local_if $1 (mkexp_constraint ~loc:$sloc $5 $3))
         in
         (pat, exp) }
   | optional_local let_ident COLON typevar_list DOT core_type EQUAL seq_expr
@@ -2573,11 +2574,11 @@ let_binding_body:
       { let typloc = ($startpos($4), $endpos($6)) in
         let patloc = ($startpos($2), $endpos($6)) in
         let pat =
-          mkpat_stack_if $1
+          mkpat_local_if $1
             (ghpat ~loc:patloc
                (Ppat_constraint($2, ghtyp ~loc:typloc (Ptyp_poly($4,$6)))))
         in
-        let exp = mkexp_stack_if $1 ~loc:$sloc $8 in
+        let exp = mkexp_local_if $1 ~loc:$sloc $8 in
         (pat, exp) }
   | let_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
       { let exp, poly =
@@ -3397,7 +3398,7 @@ strict_function_type:
       domain = extra_rhs(tuple_type)
       MINUSGREATER
       codomain = strict_function_type
-        { Ptyp_arrow(label, mktyp_stack_if local domain, codomain) }
+        { Ptyp_arrow(label, mktyp_local_if local domain, codomain) }
     )
     { $1 }
   | mktyp(
@@ -3409,8 +3410,8 @@ strict_function_type:
       codomain = tuple_type
       %prec MINUSGREATER
         { Ptyp_arrow(label,
-            mktyp_stack_if arg_local domain,
-            mktyp_stack_if ret_local (maybe_curry_typ codomain)) }
+            mktyp_local_if arg_local domain,
+            mktyp_local_if ret_local (maybe_curry_typ codomain)) }
     )
     { $1 }
 ;
diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml
@@ -112,7 +112,7 @@ let protect_longident ppf print_longident longprefix txt =
 
 let is_curry_attr attr =
   match attr.attr_name.txt with
-  | "curry" -> true
+  | "ocaml.curry" -> true
   | _ -> false
 
 let filter_curry_attrs attrs =
diff --git a/testsuite/tests/parsetree/locations_test.compilers.reference b/testsuite/tests/parsetree/locations_test.compilers.reference
@@ -262,13 +262,13 @@ Ptop_def
                 core_type (//toplevel//[2,1+21]..[2,1+22])
                   Ptyp_var a
           expression (//toplevel//[2,1+4]..[2,1+35])
-            attribute "curry"
+            attribute "ocaml.curry"
               []
             Pexp_newtype "a"
             expression (//toplevel//[2,1+4]..[2,1+35])
               Pexp_constraint
               expression (//toplevel//[2,1+25]..[2,1+35])
-                attribute "curry"
+                attribute "ocaml.curry"
                   []
                 Pexp_fun
                 Nolabel
@@ -311,13 +311,13 @@ Ptop_def
                     expression (//toplevel//[3,16+18]..[4,46+14]) ghost
                       Pexp_poly
                       expression (//toplevel//[3,16+9]..[4,46+14])
-                        attribute "curry"
+                        attribute "ocaml.curry"
                           []
                         Pexp_newtype "a"
                         expression (//toplevel//[3,16+9]..[4,46+14])
                           Pexp_constraint
                           expression (//toplevel//[4,46+4]..[4,46+14])
-                            attribute "curry"
+                            attribute "ocaml.curry"
                               []
                             Pexp_fun
                             Nolabel
diff --git a/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference b/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference
@@ -71,7 +71,7 @@
                           structure_item (shortcut_ext_attr.ml[14,294+3]..[14,294+24])
                             Pstr_eval
                             expression (shortcut_ext_attr.ml[14,294+3]..[14,294+24])
-                              attribute "curry"
+                              attribute "ocaml.curry"
                                 []
                               attribute "foo"
                                 []
diff --git a/typing/typecore.ml b/typing/typecore.ml
@@ -459,15 +459,9 @@ let extract_label_names env ty =
   with Not_found ->
     assert false
 
-let has_stack_attr_pat ppat =
-  List.exists
-    (fun attr -> String.equal attr.attr_name.txt "stack")
-    ppat.ppat_attributes
+let has_local_attr_pat ppat = Builtin_attributes.has_local ppat.ppat_attributes
 
-let has_stack_attr_exp pexp =
-  List.exists
-    (fun attr -> String.equal attr.attr_name.txt "stack")
-    pexp.pexp_attributes
+let has_local_attr_exp pexp = Builtin_attributes.has_local pexp.pexp_attributes
 
 (* Typing of patterns *)
 
@@ -1698,7 +1692,7 @@ and type_pat_aux
       (* explicitly polymorphic type *)
       assert construction_not_used_in_counterexamples;
       let type_mode =
-        if has_stack_attr_pat sp then Alloc_mode.Local
+        if has_local_attr_pat sp then Alloc_mode.Local
         else Alloc_mode.Global
       in
       let cty, ty, force =
@@ -2114,7 +2108,7 @@ and type_pat_aux
       (* Pretend separate = true *)
       begin_def();
       let type_mode =
-        if has_stack_attr_pat sp then Alloc_mode.Local
+        if has_local_attr_pat sp then Alloc_mode.Local
         else Alloc_mode.Global
       in
       let cty, ty, force =
@@ -2841,7 +2835,7 @@ let is_local_returning_expr e =
   let rec loop e =
     match e.pexp_desc with
     | Pexp_apply
-        ({ pexp_desc = Pexp_extension({txt = "stack"}, PStr []) },
+        ({ pexp_desc = Pexp_extension({txt = "extension.local"}, PStr []) },
          [Nolabel, _]) ->
         true, e.pexp_loc
     | Pexp_ident _ | Pexp_constant _ | Pexp_apply _ | Pexp_tuple _
@@ -2934,7 +2928,7 @@ let rec type_approx env sexp =
     Pexp_let (_, _, e) -> type_approx env e
   | Pexp_fun (p, _, spat, e) ->
       let marg =
-        if has_stack_attr_pat spat then Alloc_mode.local
+        if has_local_attr_pat spat then Alloc_mode.local
         else Alloc_mode.newvar ()
       in
       let mret = Alloc_mode.newvar () in
@@ -2970,11 +2964,11 @@ let rec type_approx env sexp =
       end;
       ty2
   | Pexp_apply
-      ({ pexp_desc = Pexp_extension({txt = "stack"}, PStr []) },
+      ({ pexp_desc = Pexp_extension({txt = "extension.local"}, PStr []) },
        [Nolabel, e]) ->
     type_approx env e
   | Pexp_apply
-      ({ pexp_desc = Pexp_extension({txt = "escape"}, PStr []) },
+      ({ pexp_desc = Pexp_extension({txt = "extension.escape"}, PStr []) },
        [Nolabel, e]) ->
     type_approx env e
   | _ -> newvar ()
@@ -3420,7 +3414,7 @@ and type_expect_
           (Pat.construct ~loc:default_loc
              (mknoloc (Longident.(Ldot (Lident "*predef*", "None"))))
              None)
-          (Exp.apply (Exp.extension (mknoloc "escape", PStr []))
+          (Exp.apply (Exp.extension (mknoloc "extension.escape", PStr []))
              [Nolabel, default]);
        ]
       in
@@ -3440,12 +3434,12 @@ and type_expect_
           ~attrs:[Attr.mk (mknoloc "#default") (PStr [])]
           [Vb.mk spat smatch] sbody
       in
-      let has_local = has_stack_attr_pat spat in
+      let has_local = has_local_attr_pat spat in
       type_function ?in_function loc sexp.pexp_attributes env
                     expected_mode ty_expected_explained
                     l has_local [Exp.case pat body]
   | Pexp_fun (l, None, spat, sbody) ->
-      let has_local = has_stack_attr_pat spat in
+      let has_local = has_local_attr_pat spat in
       type_function ?in_function loc sexp.pexp_attributes env
                     expected_mode ty_expected_explained l has_local
                     [Ast_helper.Exp.case spat sbody]
@@ -3454,7 +3448,7 @@ and type_expect_
         loc sexp.pexp_attributes env expected_mode
         ty_expected_explained Nolabel false caselist
   | Pexp_apply
-      ({ pexp_desc = Pexp_extension({txt = "stack"}, PStr []) },
+      ({ pexp_desc = Pexp_extension({txt = "extension.local"}, PStr []) },
        [Nolabel, sbody]) ->
       submode ~loc ~env Value_mode.local expected_mode;
       let exp =
@@ -3463,7 +3457,7 @@ and type_expect_
       in
       { exp with exp_loc = loc }
   | Pexp_apply
-      ({ pexp_desc = Pexp_extension({txt = "escape"}, PStr []) },
+      ({ pexp_desc = Pexp_extension({txt = "extension.escape"}, PStr []) },
        [Nolabel, sbody]) ->
       let exp =
         type_expect ?in_function ~recarg env mode_global sbody
@@ -3941,7 +3935,7 @@ and type_expect_
       (* Pretend separate = true, 1% slowdown for lablgtk *)
       begin_def ();
       let type_mode =
-        if has_stack_attr_exp sexp then Alloc_mode.Local
+        if has_local_attr_exp sexp then Alloc_mode.Local
         else Alloc_mode.Global
       in
       let cty = Typetexp.transl_simple_type env false type_mode sty in
@@ -3965,7 +3959,7 @@ and type_expect_
       (* Also see PR#7199 for a problem with the following:
          let separate = !Clflags.principal || Env.has_local_constraints env in*)
       let type_mode =
-        if has_stack_attr_exp sexp then Alloc_mode.Local
+        if has_local_attr_exp sexp then Alloc_mode.Local
         else Alloc_mode.Global
       in
       let (arg, ty',cty,cty') =
@@ -5761,7 +5755,7 @@ and type_let
     | Pexp_constraint (e, _)
     | Pexp_newtype (_, e)
     | Pexp_apply
-      ({ pexp_desc = Pexp_extension({txt = "stack"}, PStr []) },
+      ({ pexp_desc = Pexp_extension({txt = "extension.local"}, PStr []) },
        [Nolabel, e]) -> sexp_is_fun e
     | _ -> false
   in
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
@@ -202,12 +202,12 @@ let make_params env params =
 
 let has_global_attr attributes =
   List.exists
-    (fun attr -> String.equal attr.attr_name.txt "global")
+    (fun attr -> String.equal attr.attr_name.txt "ocaml.global")
     attributes
 
 let has_nonlocal_attr attributes =
   List.exists
-    (fun attr -> String.equal attr.attr_name.txt "nonlocal")
+    (fun attr -> String.equal attr.attr_name.txt "ocaml.nonlocal")
     attributes
 
 let transl_labels env closed lbls =
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
@@ -156,27 +156,22 @@ let transl_type_param env styp =
   Builtin_attributes.warning_scope styp.ptyp_attributes
     (fun () -> transl_type_param env styp)
 
-let has_attr s styp =
-  List.exists
-    (fun attr -> String.equal attr.attr_name.txt s)
-    styp.ptyp_attributes
-
 let rec extract_params styp =
   let final styp =
     let ret_mode =
-      if has_attr "stack" styp then Alloc_mode.Local
+      if Builtin_attributes.has_local styp.ptyp_attributes then Alloc_mode.Local
       else Alloc_mode.Global
     in
     [], styp, ret_mode
   in
   match styp.ptyp_desc with
   | Ptyp_arrow (l, a, r) ->
       let arg_mode =
-        if has_attr "stack" a then Alloc_mode.Local
+        if Builtin_attributes.has_local a.ptyp_attributes then Alloc_mode.Local
         else Alloc_mode.Global
       in
       let params, ret, ret_mode =
-        if has_attr "curry" r then final r
+        if Builtin_attributes.has_curry r.ptyp_attributes then final r
         else extract_params r
       in
       (l, arg_mode, a) :: params, ret, ret_mode
