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
|
(***********************************************************************)
(* *)
(* 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 Q Public License version 1.0. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* 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 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 loop row.row_more
| _ ->
iter_type_expr loop ty
end
in
loop ty;
unmark_type ty;
!ret
let constructor_descrs ty_res cstrs priv =
let num_consts = ref 0 and num_nonconsts = ref 0 and num_normal = ref 0 in
List.iter
(fun (name, args, ret) ->
if args = [] then incr num_consts else incr num_nonconsts;
if ret = None then incr num_normal)
cstrs;
let rec describe_constructors idx_const idx_nonconst = function
[] -> []
| (name, ty_args, ty_res_opt) :: rem ->
let ty_res =
match ty_res_opt with
| Some ty_res' -> ty_res'
| None -> ty_res
in
let (tag, descr_rem) =
match ty_args with
[] -> (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 existentials =
match ty_res_opt with
| None -> []
| Some type_ret ->
let res_vars = free_vars type_ret in
let arg_vars = free_vars (newgenty (Ttuple ty_args)) in
TypeSet.elements (TypeSet.diff arg_vars res_vars)
in
let cstr =
{ cstr_res = ty_res;
cstr_existentials = existentials;
cstr_args = ty_args;
cstr_arity = List.length ty_args;
cstr_tag = tag;
cstr_consts = !num_consts;
cstr_nonconsts = !num_nonconsts;
cstr_normal = !num_normal;
cstr_private = priv;
cstr_generalized = ty_res_opt <> None
} in
(name, cstr) :: descr_rem in
describe_constructors 0 0 cstrs
let exception_descr path_exc decl =
{ cstr_res = Predef.type_exn;
cstr_existentials = [];
cstr_args = decl.exn_args;
cstr_arity = List.length decl.exn_args;
cstr_tag = Cstr_exception (path_exc, decl.exn_loc);
cstr_consts = -1;
cstr_nonconsts = -1;
cstr_private = Public;
cstr_normal = -1;
cstr_generalized = false }
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 }
let label_descrs ty_res lbls repres priv =
let all_labels = Array.create (List.length lbls) dummy_label in
let rec describe_labels num = function
[] -> []
| (name, mut_flag, ty_arg) :: rest ->
let lbl =
{ lbl_name = Ident.name name;
lbl_res = ty_res;
lbl_arg = ty_arg;
lbl_mut = mut_flag;
lbl_pos = num;
lbl_all = all_labels;
lbl_repres = repres;
lbl_private = priv } in
all_labels.(num) <- lbl;
(name, 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
| (name, ([] as cstr),(_ as ret_type_opt)) :: rem ->
if tag = Cstr_constant num_const
then (name,cstr,ret_type_opt)
else find_constr tag (num_const + 1) num_nonconst rem
| (name, (_ as cstr),(_ as ret_type_opt)) :: rem ->
if tag = Cstr_block num_nonconst
then (name,cstr,ret_type_opt)
else find_constr tag num_const (num_nonconst + 1) rem
let find_constr_by_tag tag cstrlist =
find_constr tag 0 0 cstrlist
|