Skip to content

Commit 8dd7270

Browse files
lpw25stedolan
authored andcommitted
Nonlocal fields (#28)
* Add support for "global" fields * Bootstrap
1 parent e19a2f0 commit 8dd7270

File tree

21 files changed

+5484
-5174
lines changed

21 files changed

+5484
-5174
lines changed

boot/menhir/parser.ml

Lines changed: 5260 additions & 5147 deletions
Large diffs are not rendered by default.

boot/menhir/parser.mli

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -41,6 +41,7 @@ type token =
4141
| OF
4242
| OBJECT
4343
| NONREC
44+
| NONLOCAL
4445
| NEW
4546
| MUTABLE
4647
| MODULE

boot/ocamlc

3.18 KB
Binary file not shown.

boot/ocamllex

0 Bytes
Binary file not shown.

ocamldoc/odoc_sig.ml

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -415,7 +415,8 @@ module Analyser =
415415
let record comments
416416
{ Typedtree.ld_id; ld_mutable; ld_type; ld_loc; ld_attributes } =
417417
get_field env comments @@
418-
{Types.ld_id; ld_mutable; ld_type=ld_type.Typedtree.ctyp_type;
418+
{Types.ld_id; ld_mutable; ld_nonlocal = Not_nonlocal;
419+
ld_type=ld_type.Typedtree.ctyp_type;
419420
ld_loc; ld_attributes; ld_uid=Types.Uid.internal_not_actually_unique} in
420421
let open Typedtree in
421422
function

parsing/lexer.mll

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -69,6 +69,7 @@ let keyword_table =
6969
"module", MODULE;
7070
"mutable", MUTABLE;
7171
"new", NEW;
72+
"nonlocal_", NONLOCAL;
7273
"nonrec", NONREC;
7374
"object", OBJECT;
7475
"of", OF;

parsing/parser.mly

Lines changed: 28 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -197,6 +197,17 @@ let maybe_curry_typ typ =
197197
else mktyp_curry typ
198198
| _ -> typ
199199

200+
let nonlocal_loc = mknoloc "nonlocal"
201+
202+
let nonlocal_attr =
203+
Attr.mk ~loc:Location.none nonlocal_loc (PStr [])
204+
205+
let mkld_nonlocal ld =
206+
{ ld with pld_attributes = nonlocal_attr :: ld.pld_attributes }
207+
208+
let mkld_nonlocal_if p ld =
209+
if p then mkld_nonlocal ld else ld
210+
200211
(* TODO define an abstraction boundary between locations-as-pairs
201212
and locations-as-Location.t; it should be clear when we move from
202213
one world to the other *)
@@ -659,6 +670,7 @@ let mk_directive ~loc name arg =
659670
%token FUN
660671
%token FUNCTION
661672
%token FUNCTOR
673+
%token NONLOCAL
662674
%token GREATER
663675
%token GREATERRBRACE
664676
%token GREATERRBRACKET
@@ -3121,18 +3133,23 @@ label_declarations:
31213133
| label_declaration_semi label_declarations { $1 :: $2 }
31223134
;
31233135
label_declaration:
3124-
mutable_flag mkrhs(label) COLON poly_type_no_attr attributes
3136+
mutable_or_nonlocal_flag mkrhs(label) COLON poly_type_no_attr attributes
31253137
{ let info = symbol_info $endpos in
3126-
Type.field $2 $4 ~mut:$1 ~attrs:$5 ~loc:(make_loc $sloc) ~info }
3138+
let mut, nlcl = $1 in
3139+
mkld_nonlocal_if nlcl
3140+
(Type.field $2 $4 ~mut ~attrs:$5 ~loc:(make_loc $sloc) ~info) }
31273141
;
31283142
label_declaration_semi:
3129-
mutable_flag mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes
3143+
mutable_or_nonlocal_flag mkrhs(label) COLON poly_type_no_attr attributes
3144+
SEMI attributes
31303145
{ let info =
31313146
match rhs_info $endpos($5) with
31323147
| Some _ as info_before_semi -> info_before_semi
31333148
| None -> symbol_info $endpos
31343149
in
3135-
Type.field $2 $4 ~mut:$1 ~attrs:($5 @ $7) ~loc:(make_loc $sloc) ~info }
3150+
let mut, nlcl = $1 in
3151+
mkld_nonlocal_if nlcl
3152+
(Type.field $2 $4 ~mut ~attrs:($5 @ $7) ~loc:(make_loc $sloc) ~info) }
31363153
;
31373154

