Nonlocal fields (ocaml#28)

lpw25 · stedolan · commit 8dd72709c955 · 2021-11-11T09:41:21.000Z
* Add support for "global" fields

* Bootstrap
diff --git a/boot/menhir/parser.ml b/boot/menhir/parser.ml
diff --git a/boot/menhir/parser.mli b/boot/menhir/parser.mli
@@ -41,6 +41,7 @@ type token =
   | OF
   | OBJECT
   | NONREC
+  | NONLOCAL
   | NEW
   | MUTABLE
   | MODULE
diff --git a/boot/ocamlc b/boot/ocamlc
diff --git a/boot/ocamllex b/boot/ocamllex
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
@@ -415,7 +415,8 @@ module Analyser =
       let record comments
           { Typedtree.ld_id; ld_mutable; ld_type; ld_loc; ld_attributes } =
         get_field env comments @@
-        {Types.ld_id; ld_mutable; ld_type=ld_type.Typedtree.ctyp_type;
+        {Types.ld_id; ld_mutable; ld_nonlocal = Not_nonlocal;
+         ld_type=ld_type.Typedtree.ctyp_type;
          ld_loc; ld_attributes; ld_uid=Types.Uid.internal_not_actually_unique} in
       let open Typedtree in
       function
diff --git a/parsing/lexer.mll b/parsing/lexer.mll
@@ -69,6 +69,7 @@ let keyword_table =
     "module", MODULE;
     "mutable", MUTABLE;
     "new", NEW;
+    "nonlocal_", NONLOCAL;
     "nonrec", NONREC;
     "object", OBJECT;
     "of", OF;
diff --git a/parsing/parser.mly b/parsing/parser.mly
@@ -197,6 +197,17 @@ let maybe_curry_typ typ =
       else mktyp_curry typ
   | _ -> typ
 
+let nonlocal_loc = mknoloc "nonlocal"
+
+let nonlocal_attr =
+  Attr.mk ~loc:Location.none nonlocal_loc (PStr [])
+
+let mkld_nonlocal ld =
+  { ld with pld_attributes = nonlocal_attr :: ld.pld_attributes }
+
+let mkld_nonlocal_if p ld =
+  if p then mkld_nonlocal ld else ld
+
 (* TODO define an abstraction boundary between locations-as-pairs
    and locations-as-Location.t; it should be clear when we move from
    one world to the other *)
@@ -659,6 +670,7 @@ let mk_directive ~loc name arg =
 %token FUN
 %token FUNCTION
 %token FUNCTOR
+%token NONLOCAL
 %token GREATER
 %token GREATERRBRACE
 %token GREATERRBRACKET
@@ -3121,18 +3133,23 @@ label_declarations:
   | label_declaration_semi label_declarations   { $1 :: $2 }
 ;
 label_declaration:
-    mutable_flag mkrhs(label) COLON poly_type_no_attr attributes
+    mutable_or_nonlocal_flag mkrhs(label) COLON poly_type_no_attr attributes
       { let info = symbol_info $endpos in
-        Type.field $2 $4 ~mut:$1 ~attrs:$5 ~loc:(make_loc $sloc) ~info }
+        let mut, nlcl = $1 in
+        mkld_nonlocal_if nlcl
+          (Type.field $2 $4 ~mut ~attrs:$5 ~loc:(make_loc $sloc) ~info) }
 ;
 label_declaration_semi:
-    mutable_flag mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes
+    mutable_or_nonlocal_flag mkrhs(label) COLON poly_type_no_attr attributes
+      SEMI attributes
       { let info =
           match rhs_info $endpos($5) with
           | Some _ as info_before_semi -> info_before_semi
           | None -> symbol_info $endpos
        in
-       Type.field $2 $4 ~mut:$1 ~attrs:($5 @ $7) ~loc:(make_loc $sloc) ~info }
+       let mut, nlcl = $1 in
+       mkld_nonlocal_if nlcl
+         (Type.field $2 $4 ~mut ~attrs:($5 @ $7) ~loc:(make_loc $sloc) ~info) }
 ;
 
 /* Type Extensions */
