Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Change Texp_record contents to ease the use 

It also allows to recover the type of kept fields in a
{ record with field = expr } expression
master
Pierre Chambart 2016-03-17 23:15:08 +01:00
parent 140552168b
commit 3f00684169
11 changed files with 135 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
bytecomp/translcore.ml
View File

@ -864,12 +864,10 @@ and transl_exp0 e =
Lprim(Pmakeblock(0, Immutable, None),
[Lconst(Const_base(Const_int tag)); lam], e.exp_loc)
end
| Texp_record ((_, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) ->
| Texp_record (label_definitions, label_descriptions, repr, opt_init_expr) ->
transl_record e.exp_loc e.exp_env
lbl1.lbl_all lbl1.lbl_repres lbl_expr_list
label_descriptions repr label_definitions
opt_init_expr
| Texp_record ([], _) ->
fatal_error "Translcore.transl_exp: bad Texp_record"
| Texp_field(arg, _, lbl) ->
let access =
match lbl.lbl_repres with
@ -1262,8 +1260,16 @@ and transl_setinstvar loc self var expr =
in
Lprim(Parraysetu prim, [self; transl_normal_path var; transl_exp expr], loc)
and transl_record loc env all_labels repres lbl_expr_list opt_init_expr =
and transl_record loc env all_labels repres lbl_definitions opt_init_expr =
let size = Array.length all_labels in
let _, lbl_expr_list =
Array.fold_left (fun (i, l) -> function
| Kept _ ->
succ i, l
| Overridden (lid, exp) ->
succ i, (lid, all_labels.(i), exp) :: l)
(0, []) lbl_definitions
in
(* Determine if there are "enough" fields (only relevant if this is a
functional-style record update *)
let no_init = match opt_init_expr with None -> true | _ -> false in

23
typing/printtyped.ml
View File

@ -121,6 +121,16 @@ let list i f ppf l =
line i ppf "]\n";
;;
let array i f ppf a =
if Array.length a = 0 then
line i ppf "[]\n"
else begin
line i ppf "[\n";
Array.iter (f (i+1) ppf) a;
line i ppf "]\n"
end
;;
let option i f ppf x =
match x with
| None -> line i ppf "None\n";
@ -313,9 +323,9 @@ and expression i ppf x =
| Texp_variant (l, eo) ->
line i ppf "Texp_variant \"%s\"\n" l;
option i expression ppf eo;
| Texp_record (l, eo) ->
| Texp_record (l, _, _, eo) ->
line i ppf "Texp_record\n";
list i longident_x_expression ppf l;
array i record_field ppf l;
option i expression ppf eo;
| Texp_field (e, li, _) ->
line i ppf "Texp_field\n";
@ -827,9 +837,12 @@ and string_x_expression i ppf (s, _, e) =
line i ppf "<override> \"%a\"\n" fmt_path s;
expression (i+1) ppf e;
and longident_x_expression i ppf (li, _, e) =
line i ppf "%a\n" fmt_longident li;
expression (i+1) ppf e;
and record_field i ppf = function
| Overridden (li, e) ->
line i ppf "%a\n" fmt_longident li;
expression (i+1) ppf e;
| Kept _ ->
line i ppf "<kept>"
and label_x_expression i ppf (l, e) =
line i ppf "<arg>\n";

10
typing/tast_mapper.ml
View File

@ -255,9 +255,15 @@ let expr sub x =
Texp_construct (lid, cd, List.map (sub.expr sub) args)
| Texp_variant (l, expo) ->
Texp_variant (l, opt (sub.expr sub) expo)
| Texp_record (list, expo) ->
| Texp_record (fields, labels, repr, expo) ->
let fields = Array.map (function
| Kept t -> Kept t
| Overridden (lid, exp) ->
Overridden (lid, sub.expr sub exp))
fields
in
Texp_record (
List.map (tuple3 id id (sub.expr sub)) list,
fields, labels, repr,
opt (sub.expr sub) expo
)
| Texp_field (exp, lid, ld) ->

70
typing/typecore.ml
View File

@ -1573,10 +1573,14 @@ let rec is_nonexpansive exp =
| Texp_construct( _, _, el) ->
List.for_all is_nonexpansive el
| Texp_variant(_, arg) -> is_nonexpansive_opt arg
| Texp_record(lbl_exp_list, opt_init_exp) ->
List.for_all
(fun (_, lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp)
lbl_exp_list
| Texp_record (lbl_definitions, lbl_descriptions, _, opt_init_exp) ->
Misc.array_for_all2
(fun definition lbl ->
match definition with
| Overridden (_, exp) ->
lbl.lbl_mut = Immutable && is_nonexpansive exp
| Kept _ -> true)
lbl_definitions lbl_descriptions
&& is_nonexpansive_opt opt_init_exp
| Texp_field(exp, _, _) -> is_nonexpansive exp
| Texp_array [] -> true
@ -2278,26 +2282,43 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
| [] -> ()
in
check_duplicates lbl_exp_list;
let opt_exp =
match opt_exp, lbl_exp_list with
None, _ -> None
| Some exp, (_lid, lbl, _lbl_exp) :: _ ->
let opt_exp, label_definitions =
let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in
match opt_exp with
None ->
let label_definitions =
Array.map (fun lbl ->
let (lid, _lbl, lbl_exp) =
List.find
(fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos)
lbl_exp_list
in
Overridden (lid, lbl_exp))
lbl.lbl_all
in
None, label_definitions
| Some exp ->
let ty_exp = instance env exp.exp_type in
let unify_kept lbl =
(* do not connect overridden labels *)
if List.for_all
(fun (_, lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
match
List.find
(fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos)
lbl_exp_list
then begin
let _, ty_arg1, ty_res1 = instance_label false lbl
and _, ty_arg2, ty_res2 = instance_label false lbl in
unify env ty_arg1 ty_arg2;
unify env (instance env ty_expected) ty_res2;
unify_exp_types exp.exp_loc env ty_exp ty_res1;
end in
Array.iter unify_kept lbl.lbl_all;
Some {exp with exp_type = ty_exp}
| _ -> assert false
with
| lid, _lbl, lbl_exp ->
Overridden (lid, lbl_exp)
| exception Not_found -> begin
(* do not connect overridden labels *)
let _, ty_arg1, ty_res1 = instance_label false lbl
and _, ty_arg2, ty_res2 = instance_label false lbl in
unify env ty_arg1 ty_arg2;
unify env (instance env ty_expected) ty_res2;
unify_exp_types exp.exp_loc env ty_exp ty_res1;
Kept ty_arg1
end
in
let label_definitions = Array.map unify_kept lbl.lbl_all in
Some {exp with exp_type = ty_exp}, label_definitions
in
let num_fields =
match lbl_exp_list with [] -> assert false
@ -2317,8 +2338,13 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
end
else if opt_sexp <> None && List.length lid_sexp_list = num_fields then
Location.prerr_warning loc Warnings.Useless_record_with;
let label_descriptions, record_representation =
let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in
lbl_all, lbl_repres
in
re {
exp_desc = Texp_record(lbl_exp_list, opt_exp);
exp_desc = Texp_record(label_definitions, label_descriptions,
record_representation, opt_exp);
exp_loc = loc; exp_extra = [];
exp_type = instance env ty_expected;
exp_attributes = sexp.pexp_attributes;

8
typing/typedtree.ml
View File

@ -86,8 +86,8 @@ and expression_desc =
Longident.t loc * constructor_description * expression list
| Texp_variant of label * expression option
| Texp_record of
(Longident.t loc * label_description * expression) list *
expression option
record_label_definition array * Types.label_description array *
Types.record_representation * expression option
| Texp_field of expression * Longident.t loc * label_description
| Texp_setfield of
expression * Longident.t loc * label_description * expression
@ -123,6 +123,10 @@ and case =
c_rhs: expression;
}
and record_label_definition =
| Kept of Types.type_expr
| Overridden of Longident.t loc * expression
(* Value expressions for the class language *)
and class_expr =

13
typing/typedtree.mli
View File

@ -187,8 +187,13 @@ and expression_desc =
*)
| Texp_variant of label * expression option
| Texp_record of
(Longident.t loc * label_description * expression) list *
expression option
record_label_definition array * Types.label_description array *
Types.record_representation * expression option
(** { l1=P1; ...; ln=Pn } (None)
{ E0 with l1=P1; ...; ln=Pn } (Some E0)
Invariant: n > 0
*)
| Texp_field of expression * Longident.t loc * label_description
| Texp_setfield of
expression * Longident.t loc * label_description * expression
@ -224,6 +229,10 @@ and case =
c_rhs: expression;
}
and record_label_definition =
| Kept of Types.type_expr
| Overridden of Longident.t loc * expression
(* Value expressions for the class language *)
and class_expr =

7
typing/typedtreeIter.ml
View File

@ -295,8 +295,11 @@ module MakeIterator(Iter : IteratorArgument) : sig
None -> ()
| Some exp -> iter_expression exp
end
| Texp_record (list, expo) ->
List.iter (fun (_, _, exp) -> iter_expression exp) list;
| Texp_record (fields, _, _, expo) ->
Array.iter (function
| Kept _ -> ()
| Overridden (_, exp) -> iter_expression exp)
fields;
begin match expo with
None -> ()
| Some exp -> iter_expression exp

15
typing/typedtreeMap.ml
View File

@ -306,16 +306,19 @@ module MakeMap(Map : MapArgument) = struct
| Some exp -> Some (map_expression exp)
in
Texp_variant (label, expo)
| Texp_record (list, expo) ->
let list =
List.map (fun (lid, lab_desc, exp) ->
(lid, lab_desc, map_expression exp)
) list in
| Texp_record (fields, labels, repr, expo) ->
let fields =
Array.map (function
| Kept t -> Kept t
| Overridden (lid, exp) ->
Overridden (lid, map_expression exp))
fields
in
let expo = match expo with
None -> expo
| Some exp -> Some (map_expression exp)
in
Texp_record (list, expo)
Texp_record (fields, labels, repr, expo)
| Texp_field (exp, lid, label) ->
Texp_field (map_expression exp, lid, label)
| Texp_setfield (exp1, lid, label, exp2) ->

12
typing/untypeast.ml
View File

@ -410,11 +410,13 @@ let expression sub exp =
))
| Texp_variant (label, expo) ->
Pexp_variant (label, map_opt (sub.expr sub) expo)
| Texp_record (list, expo) ->
Pexp_record (List.map (fun (lid, _, exp) ->
(map_loc sub lid, sub.expr sub exp)
) list,
map_opt (sub.expr sub) expo)
| Texp_record (fields, _labels, _repr, expo) ->
let list = Array.fold_left (fun l -> function
| Kept _ -> l
| Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l)
[] fields
in
Pexp_record (list, map_opt (sub.expr sub) expo)
| Texp_field (exp, lid, _label) ->
Pexp_field (sub.expr sub exp, map_loc sub lid)
| Texp_setfield (exp1, lid, _label, exp2) ->

9
utils/misc.ml
View File

@ -73,6 +73,15 @@ let rec split_last = function
let (lst, last) = split_last tl in
(hd :: lst, last)
let array_for_all2 p a1 a2 =
if Array.length a1 <> Array.length a2 then
invalid_arg "Misc.array_for_all2";
let rec loop i =
if i = Array.length a1 then true
else if p a1.(i) a2.(i) then loop (succ i)
else false in
loop 0
module Stdlib = struct
module List = struct
type 'a t = 'a list

3
utils/misc.mli
View File

@ -40,6 +40,9 @@ val split_last: 'a list -> 'a list * 'a
val may: ('a -> unit) -> 'a option -> unit
val may_map: ('a -> 'b) -> 'a option -> 'b option
val array_for_all2: ('a -> 'b -> bool) -> 'a array -> 'b array -> bool
(* Fails if the two arrays have different sizes *)
type ref_and_value = R : 'a ref * 'a -> ref_and_value
val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a