31383155
/* Type Extensions */
@@ -3695,6 +3712,11 @@ mutable_flag:
36953712
/* empty */ { Immutable }
36963713
| MUTABLE { Mutable }
36973714
;
3715+
mutable_or_nonlocal_flag:
3716+
/* empty */ { Immutable, false }
3717+
| MUTABLE { Mutable, false }
3718+
| NONLOCAL { Immutable, true }
3719+
;
36983720
virtual_flag:
36993721
/* empty */ { Concrete }
37003722
| VIRTUAL { Virtual }
@@ -3774,14 +3796,15 @@ single_attr_id:
37743796
| FUN { "fun" }
37753797
| FUNCTION { "function" }
37763798
| FUNCTOR { "functor" }
3799+
| NONLOCAL { "nonlocal_" }
37773800
| IF { "if" }
37783801
| IN { "in" }
37793802
| INCLUDE { "include" }
37803803
| INHERIT { "inherit" }
37813804
| INITIALIZER { "initializer" }
37823805
| LAZY { "lazy" }
37833806
| LET { "let" }
3784-
| LOCAL { "local" }
3807+
| LOCAL { "local_" }
37853808
| MATCH { "match" }
37863809
| METHOD { "method" }
37873810
| MODULE { "module" }

testsuite/tests/typing-local/local.ml

Lines changed: 121 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -855,3 +855,124 @@ Line 1, characters 37-51:
855855
^^^^^^^^^^^^^^
856856
Error: This locally-allocated value escapes
857857
|}]
858+
859+
(* Fields have the same mode unless they are nonlocal or mutable *)
860+
861+
type 'a imm = { imm : 'a }
862+
type 'a mut = { mutable mut : 'a }
863+
type 'a nlcl = { nonlocal_ nlcl : 'a }
864+
[%%expect{|
865+
type 'a imm = { imm : 'a; }
866+
type 'a mut = { mutable mut : 'a; }
867+
type 'a nlcl = { nonlocal_ nlcl : 'a; }
868+
|}]
869+
870+
let foo (local_ x) = x.imm
871+
[%%expect{|
872+
Line 1, characters 21-26:
873+
1 | let foo (local_ x) = x.imm
874+
^^^^^
875+
Error: This locally-allocated value escapes
876+
|}]
877+
let foo (local_ x) = x.mut
878+
[%%expect{|
879+
val foo : local_ 'a mut -> 'a = <fun>
880+
|}]
881+
let foo (local_ x) = x.nlcl
882+
[%%expect{|
883+
val foo : local_ 'a nlcl -> 'a = <fun>
884+
|}]
885+
886+
let foo (local_ { imm }) = imm
887+
[%%expect{|
888+
Line 1, characters 27-30:
889+
1 | let foo (local_ { imm }) = imm
890+
^^^
891+
Error: Cannot return locally-allocated value without explicit "local_" annotation
892+
|}]
893+
let foo (local_ { mut }) = mut
894+
[%%expect{|
895+
val foo : local_ 'a mut -> 'a = <fun>
896+
|}]
897+
let foo (local_ { nlcl }) = nlcl
898+
[%%expect{|
899+
val foo : local_ 'a nlcl -> 'a = <fun>
900+
|}]
901+
902+
let foo (local_ imm) =
903+
let _ = { imm } in
904+
()
905+
[%%expect{|
906+
val foo : local_ 'a -> unit = <fun>
907+
|}]
908+
let foo (local_ mut) =
909+
let _ = { mut } in
910+
()
911+
[%%expect{|
912+
Line 2, characters 12-15:
913+
2 | let _ = { mut } in
914+
^^^
915+
Error: The value mut is local, so cannot be used here as it might escape
916+
|}]
917+
let foo (local_ nlcl) =
918+
let _ = { nlcl } in
919+
()
920+
[%%expect{|
921+
Line 2, characters 12-16:
922+
2 | let _ = { nlcl } in
923+
^^^^
924+
Error: The value nlcl is local, so cannot be used here as it might escape
925+
|}]
926+
927+
(* Nonlocality is preserved in module inclusion *)
928+
module M : sig
929+
type t = { nonlocal_ foo : string }
930+
end = struct
931+
type t = { foo : string }
932+
end
933+
[%%expect{|
934+
Lines 3-5, characters 6-3:
935+
3 | ......struct
936+
4 | type t = { foo : string }
937+
5 | end
938+
Error: Signature mismatch:
939+
Modules do not match:
940+
sig type t = { foo : string; } end
941+
is not included in
942+
sig type t = { nonlocal_ foo : string; } end
943+
Type declarations do not match:
944+
type t = { foo : string; }
945+
is not included in
946+
type t = { nonlocal_ foo : string; }
947+
Fields do not match:
948+
foo : string;
949+
is not compatible with:
950+
nonlocal_ foo : string;
951+
The second is nonlocal and the first is not.
952+
|}]
953+
954+
module M : sig
955+
type t = { foo : string }
956+
end = struct
957+
type t = { nonlocal_ foo : string }
958+
end
959+
[%%expect{|
960+
Lines 3-5, characters 6-3:
961+
3 | ......struct
962+
4 | type t = { nonlocal_ foo : string }
963+
5 | end
964+
Error: Signature mismatch:
965+
Modules do not match:
966+
sig type t = { nonlocal_ foo : string; } end
967+
is not included in
968+
sig type t = { foo : string; } end
969+
Type declarations do not match:
970+
type t = { nonlocal_ foo : string; }
971+
is not included in
972+
type t = { foo : string; }
973+
Fields do not match:
974+
nonlocal_ foo : string;
975+
is not compatible with:
976+
foo : string;
977+
The first is nonlocal and the second is not.
978+
|}]