@@ -3695,6 +3712,11 @@ mutable_flag:
     /* empty */                                 { Immutable }
   | MUTABLE                                     { Mutable }
 ;
+mutable_or_nonlocal_flag:
+    /* empty */                                 { Immutable, false }
+  | MUTABLE                                     { Mutable, false }
+  | NONLOCAL                                      { Immutable, true }
+;
 virtual_flag:
     /* empty */                                 { Concrete }
   | VIRTUAL                                     { Virtual }
@@ -3774,14 +3796,15 @@ single_attr_id:
   | FUN { "fun" }
   | FUNCTION { "function" }
   | FUNCTOR { "functor" }
+  | NONLOCAL { "nonlocal_" }
   | IF { "if" }
   | IN { "in" }
   | INCLUDE { "include" }
   | INHERIT { "inherit" }
   | INITIALIZER { "initializer" }
   | LAZY { "lazy" }
   | LET { "let" }
-  | LOCAL { "local" }
+  | LOCAL { "local_" }
   | MATCH { "match" }
   | METHOD { "method" }
   | MODULE { "module" }
diff --git a/testsuite/tests/typing-local/local.ml b/testsuite/tests/typing-local/local.ml
@@ -855,3 +855,124 @@ Line 1, characters 37-51:
                                          ^^^^^^^^^^^^^^
 Error: This locally-allocated value escapes
 |}]
+
+(* Fields have the same mode unless they are nonlocal or mutable *)
+
+type 'a imm = { imm : 'a }
+type 'a mut = { mutable mut : 'a }
+type 'a nlcl = { nonlocal_ nlcl : 'a }
+[%%expect{|
+type 'a imm = { imm : 'a; }
+type 'a mut = { mutable mut : 'a; }
+type 'a nlcl = { nonlocal_ nlcl : 'a; }
+|}]
+
+let foo (local_ x) = x.imm
+[%%expect{|
+Line 1, characters 21-26:
+1 | let foo (local_ x) = x.imm
+                         ^^^^^
+Error: This locally-allocated value escapes
+|}]
+let foo (local_ x) = x.mut
+[%%expect{|
+val foo : local_ 'a mut -> 'a = <fun>
+|}]
+let foo (local_ x) = x.nlcl
+[%%expect{|
+val foo : local_ 'a nlcl -> 'a = <fun>
+|}]
+
+let foo (local_ { imm }) = imm
+[%%expect{|
+Line 1, characters 27-30:
+1 | let foo (local_ { imm }) = imm
+                               ^^^
+Error: Cannot return locally-allocated value without explicit "local_" annotation
+|}]
+let foo (local_ { mut }) = mut
+[%%expect{|
+val foo : local_ 'a mut -> 'a = <fun>
+|}]
+let foo (local_ { nlcl }) = nlcl
+[%%expect{|
+val foo : local_ 'a nlcl -> 'a = <fun>
+|}]
+
+let foo (local_ imm) =
+  let _ = { imm } in
+  ()
+[%%expect{|
+val foo : local_ 'a -> unit = <fun>
+|}]
+let foo (local_ mut) =
+  let _ = { mut } in
+  ()
+[%%expect{|
+Line 2, characters 12-15:
+2 |   let _ = { mut } in
+                ^^^
+Error: The value mut is local, so cannot be used here as it might escape
+|}]
+let foo (local_ nlcl) =
+  let _ = { nlcl } in
+  ()
+[%%expect{|
+Line 2, characters 12-16:
+2 |   let _ = { nlcl } in
+                ^^^^
+Error: The value nlcl is local, so cannot be used here as it might escape
+|}]
+
+(* Nonlocality is preserved in module inclusion *)
+module M : sig
+  type t = { nonlocal_ foo : string }
+end = struct
+  type t = { foo : string }
+end
+[%%expect{|
+Lines 3-5, characters 6-3:
+3 | ......struct
+4 |   type t = { foo : string }
+5 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = { foo : string; } end
+       is not included in
+         sig type t = { nonlocal_ foo : string; } end
+       Type declarations do not match:
+         type t = { foo : string; }
+       is not included in
+         type t = { nonlocal_ foo : string; }
+       Fields do not match:
+         foo : string;
+       is not compatible with:
+         nonlocal_ foo : string;
+       The second is nonlocal and the first is not.
+|}]
+
+module M : sig
+  type t = { foo : string }
+end = struct
+  type t = { nonlocal_ foo : string }
+end
+[%%expect{|
+Lines 3-5, characters 6-3:
+3 | ......struct
+4 |   type t = { nonlocal_ foo : string }
+5 | end
+Error: Signature mismatch:
+       Modules do not match:
+         sig type t = { nonlocal_ foo : string; } end
+       is not included in
+         sig type t = { foo : string; } end
+       Type declarations do not match:
+         type t = { nonlocal_ foo : string; }
+       is not included in
+         type t = { foo : string; }
+       Fields do not match:
+         nonlocal_ foo : string;
+       is not compatible with:
+         foo : string;
+       The first is nonlocal and the second is not.
+|}]
diff --git a/typing/ctype.ml b/typing/ctype.ml
@@ -2431,7 +2431,8 @@ and mcomp_record_description type_pairs env =
     | l1 :: xs, l2 :: ys ->
         mcomp type_pairs env l1.ld_type l2.ld_type;
         if Ident.name l1.ld_id = Ident.name l2.ld_id &&
