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
|
(***********************************************************************)
(* *)
(* Objective Caml *)
(* *)
(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 1996 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
(* $Id$ *)
(* Compute constructor and label descriptions from type declarations,
determining their representation. *)
open Misc
open Asttypes
open Types
let constructor_descrs ty_res cstrs =
let num_consts = ref 0 and num_nonconsts = ref 0 in
List.iter
(function (name, []) -> incr num_consts
| (name, _) -> incr num_nonconsts)
cstrs;
let rec describe_constructors idx_const idx_nonconst = function
[] -> []
| (name, ty_args) :: rem ->
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 cstr =
{ cstr_res = ty_res;
cstr_args = ty_args;
cstr_arity = List.length ty_args;
cstr_tag = tag;
cstr_consts = !num_consts;
cstr_nonconsts = !num_nonconsts } in
(name, cstr) :: descr_rem in
describe_constructors 0 0 cstrs
let exception_descr path_exc decl =
{ cstr_res = Predef.type_exn;
cstr_args = decl;
cstr_arity = List.length decl;
cstr_tag = Cstr_exception path_exc;
cstr_consts = -1;
cstr_nonconsts = -1 }
let none = {desc = Ttuple []; level = -1; id = -1}
(* Clearly ill-formed type *)
let dummy_label =
{ lbl_res = none; lbl_arg = none; lbl_mut = Immutable;
lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular }
(* Cannot call ctype.repres here *)
let rec is_float =
function
{desc = Tlink ty} -> is_float ty
| {desc = Tconstr(p, _, _)} -> Path.same p Predef.path_float
| _ -> false
let label_descrs ty_res lbls =
let all_labels = Array.create (List.length lbls) dummy_label in
let repres =
if List.for_all (fun (name, flag, ty) -> is_float ty) lbls
then Record_float
else Record_regular in
let rec describe_labels num = function
[] -> []
| (name, mut_flag, ty_arg) :: rest ->
let lbl =
{ lbl_res = ty_res;
lbl_arg = ty_arg;
lbl_mut = mut_flag;
lbl_pos = num;
lbl_all = all_labels;
lbl_repres = repres } 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) :: rem ->
if tag = Cstr_constant num_const
then cstr
else find_constr tag (num_const + 1) num_nonconst rem
| (name, _ as cstr) :: rem ->
if tag = Cstr_block num_nonconst
then cstr
else find_constr tag num_const (num_nonconst + 1) rem
let find_constr_by_tag tag cstrlist =
find_constr tag 0 0 cstrlist
|
