1(**************************************************************************) 2(* *) 3(* OCaml *) 4(* *) 5(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) 6(* *) 7(* Copyright 1996 Institut National de Recherche en Informatique et *) 8(* en Automatique. *) 9(* *) 10(* All rights reserved. This file is distributed under the terms of *) 11(* the GNU Lesser General Public License version 2.1, with the *) 12(* special exception on linking described in the file LICENSE. *) 13(* *) 14(**************************************************************************) 15 16(* Compute constructor and label descriptions from type declarations, 17 determining their representation. *) 18 19open Asttypes 20open Types 21open Btype 22 23(* Simplified version of Ctype.free_vars *) 24let free_vars ?(param=false) ty = 25 let ret = ref TypeSet.empty in 26 let rec loop ty = 27 let ty = repr ty in 28 if ty.level >= lowest_level then begin 29 ty.level <- pivot_level - ty.level; 30 match ty.desc with 31 | Tvar _ -> 32 ret := TypeSet.add ty !ret 33 | Tvariant row -> 34 let row = row_repr row in 35 iter_row loop row; 36 if not (static_row row) then begin 37 match row.row_more.desc with 38 | Tvar _ when param -> ret := TypeSet.add ty !ret 39 | _ -> loop row.row_more 40 end 41 (* XXX: What about Tobject ? *) 42 | _ -> 43 iter_type_expr loop ty 44 end 45 in 46 loop ty; 47 unmark_type ty; 48 !ret 49 50let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil)) 51 52let constructor_existentials cd_args cd_res = 53 let tyl = 54 match cd_args with 55 | Cstr_tuple l -> l 56 | Cstr_record l -> List.map (fun l -> l.ld_type) l 57 in 58 let existentials = 59 match cd_res with 60 | None -> [] 61 | Some type_ret -> 62 let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in 63 let res_vars = free_vars type_ret in 64 TypeSet.elements (TypeSet.diff arg_vars_set res_vars) 65 in 66 (tyl, existentials) 67 68let constructor_args priv cd_args cd_res path rep = 69 let tyl, existentials = constructor_existentials cd_args cd_res in 70 match cd_args with 71 | Cstr_tuple l -> existentials, l, None 72 | Cstr_record lbls -> 73 let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in 74 let type_params = TypeSet.elements arg_vars_set in 75 let type_unboxed = 76 match rep with 77 | Record_unboxed _ -> unboxed_true_default_false 78 | _ -> unboxed_false_default_false 79 in 80 let tdecl = 81 { 82 type_params; 83 type_arity = List.length type_params; 84 type_kind = Type_record (lbls, rep); 85 type_private = priv; 86 type_manifest = None; 87 type_variance = List.map (fun _ -> Variance.full) type_params; 88 type_newtype_level = None; 89 type_loc = Location.none; 90 type_attributes = []; 91 type_immediate = false; 92 type_unboxed; 93 } 94 in 95 existentials, 96 [ newgenconstr path type_params ], 97 Some tdecl 98 99let constructor_descrs ty_path decl cstrs = 100 let ty_res = newgenconstr ty_path decl.type_params in 101 let num_consts = ref 0 and num_nonconsts = ref 0 and num_normal = ref 0 in 102 List.iter 103 (fun {cd_args; cd_res; _} -> 104 if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts; 105 if cd_res = None then incr num_normal) 106 cstrs; 107 let rec describe_constructors idx_const idx_nonconst = function 108 [] -> [] 109 | {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem -> 110 let ty_res = 111 match cd_res with 112 | Some ty_res' -> ty_res' 113 | None -> ty_res 114 in 115 let (tag, descr_rem) = 116 match cd_args with 117 | _ when decl.type_unboxed.unboxed -> 118 assert (rem = []); 119 (Cstr_unboxed, []) 120 | Cstr_tuple [] -> (Cstr_constant idx_const, 121 describe_constructors (idx_const+1) idx_nonconst rem) 122 | _ -> (Cstr_block idx_nonconst, 123 describe_constructors idx_const (idx_nonconst+1) rem) in 124 let cstr_name = Ident.name cd_id in 125 let existentials, cstr_args, cstr_inlined = 126 let representation = 127 if decl.type_unboxed.unboxed 128 then Record_unboxed true 129 else Record_inlined idx_nonconst 130 in 131 constructor_args decl.type_private cd_args cd_res 132 (Path.Pdot (ty_path, cstr_name, Path.nopos)) representation 133 in 134 let cstr = 135 { cstr_name; 136 cstr_res = ty_res; 137 cstr_existentials = existentials; 138 cstr_args; 139 cstr_arity = List.length cstr_args; 140 cstr_tag = tag; 141 cstr_consts = !num_consts; 142 cstr_nonconsts = !num_nonconsts; 143 cstr_normal = !num_normal; 144 cstr_private = decl.type_private; 145 cstr_generalized = cd_res <> None; 146 cstr_loc = cd_loc; 147 cstr_attributes = cd_attributes; 148 cstr_inlined; 149 } in 150 (cd_id, cstr) :: descr_rem in 151 describe_constructors 0 0 cstrs 152 153let extension_descr path_ext ext = 154 let ty_res = 155 match ext.ext_ret_type with 156 Some type_ret -> type_ret 157 | None -> newgenconstr ext.ext_type_path ext.ext_type_params 158 in 159 let existentials, cstr_args, cstr_inlined = 160 constructor_args ext.ext_private ext.ext_args ext.ext_ret_type 161 path_ext Record_extension 162 in 163 { cstr_name = Path.last path_ext; 164 cstr_res = ty_res; 165 cstr_existentials = existentials; 166 cstr_args; 167 cstr_arity = List.length cstr_args; 168 cstr_tag = Cstr_extension(path_ext, cstr_args = []); 169 cstr_consts = -1; 170 cstr_nonconsts = -1; 171 cstr_private = ext.ext_private; 172 cstr_normal = -1; 173 cstr_generalized = ext.ext_ret_type <> None; 174 cstr_loc = ext.ext_loc; 175 cstr_attributes = ext.ext_attributes; 176 cstr_inlined; 177 } 178 179let none = {desc = Ttuple []; level = -1; id = -1} 180 (* Clearly ill-formed type *) 181let dummy_label = 182 { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; 183 lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular; 184 lbl_private = Public; 185 lbl_loc = Location.none; 186 lbl_attributes = []; 187 } 188 189let label_descrs ty_res lbls repres priv = 190 let all_labels = Array.make (List.length lbls) dummy_label in 191 let rec describe_labels num = function 192 [] -> [] 193 | l :: rest -> 194 let lbl = 195 { lbl_name = Ident.name l.ld_id; 196 lbl_res = ty_res; 197 lbl_arg = l.ld_type; 198 lbl_mut = l.ld_mutable; 199 lbl_pos = num; 200 lbl_all = all_labels; 201 lbl_repres = repres; 202 lbl_private = priv; 203 lbl_loc = l.ld_loc; 204 lbl_attributes = l.ld_attributes; 205 } in 206 all_labels.(num) <- lbl; 207 (l.ld_id, lbl) :: describe_labels (num+1) rest in 208 describe_labels 0 lbls 209 210exception Constr_not_found 211 212let rec find_constr tag num_const num_nonconst = function 213 [] -> 214 raise Constr_not_found 215 | {cd_args = Cstr_tuple []; _} as c :: rem -> 216 if tag = Cstr_constant num_const 217 then c 218 else find_constr tag (num_const + 1) num_nonconst rem 219 | c :: rem -> 220 if tag = Cstr_block num_nonconst || tag = Cstr_unboxed 221 then c 222 else find_constr tag num_const (num_nonconst + 1) rem 223 224let find_constr_by_tag tag cstrlist = 225 find_constr tag 0 0 cstrlist 226 227let constructors_of_type ty_path decl = 228 match decl.type_kind with 229 | Type_variant cstrs -> constructor_descrs ty_path decl cstrs 230 | Type_record _ | Type_abstract | Type_open -> [] 231 232let labels_of_type ty_path decl = 233 match decl.type_kind with 234 | Type_record(labels, rep) -> 235 label_descrs (newgenconstr ty_path decl.type_params) 236 labels rep decl.type_private 237 | Type_variant _ | Type_abstract | Type_open -> [] 238