-           l1.ld_mutable = l2.ld_mutable
+           l1.ld_mutable = l2.ld_mutable &&
+           l1.ld_nonlocal = l2.ld_nonlocal
         then iter xs ys
         else raise (Unify [])
     | [], [] -> ()
diff --git a/typing/datarepr.ml b/typing/datarepr.ml
@@ -185,7 +185,8 @@ let extension_descr ~current_unit path_ext ext =
 let none = {desc = Ttuple []; level = -1; scope = Btype.generic_level; id = -1}
                                         (* Clearly ill-formed type *)
 let dummy_label =
-  { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
+  { lbl_name = ""; lbl_res = none; lbl_arg = none;
+    lbl_mut = Immutable; lbl_nonlocal = Not_nonlocal;
     lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular;
     lbl_private = Public;
     lbl_loc = Location.none;
@@ -203,6 +204,7 @@ let label_descrs ty_res lbls repres priv =
             lbl_res = ty_res;
             lbl_arg = l.ld_type;
             lbl_mut = l.ld_mutable;
+            lbl_nonlocal = l.ld_nonlocal;
             lbl_pos = num;
             lbl_all = all_labels;
             lbl_repres = repres;
diff --git a/typing/includecore.ml b/typing/includecore.ml
@@ -137,6 +137,7 @@ let choose_other ord first second =
 type label_mismatch =
   | Type
   | Mutability of position
+  | Nonlocality of position
 
 type record_mismatch =
   | Label_mismatch of Types.label_declaration
@@ -187,6 +188,10 @@ let report_label_mismatch first second ppf err =
       pr "%s is mutable and %s is not."
         (String.capitalize_ascii  (choose ord first second))
         (choose_other ord first second)
+  | Nonlocality ord ->
+      pr "%s is nonlocal and %s is not."
+        (String.capitalize_ascii  (choose ord first second))
+        (choose_other ord first second)
 
 let report_record_mismatch first second decl ppf err =
   let pr fmt = Format.fprintf ppf fmt in
@@ -337,11 +342,17 @@ and compare_labels env params1 params2
       if ld1.ld_mutable <> ld2.ld_mutable
       then
         let ord = if ld1.ld_mutable = Asttypes.Mutable then First else Second in
-        Some (Mutability  ord)
-      else
-        if Ctype.equal env true (ld1.ld_type::params1) (ld2.ld_type::params2)
-        then None
-        else Some (Type : label_mismatch)
+        Some (Mutability ord)
+      else begin
+        match ld1.ld_nonlocal, ld2.ld_nonlocal with
+        | Nonlocal, Not_nonlocal -> Some (Nonlocality First)
+        | Not_nonlocal, Nonlocal -> Some (Nonlocality Second)
+        | Nonlocal, Nonlocal
+        | Not_nonlocal, Not_nonlocal ->
+          if Ctype.equal env true (ld1.ld_type::params1) (ld2.ld_type::params2)
+          then None
+          else Some (Type : label_mismatch)
+      end
 
 and compare_records ~loc env params1 params2 n
     (labels1 : Types.label_declaration list)
diff --git a/typing/includecore.mli b/typing/includecore.mli
@@ -25,6 +25,7 @@ type position = Ctype.Unification_trace.position = First | Second
 type label_mismatch =
   | Type
   | Mutability of position
+  | Nonlocality of position
 
 type record_mismatch =
   | Label_mismatch of label_declaration * label_declaration * label_mismatch
diff --git a/typing/oprint.ml b/typing/oprint.ml
@@ -425,8 +425,9 @@ and print_typargs ppf =
       pp_print_char ppf ')';
       pp_close_box ppf ();
       pp_print_space ppf ()
-and print_out_label ppf (name, mut, arg) =
-  fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
+and print_out_label ppf (name, mut, nlcl, arg) =
+  fprintf ppf "@[<2>%s%s%s :@ %a@];" (if mut then "mutable " else "")
+    (if nlcl && not mut then "nonlocal_ " else "") name
     print_out_type arg
 
 let out_label = ref print_out_label
diff --git a/typing/oprint.mli b/typing/oprint.mli
@@ -18,7 +18,7 @@ open Outcometree
 
 val out_ident : (formatter -> out_ident -> unit) ref
 val out_value : (formatter -> out_value -> unit) ref
-val out_label : (formatter -> string * bool * out_type -> unit) ref
+val out_label : (formatter -> string * bool * bool * out_type -> unit) ref
 val out_type : (formatter -> out_type -> unit) ref
 val out_constr :
   (formatter -> string * out_type list * out_type option -> unit) ref
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
@@ -67,7 +67,7 @@ type out_type =
   | Otyp_constr of out_ident * out_type list
   | Otyp_manifest of out_type * out_type
   | Otyp_object of (string * out_type) list * bool option
-  | Otyp_record of (string * bool * out_type) list
+  | Otyp_record of (string * bool * bool * out_type) list
   | Otyp_stuff of string
   | Otyp_sum of (string * out_type list * out_type option) list
   | Otyp_tuple of out_type list
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
@@ -1334,7 +1334,8 @@ and tree_of_constructor cd =
       (name, args, Some ret)
 
 and tree_of_label l =
-  (Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp false l.ld_type)
+  (Ident.name l.ld_id, l.ld_mutable = Mutable, l.ld_nonlocal = Nonlocal,
+   tree_of_typexp false l.ld_type)
 
 let constructor ppf c =
   reset_except_context ();
diff --git a/typing/subst.ml b/typing/subst.ml
@@ -262,6 +262,7 @@ let label_declaration copy_scope s l =
   {
     ld_id = l.ld_id;
     ld_mutable = l.ld_mutable;
+    ld_nonlocal = l.ld_nonlocal;
     ld_type = typexp copy_scope s l.ld_type;
     ld_loc = loc s l.ld_loc;
     ld_attributes = attrs s l.ld_attributes;
diff --git a/typing/typecore.ml b/typing/typecore.ml
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
diff --git a/typing/types.ml b/typing/types.ml
diff --git a/typing/types.mli b/typing/types.mli
