ocaml/typing/datarepr.ml

259 lines
9.0 KiB
OCaml

(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* en Automatique. *)
(* *)
(* All rights reserved. This file is distributed under the terms of *)
(* the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(* Compute constructor and label descriptions from type declarations,
determining their representation. *)
open Asttypes
open Types
open Btype
(* Simplified version of Ctype.free_vars *)
let free_vars ?(param=false) ty =
let ret = ref TypeSet.empty in
let rec loop ty =
let ty = repr ty in
if ty.level >= lowest_level then begin
ty.level <- pivot_level - ty.level;
match ty.desc with
| Tvar _ ->
ret := TypeSet.add ty !ret
| Tvariant row ->
let row = row_repr row in
iter_row loop row;
if not (static_row row) then begin
match row.row_more.desc with
| Tvar _ when param -> ret := TypeSet.add ty !ret
| _ -> loop row.row_more
end
(* XXX: What about Tobject ? *)
| _ ->
iter_type_expr loop ty
end
in
loop ty;
unmark_type ty;
!ret
let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil))
let constructor_existentials cd_args cd_res =
let tyl =
match cd_args with
| Cstr_tuple l -> l
| Cstr_record l -> List.map (fun l -> l.ld_type) l
in
let existentials =
match cd_res with
| None -> []
| Some type_ret ->
let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in
let res_vars = free_vars type_ret in
TypeSet.elements (TypeSet.diff arg_vars_set res_vars)
in
(tyl, existentials)
let constructor_args ~current_unit priv cd_args cd_res path rep =
let tyl, existentials = constructor_existentials cd_args cd_res in
match cd_args with
| Cstr_tuple l -> existentials, l, None
| Cstr_record lbls ->
let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in
let type_params = TypeSet.elements arg_vars_set in
let type_unboxed =
match rep with
| Record_unboxed _ -> unboxed_true_default_false
| _ -> unboxed_false_default_false
in
let arity = List.length type_params in
let tdecl =
{
type_params;
type_arity = arity;
type_kind = Type_record (lbls, rep);
type_private = priv;
type_manifest = None;
type_variance = Variance.unknown_signature ~arity;
type_separability = Types.Separability.default_signature ~arity;
type_is_newtype = false;
type_expansion_scope = Btype.lowest_level;
type_loc = Location.none;
type_attributes = [];
type_immediate = Unknown;
type_unboxed;
type_uid = Uid.mk ~current_unit;
}
in
existentials,
[ newgenconstr path type_params ],
Some tdecl
let constructor_descrs ~current_unit ty_path decl cstrs =
let ty_res = newgenconstr ty_path decl.type_params in
let num_consts = ref 0 and num_nonconsts = ref 0 and num_normal = ref 0 in
List.iter
(fun {cd_args; cd_res; _} ->
if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts;
if cd_res = None then incr num_normal)
cstrs;
let rec describe_constructors idx_const idx_nonconst = function
[] -> []
| {cd_id; cd_args; cd_res; cd_loc; cd_attributes; cd_uid} :: rem ->
let ty_res =
match cd_res with
| Some ty_res' -> ty_res'
| None -> ty_res
in
let (tag, descr_rem) =
match cd_args with
| _ when decl.type_unboxed.unboxed ->
assert (rem = []);
(Cstr_unboxed, [])
| Cstr_tuple [] -> (Cstr_constant idx_const,
describe_constructors (idx_const+1) idx_nonconst rem)
| _ -> (Cstr_block idx_nonconst,
describe_constructors idx_const (idx_nonconst+1) rem) in
let cstr_name = Ident.name cd_id in
let existentials, cstr_args, cstr_inlined =
let representation =
if decl.type_unboxed.unboxed
then Record_unboxed true
else Record_inlined idx_nonconst
in
constructor_args ~current_unit decl.type_private cd_args cd_res
(Path.Pdot (ty_path, cstr_name)) representation
in
let cstr =
{ cstr_name;
cstr_res = ty_res;
cstr_existentials = existentials;
cstr_args;
cstr_arity = List.length cstr_args;
cstr_tag = tag;
cstr_consts = !num_consts;
cstr_nonconsts = !num_nonconsts;
cstr_normal = !num_normal;
cstr_private = decl.type_private;
cstr_generalized = cd_res <> None;
cstr_loc = cd_loc;
cstr_attributes = cd_attributes;
cstr_inlined;
cstr_uid = cd_uid;
} in
(cd_id, cstr) :: descr_rem in
describe_constructors 0 0 cstrs
let extension_descr ~current_unit path_ext ext =
let ty_res =
match ext.ext_ret_type with
Some type_ret -> type_ret
| None -> newgenconstr ext.ext_type_path ext.ext_type_params
in
let existentials, cstr_args, cstr_inlined =
constructor_args ~current_unit ext.ext_private ext.ext_args ext.ext_ret_type
path_ext (Record_extension path_ext)
in
{ cstr_name = Path.last path_ext;
cstr_res = ty_res;
cstr_existentials = existentials;
cstr_args;
cstr_arity = List.length cstr_args;
cstr_tag = Cstr_extension(path_ext, cstr_args = []);
cstr_consts = -1;
cstr_nonconsts = -1;
cstr_private = ext.ext_private;
cstr_normal = -1;
cstr_generalized = ext.ext_ret_type <> None;
cstr_loc = ext.ext_loc;
cstr_attributes = ext.ext_attributes;
cstr_inlined;
cstr_uid = ext.ext_uid;
}
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_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular;
lbl_private = Public;
lbl_loc = Location.none;
lbl_attributes = [];
lbl_uid = Uid.internal_not_actually_unique;
}
let label_descrs ty_res lbls repres priv =
let all_labels = Array.make (List.length lbls) dummy_label in
let rec describe_labels num = function
[] -> []
| l :: rest ->
let lbl =
{ lbl_name = Ident.name l.ld_id;
lbl_res = ty_res;
lbl_arg = l.ld_type;
lbl_mut = l.ld_mutable;
lbl_pos = num;
lbl_all = all_labels;
lbl_repres = repres;
lbl_private = priv;
lbl_loc = l.ld_loc;
lbl_attributes = l.ld_attributes;
lbl_uid = l.ld_uid;
} in
all_labels.(num) <- lbl;
(l.ld_id, lbl) :: describe_labels (num+1) rest in
describe_labels 0 lbls
exception Constr_not_found
let rec find_constr tag num_const num_nonconst = function
[] ->
raise Constr_not_found
| {cd_args = Cstr_tuple []; _} as c :: rem ->
if tag = Cstr_constant num_const
then c
else find_constr tag (num_const + 1) num_nonconst rem
| c :: rem ->
if tag = Cstr_block num_nonconst || tag = Cstr_unboxed
then c
else find_constr tag num_const (num_nonconst + 1) rem
let find_constr_by_tag tag cstrlist =
find_constr tag 0 0 cstrlist
let constructors_of_type ~current_unit ty_path decl =
match decl.type_kind with
| Type_variant cstrs -> constructor_descrs ~current_unit ty_path decl cstrs
| Type_record _ | Type_abstract | Type_open -> []
let labels_of_type ty_path decl =
match decl.type_kind with
| Type_record(labels, rep) ->
label_descrs (newgenconstr ty_path decl.type_params)
labels rep decl.type_private
| Type_variant _ | Type_abstract | Type_open -> []
(* Set row_name in Env, cf. GPR#1204/1329 *)
let set_row_name decl path =
match decl.type_manifest with
None -> ()
| Some ty ->
let ty = repr ty in
match ty.desc with
Tvariant row when static_row row ->
let row = {(row_repr row) with
row_name = Some (path, decl.type_params)} in
ty.desc <- Tvariant row
| _ -> ()