1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237
|
(**************************************************************************)
(* *)
(* 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 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 tdecl =
{
type_params;
type_arity = List.length type_params;
type_kind = Type_record (lbls, rep);
type_private = priv;
type_manifest = None;
type_variance = List.map (fun _ -> Variance.full) type_params;
type_newtype_level = None;
type_loc = Location.none;
type_attributes = [];
type_immediate = false;
type_unboxed;
}
in
existentials,
[ newgenconstr path type_params ],
Some tdecl
let constructor_descrs 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} :: 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 decl.type_private cd_args cd_res
(Path.Pdot (ty_path, cstr_name, Path.nopos)) 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;
} in
(cd_id, cstr) :: descr_rem in
describe_constructors 0 0 cstrs
let extension_descr 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 ext.ext_private ext.ext_args ext.ext_ret_type
path_ext Record_extension
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;
}
let none = {desc = Ttuple []; level = -1; 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 = [];
}
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;
} 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 ty_path decl =
match decl.type_kind with
| Type_variant cstrs -> constructor_descrs 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 -> []
|