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
|
(**************************************************************************)
(* *)
(* OCaml *)
(* *)
(* Gabriel Scherer, projet Picube, INRIA Paris *)
(* *)
(* Copyright 2024 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. *)
(* *)
(**************************************************************************)
open Asttypes
open Types
(* Constructor and record label descriptions inserted held in typing
environments *)
type constructor_description =
{ cstr_name: string; (* Constructor name *)
cstr_res: type_expr; (* Type of the result *)
cstr_existentials: type_expr list; (* list of existentials *)
cstr_args: type_expr list; (* Type of the arguments *)
cstr_arity: int; (* Number of arguments *)
cstr_tag: constructor_tag; (* Tag for heap blocks *)
cstr_consts: int; (* Number of constant constructors *)
cstr_nonconsts: int; (* Number of non-const constructors *)
cstr_generalized: bool; (* Constrained return type? *)
cstr_private: private_flag; (* Read-only constructor? *)
cstr_loc: Location.t;
cstr_attributes: Parsetree.attributes;
cstr_inlined: type_declaration option;
cstr_uid: Uid.t;
}
and constructor_tag =
Cstr_constant of int (* Constant constructor (an int) *)
| Cstr_block of int (* Regular constructor (a block) *)
| Cstr_unboxed (* Constructor of an unboxed type *)
| Cstr_extension of Path.t * bool (* Extension constructor
true if a constant false if a block*)
let equal_tag t1 t2 =
match (t1, t2) with
| Cstr_constant i1, Cstr_constant i2 -> i2 = i1
| Cstr_block i1, Cstr_block i2 -> i2 = i1
| Cstr_unboxed, Cstr_unboxed -> true
| Cstr_extension (path1, _), Cstr_extension (path2, _) ->
Path.same path1 path2
| (Cstr_constant _|Cstr_block _|Cstr_unboxed|Cstr_extension _), _ -> false
let equal_constr c1 c2 =
equal_tag c1.cstr_tag c2.cstr_tag
let may_equal_constr c1 c2 =
c1.cstr_arity = c2.cstr_arity
&& (match c1.cstr_tag,c2.cstr_tag with
| Cstr_extension _,Cstr_extension _ ->
(* extension constructors may be rebindings of each other *)
true
| tag1, tag2 ->
equal_tag tag1 tag2)
let cstr_res_type_path cstr =
match get_desc cstr.cstr_res with
| Tconstr (p, _, _) -> p
| _ -> assert false
type label_description =
{ lbl_name: string; (* Short name *)
lbl_res: type_expr; (* Type of the result (the record) *)
lbl_arg: type_expr; (* Type of the argument
(the field value) *)
lbl_mut: mutable_flag; (* Is this a mutable field? *)
lbl_atomic: atomic_flag; (* Is this an atomic field? *)
lbl_pos: int; (* Position in block *)
lbl_all: label_description array; (* All the labels in this type *)
lbl_repres: record_representation; (* Representation for this record *)
lbl_private: private_flag; (* Read-only field? *)
lbl_loc: Location.t;
lbl_attributes: Parsetree.attributes;
lbl_uid: Uid.t;
}
let lbl_res_type_path lbl =
match get_desc lbl.lbl_res with
| Tconstr (p, _, _) -> p
| _ -> assert false
|
