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