typing/ctype.ml

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2431,7 +2431,8 @@ and mcomp_record_description type_pairs env =
24312431
| l1 :: xs, l2 :: ys ->
24322432
mcomp type_pairs env l1.ld_type l2.ld_type;
24332433
if Ident.name l1.ld_id = Ident.name l2.ld_id &&
2434-
l1.ld_mutable = l2.ld_mutable
2434+
l1.ld_mutable = l2.ld_mutable &&
2435+
l1.ld_nonlocal = l2.ld_nonlocal
24352436
then iter xs ys
24362437
else raise (Unify [])
24372438
| [], [] -> ()

typing/datarepr.ml

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -185,7 +185,8 @@ let extension_descr ~current_unit path_ext ext =
185185
let none = {desc = Ttuple []; level = -1; scope = Btype.generic_level; id = -1}
186186
(* Clearly ill-formed type *)
187187
let dummy_label =
188-
{ lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
188+
{ lbl_name = ""; lbl_res = none; lbl_arg = none;
189+
lbl_mut = Immutable; lbl_nonlocal = Not_nonlocal;
189190
lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular;
190191
lbl_private = Public;
191192
lbl_loc = Location.none;
@@ -203,6 +204,7 @@ let label_descrs ty_res lbls repres priv =
203204
lbl_res = ty_res;
204205
lbl_arg = l.ld_type;
205206
lbl_mut = l.ld_mutable;
207+
lbl_nonlocal = l.ld_nonlocal;
206208
lbl_pos = num;
207209
lbl_all = all_labels;
208210
lbl_repres = repres;

typing/includecore.ml

Lines changed: 16 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -137,6 +137,7 @@ let choose_other ord first second =
137137
type label_mismatch =
138138
| Type
139139
| Mutability of position
140+
| Nonlocality of position
140141

141142
type record_mismatch =
142143
| Label_mismatch of Types.label_declaration
@@ -187,6 +188,10 @@ let report_label_mismatch first second ppf err =
187188
pr "%s is mutable and %s is not."
188189
(String.capitalize_ascii (choose ord first second))
189190
(choose_other ord first second)
191+
| Nonlocality ord ->
192+
pr "%s is nonlocal and %s is not."
193+
(String.capitalize_ascii (choose ord first second))
194+
(choose_other ord first second)
190195

191196
let report_record_mismatch first second decl ppf err =
192197
let pr fmt = Format.fprintf ppf fmt in
@@ -337,11 +342,17 @@ and compare_labels env params1 params2
337342
if ld1.ld_mutable <> ld2.ld_mutable
338343
then
339344
let ord = if ld1.ld_mutable = Asttypes.Mutable then First else Second in
340-
Some (Mutability ord)
341-
else
342-
if Ctype.equal env true (ld1.ld_type::params1) (ld2.ld_type::params2)
343-
then None
344-
else Some (Type : label_mismatch)
345+
Some (Mutability ord)
346+
else begin
347+
match ld1.ld_nonlocal, ld2.ld_nonlocal with
348+
| Nonlocal, Not_nonlocal -> Some (Nonlocality First)
349+
| Not_nonlocal, Nonlocal -> Some (Nonlocality Second)
350+
| Nonlocal, Nonlocal
351+
| Not_nonlocal, Not_nonlocal ->
352+
if Ctype.equal env true (ld1.ld_type::params1) (ld2.ld_type::params2)
353+
then None
354+
else Some (Type : label_mismatch)
355+
end
345356

346357
and compare_records ~loc env params1 params2 n
347358
(labels1 : Types.label_declaration list)

typing/includecore.mli

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ type position = Ctype.Unification_trace.position = First | Second
2525
type label_mismatch =
2626
| Type
2727
| Mutability of position
28+
| Nonlocality of position
2829

2930
type record_mismatch =
3031
| Label_mismatch of label_declaration * label_declaration * label_mismatch

typing/oprint.ml

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -425,8 +425,9 @@ and print_typargs ppf =
425425
pp_print_char ppf ')';
426426
pp_close_box ppf ();
427427
pp_print_space ppf ()
428-
and print_out_label ppf (name, mut, arg) =
429-
fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
428+
and print_out_label ppf (name, mut, nlcl, arg) =
429+
fprintf ppf "@[<2>%s%s%s :@ %a@];" (if mut then "mutable " else "")
430+
(if nlcl && not mut then "nonlocal_ " else "") name
430431
print_out_type arg
431432

432433
let out_label = ref print_out_label

typing/oprint.mli

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -18,7 +18,7 @@ open Outcometree
1818

1919
val out_ident : (formatter -> out_ident -> unit) ref
2020
val out_value : (formatter -> out_value -> unit) ref
21-
val out_label : (formatter -> string * bool * out_type -> unit) ref
21+
val out_label : (formatter -> string * bool * bool * out_type -> unit) ref
2222
val out_type : (formatter -> out_type -> unit) ref
2323
val out_constr :
2424
(formatter -> string * out_type list * out_type option -> unit) ref

typing/outcometree.mli

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -67,7 +67,7 @@ type out_type =
6767
| Otyp_constr of out_ident * out_type list
6868
| Otyp_manifest of out_type * out_type
6969
| Otyp_object of (string * out_type) list * bool option
70-
| Otyp_record of (string * bool * out_type) list
70+
| Otyp_record of (string * bool * bool * out_type) list
7171
| Otyp_stuff of string
7272
| Otyp_sum of (string * out_type list * out_type option) list
7373
| Otyp_tuple of out_type list

typing/printtyp.ml

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1334,7 +1334,8 @@ and tree_of_constructor cd =
13341334
(name, args, Some ret)
13351335

13361336
and tree_of_label l =
1337-
(Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp false l.ld_type)
1337+
(Ident.name l.ld_id, l.ld_mutable = Mutable, l.ld_nonlocal = Nonlocal,
1338+
tree_of_typexp false l.ld_type)
13381339

13391340
let constructor ppf c =
13401341
reset_except_context ();

typing/subst.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -262,6 +262,7 @@ let label_declaration copy_scope s l =
262262
{
263263
ld_id = l.ld_id;
264264
ld_mutable = l.ld_mutable;
265+
ld_nonlocal = l.ld_nonlocal;
265266
ld_type = typexp copy_scope s l.ld_type;
266267
ld_loc = loc s l.ld_loc;
267268
ld_attributes = attrs s l.ld_attributes;

0 commit comments

Comments
 (0)