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
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261 | ------------------------------------------------------------------------------
-- --
-- TGen --
-- --
-- Copyright (C) 2022, AdaCore --
-- --
-- TGen is free software; you can redistribute it and/or modify it under --
-- under terms of the GNU General Public License as published by the --
-- Free Software Foundation; either version 3, or (at your option) any --
-- later version. This software is distributed in the hope that it will be --
-- useful but WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are --
-- granted additional permissions described in the GCC Runtime Library --
-- Exception, version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and a --
-- copy of the GCC Runtime Library Exception along with this program; see --
-- the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
--
-- Type representation for type constraints and anonymous subtypes, along with
-- generation strategies
with Ada.Containers.Hashed_Maps;
with Ada.Strings.Unbounded.Hash;
with Ada.Unchecked_Deallocation;
with TGen.Strategies; use TGen.Strategies;
package TGen.Types.Constraints is
type Constraint is abstract tagged null record;
function Image (Self : Constraint) return String is abstract;
function Static (Self : Constraint) return Boolean is abstract;
-- Whether the constraints are suitable for static (single pass) generation
type Constraint_Acc is access all Constraint'Class;
procedure Free is new Ada.Unchecked_Deallocation
(Constraint'Class, Constraint_Acc);
type Constraint_Value_Kind is (Static, Non_Static, Discriminant);
-- Constraint kind. Discriminant means that the constraint value is the
-- value of one of the discriminants of the enclosing record type. Does not
-- make sense if the constraints are not applied to a component of a
-- discriminated record type.
type Discrete_Constraint_Value (Kind : Constraint_Value_Kind := Non_Static)
is record
case Kind is
when Static =>
Int_Val : Big_Int.Big_Integer;
-- The Static integer value of the constraint
when Non_Static =>
Text : Unbounded_String;
-- The textual representation of the constraint
when Discriminant =>
Disc_Name : Unbounded_String;
-- The defining name of the discriminant that appears in this
-- context.
end case;
end record;
-- A constraint value for a discrete type
subtype Real_Constraint_Value_Kind is
Constraint_Value_Kind range Static .. Non_Static;
type Real_Constraint_Value (Kind : Real_Constraint_Value_Kind := Non_Static)
is record
case Kind is
when Static =>
Real_Val : Big_Reals.Big_Real;
-- The static real value of the constraint
when Non_Static =>
Text : Unbounded_String;
-- Textual representation of the constraint
end case;
end record;
-- A constraint_Value for a real type
type Discrete_Range_Constraint is new Constraint with record
Low_Bound, High_Bound : Discrete_Constraint_Value;
end record;
-- A discrete range constraint. In case the range is not static, and the
-- range expression is not in the form Low_Bound .. High_Bound
-- (for instance a range attribute reference), then the low bound text is
-- left empty and the high bound text contains the text for the whole range
-- constraint. This is to avoid including text that is not present in
-- in the declaration of the type, which could be unuseable.
function Image (Self : Discrete_Range_Constraint) return String;
function Static (Self : Discrete_Range_Constraint) return Boolean is
(Self.Low_Bound.Kind in Static | Discriminant
and then Self.High_Bound.Kind in Static | Discriminant);
-- A discriminant constraint is considered as static because we get to
-- choose its value.
type Real_Range_Constraint is new Constraint with record
Low_Bound, High_Bound : Real_Constraint_Value;
end record;
-- A Real range constraint. In case the range is not static, and the
-- range expression is not in the form Low_Bound .. High_Bound
-- (for instance a range attribute reference), then the low bound text is
-- left empty and the high bound text contains the text for the whole range
-- constraint. This is to avoid including text that is not present in
-- in the declaration of the type, which could be unuseable.
function Image (Self : Real_Range_Constraint) return String;
function Static (Self : Real_Range_Constraint) return Boolean is
(Self.Low_Bound.Kind = Static and then Self.High_Bound.Kind = Static);
type Digits_Constraint (Has_Range : Boolean) is new Constraint
with record
Digits_Value : Discrete_Constraint_Value;
case Has_Range is
when True =>
Range_Value : Real_Range_Constraint;
when False =>
null;
end case;
end record;
-- Digits constraints for a real type. The range is optional.
function Image (Self : Digits_Constraint) return String;
function Static (Self : Digits_Constraint) return Boolean is
(Self.Digits_Value.Kind = Static
and then (if Self.Has_Range then Self.Range_Value.Static));
type Index_Constraint (Present : Boolean := False) is record
case Present is
when True =>
Discrete_Range : Discrete_Range_Constraint;
when others =>
null;
end case;
end record;
-- Constraints for one index of an array. If the constraints are static
-- then these contains the discrete range that constrain this index.
-- If absent is true, this means that the index is constrained on the whole
-- range of the index type. TODO: why can't we put the discrete range
-- constraint either way?
function Static (Self : Index_Constraint) return Boolean is
(if Self.Present then Self.Discrete_Range.Static);
type Index_Constraint_Arr is array (Positive range <>) of Index_Constraint;
type Index_Constraints (Num_Dims : Positive) is new Constraint with record
Constraint_Array : Index_Constraint_Arr (1 .. Num_Dims);
end record;
-- Constraints for a whole array, on constraint per dimension.
function Image (Self : Index_Constraints) return String;
function Static (Self : Index_Constraints) return Boolean is
(for all J in 1 .. Self.Num_Dims => Static (Self.Constraint_Array (J)));
package Discriminant_Constraint_Maps is new Ada.Containers.Hashed_Maps
(Key_Type => Unbounded_String,
Element_Type => Discrete_Constraint_Value,
Hash => Ada.Strings.Unbounded.Hash,
Equivalent_Keys => "=");
subtype Discriminant_Constraint_Map is Discriminant_Constraint_Maps.Map;
-- Maps to represent discriminant constraints. Each entry specifies the
-- value given to the discriminant of which the defining name is used as
-- key. For enumeration types used as discriminants, this is the 'Pos value
-- of the corresponding literal.
type Discriminant_Constraints is new Constraint with record
Constraint_Map : Discriminant_Constraint_Map;
end record;
-- Constraints for a discriminated record type, maps from discriminant
-- defining name to the value of the discriminant.
function Image (Self : Discriminant_Constraints) return String;
function Static (Self : Discriminant_Constraints) return Boolean is
(for all Val of Self.Constraint_Map => Val.Kind in Static | Discriminant);
type Anonymous_Typ is new Typ with record
Named_Ancestor : SP.Ref;
Subtype_Constraints : Constraint_Acc;
end record;
function Kind (Self : Anonymous_Typ) return Typ_Kind is (Anonymous_Kind);
function As_Anonymous_Typ (Self : SP.Ref) return Anonymous_Typ'Class is
(Anonymous_Typ'Class (Self.Unchecked_Get.all)) with
Pre => (not SP.Is_Null (Self))
and then (Self.Get.Kind in Anonymous_Kind);
pragma Inline (As_Anonymous_Typ);
function Image (Self : Anonymous_Typ) return String;
function As_Named_Typ (Self : Anonymous_Typ) return SP.Ref;
-- Return a copy of Self.Ancestor_Type but with the constraints applied
-- to it. The returned type will have the name of the ancestor.
-- This operation performs lots of map copies for record types so it may be
-- relatively slow.
function Supports_Static_Gen (Self : Anonymous_Typ) return Boolean is
(Self.Named_Ancestor.Get.Supports_Static_Gen
and then Self.Subtype_Constraints.Static);
-- Whether values for this Typ can be statically generated
function Encode (Self : Anonymous_Typ; Val : JSON_Value) return JSON_Value;
function Get_Diagnostics (Self : Anonymous_Typ) return String is
(Self.Named_Ancestor.Get.Get_Diagnostics);
overriding function Default_Strategy
(Self : Anonymous_Typ) return Strategy_Type'Class;
procedure Free_Content (Self : in out Anonymous_Typ);
function Supports_Gen (Self : Anonymous_Typ) return Boolean is
(Self.Named_Ancestor.Get.Supports_Gen);
type Instance_Typ is new Typ with record
Orig_Typ : SP.Ref;
end record;
-- Special type to handle strategy customization
function Kind (Self : Instance_Typ) return Typ_Kind is (Instance_Kind);
function As_Instance_Typ (Self : SP.Ref) return Instance_Typ'Class is
(Instance_Typ'Class (Self.Unchecked_Get.all)) with
Pre => (not SP.Is_Null (Self))
and then (Self.Get.Kind in Instance_Kind);
pragma Inline (As_Instance_Typ);
function Image (Self : Instance_Typ) return String;
function Supports_Static_Gen (Self : Instance_Typ) return Boolean is
(False);
-- Whether values for this Typ can be statically generated
function Get_Diagnostics (Self : Instance_Typ) return String is
(Self.Orig_Typ.Get.Get_Diagnostics);
function Supports_Gen (Self : Instance_Typ) return Boolean is
(Self.Orig_Typ.Get.Supports_Gen);
overriding function Default_Strategy
(Self : Instance_Typ) return Strategy_Type'Class
is (raise Program_Error);
end TGen.Types.Constraints;
|