]>
Commit | Line | Data |
---|---|---|
996ae0b0 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S E M _ R E S -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
7a71a7c4 | 9 | -- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- |
996ae0b0 RK |
10 | -- -- |
11 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
996ae0b0 RK |
14 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
15 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
16 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
17 | -- for more details. You should have received a copy of the GNU General -- | |
b5c84c3c RD |
18 | -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
19 | -- http://www.gnu.org/licenses for a complete copy of the license. -- | |
996ae0b0 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
996ae0b0 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
26 | with Atree; use Atree; | |
27 | with Checks; use Checks; | |
28 | with Debug; use Debug; | |
29 | with Debug_A; use Debug_A; | |
30 | with Einfo; use Einfo; | |
31 | with Errout; use Errout; | |
32 | with Expander; use Expander; | |
758c442c | 33 | with Exp_Disp; use Exp_Disp; |
0669bebe | 34 | with Exp_Ch6; use Exp_Ch6; |
996ae0b0 | 35 | with Exp_Ch7; use Exp_Ch7; |
fbf5a39b | 36 | with Exp_Tss; use Exp_Tss; |
996ae0b0 | 37 | with Exp_Util; use Exp_Util; |
dae2b8ea | 38 | with Fname; use Fname; |
996ae0b0 | 39 | with Freeze; use Freeze; |
8636f52f | 40 | with Ghost; use Ghost; |
ecad37f3 | 41 | with Inline; use Inline; |
996ae0b0 RK |
42 | with Itypes; use Itypes; |
43 | with Lib; use Lib; | |
44 | with Lib.Xref; use Lib.Xref; | |
45 | with Namet; use Namet; | |
46 | with Nmake; use Nmake; | |
47 | with Nlists; use Nlists; | |
48 | with Opt; use Opt; | |
49 | with Output; use Output; | |
0566484a | 50 | with Par_SCO; use Par_SCO; |
996ae0b0 | 51 | with Restrict; use Restrict; |
6e937c1c | 52 | with Rident; use Rident; |
996ae0b0 RK |
53 | with Rtsfind; use Rtsfind; |
54 | with Sem; use Sem; | |
a4100e55 | 55 | with Sem_Aux; use Sem_Aux; |
996ae0b0 RK |
56 | with Sem_Aggr; use Sem_Aggr; |
57 | with Sem_Attr; use Sem_Attr; | |
58 | with Sem_Cat; use Sem_Cat; | |
59 | with Sem_Ch4; use Sem_Ch4; | |
7f54dc83 | 60 | with Sem_Ch3; use Sem_Ch3; |
996ae0b0 RK |
61 | with Sem_Ch6; use Sem_Ch6; |
62 | with Sem_Ch8; use Sem_Ch8; | |
4b92fd3c | 63 | with Sem_Ch13; use Sem_Ch13; |
dec6faf1 | 64 | with Sem_Dim; use Sem_Dim; |
996ae0b0 RK |
65 | with Sem_Disp; use Sem_Disp; |
66 | with Sem_Dist; use Sem_Dist; | |
16212e89 | 67 | with Sem_Elim; use Sem_Elim; |
996ae0b0 RK |
68 | with Sem_Elab; use Sem_Elab; |
69 | with Sem_Eval; use Sem_Eval; | |
70 | with Sem_Intr; use Sem_Intr; | |
71 | with Sem_Util; use Sem_Util; | |
ce72a9a3 | 72 | with Targparm; use Targparm; |
996ae0b0 RK |
73 | with Sem_Type; use Sem_Type; |
74 | with Sem_Warn; use Sem_Warn; | |
75 | with Sinfo; use Sinfo; | |
f4b049db | 76 | with Sinfo.CN; use Sinfo.CN; |
fbf5a39b | 77 | with Snames; use Snames; |
996ae0b0 RK |
78 | with Stand; use Stand; |
79 | with Stringt; use Stringt; | |
45fc7ddb | 80 | with Style; use Style; |
996ae0b0 RK |
81 | with Tbuild; use Tbuild; |
82 | with Uintp; use Uintp; | |
83 | with Urealp; use Urealp; | |
84 | ||
85 | package body Sem_Res is | |
86 | ||
87 | ----------------------- | |
88 | -- Local Subprograms -- | |
89 | ----------------------- | |
90 | ||
91 | -- Second pass (top-down) type checking and overload resolution procedures | |
ac16e74c RD |
92 | -- Typ is the type required by context. These procedures propagate the |
93 | -- type information recursively to the descendants of N. If the node is not | |
5cc9353d | 94 | -- overloaded, its Etype is established in the first pass. If overloaded, |
ac16e74c | 95 | -- the Resolve routines set the correct type. For arithmetic operators, the |
5cc9353d | 96 | -- Etype is the base type of the context. |
996ae0b0 RK |
97 | |
98 | -- Note that Resolve_Attribute is separated off in Sem_Attr | |
99 | ||
996ae0b0 RK |
100 | procedure Check_Discriminant_Use (N : Node_Id); |
101 | -- Enforce the restrictions on the use of discriminants when constraining | |
102 | -- a component of a discriminated type (record or concurrent type). | |
103 | ||
104 | procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id); | |
966fc9c5 AC |
105 | -- Given a node for an operator associated with type T, check that the |
106 | -- operator is visible. Operators all of whose operands are universal must | |
107 | -- be checked for visibility during resolution because their type is not | |
108 | -- determinable based on their operands. | |
996ae0b0 | 109 | |
c8ef728f ES |
110 | procedure Check_Fully_Declared_Prefix |
111 | (Typ : Entity_Id; | |
112 | Pref : Node_Id); | |
113 | -- Check that the type of the prefix of a dereference is not incomplete | |
114 | ||
996ae0b0 RK |
115 | function Check_Infinite_Recursion (N : Node_Id) return Boolean; |
116 | -- Given a call node, N, which is known to occur immediately within the | |
117 | -- subprogram being called, determines whether it is a detectable case of | |
118 | -- an infinite recursion, and if so, outputs appropriate messages. Returns | |
119 | -- True if an infinite recursion is detected, and False otherwise. | |
120 | ||
121 | procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id); | |
122 | -- If the type of the object being initialized uses the secondary stack | |
123 | -- directly or indirectly, create a transient scope for the call to the | |
fbf5a39b AC |
124 | -- init proc. This is because we do not create transient scopes for the |
125 | -- initialization of individual components within the init proc itself. | |
996ae0b0 RK |
126 | -- Could be optimized away perhaps? |
127 | ||
f61580d4 | 128 | procedure Check_No_Direct_Boolean_Operators (N : Node_Id); |
6fb4cdde AC |
129 | -- N is the node for a logical operator. If the operator is predefined, and |
130 | -- the root type of the operands is Standard.Boolean, then a check is made | |
a36c1c3e RD |
131 | -- for restriction No_Direct_Boolean_Operators. This procedure also handles |
132 | -- the style check for Style_Check_Boolean_And_Or. | |
f61580d4 | 133 | |
c2a2dbcc RD |
134 | function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean; |
135 | -- N is either an indexed component or a selected component. This function | |
136 | -- returns true if the prefix refers to an object that has an address | |
137 | -- clause (the case in which we may want to issue a warning). | |
138 | ||
67ce0d7e | 139 | function Is_Definite_Access_Type (E : Entity_Id) return Boolean; |
5cc9353d RD |
140 | -- Determine whether E is an access type declared by an access declaration, |
141 | -- and not an (anonymous) allocator type. | |
67ce0d7e | 142 | |
996ae0b0 | 143 | function Is_Predefined_Op (Nam : Entity_Id) return Boolean; |
6a497607 AC |
144 | -- Utility to check whether the entity for an operator is a predefined |
145 | -- operator, in which case the expression is left as an operator in the | |
146 | -- tree (else it is rewritten into a call). An instance of an intrinsic | |
147 | -- conversion operation may be given an operator name, but is not treated | |
148 | -- like an operator. Note that an operator that is an imported back-end | |
149 | -- builtin has convention Intrinsic, but is expected to be rewritten into | |
150 | -- a call, so such an operator is not treated as predefined by this | |
151 | -- predicate. | |
996ae0b0 RK |
152 | |
153 | procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id); | |
154 | -- If a default expression in entry call N depends on the discriminants | |
155 | -- of the task, it must be replaced with a reference to the discriminant | |
156 | -- of the task being called. | |
157 | ||
10303118 BD |
158 | procedure Resolve_Op_Concat_Arg |
159 | (N : Node_Id; | |
160 | Arg : Node_Id; | |
161 | Typ : Entity_Id; | |
162 | Is_Comp : Boolean); | |
163 | -- Internal procedure for Resolve_Op_Concat to resolve one operand of | |
164 | -- concatenation operator. The operand is either of the array type or of | |
165 | -- the component type. If the operand is an aggregate, and the component | |
166 | -- type is composite, this is ambiguous if component type has aggregates. | |
167 | ||
168 | procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id); | |
169 | -- Does the first part of the work of Resolve_Op_Concat | |
170 | ||
171 | procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id); | |
172 | -- Does the "rest" of the work of Resolve_Op_Concat, after the left operand | |
173 | -- has been resolved. See Resolve_Op_Concat for details. | |
174 | ||
996ae0b0 RK |
175 | procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id); |
176 | procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id); | |
177 | procedure Resolve_Call (N : Node_Id; Typ : Entity_Id); | |
19d846a0 | 178 | procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id); |
996ae0b0 RK |
179 | procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id); |
180 | procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id); | |
955871d3 | 181 | procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id); |
996ae0b0 RK |
182 | procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id); |
183 | procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id); | |
955871d3 | 184 | procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id); |
9b16cb57 | 185 | procedure Resolve_If_Expression (N : Node_Id; Typ : Entity_Id); |
5f50020a | 186 | procedure Resolve_Generalized_Indexing (N : Node_Id; Typ : Entity_Id); |
996ae0b0 RK |
187 | procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id); |
188 | procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id); | |
189 | procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id); | |
190 | procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id); | |
191 | procedure Resolve_Null (N : Node_Id; Typ : Entity_Id); | |
192 | procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id); | |
193 | procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id); | |
194 | procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id); | |
195 | procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id); | |
196 | procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id); | |
7610fee8 | 197 | procedure Resolve_Raise_Expression (N : Node_Id; Typ : Entity_Id); |
996ae0b0 RK |
198 | procedure Resolve_Range (N : Node_Id; Typ : Entity_Id); |
199 | procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id); | |
200 | procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id); | |
201 | procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id); | |
202 | procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id); | |
203 | procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id); | |
204 | procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id); | |
205 | procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id); | |
ae33543c | 206 | procedure Resolve_Target_Name (N : Node_Id; Typ : Entity_Id); |
996ae0b0 RK |
207 | procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id); |
208 | procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id); | |
209 | procedure Resolve_Unchecked_Expression (N : Node_Id; Typ : Entity_Id); | |
210 | procedure Resolve_Unchecked_Type_Conversion (N : Node_Id; Typ : Entity_Id); | |
211 | ||
212 | function Operator_Kind | |
213 | (Op_Name : Name_Id; | |
0ab80019 | 214 | Is_Binary : Boolean) return Node_Kind; |
996ae0b0 RK |
215 | -- Utility to map the name of an operator into the corresponding Node. Used |
216 | -- by other node rewriting procedures. | |
217 | ||
218 | procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id); | |
bc5f3720 RD |
219 | -- Resolve actuals of call, and add default expressions for missing ones. |
220 | -- N is the Node_Id for the subprogram call, and Nam is the entity of the | |
221 | -- called subprogram. | |
996ae0b0 RK |
222 | |
223 | procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id); | |
224 | -- Called from Resolve_Call, when the prefix denotes an entry or element | |
225 | -- of entry family. Actuals are resolved as for subprograms, and the node | |
226 | -- is rebuilt as an entry call. Also called for protected operations. Typ | |
227 | -- is the context type, which is used when the operation is a protected | |
228 | -- function with no arguments, and the return value is indexed. | |
229 | ||
230 | procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id); | |
5cc9353d RD |
231 | -- A call to a user-defined intrinsic operator is rewritten as a call to |
232 | -- the corresponding predefined operator, with suitable conversions. Note | |
233 | -- that this applies only for intrinsic operators that denote predefined | |
234 | -- operators, not ones that are intrinsic imports of back-end builtins. | |
996ae0b0 | 235 | |
fbf5a39b | 236 | procedure Resolve_Intrinsic_Unary_Operator (N : Node_Id; Typ : Entity_Id); |
7a5b62b0 | 237 | -- Ditto, for arithmetic unary operators |
fbf5a39b | 238 | |
996ae0b0 RK |
239 | procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id); |
240 | -- If an operator node resolves to a call to a user-defined operator, | |
241 | -- rewrite the node as a function call. | |
242 | ||
243 | procedure Make_Call_Into_Operator | |
244 | (N : Node_Id; | |
245 | Typ : Entity_Id; | |
246 | Op_Id : Entity_Id); | |
247 | -- Inverse transformation: if an operator is given in functional notation, | |
ac16e74c RD |
248 | -- then after resolving the node, transform into an operator node, so that |
249 | -- operands are resolved properly. Recall that predefined operators do not | |
250 | -- have a full signature and special resolution rules apply. | |
996ae0b0 | 251 | |
0ab80019 AC |
252 | procedure Rewrite_Renamed_Operator |
253 | (N : Node_Id; | |
254 | Op : Entity_Id; | |
255 | Typ : Entity_Id); | |
21d7ef70 | 256 | -- An operator can rename another, e.g. in an instantiation. In that |
0ab80019 | 257 | -- case, the proper operator node must be constructed and resolved. |
996ae0b0 RK |
258 | |
259 | procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id); | |
260 | -- The String_Literal_Subtype is built for all strings that are not | |
966fc9c5 AC |
261 | -- operands of a static concatenation operation. If the argument is not |
262 | -- a N_String_Literal node, then the call has no effect. | |
996ae0b0 RK |
263 | |
264 | procedure Set_Slice_Subtype (N : Node_Id); | |
fbf5a39b | 265 | -- Build subtype of array type, with the range specified by the slice |
996ae0b0 | 266 | |
0669bebe GB |
267 | procedure Simplify_Type_Conversion (N : Node_Id); |
268 | -- Called after N has been resolved and evaluated, but before range checks | |
269 | -- have been applied. Currently simplifies a combination of floating-point | |
24228312 | 270 | -- to integer conversion and Rounding or Truncation attribute. |
0669bebe | 271 | |
996ae0b0 | 272 | function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id; |
5cc9353d RD |
273 | -- A universal_fixed expression in an universal context is unambiguous if |
274 | -- there is only one applicable fixed point type. Determining whether there | |
275 | -- is only one requires a search over all visible entities, and happens | |
276 | -- only in very pathological cases (see 6115-006). | |
996ae0b0 | 277 | |
996ae0b0 RK |
278 | ------------------------- |
279 | -- Ambiguous_Character -- | |
280 | ------------------------- | |
281 | ||
282 | procedure Ambiguous_Character (C : Node_Id) is | |
283 | E : Entity_Id; | |
284 | ||
285 | begin | |
286 | if Nkind (C) = N_Character_Literal then | |
ed2233dc | 287 | Error_Msg_N ("ambiguous character literal", C); |
b7d1f17f HK |
288 | |
289 | -- First the ones in Standard | |
290 | ||
ed2233dc AC |
291 | Error_Msg_N ("\\possible interpretation: Character!", C); |
292 | Error_Msg_N ("\\possible interpretation: Wide_Character!", C); | |
b7d1f17f HK |
293 | |
294 | -- Include Wide_Wide_Character in Ada 2005 mode | |
295 | ||
0791fbe9 | 296 | if Ada_Version >= Ada_2005 then |
ed2233dc | 297 | Error_Msg_N ("\\possible interpretation: Wide_Wide_Character!", C); |
b7d1f17f HK |
298 | end if; |
299 | ||
300 | -- Now any other types that match | |
996ae0b0 RK |
301 | |
302 | E := Current_Entity (C); | |
1420b484 | 303 | while Present (E) loop |
ed2233dc | 304 | Error_Msg_NE ("\\possible interpretation:}!", C, Etype (E)); |
1420b484 JM |
305 | E := Homonym (E); |
306 | end loop; | |
996ae0b0 RK |
307 | end if; |
308 | end Ambiguous_Character; | |
309 | ||
310 | ------------------------- | |
311 | -- Analyze_And_Resolve -- | |
312 | ------------------------- | |
313 | ||
314 | procedure Analyze_And_Resolve (N : Node_Id) is | |
315 | begin | |
316 | Analyze (N); | |
fbf5a39b | 317 | Resolve (N); |
996ae0b0 RK |
318 | end Analyze_And_Resolve; |
319 | ||
320 | procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id) is | |
321 | begin | |
322 | Analyze (N); | |
323 | Resolve (N, Typ); | |
324 | end Analyze_And_Resolve; | |
325 | ||
a91e9ac7 | 326 | -- Versions with check(s) suppressed |
996ae0b0 RK |
327 | |
328 | procedure Analyze_And_Resolve | |
329 | (N : Node_Id; | |
330 | Typ : Entity_Id; | |
331 | Suppress : Check_Id) | |
332 | is | |
fbf5a39b | 333 | Scop : constant Entity_Id := Current_Scope; |
996ae0b0 RK |
334 | |
335 | begin | |
336 | if Suppress = All_Checks then | |
337 | declare | |
a7f1b24f | 338 | Sva : constant Suppress_Array := Scope_Suppress.Suppress; |
996ae0b0 | 339 | begin |
a7f1b24f | 340 | Scope_Suppress.Suppress := (others => True); |
996ae0b0 | 341 | Analyze_And_Resolve (N, Typ); |
a7f1b24f | 342 | Scope_Suppress.Suppress := Sva; |
a91e9ac7 AC |
343 | end; |
344 | ||
996ae0b0 RK |
345 | else |
346 | declare | |
3217f71e | 347 | Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); |
996ae0b0 | 348 | begin |
3217f71e | 349 | Scope_Suppress.Suppress (Suppress) := True; |
996ae0b0 | 350 | Analyze_And_Resolve (N, Typ); |
3217f71e | 351 | Scope_Suppress.Suppress (Suppress) := Svg; |
996ae0b0 RK |
352 | end; |
353 | end if; | |
354 | ||
355 | if Current_Scope /= Scop | |
356 | and then Scope_Is_Transient | |
357 | then | |
5cc9353d RD |
358 | -- This can only happen if a transient scope was created for an inner |
359 | -- expression, which will be removed upon completion of the analysis | |
360 | -- of an enclosing construct. The transient scope must have the | |
361 | -- suppress status of the enclosing environment, not of this Analyze | |
362 | -- call. | |
996ae0b0 RK |
363 | |
364 | Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress := | |
365 | Scope_Suppress; | |
366 | end if; | |
367 | end Analyze_And_Resolve; | |
368 | ||
369 | procedure Analyze_And_Resolve | |
370 | (N : Node_Id; | |
371 | Suppress : Check_Id) | |
372 | is | |
fbf5a39b | 373 | Scop : constant Entity_Id := Current_Scope; |
996ae0b0 RK |
374 | |
375 | begin | |
376 | if Suppress = All_Checks then | |
377 | declare | |
a7f1b24f | 378 | Sva : constant Suppress_Array := Scope_Suppress.Suppress; |
a91e9ac7 | 379 | begin |
a7f1b24f | 380 | Scope_Suppress.Suppress := (others => True); |
a91e9ac7 | 381 | Analyze_And_Resolve (N); |
a7f1b24f | 382 | Scope_Suppress.Suppress := Sva; |
a91e9ac7 AC |
383 | end; |
384 | ||
996ae0b0 RK |
385 | else |
386 | declare | |
3217f71e | 387 | Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); |
996ae0b0 | 388 | begin |
3217f71e | 389 | Scope_Suppress.Suppress (Suppress) := True; |
996ae0b0 | 390 | Analyze_And_Resolve (N); |
3217f71e | 391 | Scope_Suppress.Suppress (Suppress) := Svg; |
996ae0b0 RK |
392 | end; |
393 | end if; | |
394 | ||
3217f71e | 395 | if Current_Scope /= Scop and then Scope_Is_Transient then |
996ae0b0 RK |
396 | Scope_Stack.Table (Scope_Stack.Last).Save_Scope_Suppress := |
397 | Scope_Suppress; | |
398 | end if; | |
399 | end Analyze_And_Resolve; | |
400 | ||
401 | ---------------------------- | |
402 | -- Check_Discriminant_Use -- | |
403 | ---------------------------- | |
404 | ||
405 | procedure Check_Discriminant_Use (N : Node_Id) is | |
406 | PN : constant Node_Id := Parent (N); | |
407 | Disc : constant Entity_Id := Entity (N); | |
408 | P : Node_Id; | |
409 | D : Node_Id; | |
410 | ||
411 | begin | |
f3d0f304 | 412 | -- Any use in a spec-expression is legal |
996ae0b0 | 413 | |
45fc7ddb | 414 | if In_Spec_Expression then |
996ae0b0 RK |
415 | null; |
416 | ||
417 | elsif Nkind (PN) = N_Range then | |
418 | ||
a77842bd | 419 | -- Discriminant cannot be used to constrain a scalar type |
996ae0b0 RK |
420 | |
421 | P := Parent (PN); | |
422 | ||
423 | if Nkind (P) = N_Range_Constraint | |
424 | and then Nkind (Parent (P)) = N_Subtype_Indication | |
a397db96 | 425 | and then Nkind (Parent (Parent (P))) = N_Component_Definition |
996ae0b0 RK |
426 | then |
427 | Error_Msg_N ("discriminant cannot constrain scalar type", N); | |
428 | ||
429 | elsif Nkind (P) = N_Index_Or_Discriminant_Constraint then | |
430 | ||
5cc9353d | 431 | -- The following check catches the unusual case where a |
966fc9c5 AC |
432 | -- discriminant appears within an index constraint that is part |
433 | -- of a larger expression within a constraint on a component, | |
434 | -- e.g. "C : Int range 1 .. F (new A(1 .. D))". For now we only | |
435 | -- check case of record components, and note that a similar check | |
436 | -- should also apply in the case of discriminant constraints | |
437 | -- below. ??? | |
996ae0b0 RK |
438 | |
439 | -- Note that the check for N_Subtype_Declaration below is to | |
440 | -- detect the valid use of discriminants in the constraints of a | |
441 | -- subtype declaration when this subtype declaration appears | |
442 | -- inside the scope of a record type (which is syntactically | |
443 | -- illegal, but which may be created as part of derived type | |
444 | -- processing for records). See Sem_Ch3.Build_Derived_Record_Type | |
445 | -- for more info. | |
446 | ||
447 | if Ekind (Current_Scope) = E_Record_Type | |
448 | and then Scope (Disc) = Current_Scope | |
449 | and then not | |
450 | (Nkind (Parent (P)) = N_Subtype_Indication | |
45fc7ddb HK |
451 | and then |
452 | Nkind_In (Parent (Parent (P)), N_Component_Definition, | |
453 | N_Subtype_Declaration) | |
996ae0b0 RK |
454 | and then Paren_Count (N) = 0) |
455 | then | |
456 | Error_Msg_N | |
457 | ("discriminant must appear alone in component constraint", N); | |
458 | return; | |
459 | end if; | |
460 | ||
a0ac3932 | 461 | -- Detect a common error: |
9bc43c53 | 462 | |
996ae0b0 | 463 | -- type R (D : Positive := 100) is record |
9bc43c53 | 464 | -- Name : String (1 .. D); |
996ae0b0 RK |
465 | -- end record; |
466 | ||
a0ac3932 RD |
467 | -- The default value causes an object of type R to be allocated |
468 | -- with room for Positive'Last characters. The RM does not mandate | |
469 | -- the allocation of the maximum size, but that is what GNAT does | |
470 | -- so we should warn the programmer that there is a problem. | |
996ae0b0 | 471 | |
a0ac3932 | 472 | Check_Large : declare |
996ae0b0 RK |
473 | SI : Node_Id; |
474 | T : Entity_Id; | |
475 | TB : Node_Id; | |
476 | CB : Entity_Id; | |
477 | ||
478 | function Large_Storage_Type (T : Entity_Id) return Boolean; | |
5cc9353d RD |
479 | -- Return True if type T has a large enough range that any |
480 | -- array whose index type covered the whole range of the type | |
481 | -- would likely raise Storage_Error. | |
996ae0b0 | 482 | |
fbf5a39b AC |
483 | ------------------------ |
484 | -- Large_Storage_Type -- | |
485 | ------------------------ | |
486 | ||
996ae0b0 RK |
487 | function Large_Storage_Type (T : Entity_Id) return Boolean is |
488 | begin | |
4b92fd3c ST |
489 | -- The type is considered large if its bounds are known at |
490 | -- compile time and if it requires at least as many bits as | |
491 | -- a Positive to store the possible values. | |
492 | ||
493 | return Compile_Time_Known_Value (Type_Low_Bound (T)) | |
494 | and then Compile_Time_Known_Value (Type_High_Bound (T)) | |
495 | and then | |
496 | Minimum_Size (T, Biased => True) >= | |
a0ac3932 | 497 | RM_Size (Standard_Positive); |
996ae0b0 RK |
498 | end Large_Storage_Type; |
499 | ||
a0ac3932 RD |
500 | -- Start of processing for Check_Large |
501 | ||
996ae0b0 RK |
502 | begin |
503 | -- Check that the Disc has a large range | |
504 | ||
505 | if not Large_Storage_Type (Etype (Disc)) then | |
506 | goto No_Danger; | |
507 | end if; | |
508 | ||
509 | -- If the enclosing type is limited, we allocate only the | |
510 | -- default value, not the maximum, and there is no need for | |
511 | -- a warning. | |
512 | ||
513 | if Is_Limited_Type (Scope (Disc)) then | |
514 | goto No_Danger; | |
515 | end if; | |
516 | ||
517 | -- Check that it is the high bound | |
518 | ||
519 | if N /= High_Bound (PN) | |
c8ef728f | 520 | or else No (Discriminant_Default_Value (Disc)) |
996ae0b0 RK |
521 | then |
522 | goto No_Danger; | |
523 | end if; | |
524 | ||
5cc9353d RD |
525 | -- Check the array allows a large range at this bound. First |
526 | -- find the array | |
996ae0b0 RK |
527 | |
528 | SI := Parent (P); | |
529 | ||
530 | if Nkind (SI) /= N_Subtype_Indication then | |
531 | goto No_Danger; | |
532 | end if; | |
533 | ||
534 | T := Entity (Subtype_Mark (SI)); | |
535 | ||
536 | if not Is_Array_Type (T) then | |
537 | goto No_Danger; | |
538 | end if; | |
539 | ||
540 | -- Next, find the dimension | |
541 | ||
542 | TB := First_Index (T); | |
543 | CB := First (Constraints (P)); | |
544 | while True | |
545 | and then Present (TB) | |
546 | and then Present (CB) | |
547 | and then CB /= PN | |
548 | loop | |
549 | Next_Index (TB); | |
550 | Next (CB); | |
551 | end loop; | |
552 | ||
553 | if CB /= PN then | |
554 | goto No_Danger; | |
555 | end if; | |
556 | ||
557 | -- Now, check the dimension has a large range | |
558 | ||
559 | if not Large_Storage_Type (Etype (TB)) then | |
560 | goto No_Danger; | |
561 | end if; | |
562 | ||
563 | -- Warn about the danger | |
564 | ||
565 | Error_Msg_N | |
324ac540 | 566 | ("??creation of & object may raise Storage_Error!", |
fbf5a39b | 567 | Scope (Disc)); |
996ae0b0 RK |
568 | |
569 | <<No_Danger>> | |
570 | null; | |
571 | ||
a0ac3932 | 572 | end Check_Large; |
996ae0b0 RK |
573 | end if; |
574 | ||
575 | -- Legal case is in index or discriminant constraint | |
576 | ||
45fc7ddb HK |
577 | elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint, |
578 | N_Discriminant_Association) | |
996ae0b0 RK |
579 | then |
580 | if Paren_Count (N) > 0 then | |
581 | Error_Msg_N | |
582 | ("discriminant in constraint must appear alone", N); | |
758c442c GD |
583 | |
584 | elsif Nkind (N) = N_Expanded_Name | |
585 | and then Comes_From_Source (N) | |
586 | then | |
587 | Error_Msg_N | |
588 | ("discriminant must appear alone as a direct name", N); | |
996ae0b0 RK |
589 | end if; |
590 | ||
591 | return; | |
592 | ||
5cc9353d RD |
593 | -- Otherwise, context is an expression. It should not be within (i.e. a |
594 | -- subexpression of) a constraint for a component. | |
996ae0b0 RK |
595 | |
596 | else | |
597 | D := PN; | |
598 | P := Parent (PN); | |
45fc7ddb HK |
599 | while not Nkind_In (P, N_Component_Declaration, |
600 | N_Subtype_Indication, | |
601 | N_Entry_Declaration) | |
996ae0b0 RK |
602 | loop |
603 | D := P; | |
604 | P := Parent (P); | |
605 | exit when No (P); | |
606 | end loop; | |
607 | ||
5cc9353d RD |
608 | -- If the discriminant is used in an expression that is a bound of a |
609 | -- scalar type, an Itype is created and the bounds are attached to | |
610 | -- its range, not to the original subtype indication. Such use is of | |
611 | -- course a double fault. | |
996ae0b0 RK |
612 | |
613 | if (Nkind (P) = N_Subtype_Indication | |
45fc7ddb HK |
614 | and then Nkind_In (Parent (P), N_Component_Definition, |
615 | N_Derived_Type_Definition) | |
996ae0b0 RK |
616 | and then D = Constraint (P)) |
617 | ||
19fb051c AC |
618 | -- The constraint itself may be given by a subtype indication, |
619 | -- rather than by a more common discrete range. | |
996ae0b0 RK |
620 | |
621 | or else (Nkind (P) = N_Subtype_Indication | |
fbf5a39b AC |
622 | and then |
623 | Nkind (Parent (P)) = N_Index_Or_Discriminant_Constraint) | |
996ae0b0 RK |
624 | or else Nkind (P) = N_Entry_Declaration |
625 | or else Nkind (D) = N_Defining_Identifier | |
626 | then | |
627 | Error_Msg_N | |
628 | ("discriminant in constraint must appear alone", N); | |
629 | end if; | |
630 | end if; | |
631 | end Check_Discriminant_Use; | |
632 | ||
633 | -------------------------------- | |
634 | -- Check_For_Visible_Operator -- | |
635 | -------------------------------- | |
636 | ||
637 | procedure Check_For_Visible_Operator (N : Node_Id; T : Entity_Id) is | |
996ae0b0 | 638 | begin |
fbf5a39b | 639 | if Is_Invisible_Operator (N, T) then |
305caf42 | 640 | Error_Msg_NE -- CODEFIX |
996ae0b0 | 641 | ("operator for} is not directly visible!", N, First_Subtype (T)); |
305caf42 AC |
642 | Error_Msg_N -- CODEFIX |
643 | ("use clause would make operation legal!", N); | |
996ae0b0 RK |
644 | end if; |
645 | end Check_For_Visible_Operator; | |
646 | ||
c8ef728f ES |
647 | ---------------------------------- |
648 | -- Check_Fully_Declared_Prefix -- | |
649 | ---------------------------------- | |
650 | ||
651 | procedure Check_Fully_Declared_Prefix | |
652 | (Typ : Entity_Id; | |
653 | Pref : Node_Id) | |
654 | is | |
655 | begin | |
656 | -- Check that the designated type of the prefix of a dereference is | |
657 | -- not an incomplete type. This cannot be done unconditionally, because | |
658 | -- dereferences of private types are legal in default expressions. This | |
659 | -- case is taken care of in Check_Fully_Declared, called below. There | |
660 | -- are also 2005 cases where it is legal for the prefix to be unfrozen. | |
661 | ||
662 | -- This consideration also applies to similar checks for allocators, | |
663 | -- qualified expressions, and type conversions. | |
664 | ||
665 | -- An additional exception concerns other per-object expressions that | |
666 | -- are not directly related to component declarations, in particular | |
667 | -- representation pragmas for tasks. These will be per-object | |
668 | -- expressions if they depend on discriminants or some global entity. | |
669 | -- If the task has access discriminants, the designated type may be | |
670 | -- incomplete at the point the expression is resolved. This resolution | |
671 | -- takes place within the body of the initialization procedure, where | |
672 | -- the discriminant is replaced by its discriminal. | |
673 | ||
674 | if Is_Entity_Name (Pref) | |
675 | and then Ekind (Entity (Pref)) = E_In_Parameter | |
676 | then | |
677 | null; | |
678 | ||
679 | -- Ada 2005 (AI-326): Tagged incomplete types allowed. The wrong usages | |
680 | -- are handled by Analyze_Access_Attribute, Analyze_Assignment, | |
681 | -- Analyze_Object_Renaming, and Freeze_Entity. | |
682 | ||
0791fbe9 | 683 | elsif Ada_Version >= Ada_2005 |
c8ef728f | 684 | and then Is_Entity_Name (Pref) |
811c6a85 | 685 | and then Is_Access_Type (Etype (Pref)) |
c8ef728f ES |
686 | and then Ekind (Directly_Designated_Type (Etype (Pref))) = |
687 | E_Incomplete_Type | |
688 | and then Is_Tagged_Type (Directly_Designated_Type (Etype (Pref))) | |
689 | then | |
690 | null; | |
691 | else | |
692 | Check_Fully_Declared (Typ, Parent (Pref)); | |
693 | end if; | |
694 | end Check_Fully_Declared_Prefix; | |
695 | ||
996ae0b0 RK |
696 | ------------------------------ |
697 | -- Check_Infinite_Recursion -- | |
698 | ------------------------------ | |
699 | ||
700 | function Check_Infinite_Recursion (N : Node_Id) return Boolean is | |
701 | P : Node_Id; | |
702 | C : Node_Id; | |
703 | ||
07fc65c4 | 704 | function Same_Argument_List return Boolean; |
5cc9353d RD |
705 | -- Check whether list of actuals is identical to list of formals of |
706 | -- called function (which is also the enclosing scope). | |
07fc65c4 GB |
707 | |
708 | ------------------------ | |
709 | -- Same_Argument_List -- | |
710 | ------------------------ | |
711 | ||
712 | function Same_Argument_List return Boolean is | |
713 | A : Node_Id; | |
714 | F : Entity_Id; | |
715 | Subp : Entity_Id; | |
716 | ||
717 | begin | |
718 | if not Is_Entity_Name (Name (N)) then | |
719 | return False; | |
720 | else | |
721 | Subp := Entity (Name (N)); | |
722 | end if; | |
723 | ||
724 | F := First_Formal (Subp); | |
725 | A := First_Actual (N); | |
07fc65c4 | 726 | while Present (F) and then Present (A) loop |
445e5888 | 727 | if not Is_Entity_Name (A) or else Entity (A) /= F then |
07fc65c4 GB |
728 | return False; |
729 | end if; | |
730 | ||
731 | Next_Actual (A); | |
732 | Next_Formal (F); | |
733 | end loop; | |
734 | ||
735 | return True; | |
736 | end Same_Argument_List; | |
737 | ||
738 | -- Start of processing for Check_Infinite_Recursion | |
739 | ||
996ae0b0 | 740 | begin |
26570b21 RD |
741 | -- Special case, if this is a procedure call and is a call to the |
742 | -- current procedure with the same argument list, then this is for | |
743 | -- sure an infinite recursion and we insert a call to raise SE. | |
744 | ||
745 | if Is_List_Member (N) | |
746 | and then List_Length (List_Containing (N)) = 1 | |
747 | and then Same_Argument_List | |
748 | then | |
749 | declare | |
750 | P : constant Node_Id := Parent (N); | |
751 | begin | |
752 | if Nkind (P) = N_Handled_Sequence_Of_Statements | |
753 | and then Nkind (Parent (P)) = N_Subprogram_Body | |
754 | and then Is_Empty_List (Declarations (Parent (P))) | |
755 | then | |
43417b90 | 756 | Error_Msg_Warn := SPARK_Mode /= On; |
4a28b181 AC |
757 | Error_Msg_N ("!infinite recursion<<", N); |
758 | Error_Msg_N ("\!Storage_Error [<<", N); | |
26570b21 RD |
759 | Insert_Action (N, |
760 | Make_Raise_Storage_Error (Sloc (N), | |
761 | Reason => SE_Infinite_Recursion)); | |
762 | return True; | |
763 | end if; | |
764 | end; | |
765 | end if; | |
766 | ||
767 | -- If not that special case, search up tree, quitting if we reach a | |
768 | -- construct (e.g. a conditional) that tells us that this is not a | |
769 | -- case for an infinite recursion warning. | |
996ae0b0 RK |
770 | |
771 | C := N; | |
772 | loop | |
773 | P := Parent (C); | |
9a7da240 RD |
774 | |
775 | -- If no parent, then we were not inside a subprogram, this can for | |
776 | -- example happen when processing certain pragmas in a spec. Just | |
777 | -- return False in this case. | |
778 | ||
779 | if No (P) then | |
780 | return False; | |
781 | end if; | |
782 | ||
783 | -- Done if we get to subprogram body, this is definitely an infinite | |
784 | -- recursion case if we did not find anything to stop us. | |
785 | ||
996ae0b0 | 786 | exit when Nkind (P) = N_Subprogram_Body; |
9a7da240 RD |
787 | |
788 | -- If appearing in conditional, result is false | |
789 | ||
45fc7ddb HK |
790 | if Nkind_In (P, N_Or_Else, |
791 | N_And_Then, | |
d347f572 AC |
792 | N_Case_Expression, |
793 | N_Case_Statement, | |
9b16cb57 | 794 | N_If_Expression, |
d347f572 | 795 | N_If_Statement) |
996ae0b0 RK |
796 | then |
797 | return False; | |
798 | ||
799 | elsif Nkind (P) = N_Handled_Sequence_Of_Statements | |
800 | and then C /= First (Statements (P)) | |
801 | then | |
26570b21 RD |
802 | -- If the call is the expression of a return statement and the |
803 | -- actuals are identical to the formals, it's worth a warning. | |
804 | -- However, we skip this if there is an immediately preceding | |
805 | -- raise statement, since the call is never executed. | |
07fc65c4 GB |
806 | |
807 | -- Furthermore, this corresponds to a common idiom: | |
808 | ||
809 | -- function F (L : Thing) return Boolean is | |
810 | -- begin | |
811 | -- raise Program_Error; | |
812 | -- return F (L); | |
813 | -- end F; | |
814 | ||
815 | -- for generating a stub function | |
816 | ||
aa5147f0 | 817 | if Nkind (Parent (N)) = N_Simple_Return_Statement |
07fc65c4 GB |
818 | and then Same_Argument_List |
819 | then | |
9ebe3743 HK |
820 | exit when not Is_List_Member (Parent (N)); |
821 | ||
822 | -- OK, return statement is in a statement list, look for raise | |
823 | ||
824 | declare | |
825 | Nod : Node_Id; | |
826 | ||
827 | begin | |
828 | -- Skip past N_Freeze_Entity nodes generated by expansion | |
829 | ||
830 | Nod := Prev (Parent (N)); | |
831 | while Present (Nod) | |
832 | and then Nkind (Nod) = N_Freeze_Entity | |
833 | loop | |
834 | Prev (Nod); | |
835 | end loop; | |
836 | ||
3235dc87 AC |
837 | -- If no raise statement, give warning. We look at the |
838 | -- original node, because in the case of "raise ... with | |
839 | -- ...", the node has been transformed into a call. | |
9ebe3743 | 840 | |
3235dc87 | 841 | exit when Nkind (Original_Node (Nod)) /= N_Raise_Statement |
9ebe3743 HK |
842 | and then |
843 | (Nkind (Nod) not in N_Raise_xxx_Error | |
19fb051c | 844 | or else Present (Condition (Nod))); |
9ebe3743 | 845 | end; |
07fc65c4 GB |
846 | end if; |
847 | ||
996ae0b0 RK |
848 | return False; |
849 | ||
850 | else | |
851 | C := P; | |
852 | end if; | |
853 | end loop; | |
854 | ||
43417b90 | 855 | Error_Msg_Warn := SPARK_Mode /= On; |
4a28b181 AC |
856 | Error_Msg_N ("!possible infinite recursion<<", N); |
857 | Error_Msg_N ("\!??Storage_Error ]<<", N); | |
996ae0b0 RK |
858 | |
859 | return True; | |
860 | end Check_Infinite_Recursion; | |
861 | ||
862 | ------------------------------- | |
863 | -- Check_Initialization_Call -- | |
864 | ------------------------------- | |
865 | ||
866 | procedure Check_Initialization_Call (N : Entity_Id; Nam : Entity_Id) is | |
fbf5a39b | 867 | Typ : constant Entity_Id := Etype (First_Formal (Nam)); |
996ae0b0 RK |
868 | |
869 | function Uses_SS (T : Entity_Id) return Boolean; | |
07fc65c4 GB |
870 | -- Check whether the creation of an object of the type will involve |
871 | -- use of the secondary stack. If T is a record type, this is true | |
f3d57416 | 872 | -- if the expression for some component uses the secondary stack, e.g. |
07fc65c4 GB |
873 | -- through a call to a function that returns an unconstrained value. |
874 | -- False if T is controlled, because cleanups occur elsewhere. | |
875 | ||
876 | ------------- | |
877 | -- Uses_SS -- | |
878 | ------------- | |
996ae0b0 RK |
879 | |
880 | function Uses_SS (T : Entity_Id) return Boolean is | |
aa5147f0 ES |
881 | Comp : Entity_Id; |
882 | Expr : Node_Id; | |
883 | Full_Type : Entity_Id := Underlying_Type (T); | |
996ae0b0 RK |
884 | |
885 | begin | |
aa5147f0 ES |
886 | -- Normally we want to use the underlying type, but if it's not set |
887 | -- then continue with T. | |
888 | ||
889 | if not Present (Full_Type) then | |
890 | Full_Type := T; | |
891 | end if; | |
892 | ||
893 | if Is_Controlled (Full_Type) then | |
996ae0b0 RK |
894 | return False; |
895 | ||
aa5147f0 ES |
896 | elsif Is_Array_Type (Full_Type) then |
897 | return Uses_SS (Component_Type (Full_Type)); | |
996ae0b0 | 898 | |
aa5147f0 ES |
899 | elsif Is_Record_Type (Full_Type) then |
900 | Comp := First_Component (Full_Type); | |
996ae0b0 | 901 | while Present (Comp) loop |
996ae0b0 RK |
902 | if Ekind (Comp) = E_Component |
903 | and then Nkind (Parent (Comp)) = N_Component_Declaration | |
904 | then | |
aa5147f0 ES |
905 | -- The expression for a dynamic component may be rewritten |
906 | -- as a dereference, so retrieve original node. | |
907 | ||
908 | Expr := Original_Node (Expression (Parent (Comp))); | |
996ae0b0 | 909 | |
aa5147f0 | 910 | -- Return True if the expression is a call to a function |
1d57c04f AC |
911 | -- (including an attribute function such as Image, or a |
912 | -- user-defined operator) with a result that requires a | |
913 | -- transient scope. | |
fbf5a39b | 914 | |
aa5147f0 | 915 | if (Nkind (Expr) = N_Function_Call |
1d57c04f | 916 | or else Nkind (Expr) in N_Op |
aa5147f0 ES |
917 | or else (Nkind (Expr) = N_Attribute_Reference |
918 | and then Present (Expressions (Expr)))) | |
996ae0b0 RK |
919 | and then Requires_Transient_Scope (Etype (Expr)) |
920 | then | |
921 | return True; | |
922 | ||
923 | elsif Uses_SS (Etype (Comp)) then | |
924 | return True; | |
925 | end if; | |
926 | end if; | |
927 | ||
928 | Next_Component (Comp); | |
929 | end loop; | |
930 | ||
931 | return False; | |
932 | ||
933 | else | |
934 | return False; | |
935 | end if; | |
936 | end Uses_SS; | |
937 | ||
07fc65c4 GB |
938 | -- Start of processing for Check_Initialization_Call |
939 | ||
996ae0b0 | 940 | begin |
0669bebe | 941 | -- Establish a transient scope if the type needs it |
07fc65c4 | 942 | |
0669bebe | 943 | if Uses_SS (Typ) then |
996ae0b0 RK |
944 | Establish_Transient_Scope (First_Actual (N), Sec_Stack => True); |
945 | end if; | |
946 | end Check_Initialization_Call; | |
947 | ||
f61580d4 AC |
948 | --------------------------------------- |
949 | -- Check_No_Direct_Boolean_Operators -- | |
950 | --------------------------------------- | |
951 | ||
952 | procedure Check_No_Direct_Boolean_Operators (N : Node_Id) is | |
953 | begin | |
954 | if Scope (Entity (N)) = Standard_Standard | |
955 | and then Root_Type (Etype (Left_Opnd (N))) = Standard_Boolean | |
956 | then | |
6fb4cdde | 957 | -- Restriction only applies to original source code |
f61580d4 | 958 | |
6fb4cdde | 959 | if Comes_From_Source (N) then |
f61580d4 AC |
960 | Check_Restriction (No_Direct_Boolean_Operators, N); |
961 | end if; | |
962 | end if; | |
a36c1c3e | 963 | |
545d3e65 RD |
964 | -- Do style check (but skip if in instance, error is on template) |
965 | ||
a36c1c3e | 966 | if Style_Check then |
545d3e65 RD |
967 | if not In_Instance then |
968 | Check_Boolean_Operator (N); | |
969 | end if; | |
a36c1c3e | 970 | end if; |
f61580d4 AC |
971 | end Check_No_Direct_Boolean_Operators; |
972 | ||
996ae0b0 RK |
973 | ------------------------------ |
974 | -- Check_Parameterless_Call -- | |
975 | ------------------------------ | |
976 | ||
977 | procedure Check_Parameterless_Call (N : Node_Id) is | |
978 | Nam : Node_Id; | |
979 | ||
bc5f3720 RD |
980 | function Prefix_Is_Access_Subp return Boolean; |
981 | -- If the prefix is of an access_to_subprogram type, the node must be | |
982 | -- rewritten as a call. Ditto if the prefix is overloaded and all its | |
983 | -- interpretations are access to subprograms. | |
984 | ||
985 | --------------------------- | |
986 | -- Prefix_Is_Access_Subp -- | |
987 | --------------------------- | |
988 | ||
989 | function Prefix_Is_Access_Subp return Boolean is | |
990 | I : Interp_Index; | |
991 | It : Interp; | |
992 | ||
993 | begin | |
22b77f68 | 994 | -- If the context is an attribute reference that can apply to |
b4a4936b | 995 | -- functions, this is never a parameterless call (RM 4.1.4(6)). |
96d2756f AC |
996 | |
997 | if Nkind (Parent (N)) = N_Attribute_Reference | |
b69cd36a AC |
998 | and then Nam_In (Attribute_Name (Parent (N)), Name_Address, |
999 | Name_Code_Address, | |
1000 | Name_Access) | |
96d2756f AC |
1001 | then |
1002 | return False; | |
1003 | end if; | |
1004 | ||
bc5f3720 RD |
1005 | if not Is_Overloaded (N) then |
1006 | return | |
1007 | Ekind (Etype (N)) = E_Subprogram_Type | |
1008 | and then Base_Type (Etype (Etype (N))) /= Standard_Void_Type; | |
1009 | else | |
1010 | Get_First_Interp (N, I, It); | |
1011 | while Present (It.Typ) loop | |
1012 | if Ekind (It.Typ) /= E_Subprogram_Type | |
1013 | or else Base_Type (Etype (It.Typ)) = Standard_Void_Type | |
1014 | then | |
1015 | return False; | |
1016 | end if; | |
1017 | ||
1018 | Get_Next_Interp (I, It); | |
1019 | end loop; | |
1020 | ||
1021 | return True; | |
1022 | end if; | |
1023 | end Prefix_Is_Access_Subp; | |
1024 | ||
1025 | -- Start of processing for Check_Parameterless_Call | |
1026 | ||
996ae0b0 | 1027 | begin |
07fc65c4 GB |
1028 | -- Defend against junk stuff if errors already detected |
1029 | ||
1030 | if Total_Errors_Detected /= 0 then | |
1031 | if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then | |
1032 | return; | |
1033 | elsif Nkind (N) in N_Has_Chars | |
1034 | and then Chars (N) in Error_Name_Or_No_Name | |
1035 | then | |
1036 | return; | |
1037 | end if; | |
fbf5a39b AC |
1038 | |
1039 | Require_Entity (N); | |
996ae0b0 RK |
1040 | end if; |
1041 | ||
45fc7ddb HK |
1042 | -- If the context expects a value, and the name is a procedure, this is |
1043 | -- most likely a missing 'Access. Don't try to resolve the parameterless | |
1044 | -- call, error will be caught when the outer call is analyzed. | |
18c0ecbe AC |
1045 | |
1046 | if Is_Entity_Name (N) | |
1047 | and then Ekind (Entity (N)) = E_Procedure | |
1048 | and then not Is_Overloaded (N) | |
1049 | and then | |
45fc7ddb HK |
1050 | Nkind_In (Parent (N), N_Parameter_Association, |
1051 | N_Function_Call, | |
1052 | N_Procedure_Call_Statement) | |
18c0ecbe AC |
1053 | then |
1054 | return; | |
1055 | end if; | |
1056 | ||
45fc7ddb HK |
1057 | -- Rewrite as call if overloadable entity that is (or could be, in the |
1058 | -- overloaded case) a function call. If we know for sure that the entity | |
1059 | -- is an enumeration literal, we do not rewrite it. | |
f4b049db | 1060 | |
e1d9659d AC |
1061 | -- If the entity is the name of an operator, it cannot be a call because |
1062 | -- operators cannot have default parameters. In this case, this must be | |
1063 | -- a string whose contents coincide with an operator name. Set the kind | |
96d2756f | 1064 | -- of the node appropriately. |
996ae0b0 RK |
1065 | |
1066 | if (Is_Entity_Name (N) | |
e1d9659d | 1067 | and then Nkind (N) /= N_Operator_Symbol |
996ae0b0 RK |
1068 | and then Is_Overloadable (Entity (N)) |
1069 | and then (Ekind (Entity (N)) /= E_Enumeration_Literal | |
964f13da | 1070 | or else Is_Overloaded (N))) |
996ae0b0 | 1071 | |
09494c32 | 1072 | -- Rewrite as call if it is an explicit dereference of an expression of |
f3d57416 | 1073 | -- a subprogram access type, and the subprogram type is not that of a |
996ae0b0 RK |
1074 | -- procedure or entry. |
1075 | ||
1076 | or else | |
bc5f3720 | 1077 | (Nkind (N) = N_Explicit_Dereference and then Prefix_Is_Access_Subp) |
996ae0b0 RK |
1078 | |
1079 | -- Rewrite as call if it is a selected component which is a function, | |
1080 | -- this is the case of a call to a protected function (which may be | |
1081 | -- overloaded with other protected operations). | |
1082 | ||
1083 | or else | |
1084 | (Nkind (N) = N_Selected_Component | |
1085 | and then (Ekind (Entity (Selector_Name (N))) = E_Function | |
964f13da RD |
1086 | or else |
1087 | (Ekind_In (Entity (Selector_Name (N)), E_Entry, | |
1088 | E_Procedure) | |
1089 | and then Is_Overloaded (Selector_Name (N))))) | |
996ae0b0 | 1090 | |
5cc9353d RD |
1091 | -- If one of the above three conditions is met, rewrite as call. Apply |
1092 | -- the rewriting only once. | |
996ae0b0 RK |
1093 | |
1094 | then | |
1095 | if Nkind (Parent (N)) /= N_Function_Call | |
1096 | or else N /= Name (Parent (N)) | |
1097 | then | |
747de90b AC |
1098 | |
1099 | -- This may be a prefixed call that was not fully analyzed, e.g. | |
1100 | -- an actual in an instance. | |
1101 | ||
1102 | if Ada_Version >= Ada_2005 | |
1103 | and then Nkind (N) = N_Selected_Component | |
1104 | and then Is_Dispatching_Operation (Entity (Selector_Name (N))) | |
1105 | then | |
1106 | Analyze_Selected_Component (N); | |
996c8821 | 1107 | |
747de90b AC |
1108 | if Nkind (N) /= N_Selected_Component then |
1109 | return; | |
1110 | end if; | |
1111 | end if; | |
1112 | ||
b80a2b4b AC |
1113 | -- The node is the name of the parameterless call. Preserve its |
1114 | -- descendants, which may be complex expressions. | |
1115 | ||
1116 | Nam := Relocate_Node (N); | |
996ae0b0 | 1117 | |
bc5f3720 | 1118 | -- If overloaded, overload set belongs to new copy |
996ae0b0 RK |
1119 | |
1120 | Save_Interps (N, Nam); | |
1121 | ||
1122 | -- Change node to parameterless function call (note that the | |
1123 | -- Parameter_Associations associations field is left set to Empty, | |
1124 | -- its normal default value since there are no parameters) | |
1125 | ||
1126 | Change_Node (N, N_Function_Call); | |
1127 | Set_Name (N, Nam); | |
1128 | Set_Sloc (N, Sloc (Nam)); | |
1129 | Analyze_Call (N); | |
1130 | end if; | |
1131 | ||
1132 | elsif Nkind (N) = N_Parameter_Association then | |
1133 | Check_Parameterless_Call (Explicit_Actual_Parameter (N)); | |
e1d9659d AC |
1134 | |
1135 | elsif Nkind (N) = N_Operator_Symbol then | |
1136 | Change_Operator_Symbol_To_String_Literal (N); | |
1137 | Set_Is_Overloaded (N, False); | |
1138 | Set_Etype (N, Any_String); | |
996ae0b0 RK |
1139 | end if; |
1140 | end Check_Parameterless_Call; | |
1141 | ||
c2a2dbcc RD |
1142 | -------------------------------- |
1143 | -- Is_Atomic_Ref_With_Address -- | |
1144 | -------------------------------- | |
1145 | ||
1146 | function Is_Atomic_Ref_With_Address (N : Node_Id) return Boolean is | |
1147 | Pref : constant Node_Id := Prefix (N); | |
1148 | ||
1149 | begin | |
1150 | if not Is_Entity_Name (Pref) then | |
1151 | return False; | |
1152 | ||
1153 | else | |
1154 | declare | |
1155 | Pent : constant Entity_Id := Entity (Pref); | |
1156 | Ptyp : constant Entity_Id := Etype (Pent); | |
1157 | begin | |
1158 | return not Is_Access_Type (Ptyp) | |
1159 | and then (Is_Atomic (Ptyp) or else Is_Atomic (Pent)) | |
1160 | and then Present (Address_Clause (Pent)); | |
1161 | end; | |
1162 | end if; | |
1163 | end Is_Atomic_Ref_With_Address; | |
1164 | ||
67ce0d7e RD |
1165 | ----------------------------- |
1166 | -- Is_Definite_Access_Type -- | |
1167 | ----------------------------- | |
1168 | ||
1169 | function Is_Definite_Access_Type (E : Entity_Id) return Boolean is | |
1170 | Btyp : constant Entity_Id := Base_Type (E); | |
1171 | begin | |
1172 | return Ekind (Btyp) = E_Access_Type | |
1173 | or else (Ekind (Btyp) = E_Access_Subprogram_Type | |
72e9f2b9 | 1174 | and then Comes_From_Source (Btyp)); |
67ce0d7e RD |
1175 | end Is_Definite_Access_Type; |
1176 | ||
996ae0b0 RK |
1177 | ---------------------- |
1178 | -- Is_Predefined_Op -- | |
1179 | ---------------------- | |
1180 | ||
1181 | function Is_Predefined_Op (Nam : Entity_Id) return Boolean is | |
1182 | begin | |
6a497607 AC |
1183 | -- Predefined operators are intrinsic subprograms |
1184 | ||
1185 | if not Is_Intrinsic_Subprogram (Nam) then | |
1186 | return False; | |
1187 | end if; | |
1188 | ||
1189 | -- A call to a back-end builtin is never a predefined operator | |
1190 | ||
1191 | if Is_Imported (Nam) and then Present (Interface_Name (Nam)) then | |
1192 | return False; | |
1193 | end if; | |
1194 | ||
1195 | return not Is_Generic_Instance (Nam) | |
996ae0b0 | 1196 | and then Chars (Nam) in Any_Operator_Name |
6a497607 | 1197 | and then (No (Alias (Nam)) or else Is_Predefined_Op (Alias (Nam))); |
996ae0b0 RK |
1198 | end Is_Predefined_Op; |
1199 | ||
1200 | ----------------------------- | |
1201 | -- Make_Call_Into_Operator -- | |
1202 | ----------------------------- | |
1203 | ||
1204 | procedure Make_Call_Into_Operator | |
1205 | (N : Node_Id; | |
1206 | Typ : Entity_Id; | |
1207 | Op_Id : Entity_Id) | |
1208 | is | |
1209 | Op_Name : constant Name_Id := Chars (Op_Id); | |
1210 | Act1 : Node_Id := First_Actual (N); | |
1211 | Act2 : Node_Id := Next_Actual (Act1); | |
1212 | Error : Boolean := False; | |
2820d220 AC |
1213 | Func : constant Entity_Id := Entity (Name (N)); |
1214 | Is_Binary : constant Boolean := Present (Act2); | |
996ae0b0 RK |
1215 | Op_Node : Node_Id; |
1216 | Opnd_Type : Entity_Id; | |
1217 | Orig_Type : Entity_Id := Empty; | |
1218 | Pack : Entity_Id; | |
1219 | ||
1220 | type Kind_Test is access function (E : Entity_Id) return Boolean; | |
1221 | ||
996ae0b0 | 1222 | function Operand_Type_In_Scope (S : Entity_Id) return Boolean; |
b4a4936b AC |
1223 | -- If the operand is not universal, and the operator is given by an |
1224 | -- expanded name, verify that the operand has an interpretation with a | |
1225 | -- type defined in the given scope of the operator. | |
996ae0b0 RK |
1226 | |
1227 | function Type_In_P (Test : Kind_Test) return Entity_Id; | |
b4a4936b AC |
1228 | -- Find a type of the given class in package Pack that contains the |
1229 | -- operator. | |
996ae0b0 | 1230 | |
996ae0b0 RK |
1231 | --------------------------- |
1232 | -- Operand_Type_In_Scope -- | |
1233 | --------------------------- | |
1234 | ||
1235 | function Operand_Type_In_Scope (S : Entity_Id) return Boolean is | |
1236 | Nod : constant Node_Id := Right_Opnd (Op_Node); | |
1237 | I : Interp_Index; | |
1238 | It : Interp; | |
1239 | ||
1240 | begin | |
1241 | if not Is_Overloaded (Nod) then | |
1242 | return Scope (Base_Type (Etype (Nod))) = S; | |
1243 | ||
1244 | else | |
1245 | Get_First_Interp (Nod, I, It); | |
996ae0b0 | 1246 | while Present (It.Typ) loop |
996ae0b0 RK |
1247 | if Scope (Base_Type (It.Typ)) = S then |
1248 | return True; | |
1249 | end if; | |
1250 | ||
1251 | Get_Next_Interp (I, It); | |
1252 | end loop; | |
1253 | ||
1254 | return False; | |
1255 | end if; | |
1256 | end Operand_Type_In_Scope; | |
1257 | ||
1258 | --------------- | |
1259 | -- Type_In_P -- | |
1260 | --------------- | |
1261 | ||
1262 | function Type_In_P (Test : Kind_Test) return Entity_Id is | |
1263 | E : Entity_Id; | |
1264 | ||
1265 | function In_Decl return Boolean; | |
1266 | -- Verify that node is not part of the type declaration for the | |
1267 | -- candidate type, which would otherwise be invisible. | |
1268 | ||
1269 | ------------- | |
1270 | -- In_Decl -- | |
1271 | ------------- | |
1272 | ||
1273 | function In_Decl return Boolean is | |
1274 | Decl_Node : constant Node_Id := Parent (E); | |
1275 | N2 : Node_Id; | |
1276 | ||
1277 | begin | |
1278 | N2 := N; | |
1279 | ||
1280 | if Etype (E) = Any_Type then | |
1281 | return True; | |
1282 | ||
1283 | elsif No (Decl_Node) then | |
1284 | return False; | |
1285 | ||
1286 | else | |
1287 | while Present (N2) | |
1288 | and then Nkind (N2) /= N_Compilation_Unit | |
1289 | loop | |
1290 | if N2 = Decl_Node then | |
1291 | return True; | |
1292 | else | |
1293 | N2 := Parent (N2); | |
1294 | end if; | |
1295 | end loop; | |
1296 | ||
1297 | return False; | |
1298 | end if; | |
1299 | end In_Decl; | |
1300 | ||
1301 | -- Start of processing for Type_In_P | |
1302 | ||
1303 | begin | |
b4a4936b AC |
1304 | -- If the context type is declared in the prefix package, this is the |
1305 | -- desired base type. | |
996ae0b0 | 1306 | |
b4a4936b | 1307 | if Scope (Base_Type (Typ)) = Pack and then Test (Typ) then |
996ae0b0 RK |
1308 | return Base_Type (Typ); |
1309 | ||
1310 | else | |
1311 | E := First_Entity (Pack); | |
996ae0b0 | 1312 | while Present (E) loop |
445e5888 | 1313 | if Test (E) and then not In_Decl then |
996ae0b0 RK |
1314 | return E; |
1315 | end if; | |
1316 | ||
1317 | Next_Entity (E); | |
1318 | end loop; | |
1319 | ||
1320 | return Empty; | |
1321 | end if; | |
1322 | end Type_In_P; | |
1323 | ||
996ae0b0 RK |
1324 | -- Start of processing for Make_Call_Into_Operator |
1325 | ||
1326 | begin | |
1327 | Op_Node := New_Node (Operator_Kind (Op_Name, Is_Binary), Sloc (N)); | |
1328 | ||
1329 | -- Binary operator | |
1330 | ||
1331 | if Is_Binary then | |
1332 | Set_Left_Opnd (Op_Node, Relocate_Node (Act1)); | |
1333 | Set_Right_Opnd (Op_Node, Relocate_Node (Act2)); | |
1334 | Save_Interps (Act1, Left_Opnd (Op_Node)); | |
1335 | Save_Interps (Act2, Right_Opnd (Op_Node)); | |
1336 | Act1 := Left_Opnd (Op_Node); | |
1337 | Act2 := Right_Opnd (Op_Node); | |
1338 | ||
1339 | -- Unary operator | |
1340 | ||
1341 | else | |
1342 | Set_Right_Opnd (Op_Node, Relocate_Node (Act1)); | |
1343 | Save_Interps (Act1, Right_Opnd (Op_Node)); | |
1344 | Act1 := Right_Opnd (Op_Node); | |
1345 | end if; | |
1346 | ||
1347 | -- If the operator is denoted by an expanded name, and the prefix is | |
1348 | -- not Standard, but the operator is a predefined one whose scope is | |
1349 | -- Standard, then this is an implicit_operator, inserted as an | |
1350 | -- interpretation by the procedure of the same name. This procedure | |
1351 | -- overestimates the presence of implicit operators, because it does | |
1352 | -- not examine the type of the operands. Verify now that the operand | |
1353 | -- type appears in the given scope. If right operand is universal, | |
1354 | -- check the other operand. In the case of concatenation, either | |
1355 | -- argument can be the component type, so check the type of the result. | |
1356 | -- If both arguments are literals, look for a type of the right kind | |
1357 | -- defined in the given scope. This elaborate nonsense is brought to | |
1358 | -- you courtesy of b33302a. The type itself must be frozen, so we must | |
1359 | -- find the type of the proper class in the given scope. | |
1360 | ||
06f2efd7 TQ |
1361 | -- A final wrinkle is the multiplication operator for fixed point types, |
1362 | -- which is defined in Standard only, and not in the scope of the | |
b4a4936b | 1363 | -- fixed point type itself. |
996ae0b0 RK |
1364 | |
1365 | if Nkind (Name (N)) = N_Expanded_Name then | |
1366 | Pack := Entity (Prefix (Name (N))); | |
1367 | ||
1115dd7e ES |
1368 | -- If this is a package renaming, get renamed entity, which will be |
1369 | -- the scope of the operands if operaton is type-correct. | |
1370 | ||
1371 | if Present (Renamed_Entity (Pack)) then | |
1372 | Pack := Renamed_Entity (Pack); | |
1373 | end if; | |
1374 | ||
06f2efd7 TQ |
1375 | -- If the entity being called is defined in the given package, it is |
1376 | -- a renaming of a predefined operator, and known to be legal. | |
996ae0b0 RK |
1377 | |
1378 | if Scope (Entity (Name (N))) = Pack | |
1379 | and then Pack /= Standard_Standard | |
1380 | then | |
1381 | null; | |
1382 | ||
9ebe3743 HK |
1383 | -- Visibility does not need to be checked in an instance: if the |
1384 | -- operator was not visible in the generic it has been diagnosed | |
1385 | -- already, else there is an implicit copy of it in the instance. | |
1386 | ||
1387 | elsif In_Instance then | |
1388 | null; | |
1389 | ||
b69cd36a | 1390 | elsif Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide) |
996ae0b0 RK |
1391 | and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node))) |
1392 | and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node))) | |
1393 | then | |
1394 | if Pack /= Standard_Standard then | |
1395 | Error := True; | |
1396 | end if; | |
1397 | ||
b4a4936b | 1398 | -- Ada 2005 AI-420: Predefined equality on Universal_Access is |
06f2efd7 | 1399 | -- available. |
c8ef728f | 1400 | |
0791fbe9 | 1401 | elsif Ada_Version >= Ada_2005 |
b69cd36a | 1402 | and then Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne) |
c8ef728f ES |
1403 | and then Ekind (Etype (Act1)) = E_Anonymous_Access_Type |
1404 | then | |
1405 | null; | |
1406 | ||
996ae0b0 RK |
1407 | else |
1408 | Opnd_Type := Base_Type (Etype (Right_Opnd (Op_Node))); | |
1409 | ||
1410 | if Op_Name = Name_Op_Concat then | |
1411 | Opnd_Type := Base_Type (Typ); | |
1412 | ||
1413 | elsif (Scope (Opnd_Type) = Standard_Standard | |
d8f43ee6 | 1414 | and then Is_Binary) |
996ae0b0 RK |
1415 | or else (Nkind (Right_Opnd (Op_Node)) = N_Attribute_Reference |
1416 | and then Is_Binary | |
1417 | and then not Comes_From_Source (Opnd_Type)) | |
1418 | then | |
1419 | Opnd_Type := Base_Type (Etype (Left_Opnd (Op_Node))); | |
1420 | end if; | |
1421 | ||
1422 | if Scope (Opnd_Type) = Standard_Standard then | |
1423 | ||
1424 | -- Verify that the scope contains a type that corresponds to | |
1425 | -- the given literal. Optimize the case where Pack is Standard. | |
1426 | ||
1427 | if Pack /= Standard_Standard then | |
996ae0b0 | 1428 | if Opnd_Type = Universal_Integer then |
06f2efd7 | 1429 | Orig_Type := Type_In_P (Is_Integer_Type'Access); |
996ae0b0 RK |
1430 | |
1431 | elsif Opnd_Type = Universal_Real then | |
1432 | Orig_Type := Type_In_P (Is_Real_Type'Access); | |
1433 | ||
1434 | elsif Opnd_Type = Any_String then | |
1435 | Orig_Type := Type_In_P (Is_String_Type'Access); | |
1436 | ||
1437 | elsif Opnd_Type = Any_Access then | |
06f2efd7 | 1438 | Orig_Type := Type_In_P (Is_Definite_Access_Type'Access); |
996ae0b0 RK |
1439 | |
1440 | elsif Opnd_Type = Any_Composite then | |
1441 | Orig_Type := Type_In_P (Is_Composite_Type'Access); | |
1442 | ||
1443 | if Present (Orig_Type) then | |
1444 | if Has_Private_Component (Orig_Type) then | |
1445 | Orig_Type := Empty; | |
1446 | else | |
1447 | Set_Etype (Act1, Orig_Type); | |
1448 | ||
1449 | if Is_Binary then | |
1450 | Set_Etype (Act2, Orig_Type); | |
1451 | end if; | |
1452 | end if; | |
1453 | end if; | |
1454 | ||
1455 | else | |
1456 | Orig_Type := Empty; | |
1457 | end if; | |
1458 | ||
1459 | Error := No (Orig_Type); | |
1460 | end if; | |
1461 | ||
1462 | elsif Ekind (Opnd_Type) = E_Allocator_Type | |
1463 | and then No (Type_In_P (Is_Definite_Access_Type'Access)) | |
1464 | then | |
1465 | Error := True; | |
1466 | ||
1467 | -- If the type is defined elsewhere, and the operator is not | |
1468 | -- defined in the given scope (by a renaming declaration, e.g.) | |
1469 | -- then this is an error as well. If an extension of System is | |
1470 | -- present, and the type may be defined there, Pack must be | |
1471 | -- System itself. | |
1472 | ||
1473 | elsif Scope (Opnd_Type) /= Pack | |
1474 | and then Scope (Op_Id) /= Pack | |
1475 | and then (No (System_Aux_Id) | |
1476 | or else Scope (Opnd_Type) /= System_Aux_Id | |
1477 | or else Pack /= Scope (System_Aux_Id)) | |
1478 | then | |
244e5a2c AC |
1479 | if not Is_Overloaded (Right_Opnd (Op_Node)) then |
1480 | Error := True; | |
1481 | else | |
1482 | Error := not Operand_Type_In_Scope (Pack); | |
1483 | end if; | |
996ae0b0 RK |
1484 | |
1485 | elsif Pack = Standard_Standard | |
1486 | and then not Operand_Type_In_Scope (Standard_Standard) | |
1487 | then | |
1488 | Error := True; | |
1489 | end if; | |
1490 | end if; | |
1491 | ||
1492 | if Error then | |
1493 | Error_Msg_Node_2 := Pack; | |
1494 | Error_Msg_NE | |
1495 | ("& not declared in&", N, Selector_Name (Name (N))); | |
1496 | Set_Etype (N, Any_Type); | |
1497 | return; | |
88b17d45 AC |
1498 | |
1499 | -- Detect a mismatch between the context type and the result type | |
1500 | -- in the named package, which is otherwise not detected if the | |
1501 | -- operands are universal. Check is only needed if source entity is | |
1502 | -- an operator, not a function that renames an operator. | |
1503 | ||
1504 | elsif Nkind (Parent (N)) /= N_Type_Conversion | |
1505 | and then Ekind (Entity (Name (N))) = E_Operator | |
1506 | and then Is_Numeric_Type (Typ) | |
1507 | and then not Is_Universal_Numeric_Type (Typ) | |
1508 | and then Scope (Base_Type (Typ)) /= Pack | |
1509 | and then not In_Instance | |
1510 | then | |
1511 | if Is_Fixed_Point_Type (Typ) | |
b69cd36a | 1512 | and then Nam_In (Op_Name, Name_Op_Multiply, Name_Op_Divide) |
88b17d45 AC |
1513 | then |
1514 | -- Already checked above | |
1515 | ||
1516 | null; | |
1517 | ||
e86a3a7e | 1518 | -- Operator may be defined in an extension of System |
80c3be7a AC |
1519 | |
1520 | elsif Present (System_Aux_Id) | |
1521 | and then Scope (Opnd_Type) = System_Aux_Id | |
1522 | then | |
1523 | null; | |
1524 | ||
88b17d45 | 1525 | else |
be5a1b93 TQ |
1526 | -- Could we use Wrong_Type here??? (this would require setting |
1527 | -- Etype (N) to the actual type found where Typ was expected). | |
1528 | ||
e86a3a7e | 1529 | Error_Msg_NE ("expect }", N, Typ); |
88b17d45 | 1530 | end if; |
996ae0b0 RK |
1531 | end if; |
1532 | end if; | |
1533 | ||
1534 | Set_Chars (Op_Node, Op_Name); | |
fbf5a39b AC |
1535 | |
1536 | if not Is_Private_Type (Etype (N)) then | |
1537 | Set_Etype (Op_Node, Base_Type (Etype (N))); | |
1538 | else | |
1539 | Set_Etype (Op_Node, Etype (N)); | |
1540 | end if; | |
1541 | ||
2820d220 AC |
1542 | -- If this is a call to a function that renames a predefined equality, |
1543 | -- the renaming declaration provides a type that must be used to | |
1544 | -- resolve the operands. This must be done now because resolution of | |
1545 | -- the equality node will not resolve any remaining ambiguity, and it | |
1546 | -- assumes that the first operand is not overloaded. | |
1547 | ||
b69cd36a | 1548 | if Nam_In (Op_Name, Name_Op_Eq, Name_Op_Ne) |
2820d220 AC |
1549 | and then Ekind (Func) = E_Function |
1550 | and then Is_Overloaded (Act1) | |
1551 | then | |
1552 | Resolve (Act1, Base_Type (Etype (First_Formal (Func)))); | |
1553 | Resolve (Act2, Base_Type (Etype (First_Formal (Func)))); | |
1554 | end if; | |
1555 | ||
996ae0b0 RK |
1556 | Set_Entity (Op_Node, Op_Id); |
1557 | Generate_Reference (Op_Id, N, ' '); | |
45fc7ddb HK |
1558 | |
1559 | -- Do rewrite setting Comes_From_Source on the result if the original | |
1560 | -- call came from source. Although it is not strictly the case that the | |
1561 | -- operator as such comes from the source, logically it corresponds | |
1562 | -- exactly to the function call in the source, so it should be marked | |
1563 | -- this way (e.g. to make sure that validity checks work fine). | |
1564 | ||
1565 | declare | |
1566 | CS : constant Boolean := Comes_From_Source (N); | |
1567 | begin | |
1568 | Rewrite (N, Op_Node); | |
1569 | Set_Comes_From_Source (N, CS); | |
1570 | end; | |
fbf5a39b AC |
1571 | |
1572 | -- If this is an arithmetic operator and the result type is private, | |
1573 | -- the operands and the result must be wrapped in conversion to | |
1574 | -- expose the underlying numeric type and expand the proper checks, | |
1575 | -- e.g. on division. | |
1576 | ||
1577 | if Is_Private_Type (Typ) then | |
1578 | case Nkind (N) is | |
d8f43ee6 HK |
1579 | when N_Op_Add |
1580 | | N_Op_Divide | |
1581 | | N_Op_Expon | |
1582 | | N_Op_Mod | |
1583 | | N_Op_Multiply | |
1584 | | N_Op_Rem | |
1585 | | N_Op_Subtract | |
1586 | => | |
fbf5a39b AC |
1587 | Resolve_Intrinsic_Operator (N, Typ); |
1588 | ||
d8f43ee6 HK |
1589 | when N_Op_Abs |
1590 | | N_Op_Minus | |
1591 | | N_Op_Plus | |
1592 | => | |
fbf5a39b AC |
1593 | Resolve_Intrinsic_Unary_Operator (N, Typ); |
1594 | ||
1595 | when others => | |
1596 | Resolve (N, Typ); | |
1597 | end case; | |
1598 | else | |
1599 | Resolve (N, Typ); | |
1600 | end if; | |
466c2127 AC |
1601 | |
1602 | -- If in ASIS_Mode, propagate operand types to original actuals of | |
d7a3e18c | 1603 | -- function call, which would otherwise not be fully resolved. If |
00ba7be8 AC |
1604 | -- the call has already been constant-folded, nothing to do. We |
1605 | -- relocate the operand nodes rather than copy them, to preserve | |
1606 | -- original_node pointers, given that the operands themselves may | |
c61ef416 AC |
1607 | -- have been rewritten. If the call was itself a rewriting of an |
1608 | -- operator node, nothing to do. | |
466c2127 | 1609 | |
c61ef416 AC |
1610 | if ASIS_Mode |
1611 | and then Nkind (N) in N_Op | |
1612 | and then Nkind (Original_Node (N)) = N_Function_Call | |
1613 | then | |
c05ba1f1 | 1614 | declare |
5fde9688 | 1615 | L : Node_Id; |
c05ba1f1 AC |
1616 | R : constant Node_Id := Right_Opnd (N); |
1617 | ||
1618 | Old_First : constant Node_Id := | |
1619 | First (Parameter_Associations (Original_Node (N))); | |
1620 | Old_Sec : Node_Id; | |
1621 | ||
1622 | begin | |
1623 | if Is_Binary then | |
5fde9688 AC |
1624 | L := Left_Opnd (N); |
1625 | Old_Sec := Next (Old_First); | |
c05ba1f1 AC |
1626 | |
1627 | -- If the original call has named associations, replace the | |
1628 | -- explicit actual parameter in the association with the proper | |
1629 | -- resolved operand. | |
1630 | ||
1631 | if Nkind (Old_First) = N_Parameter_Association then | |
1632 | if Chars (Selector_Name (Old_First)) = | |
1633 | Chars (First_Entity (Op_Id)) | |
1634 | then | |
1635 | Rewrite (Explicit_Actual_Parameter (Old_First), | |
1636 | Relocate_Node (L)); | |
1637 | else | |
1638 | Rewrite (Explicit_Actual_Parameter (Old_First), | |
1639 | Relocate_Node (R)); | |
1640 | end if; | |
1641 | ||
1642 | else | |
1643 | Rewrite (Old_First, Relocate_Node (L)); | |
1644 | end if; | |
1645 | ||
1646 | if Nkind (Old_Sec) = N_Parameter_Association then | |
7dae9ca0 | 1647 | if Chars (Selector_Name (Old_Sec)) = |
c05ba1f1 AC |
1648 | Chars (First_Entity (Op_Id)) |
1649 | then | |
1650 | Rewrite (Explicit_Actual_Parameter (Old_Sec), | |
1651 | Relocate_Node (L)); | |
1652 | else | |
1653 | Rewrite (Explicit_Actual_Parameter (Old_Sec), | |
1654 | Relocate_Node (R)); | |
1655 | end if; | |
1656 | ||
1657 | else | |
1658 | Rewrite (Old_Sec, Relocate_Node (R)); | |
1659 | end if; | |
1660 | ||
1661 | else | |
1662 | if Nkind (Old_First) = N_Parameter_Association then | |
1663 | Rewrite (Explicit_Actual_Parameter (Old_First), | |
1664 | Relocate_Node (R)); | |
1665 | else | |
1666 | Rewrite (Old_First, Relocate_Node (R)); | |
1667 | end if; | |
1668 | end if; | |
1669 | end; | |
3699edc4 AC |
1670 | |
1671 | Set_Parent (Original_Node (N), Parent (N)); | |
466c2127 | 1672 | end if; |
996ae0b0 RK |
1673 | end Make_Call_Into_Operator; |
1674 | ||
1675 | ------------------- | |
1676 | -- Operator_Kind -- | |
1677 | ------------------- | |
1678 | ||
1679 | function Operator_Kind | |
1680 | (Op_Name : Name_Id; | |
0ab80019 | 1681 | Is_Binary : Boolean) return Node_Kind |
996ae0b0 RK |
1682 | is |
1683 | Kind : Node_Kind; | |
1684 | ||
1685 | begin | |
b0186f71 AC |
1686 | -- Use CASE statement or array??? |
1687 | ||
996ae0b0 | 1688 | if Is_Binary then |
1b1d88b1 | 1689 | if Op_Name = Name_Op_And then |
aa5147f0 | 1690 | Kind := N_Op_And; |
1b1d88b1 | 1691 | elsif Op_Name = Name_Op_Or then |
aa5147f0 | 1692 | Kind := N_Op_Or; |
1b1d88b1 | 1693 | elsif Op_Name = Name_Op_Xor then |
aa5147f0 | 1694 | Kind := N_Op_Xor; |
1b1d88b1 | 1695 | elsif Op_Name = Name_Op_Eq then |
aa5147f0 | 1696 | Kind := N_Op_Eq; |
1b1d88b1 | 1697 | elsif Op_Name = Name_Op_Ne then |
aa5147f0 | 1698 | Kind := N_Op_Ne; |
1b1d88b1 | 1699 | elsif Op_Name = Name_Op_Lt then |
aa5147f0 | 1700 | Kind := N_Op_Lt; |
1b1d88b1 | 1701 | elsif Op_Name = Name_Op_Le then |
aa5147f0 | 1702 | Kind := N_Op_Le; |
1b1d88b1 | 1703 | elsif Op_Name = Name_Op_Gt then |
aa5147f0 | 1704 | Kind := N_Op_Gt; |
1b1d88b1 | 1705 | elsif Op_Name = Name_Op_Ge then |
aa5147f0 | 1706 | Kind := N_Op_Ge; |
1b1d88b1 | 1707 | elsif Op_Name = Name_Op_Add then |
aa5147f0 | 1708 | Kind := N_Op_Add; |
1b1d88b1 | 1709 | elsif Op_Name = Name_Op_Subtract then |
aa5147f0 | 1710 | Kind := N_Op_Subtract; |
1b1d88b1 | 1711 | elsif Op_Name = Name_Op_Concat then |
aa5147f0 | 1712 | Kind := N_Op_Concat; |
1b1d88b1 | 1713 | elsif Op_Name = Name_Op_Multiply then |
aa5147f0 | 1714 | Kind := N_Op_Multiply; |
1b1d88b1 | 1715 | elsif Op_Name = Name_Op_Divide then |
aa5147f0 | 1716 | Kind := N_Op_Divide; |
1b1d88b1 | 1717 | elsif Op_Name = Name_Op_Mod then |
aa5147f0 | 1718 | Kind := N_Op_Mod; |
1b1d88b1 | 1719 | elsif Op_Name = Name_Op_Rem then |
aa5147f0 | 1720 | Kind := N_Op_Rem; |
1b1d88b1 | 1721 | elsif Op_Name = Name_Op_Expon then |
aa5147f0 | 1722 | Kind := N_Op_Expon; |
996ae0b0 RK |
1723 | else |
1724 | raise Program_Error; | |
1725 | end if; | |
1726 | ||
1727 | -- Unary operators | |
1728 | ||
1729 | else | |
1b1d88b1 | 1730 | if Op_Name = Name_Op_Add then |
aa5147f0 | 1731 | Kind := N_Op_Plus; |
1b1d88b1 | 1732 | elsif Op_Name = Name_Op_Subtract then |
aa5147f0 | 1733 | Kind := N_Op_Minus; |
1b1d88b1 | 1734 | elsif Op_Name = Name_Op_Abs then |
aa5147f0 | 1735 | Kind := N_Op_Abs; |
1b1d88b1 | 1736 | elsif Op_Name = Name_Op_Not then |
aa5147f0 | 1737 | Kind := N_Op_Not; |
996ae0b0 RK |
1738 | else |
1739 | raise Program_Error; | |
1740 | end if; | |
1741 | end if; | |
1742 | ||
1743 | return Kind; | |
1744 | end Operator_Kind; | |
1745 | ||
45fc7ddb HK |
1746 | ---------------------------- |
1747 | -- Preanalyze_And_Resolve -- | |
1748 | ---------------------------- | |
996ae0b0 | 1749 | |
45fc7ddb | 1750 | procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is |
996ae0b0 RK |
1751 | Save_Full_Analysis : constant Boolean := Full_Analysis; |
1752 | ||
1753 | begin | |
1754 | Full_Analysis := False; | |
1755 | Expander_Mode_Save_And_Set (False); | |
1756 | ||
a7f1b24f RD |
1757 | -- Normally, we suppress all checks for this preanalysis. There is no |
1758 | -- point in processing them now, since they will be applied properly | |
1759 | -- and in the proper location when the default expressions reanalyzed | |
1760 | -- and reexpanded later on. We will also have more information at that | |
1761 | -- point for possible suppression of individual checks. | |
1115dd7e | 1762 | |
06b599fd YM |
1763 | -- However, in SPARK mode, most expansion is suppressed, and this |
1764 | -- later reanalysis and reexpansion may not occur. SPARK mode does | |
a7f1b24f | 1765 | -- require the setting of checking flags for proof purposes, so we |
06b599fd | 1766 | -- do the SPARK preanalysis without suppressing checks. |
a7f1b24f | 1767 | |
06b599fd | 1768 | -- This special handling for SPARK mode is required for example in the |
a7f1b24f RD |
1769 | -- case of Ada 2012 constructs such as quantified expressions, which are |
1770 | -- expanded in two separate steps. | |
996ae0b0 | 1771 | |
f5da7a97 | 1772 | if GNATprove_Mode then |
1115dd7e | 1773 | Analyze_And_Resolve (N, T); |
1115dd7e ES |
1774 | else |
1775 | Analyze_And_Resolve (N, T, Suppress => All_Checks); | |
1776 | end if; | |
996ae0b0 RK |
1777 | |
1778 | Expander_Mode_Restore; | |
1779 | Full_Analysis := Save_Full_Analysis; | |
45fc7ddb | 1780 | end Preanalyze_And_Resolve; |
996ae0b0 | 1781 | |
a77842bd | 1782 | -- Version without context type |
996ae0b0 | 1783 | |
45fc7ddb | 1784 | procedure Preanalyze_And_Resolve (N : Node_Id) is |
996ae0b0 RK |
1785 | Save_Full_Analysis : constant Boolean := Full_Analysis; |
1786 | ||
1787 | begin | |
1788 | Full_Analysis := False; | |
1789 | Expander_Mode_Save_And_Set (False); | |
1790 | ||
1791 | Analyze (N); | |
1792 | Resolve (N, Etype (N), Suppress => All_Checks); | |
1793 | ||
1794 | Expander_Mode_Restore; | |
1795 | Full_Analysis := Save_Full_Analysis; | |
45fc7ddb | 1796 | end Preanalyze_And_Resolve; |
996ae0b0 RK |
1797 | |
1798 | ---------------------------------- | |
1799 | -- Replace_Actual_Discriminants -- | |
1800 | ---------------------------------- | |
1801 | ||
1802 | procedure Replace_Actual_Discriminants (N : Node_Id; Default : Node_Id) is | |
1803 | Loc : constant Source_Ptr := Sloc (N); | |
1804 | Tsk : Node_Id := Empty; | |
1805 | ||
1806 | function Process_Discr (Nod : Node_Id) return Traverse_Result; | |
e0296583 | 1807 | -- Comment needed??? |
996ae0b0 RK |
1808 | |
1809 | ------------------- | |
1810 | -- Process_Discr -- | |
1811 | ------------------- | |
1812 | ||
1813 | function Process_Discr (Nod : Node_Id) return Traverse_Result is | |
1814 | Ent : Entity_Id; | |
1815 | ||
1816 | begin | |
1817 | if Nkind (Nod) = N_Identifier then | |
1818 | Ent := Entity (Nod); | |
1819 | ||
1820 | if Present (Ent) | |
1821 | and then Ekind (Ent) = E_Discriminant | |
1822 | then | |
1823 | Rewrite (Nod, | |
1824 | Make_Selected_Component (Loc, | |
1825 | Prefix => New_Copy_Tree (Tsk, New_Sloc => Loc), | |
1826 | Selector_Name => Make_Identifier (Loc, Chars (Ent)))); | |
1827 | ||
1828 | Set_Etype (Nod, Etype (Ent)); | |
1829 | end if; | |
1830 | ||
1831 | end if; | |
1832 | ||
1833 | return OK; | |
1834 | end Process_Discr; | |
1835 | ||
1836 | procedure Replace_Discrs is new Traverse_Proc (Process_Discr); | |
1837 | ||
1838 | -- Start of processing for Replace_Actual_Discriminants | |
1839 | ||
1840 | begin | |
4460a9bc | 1841 | if not Expander_Active then |
996ae0b0 RK |
1842 | return; |
1843 | end if; | |
1844 | ||
1845 | if Nkind (Name (N)) = N_Selected_Component then | |
1846 | Tsk := Prefix (Name (N)); | |
1847 | ||
1848 | elsif Nkind (Name (N)) = N_Indexed_Component then | |
1849 | Tsk := Prefix (Prefix (Name (N))); | |
1850 | end if; | |
1851 | ||
1852 | if No (Tsk) then | |
1853 | return; | |
1854 | else | |
1855 | Replace_Discrs (Default); | |
1856 | end if; | |
1857 | end Replace_Actual_Discriminants; | |
1858 | ||
1859 | ------------- | |
1860 | -- Resolve -- | |
1861 | ------------- | |
1862 | ||
1863 | procedure Resolve (N : Node_Id; Typ : Entity_Id) is | |
dae2b8ea HK |
1864 | Ambiguous : Boolean := False; |
1865 | Ctx_Type : Entity_Id := Typ; | |
1866 | Expr_Type : Entity_Id := Empty; -- prevent junk warning | |
1867 | Err_Type : Entity_Id := Empty; | |
1868 | Found : Boolean := False; | |
1869 | From_Lib : Boolean; | |
996ae0b0 | 1870 | I : Interp_Index; |
dae2b8ea | 1871 | I1 : Interp_Index := 0; -- prevent junk warning |
996ae0b0 RK |
1872 | It : Interp; |
1873 | It1 : Interp; | |
996ae0b0 | 1874 | Seen : Entity_Id := Empty; -- prevent junk warning |
dae2b8ea HK |
1875 | |
1876 | function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean; | |
1877 | -- Determine whether a node comes from a predefined library unit or | |
1878 | -- Standard. | |
996ae0b0 RK |
1879 | |
1880 | procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id); | |
1881 | -- Try and fix up a literal so that it matches its expected type. New | |
1882 | -- literals are manufactured if necessary to avoid cascaded errors. | |
1883 | ||
7415029d AC |
1884 | procedure Report_Ambiguous_Argument; |
1885 | -- Additional diagnostics when an ambiguous call has an ambiguous | |
1886 | -- argument (typically a controlling actual). | |
1887 | ||
996ae0b0 RK |
1888 | procedure Resolution_Failed; |
1889 | -- Called when attempt at resolving current expression fails | |
1890 | ||
dae2b8ea HK |
1891 | ------------------------------------ |
1892 | -- Comes_From_Predefined_Lib_Unit -- | |
1893 | ------------------------------------- | |
1894 | ||
1895 | function Comes_From_Predefined_Lib_Unit (Nod : Node_Id) return Boolean is | |
1896 | begin | |
1897 | return | |
1898 | Sloc (Nod) = Standard_Location | |
5cc9353d RD |
1899 | or else Is_Predefined_File_Name |
1900 | (Unit_File_Name (Get_Source_Unit (Sloc (Nod)))); | |
dae2b8ea HK |
1901 | end Comes_From_Predefined_Lib_Unit; |
1902 | ||
996ae0b0 RK |
1903 | -------------------- |
1904 | -- Patch_Up_Value -- | |
1905 | -------------------- | |
1906 | ||
1907 | procedure Patch_Up_Value (N : Node_Id; Typ : Entity_Id) is | |
1908 | begin | |
e0296583 | 1909 | if Nkind (N) = N_Integer_Literal and then Is_Real_Type (Typ) then |
996ae0b0 RK |
1910 | Rewrite (N, |
1911 | Make_Real_Literal (Sloc (N), | |
1912 | Realval => UR_From_Uint (Intval (N)))); | |
1913 | Set_Etype (N, Universal_Real); | |
1914 | Set_Is_Static_Expression (N); | |
1915 | ||
e0296583 | 1916 | elsif Nkind (N) = N_Real_Literal and then Is_Integer_Type (Typ) then |
996ae0b0 RK |
1917 | Rewrite (N, |
1918 | Make_Integer_Literal (Sloc (N), | |
1919 | Intval => UR_To_Uint (Realval (N)))); | |
1920 | Set_Etype (N, Universal_Integer); | |
1921 | Set_Is_Static_Expression (N); | |
45fc7ddb | 1922 | |
996ae0b0 | 1923 | elsif Nkind (N) = N_String_Literal |
e0296583 | 1924 | and then Is_Character_Type (Typ) |
996ae0b0 RK |
1925 | then |
1926 | Set_Character_Literal_Name (Char_Code (Character'Pos ('A'))); | |
1927 | Rewrite (N, | |
1928 | Make_Character_Literal (Sloc (N), | |
1929 | Chars => Name_Find, | |
82c80734 RD |
1930 | Char_Literal_Value => |
1931 | UI_From_Int (Character'Pos ('A')))); | |
996ae0b0 RK |
1932 | Set_Etype (N, Any_Character); |
1933 | Set_Is_Static_Expression (N); | |
1934 | ||
e0296583 | 1935 | elsif Nkind (N) /= N_String_Literal and then Is_String_Type (Typ) then |
996ae0b0 RK |
1936 | Rewrite (N, |
1937 | Make_String_Literal (Sloc (N), | |
1938 | Strval => End_String)); | |
1939 | ||
1940 | elsif Nkind (N) = N_Range then | |
e0296583 | 1941 | Patch_Up_Value (Low_Bound (N), Typ); |
996ae0b0 RK |
1942 | Patch_Up_Value (High_Bound (N), Typ); |
1943 | end if; | |
1944 | end Patch_Up_Value; | |
1945 | ||
7415029d AC |
1946 | ------------------------------- |
1947 | -- Report_Ambiguous_Argument -- | |
1948 | ------------------------------- | |
1949 | ||
1950 | procedure Report_Ambiguous_Argument is | |
1951 | Arg : constant Node_Id := First (Parameter_Associations (N)); | |
1952 | I : Interp_Index; | |
1953 | It : Interp; | |
1954 | ||
1955 | begin | |
1956 | if Nkind (Arg) = N_Function_Call | |
1957 | and then Is_Entity_Name (Name (Arg)) | |
1958 | and then Is_Overloaded (Name (Arg)) | |
1959 | then | |
ed2233dc | 1960 | Error_Msg_NE ("ambiguous call to&", Arg, Name (Arg)); |
7415029d | 1961 | |
e0296583 | 1962 | -- Could use comments on what is going on here??? |
bfc07071 | 1963 | |
7415029d AC |
1964 | Get_First_Interp (Name (Arg), I, It); |
1965 | while Present (It.Nam) loop | |
1966 | Error_Msg_Sloc := Sloc (It.Nam); | |
1967 | ||
1968 | if Nkind (Parent (It.Nam)) = N_Full_Type_Declaration then | |
ed2233dc | 1969 | Error_Msg_N ("interpretation (inherited) #!", Arg); |
7415029d | 1970 | else |
ed2233dc | 1971 | Error_Msg_N ("interpretation #!", Arg); |
7415029d AC |
1972 | end if; |
1973 | ||
1974 | Get_Next_Interp (I, It); | |
1975 | end loop; | |
1976 | end if; | |
1977 | end Report_Ambiguous_Argument; | |
1978 | ||
996ae0b0 RK |
1979 | ----------------------- |
1980 | -- Resolution_Failed -- | |
1981 | ----------------------- | |
1982 | ||
1983 | procedure Resolution_Failed is | |
1984 | begin | |
1985 | Patch_Up_Value (N, Typ); | |
405b907c AC |
1986 | |
1987 | -- Set the type to the desired one to minimize cascaded errors. Note | |
1988 | -- that this is an approximation and does not work in all cases. | |
1989 | ||
996ae0b0 | 1990 | Set_Etype (N, Typ); |
405b907c | 1991 | |
996ae0b0 RK |
1992 | Debug_A_Exit ("resolving ", N, " (done, resolution failed)"); |
1993 | Set_Is_Overloaded (N, False); | |
1994 | ||
1995 | -- The caller will return without calling the expander, so we need | |
1996 | -- to set the analyzed flag. Note that it is fine to set Analyzed | |
1997 | -- to True even if we are in the middle of a shallow analysis, | |
1998 | -- (see the spec of sem for more details) since this is an error | |
1999 | -- situation anyway, and there is no point in repeating the | |
2000 | -- analysis later (indeed it won't work to repeat it later, since | |
2001 | -- we haven't got a clear resolution of which entity is being | |
2002 | -- referenced.) | |
2003 | ||
2004 | Set_Analyzed (N, True); | |
2005 | return; | |
2006 | end Resolution_Failed; | |
2007 | ||
2008 | -- Start of processing for Resolve | |
2009 | ||
2010 | begin | |
5c736541 RD |
2011 | if N = Error then |
2012 | return; | |
2013 | end if; | |
2014 | ||
e0296583 AC |
2015 | -- Access attribute on remote subprogram cannot be used for a non-remote |
2016 | -- access-to-subprogram type. | |
996ae0b0 RK |
2017 | |
2018 | if Nkind (N) = N_Attribute_Reference | |
b69cd36a AC |
2019 | and then Nam_In (Attribute_Name (N), Name_Access, |
2020 | Name_Unrestricted_Access, | |
2021 | Name_Unchecked_Access) | |
996ae0b0 RK |
2022 | and then Comes_From_Source (N) |
2023 | and then Is_Entity_Name (Prefix (N)) | |
2024 | and then Is_Subprogram (Entity (Prefix (N))) | |
2025 | and then Is_Remote_Call_Interface (Entity (Prefix (N))) | |
2026 | and then not Is_Remote_Access_To_Subprogram_Type (Typ) | |
2027 | then | |
2028 | Error_Msg_N | |
2029 | ("prefix must statically denote a non-remote subprogram", N); | |
2030 | end if; | |
2031 | ||
dae2b8ea HK |
2032 | From_Lib := Comes_From_Predefined_Lib_Unit (N); |
2033 | ||
996ae0b0 RK |
2034 | -- If the context is a Remote_Access_To_Subprogram, access attributes |
2035 | -- must be resolved with the corresponding fat pointer. There is no need | |
2036 | -- to check for the attribute name since the return type of an | |
2037 | -- attribute is never a remote type. | |
2038 | ||
2039 | if Nkind (N) = N_Attribute_Reference | |
2040 | and then Comes_From_Source (N) | |
19fb051c | 2041 | and then (Is_Remote_Call_Interface (Typ) or else Is_Remote_Types (Typ)) |
996ae0b0 RK |
2042 | then |
2043 | declare | |
2044 | Attr : constant Attribute_Id := | |
2045 | Get_Attribute_Id (Attribute_Name (N)); | |
2046 | Pref : constant Node_Id := Prefix (N); | |
2047 | Decl : Node_Id; | |
2048 | Spec : Node_Id; | |
2049 | Is_Remote : Boolean := True; | |
2050 | ||
2051 | begin | |
a77842bd | 2052 | -- Check that Typ is a remote access-to-subprogram type |
996ae0b0 | 2053 | |
a77842bd | 2054 | if Is_Remote_Access_To_Subprogram_Type (Typ) then |
955871d3 | 2055 | |
996ae0b0 RK |
2056 | -- Prefix (N) must statically denote a remote subprogram |
2057 | -- declared in a package specification. | |
2058 | ||
799d0e05 AC |
2059 | if Attr = Attribute_Access or else |
2060 | Attr = Attribute_Unchecked_Access or else | |
2061 | Attr = Attribute_Unrestricted_Access | |
2062 | then | |
996ae0b0 RK |
2063 | Decl := Unit_Declaration_Node (Entity (Pref)); |
2064 | ||
2065 | if Nkind (Decl) = N_Subprogram_Body then | |
2066 | Spec := Corresponding_Spec (Decl); | |
2067 | ||
b8e6830b | 2068 | if Present (Spec) then |
996ae0b0 RK |
2069 | Decl := Unit_Declaration_Node (Spec); |
2070 | end if; | |
2071 | end if; | |
2072 | ||
2073 | Spec := Parent (Decl); | |
2074 | ||
2075 | if not Is_Entity_Name (Prefix (N)) | |
2076 | or else Nkind (Spec) /= N_Package_Specification | |
2077 | or else | |
2078 | not Is_Remote_Call_Interface (Defining_Entity (Spec)) | |
2079 | then | |
2080 | Is_Remote := False; | |
2081 | Error_Msg_N | |
2082 | ("prefix must statically denote a remote subprogram ", | |
2083 | N); | |
2084 | end if; | |
996ae0b0 | 2085 | |
799d0e05 AC |
2086 | -- If we are generating code in distributed mode, perform |
2087 | -- semantic checks against corresponding remote entities. | |
fbf5a39b | 2088 | |
4460a9bc | 2089 | if Expander_Active |
799d0e05 AC |
2090 | and then Get_PCS_Name /= Name_No_DSA |
2091 | then | |
2092 | Check_Subtype_Conformant | |
2093 | (New_Id => Entity (Prefix (N)), | |
2094 | Old_Id => Designated_Type | |
2095 | (Corresponding_Remote_Type (Typ)), | |
2096 | Err_Loc => N); | |
2097 | ||
2098 | if Is_Remote then | |
2099 | Process_Remote_AST_Attribute (N, Typ); | |
2100 | end if; | |
996ae0b0 RK |
2101 | end if; |
2102 | end if; | |
2103 | end if; | |
2104 | end; | |
2105 | end if; | |
2106 | ||
2107 | Debug_A_Entry ("resolving ", N); | |
fe58fea7 | 2108 | |
ee1a7572 AC |
2109 | if Debug_Flag_V then |
2110 | Write_Overloads (N); | |
2111 | end if; | |
996ae0b0 | 2112 | |
07fc65c4 GB |
2113 | if Comes_From_Source (N) then |
2114 | if Is_Fixed_Point_Type (Typ) then | |
2115 | Check_Restriction (No_Fixed_Point, N); | |
996ae0b0 | 2116 | |
07fc65c4 GB |
2117 | elsif Is_Floating_Point_Type (Typ) |
2118 | and then Typ /= Universal_Real | |
2119 | and then Typ /= Any_Real | |
2120 | then | |
2121 | Check_Restriction (No_Floating_Point, N); | |
2122 | end if; | |
996ae0b0 RK |
2123 | end if; |
2124 | ||
2125 | -- Return if already analyzed | |
2126 | ||
2127 | if Analyzed (N) then | |
2128 | Debug_A_Exit ("resolving ", N, " (done, already analyzed)"); | |
dec6faf1 | 2129 | Analyze_Dimension (N); |
996ae0b0 RK |
2130 | return; |
2131 | ||
3e586e10 AC |
2132 | -- Any case of Any_Type as the Etype value means that we had a |
2133 | -- previous error. | |
1486a00e AC |
2134 | |
2135 | elsif Etype (N) = Any_Type then | |
996ae0b0 RK |
2136 | Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)"); |
2137 | return; | |
2138 | end if; | |
2139 | ||
2140 | Check_Parameterless_Call (N); | |
2141 | ||
064f4527 TQ |
2142 | -- The resolution of an Expression_With_Actions is determined by |
2143 | -- its Expression. | |
2144 | ||
2145 | if Nkind (N) = N_Expression_With_Actions then | |
2146 | Resolve (Expression (N), Typ); | |
2147 | ||
2148 | Found := True; | |
2149 | Expr_Type := Etype (Expression (N)); | |
2150 | ||
996ae0b0 RK |
2151 | -- If not overloaded, then we know the type, and all that needs doing |
2152 | -- is to check that this type is compatible with the context. | |
2153 | ||
064f4527 | 2154 | elsif not Is_Overloaded (N) then |
996ae0b0 RK |
2155 | Found := Covers (Typ, Etype (N)); |
2156 | Expr_Type := Etype (N); | |
2157 | ||
2158 | -- In the overloaded case, we must select the interpretation that | |
2159 | -- is compatible with the context (i.e. the type passed to Resolve) | |
2160 | ||
2161 | else | |
996ae0b0 RK |
2162 | -- Loop through possible interpretations |
2163 | ||
1420b484 | 2164 | Get_First_Interp (N, I, It); |
996ae0b0 | 2165 | Interp_Loop : while Present (It.Typ) loop |
ee1a7572 AC |
2166 | if Debug_Flag_V then |
2167 | Write_Str ("Interp: "); | |
2168 | Write_Interp (It); | |
2169 | end if; | |
2170 | ||
996ae0b0 | 2171 | -- We are only interested in interpretations that are compatible |
aa5147f0 | 2172 | -- with the expected type, any other interpretations are ignored. |
996ae0b0 | 2173 | |
fbf5a39b AC |
2174 | if not Covers (Typ, It.Typ) then |
2175 | if Debug_Flag_V then | |
2176 | Write_Str (" interpretation incompatible with context"); | |
2177 | Write_Eol; | |
2178 | end if; | |
996ae0b0 | 2179 | |
fbf5a39b | 2180 | else |
aa5147f0 ES |
2181 | -- Skip the current interpretation if it is disabled by an |
2182 | -- abstract operator. This action is performed only when the | |
2183 | -- type against which we are resolving is the same as the | |
2184 | -- type of the interpretation. | |
2185 | ||
0791fbe9 | 2186 | if Ada_Version >= Ada_2005 |
aa5147f0 ES |
2187 | and then It.Typ = Typ |
2188 | and then Typ /= Universal_Integer | |
2189 | and then Typ /= Universal_Real | |
2190 | and then Present (It.Abstract_Op) | |
2191 | then | |
ee1a7572 AC |
2192 | if Debug_Flag_V then |
2193 | Write_Line ("Skip."); | |
2194 | end if; | |
2195 | ||
aa5147f0 ES |
2196 | goto Continue; |
2197 | end if; | |
2198 | ||
996ae0b0 RK |
2199 | -- First matching interpretation |
2200 | ||
2201 | if not Found then | |
2202 | Found := True; | |
2203 | I1 := I; | |
2204 | Seen := It.Nam; | |
2205 | Expr_Type := It.Typ; | |
2206 | ||
fbf5a39b | 2207 | -- Matching interpretation that is not the first, maybe an |
996ae0b0 RK |
2208 | -- error, but there are some cases where preference rules are |
2209 | -- used to choose between the two possibilities. These and | |
2210 | -- some more obscure cases are handled in Disambiguate. | |
2211 | ||
2212 | else | |
90b51aaf AC |
2213 | -- If the current statement is part of a predefined library |
2214 | -- unit, then all interpretations which come from user level | |
2215 | -- packages should not be considered. Check previous and | |
2216 | -- current one. | |
2217 | ||
2218 | if From_Lib then | |
2219 | if not Comes_From_Predefined_Lib_Unit (It.Nam) then | |
2220 | goto Continue; | |
2221 | ||
2222 | elsif not Comes_From_Predefined_Lib_Unit (Seen) then | |
2223 | ||
c2e54001 | 2224 | -- Previous interpretation must be discarded |
90b51aaf | 2225 | |
c2e54001 AC |
2226 | I1 := I; |
2227 | Seen := It.Nam; | |
90b51aaf AC |
2228 | Expr_Type := It.Typ; |
2229 | Set_Entity (N, Seen); | |
2230 | goto Continue; | |
2231 | end if; | |
dae2b8ea HK |
2232 | end if; |
2233 | ||
c2e54001 | 2234 | -- Otherwise apply further disambiguation steps |
90b51aaf | 2235 | |
996ae0b0 RK |
2236 | Error_Msg_Sloc := Sloc (Seen); |
2237 | It1 := Disambiguate (N, I1, I, Typ); | |
2238 | ||
fbf5a39b AC |
2239 | -- Disambiguation has succeeded. Skip the remaining |
2240 | -- interpretations. | |
996ae0b0 | 2241 | |
fbf5a39b AC |
2242 | if It1 /= No_Interp then |
2243 | Seen := It1.Nam; | |
2244 | Expr_Type := It1.Typ; | |
2245 | ||
2246 | while Present (It.Typ) loop | |
2247 | Get_Next_Interp (I, It); | |
2248 | end loop; | |
2249 | ||
2250 | else | |
0310af44 AC |
2251 | -- Before we issue an ambiguity complaint, check for the |
2252 | -- case of a subprogram call where at least one of the | |
2253 | -- arguments is Any_Type, and if so suppress the message, | |
2254 | -- since it is a cascaded error. This can also happen for | |
2255 | -- a generalized indexing operation. | |
2256 | ||
2257 | if Nkind (N) in N_Subprogram_Call | |
2258 | or else (Nkind (N) = N_Indexed_Component | |
2259 | and then Present (Generalized_Indexing (N))) | |
2260 | then | |
996ae0b0 | 2261 | declare |
1420b484 | 2262 | A : Node_Id; |
996ae0b0 RK |
2263 | E : Node_Id; |
2264 | ||
2265 | begin | |
0310af44 AC |
2266 | if Nkind (N) = N_Indexed_Component then |
2267 | Rewrite (N, Generalized_Indexing (N)); | |
2268 | end if; | |
2269 | ||
1420b484 | 2270 | A := First_Actual (N); |
996ae0b0 RK |
2271 | while Present (A) loop |
2272 | E := A; | |
2273 | ||
2274 | if Nkind (E) = N_Parameter_Association then | |
2275 | E := Explicit_Actual_Parameter (E); | |
2276 | end if; | |
2277 | ||
2278 | if Etype (E) = Any_Type then | |
2279 | if Debug_Flag_V then | |
2280 | Write_Str ("Any_Type in call"); | |
2281 | Write_Eol; | |
2282 | end if; | |
2283 | ||
2284 | exit Interp_Loop; | |
2285 | end if; | |
2286 | ||
2287 | Next_Actual (A); | |
2288 | end loop; | |
2289 | end; | |
2290 | ||
aa5147f0 | 2291 | elsif Nkind (N) in N_Binary_Op |
996ae0b0 RK |
2292 | and then (Etype (Left_Opnd (N)) = Any_Type |
2293 | or else Etype (Right_Opnd (N)) = Any_Type) | |
2294 | then | |
2295 | exit Interp_Loop; | |
2296 | ||
21d7ef70 | 2297 | elsif Nkind (N) in N_Unary_Op |
996ae0b0 RK |
2298 | and then Etype (Right_Opnd (N)) = Any_Type |
2299 | then | |
2300 | exit Interp_Loop; | |
2301 | end if; | |
2302 | ||
0310af44 AC |
2303 | -- Not that special case, so issue message using the flag |
2304 | -- Ambiguous to control printing of the header message | |
2305 | -- only at the start of an ambiguous set. | |
996ae0b0 RK |
2306 | |
2307 | if not Ambiguous then | |
aa180613 RD |
2308 | if Nkind (N) = N_Function_Call |
2309 | and then Nkind (Name (N)) = N_Explicit_Dereference | |
2310 | then | |
ed2233dc | 2311 | Error_Msg_N |
0310af44 AC |
2312 | ("ambiguous expression (cannot resolve indirect " |
2313 | & "call)!", N); | |
aa180613 | 2314 | else |
483c78cb | 2315 | Error_Msg_NE -- CODEFIX |
aa180613 RD |
2316 | ("ambiguous expression (cannot resolve&)!", |
2317 | N, It.Nam); | |
2318 | end if; | |
fbf5a39b | 2319 | |
996ae0b0 | 2320 | Ambiguous := True; |
0669bebe GB |
2321 | |
2322 | if Nkind (Parent (Seen)) = N_Full_Type_Declaration then | |
ed2233dc | 2323 | Error_Msg_N |
0669bebe GB |
2324 | ("\\possible interpretation (inherited)#!", N); |
2325 | else | |
4e7a4f6e AC |
2326 | Error_Msg_N -- CODEFIX |
2327 | ("\\possible interpretation#!", N); | |
0669bebe | 2328 | end if; |
7415029d | 2329 | |
d3b00ce3 | 2330 | if Nkind (N) in N_Subprogram_Call |
7415029d AC |
2331 | and then Present (Parameter_Associations (N)) |
2332 | then | |
2333 | Report_Ambiguous_Argument; | |
2334 | end if; | |
996ae0b0 RK |
2335 | end if; |
2336 | ||
2337 | Error_Msg_Sloc := Sloc (It.Nam); | |
996ae0b0 | 2338 | |
fbf5a39b | 2339 | -- By default, the error message refers to the candidate |
0669bebe GB |
2340 | -- interpretation. But if it is a predefined operator, it |
2341 | -- is implicitly declared at the declaration of the type | |
2342 | -- of the operand. Recover the sloc of that declaration | |
2343 | -- for the error message. | |
fbf5a39b AC |
2344 | |
2345 | if Nkind (N) in N_Op | |
2346 | and then Scope (It.Nam) = Standard_Standard | |
2347 | and then not Is_Overloaded (Right_Opnd (N)) | |
0669bebe GB |
2348 | and then Scope (Base_Type (Etype (Right_Opnd (N)))) /= |
2349 | Standard_Standard | |
fbf5a39b AC |
2350 | then |
2351 | Err_Type := First_Subtype (Etype (Right_Opnd (N))); | |
2352 | ||
2353 | if Comes_From_Source (Err_Type) | |
2354 | and then Present (Parent (Err_Type)) | |
2355 | then | |
2356 | Error_Msg_Sloc := Sloc (Parent (Err_Type)); | |
2357 | end if; | |
2358 | ||
2359 | elsif Nkind (N) in N_Binary_Op | |
2360 | and then Scope (It.Nam) = Standard_Standard | |
2361 | and then not Is_Overloaded (Left_Opnd (N)) | |
0669bebe GB |
2362 | and then Scope (Base_Type (Etype (Left_Opnd (N)))) /= |
2363 | Standard_Standard | |
fbf5a39b AC |
2364 | then |
2365 | Err_Type := First_Subtype (Etype (Left_Opnd (N))); | |
2366 | ||
2367 | if Comes_From_Source (Err_Type) | |
2368 | and then Present (Parent (Err_Type)) | |
2369 | then | |
2370 | Error_Msg_Sloc := Sloc (Parent (Err_Type)); | |
2371 | end if; | |
aa180613 RD |
2372 | |
2373 | -- If this is an indirect call, use the subprogram_type | |
5cc9353d RD |
2374 | -- in the message, to have a meaningful location. Also |
2375 | -- indicate if this is an inherited operation, created | |
2376 | -- by a type declaration. | |
aa180613 RD |
2377 | |
2378 | elsif Nkind (N) = N_Function_Call | |
2379 | and then Nkind (Name (N)) = N_Explicit_Dereference | |
2380 | and then Is_Type (It.Nam) | |
2381 | then | |
2382 | Err_Type := It.Nam; | |
2383 | Error_Msg_Sloc := | |
2384 | Sloc (Associated_Node_For_Itype (Err_Type)); | |
fbf5a39b AC |
2385 | else |
2386 | Err_Type := Empty; | |
2387 | end if; | |
2388 | ||
2389 | if Nkind (N) in N_Op | |
2390 | and then Scope (It.Nam) = Standard_Standard | |
2391 | and then Present (Err_Type) | |
2392 | then | |
aa5147f0 ES |
2393 | -- Special-case the message for universal_fixed |
2394 | -- operators, which are not declared with the type | |
2395 | -- of the operand, but appear forever in Standard. | |
2396 | ||
9fe696a3 | 2397 | if It.Typ = Universal_Fixed |
aa5147f0 ES |
2398 | and then Scope (It.Nam) = Standard_Standard |
2399 | then | |
ed2233dc | 2400 | Error_Msg_N |
1486a00e AC |
2401 | ("\\possible interpretation as universal_fixed " |
2402 | & "operation (RM 4.5.5 (19))", N); | |
aa5147f0 | 2403 | else |
ed2233dc | 2404 | Error_Msg_N |
aa5147f0 ES |
2405 | ("\\possible interpretation (predefined)#!", N); |
2406 | end if; | |
aa180613 RD |
2407 | |
2408 | elsif | |
2409 | Nkind (Parent (It.Nam)) = N_Full_Type_Declaration | |
2410 | then | |
ed2233dc | 2411 | Error_Msg_N |
aa180613 | 2412 | ("\\possible interpretation (inherited)#!", N); |
fbf5a39b | 2413 | else |
4e7a4f6e AC |
2414 | Error_Msg_N -- CODEFIX |
2415 | ("\\possible interpretation#!", N); | |
fbf5a39b | 2416 | end if; |
996ae0b0 | 2417 | |
996ae0b0 RK |
2418 | end if; |
2419 | end if; | |
2420 | ||
0669bebe GB |
2421 | -- We have a matching interpretation, Expr_Type is the type |
2422 | -- from this interpretation, and Seen is the entity. | |
996ae0b0 | 2423 | |
0669bebe GB |
2424 | -- For an operator, just set the entity name. The type will be |
2425 | -- set by the specific operator resolution routine. | |
996ae0b0 RK |
2426 | |
2427 | if Nkind (N) in N_Op then | |
2428 | Set_Entity (N, Seen); | |
2429 | Generate_Reference (Seen, N); | |
2430 | ||
19d846a0 RD |
2431 | elsif Nkind (N) = N_Case_Expression then |
2432 | Set_Etype (N, Expr_Type); | |
2433 | ||
996ae0b0 RK |
2434 | elsif Nkind (N) = N_Character_Literal then |
2435 | Set_Etype (N, Expr_Type); | |
2436 | ||
9b16cb57 | 2437 | elsif Nkind (N) = N_If_Expression then |
e0ba1bfd ES |
2438 | Set_Etype (N, Expr_Type); |
2439 | ||
dedac3eb RD |
2440 | -- AI05-0139-2: Expression is overloaded because type has |
2441 | -- implicit dereference. If type matches context, no implicit | |
2442 | -- dereference is involved. | |
44a10091 AC |
2443 | |
2444 | elsif Has_Implicit_Dereference (Expr_Type) then | |
2445 | Set_Etype (N, Expr_Type); | |
2446 | Set_Is_Overloaded (N, False); | |
2447 | exit Interp_Loop; | |
2448 | ||
2449 | elsif Is_Overloaded (N) | |
2450 | and then Present (It.Nam) | |
2451 | and then Ekind (It.Nam) = E_Discriminant | |
2452 | and then Has_Implicit_Dereference (It.Nam) | |
2453 | then | |
5f50020a ES |
2454 | -- If the node is a general indexing, the dereference is |
2455 | -- is inserted when resolving the rewritten form, else | |
2456 | -- insert it now. | |
2457 | ||
2458 | if Nkind (N) /= N_Indexed_Component | |
2459 | or else No (Generalized_Indexing (N)) | |
2460 | then | |
2461 | Build_Explicit_Dereference (N, It.Nam); | |
2462 | end if; | |
44a10091 | 2463 | |
996ae0b0 | 2464 | -- For an explicit dereference, attribute reference, range, |
0669bebe GB |
2465 | -- short-circuit form (which is not an operator node), or call |
2466 | -- with a name that is an explicit dereference, there is | |
2467 | -- nothing to be done at this point. | |
996ae0b0 | 2468 | |
4f324de2 | 2469 | elsif Nkind_In (N, N_Attribute_Reference, |
45fc7ddb | 2470 | N_And_Then, |
4f324de2 | 2471 | N_Explicit_Dereference, |
f4ef7b06 | 2472 | N_Identifier, |
4f324de2 | 2473 | N_Indexed_Component, |
45fc7ddb HK |
2474 | N_Or_Else, |
2475 | N_Range, | |
2476 | N_Selected_Component, | |
2477 | N_Slice) | |
996ae0b0 RK |
2478 | or else Nkind (Name (N)) = N_Explicit_Dereference |
2479 | then | |
2480 | null; | |
2481 | ||
0669bebe | 2482 | -- For procedure or function calls, set the type of the name, |
4519314c | 2483 | -- and also the entity pointer for the prefix. |
996ae0b0 | 2484 | |
d3b00ce3 | 2485 | elsif Nkind (N) in N_Subprogram_Call |
a3f2babd | 2486 | and then Is_Entity_Name (Name (N)) |
996ae0b0 RK |
2487 | then |
2488 | Set_Etype (Name (N), Expr_Type); | |
2489 | Set_Entity (Name (N), Seen); | |
2490 | Generate_Reference (Seen, Name (N)); | |
2491 | ||
2492 | elsif Nkind (N) = N_Function_Call | |
2493 | and then Nkind (Name (N)) = N_Selected_Component | |
2494 | then | |
2495 | Set_Etype (Name (N), Expr_Type); | |
2496 | Set_Entity (Selector_Name (Name (N)), Seen); | |
2497 | Generate_Reference (Seen, Selector_Name (Name (N))); | |
2498 | ||
2499 | -- For all other cases, just set the type of the Name | |
2500 | ||
2501 | else | |
2502 | Set_Etype (Name (N), Expr_Type); | |
2503 | end if; | |
2504 | ||
996ae0b0 RK |
2505 | end if; |
2506 | ||
aa5147f0 ES |
2507 | <<Continue>> |
2508 | ||
996ae0b0 RK |
2509 | -- Move to next interpretation |
2510 | ||
c8ef728f | 2511 | exit Interp_Loop when No (It.Typ); |
996ae0b0 RK |
2512 | |
2513 | Get_Next_Interp (I, It); | |
2514 | end loop Interp_Loop; | |
2515 | end if; | |
2516 | ||
2517 | -- At this stage Found indicates whether or not an acceptable | |
4519314c AC |
2518 | -- interpretation exists. If not, then we have an error, except that if |
2519 | -- the context is Any_Type as a result of some other error, then we | |
2520 | -- suppress the error report. | |
996ae0b0 RK |
2521 | |
2522 | if not Found then | |
2523 | if Typ /= Any_Type then | |
2524 | ||
0669bebe GB |
2525 | -- If type we are looking for is Void, then this is the procedure |
2526 | -- call case, and the error is simply that what we gave is not a | |
2527 | -- procedure name (we think of procedure calls as expressions with | |
159a5104 | 2528 | -- types internally, but the user doesn't think of them this way). |
996ae0b0 RK |
2529 | |
2530 | if Typ = Standard_Void_Type then | |
91b1417d AC |
2531 | |
2532 | -- Special case message if function used as a procedure | |
2533 | ||
2534 | if Nkind (N) = N_Procedure_Call_Statement | |
2535 | and then Is_Entity_Name (Name (N)) | |
2536 | and then Ekind (Entity (Name (N))) = E_Function | |
2537 | then | |
2538 | Error_Msg_NE | |
2539 | ("cannot use function & in a procedure call", | |
2540 | Name (N), Entity (Name (N))); | |
2541 | ||
0669bebe | 2542 | -- Otherwise give general message (not clear what cases this |
a90bd866 | 2543 | -- covers, but no harm in providing for them). |
91b1417d AC |
2544 | |
2545 | else | |
2546 | Error_Msg_N ("expect procedure name in procedure call", N); | |
2547 | end if; | |
2548 | ||
996ae0b0 RK |
2549 | Found := True; |
2550 | ||
2551 | -- Otherwise we do have a subexpression with the wrong type | |
2552 | ||
0669bebe GB |
2553 | -- Check for the case of an allocator which uses an access type |
2554 | -- instead of the designated type. This is a common error and we | |
2555 | -- specialize the message, posting an error on the operand of the | |
2556 | -- allocator, complaining that we expected the designated type of | |
2557 | -- the allocator. | |
996ae0b0 RK |
2558 | |
2559 | elsif Nkind (N) = N_Allocator | |
3f1bc2cf AC |
2560 | and then Is_Access_Type (Typ) |
2561 | and then Is_Access_Type (Etype (N)) | |
996ae0b0 RK |
2562 | and then Designated_Type (Etype (N)) = Typ |
2563 | then | |
2564 | Wrong_Type (Expression (N), Designated_Type (Typ)); | |
2565 | Found := True; | |
2566 | ||
0669bebe GB |
2567 | -- Check for view mismatch on Null in instances, for which the |
2568 | -- view-swapping mechanism has no identifier. | |
17be0cdf ES |
2569 | |
2570 | elsif (In_Instance or else In_Inlined_Body) | |
2571 | and then (Nkind (N) = N_Null) | |
2572 | and then Is_Private_Type (Typ) | |
2573 | and then Is_Access_Type (Full_View (Typ)) | |
2574 | then | |
2575 | Resolve (N, Full_View (Typ)); | |
2576 | Set_Etype (N, Typ); | |
2577 | return; | |
2578 | ||
aa180613 RD |
2579 | -- Check for an aggregate. Sometimes we can get bogus aggregates |
2580 | -- from misuse of parentheses, and we are about to complain about | |
2581 | -- the aggregate without even looking inside it. | |
996ae0b0 | 2582 | |
aa180613 RD |
2583 | -- Instead, if we have an aggregate of type Any_Composite, then |
2584 | -- analyze and resolve the component fields, and then only issue | |
2585 | -- another message if we get no errors doing this (otherwise | |
2586 | -- assume that the errors in the aggregate caused the problem). | |
996ae0b0 RK |
2587 | |
2588 | elsif Nkind (N) = N_Aggregate | |
2589 | and then Etype (N) = Any_Composite | |
2590 | then | |
996ae0b0 RK |
2591 | -- Disable expansion in any case. If there is a type mismatch |
2592 | -- it may be fatal to try to expand the aggregate. The flag | |
2593 | -- would otherwise be set to false when the error is posted. | |
2594 | ||
2595 | Expander_Active := False; | |
2596 | ||
2597 | declare | |
2598 | procedure Check_Aggr (Aggr : Node_Id); | |
aa180613 RD |
2599 | -- Check one aggregate, and set Found to True if we have a |
2600 | -- definite error in any of its elements | |
996ae0b0 RK |
2601 | |
2602 | procedure Check_Elmt (Aelmt : Node_Id); | |
aa180613 RD |
2603 | -- Check one element of aggregate and set Found to True if |
2604 | -- we definitely have an error in the element. | |
2605 | ||
2606 | ---------------- | |
2607 | -- Check_Aggr -- | |
2608 | ---------------- | |
996ae0b0 RK |
2609 | |
2610 | procedure Check_Aggr (Aggr : Node_Id) is | |
2611 | Elmt : Node_Id; | |
2612 | ||
2613 | begin | |
2614 | if Present (Expressions (Aggr)) then | |
2615 | Elmt := First (Expressions (Aggr)); | |
2616 | while Present (Elmt) loop | |
2617 | Check_Elmt (Elmt); | |
2618 | Next (Elmt); | |
2619 | end loop; | |
2620 | end if; | |
2621 | ||
2622 | if Present (Component_Associations (Aggr)) then | |
2623 | Elmt := First (Component_Associations (Aggr)); | |
2624 | while Present (Elmt) loop | |
aa180613 | 2625 | |
0669bebe GB |
2626 | -- If this is a default-initialized component, then |
2627 | -- there is nothing to check. The box will be | |
2628 | -- replaced by the appropriate call during late | |
2629 | -- expansion. | |
aa180613 | 2630 | |
f4ef7b06 AC |
2631 | if Nkind (Elmt) /= N_Iterated_Component_Association |
2632 | and then not Box_Present (Elmt) | |
2633 | then | |
aa180613 RD |
2634 | Check_Elmt (Expression (Elmt)); |
2635 | end if; | |
2636 | ||
996ae0b0 RK |
2637 | Next (Elmt); |
2638 | end loop; | |
2639 | end if; | |
2640 | end Check_Aggr; | |
2641 | ||
fbf5a39b AC |
2642 | ---------------- |
2643 | -- Check_Elmt -- | |
2644 | ---------------- | |
2645 | ||
996ae0b0 RK |
2646 | procedure Check_Elmt (Aelmt : Node_Id) is |
2647 | begin | |
2648 | -- If we have a nested aggregate, go inside it (to | |
5cc9353d RD |
2649 | -- attempt a naked analyze-resolve of the aggregate can |
2650 | -- cause undesirable cascaded errors). Do not resolve | |
2651 | -- expression if it needs a type from context, as for | |
2652 | -- integer * fixed expression. | |
996ae0b0 RK |
2653 | |
2654 | if Nkind (Aelmt) = N_Aggregate then | |
2655 | Check_Aggr (Aelmt); | |
2656 | ||
2657 | else | |
2658 | Analyze (Aelmt); | |
2659 | ||
2660 | if not Is_Overloaded (Aelmt) | |
2661 | and then Etype (Aelmt) /= Any_Fixed | |
2662 | then | |
fbf5a39b | 2663 | Resolve (Aelmt); |
996ae0b0 RK |
2664 | end if; |
2665 | ||
2666 | if Etype (Aelmt) = Any_Type then | |
2667 | Found := True; | |
2668 | end if; | |
2669 | end if; | |
2670 | end Check_Elmt; | |
2671 | ||
2672 | begin | |
2673 | Check_Aggr (N); | |
2674 | end; | |
2675 | end if; | |
2676 | ||
6fd0a72a AC |
2677 | -- Looks like we have a type error, but check for special case |
2678 | -- of Address wanted, integer found, with the configuration pragma | |
2679 | -- Allow_Integer_Address active. If we have this case, introduce | |
2680 | -- an unchecked conversion to allow the integer expression to be | |
2681 | -- treated as an Address. The reverse case of integer wanted, | |
2682 | -- Address found, is treated in an analogous manner. | |
2683 | ||
061828e3 AC |
2684 | if Address_Integer_Convert_OK (Typ, Etype (N)) then |
2685 | Rewrite (N, Unchecked_Convert_To (Typ, Relocate_Node (N))); | |
2686 | Analyze_And_Resolve (N, Typ); | |
2687 | return; | |
a8a42b93 AC |
2688 | |
2689 | -- Under relaxed RM semantics silently replace occurrences of null | |
3ab53b0d | 2690 | -- by System.Address_Null. |
a8a42b93 AC |
2691 | |
2692 | elsif Null_To_Null_Address_Convert_OK (N, Typ) then | |
2693 | Replace_Null_By_Null_Address (N); | |
2694 | Analyze_And_Resolve (N, Typ); | |
2695 | return; | |
6fd0a72a | 2696 | end if; |
818b578d | 2697 | |
3ab53b0d | 2698 | -- That special Allow_Integer_Address check did not apply, so we |
6fd0a72a AC |
2699 | -- have a real type error. If an error message was issued already, |
2700 | -- Found got reset to True, so if it's still False, issue standard | |
2701 | -- Wrong_Type message. | |
818b578d | 2702 | |
6fd0a72a AC |
2703 | if not Found then |
2704 | if Is_Overloaded (N) and then Nkind (N) = N_Function_Call then | |
65356e64 AC |
2705 | declare |
2706 | Subp_Name : Node_Id; | |
6fd0a72a | 2707 | |
65356e64 AC |
2708 | begin |
2709 | if Is_Entity_Name (Name (N)) then | |
2710 | Subp_Name := Name (N); | |
2711 | ||
2712 | elsif Nkind (Name (N)) = N_Selected_Component then | |
2713 | ||
a77842bd | 2714 | -- Protected operation: retrieve operation name |
65356e64 AC |
2715 | |
2716 | Subp_Name := Selector_Name (Name (N)); | |
19fb051c | 2717 | |
65356e64 AC |
2718 | else |
2719 | raise Program_Error; | |
2720 | end if; | |
2721 | ||
2722 | Error_Msg_Node_2 := Typ; | |
1486a00e | 2723 | Error_Msg_NE |
d65a80fd HK |
2724 | ("no visible interpretation of& matches expected type&", |
2725 | N, Subp_Name); | |
65356e64 | 2726 | end; |
996ae0b0 RK |
2727 | |
2728 | if All_Errors_Mode then | |
2729 | declare | |
2730 | Index : Interp_Index; | |
2731 | It : Interp; | |
2732 | ||
2733 | begin | |
aa180613 | 2734 | Error_Msg_N ("\\possible interpretations:", N); |
996ae0b0 | 2735 | |
1420b484 | 2736 | Get_First_Interp (Name (N), Index, It); |
996ae0b0 | 2737 | while Present (It.Nam) loop |
ea985d95 | 2738 | Error_Msg_Sloc := Sloc (It.Nam); |
aa5147f0 ES |
2739 | Error_Msg_Node_2 := It.Nam; |
2740 | Error_Msg_NE | |
2741 | ("\\ type& for & declared#", N, It.Typ); | |
996ae0b0 RK |
2742 | Get_Next_Interp (Index, It); |
2743 | end loop; | |
2744 | end; | |
aa5147f0 | 2745 | |
996ae0b0 RK |
2746 | else |
2747 | Error_Msg_N ("\use -gnatf for details", N); | |
2748 | end if; | |
19fb051c | 2749 | |
996ae0b0 RK |
2750 | else |
2751 | Wrong_Type (N, Typ); | |
2752 | end if; | |
2753 | end if; | |
2754 | end if; | |
2755 | ||
2756 | Resolution_Failed; | |
2757 | return; | |
2758 | ||
2759 | -- Test if we have more than one interpretation for the context | |
2760 | ||
2761 | elsif Ambiguous then | |
2762 | Resolution_Failed; | |
2763 | return; | |
2764 | ||
fe58fea7 AC |
2765 | -- Only one intepretation |
2766 | ||
996ae0b0 | 2767 | else |
ee1a7572 AC |
2768 | -- In Ada 2005, if we have something like "X : T := 2 + 2;", where |
2769 | -- the "+" on T is abstract, and the operands are of universal type, | |
2770 | -- the above code will have (incorrectly) resolved the "+" to the | |
fe58fea7 AC |
2771 | -- universal one in Standard. Therefore check for this case and give |
2772 | -- an error. We can't do this earlier, because it would cause legal | |
2773 | -- cases to get errors (when some other type has an abstract "+"). | |
ee1a7572 | 2774 | |
36504e5f AC |
2775 | if Ada_Version >= Ada_2005 |
2776 | and then Nkind (N) in N_Op | |
2777 | and then Is_Overloaded (N) | |
2778 | and then Is_Universal_Numeric_Type (Etype (Entity (N))) | |
ee1a7572 AC |
2779 | then |
2780 | Get_First_Interp (N, I, It); | |
2781 | while Present (It.Typ) loop | |
2782 | if Present (It.Abstract_Op) and then | |
2783 | Etype (It.Abstract_Op) = Typ | |
2784 | then | |
2785 | Error_Msg_NE | |
2786 | ("cannot call abstract subprogram &!", N, It.Abstract_Op); | |
2787 | return; | |
2788 | end if; | |
2789 | ||
2790 | Get_Next_Interp (I, It); | |
2791 | end loop; | |
2792 | end if; | |
2793 | ||
2794 | -- Here we have an acceptable interpretation for the context | |
2795 | ||
996ae0b0 RK |
2796 | -- Propagate type information and normalize tree for various |
2797 | -- predefined operations. If the context only imposes a class of | |
2798 | -- types, rather than a specific type, propagate the actual type | |
2799 | -- downward. | |
2800 | ||
19fb051c AC |
2801 | if Typ = Any_Integer or else |
2802 | Typ = Any_Boolean or else | |
2803 | Typ = Any_Modular or else | |
2804 | Typ = Any_Real or else | |
2805 | Typ = Any_Discrete | |
996ae0b0 RK |
2806 | then |
2807 | Ctx_Type := Expr_Type; | |
2808 | ||
5cc9353d RD |
2809 | -- Any_Fixed is legal in a real context only if a specific fixed- |
2810 | -- point type is imposed. If Norman Cohen can be confused by this, | |
2811 | -- it deserves a separate message. | |
996ae0b0 RK |
2812 | |
2813 | if Typ = Any_Real | |
2814 | and then Expr_Type = Any_Fixed | |
2815 | then | |
758c442c | 2816 | Error_Msg_N ("illegal context for mixed mode operation", N); |
996ae0b0 RK |
2817 | Set_Etype (N, Universal_Real); |
2818 | Ctx_Type := Universal_Real; | |
2819 | end if; | |
2820 | end if; | |
2821 | ||
f3d57416 | 2822 | -- A user-defined operator is transformed into a function call at |
0ab80019 AC |
2823 | -- this point, so that further processing knows that operators are |
2824 | -- really operators (i.e. are predefined operators). User-defined | |
2825 | -- operators that are intrinsic are just renamings of the predefined | |
2826 | -- ones, and need not be turned into calls either, but if they rename | |
2827 | -- a different operator, we must transform the node accordingly. | |
2828 | -- Instantiations of Unchecked_Conversion are intrinsic but are | |
2829 | -- treated as functions, even if given an operator designator. | |
2830 | ||
2831 | if Nkind (N) in N_Op | |
2832 | and then Present (Entity (N)) | |
2833 | and then Ekind (Entity (N)) /= E_Operator | |
2834 | then | |
0ab80019 AC |
2835 | if not Is_Predefined_Op (Entity (N)) then |
2836 | Rewrite_Operator_As_Call (N, Entity (N)); | |
2837 | ||
615cbd95 AC |
2838 | elsif Present (Alias (Entity (N))) |
2839 | and then | |
45fc7ddb HK |
2840 | Nkind (Parent (Parent (Entity (N)))) = |
2841 | N_Subprogram_Renaming_Declaration | |
615cbd95 | 2842 | then |
0ab80019 AC |
2843 | Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ); |
2844 | ||
2845 | -- If the node is rewritten, it will be fully resolved in | |
2846 | -- Rewrite_Renamed_Operator. | |
2847 | ||
2848 | if Analyzed (N) then | |
2849 | return; | |
2850 | end if; | |
2851 | end if; | |
2852 | end if; | |
2853 | ||
996ae0b0 | 2854 | case N_Subexpr'(Nkind (N)) is |
d8f43ee6 HK |
2855 | when N_Aggregate => |
2856 | Resolve_Aggregate (N, Ctx_Type); | |
996ae0b0 | 2857 | |
d8f43ee6 HK |
2858 | when N_Allocator => |
2859 | Resolve_Allocator (N, Ctx_Type); | |
996ae0b0 | 2860 | |
d8f43ee6 HK |
2861 | when N_Short_Circuit => |
2862 | Resolve_Short_Circuit (N, Ctx_Type); | |
996ae0b0 | 2863 | |
d8f43ee6 HK |
2864 | when N_Attribute_Reference => |
2865 | Resolve_Attribute (N, Ctx_Type); | |
19d846a0 | 2866 | |
d8f43ee6 HK |
2867 | when N_Case_Expression => |
2868 | Resolve_Case_Expression (N, Ctx_Type); | |
996ae0b0 | 2869 | |
d8f43ee6 HK |
2870 | when N_Character_Literal => |
2871 | Resolve_Character_Literal (N, Ctx_Type); | |
996ae0b0 | 2872 | |
9eb8d5b4 AC |
2873 | when N_Delta_Aggregate => |
2874 | Resolve_Delta_Aggregate (N, Ctx_Type); | |
2875 | ||
d8f43ee6 HK |
2876 | when N_Expanded_Name => |
2877 | Resolve_Entity_Name (N, Ctx_Type); | |
996ae0b0 | 2878 | |
d8f43ee6 HK |
2879 | when N_Explicit_Dereference => |
2880 | Resolve_Explicit_Dereference (N, Ctx_Type); | |
955871d3 | 2881 | |
d8f43ee6 HK |
2882 | when N_Expression_With_Actions => |
2883 | Resolve_Expression_With_Actions (N, Ctx_Type); | |
955871d3 | 2884 | |
d8f43ee6 HK |
2885 | when N_Extension_Aggregate => |
2886 | Resolve_Extension_Aggregate (N, Ctx_Type); | |
996ae0b0 | 2887 | |
d8f43ee6 HK |
2888 | when N_Function_Call => |
2889 | Resolve_Call (N, Ctx_Type); | |
996ae0b0 | 2890 | |
d8f43ee6 HK |
2891 | when N_Identifier => |
2892 | Resolve_Entity_Name (N, Ctx_Type); | |
9b16cb57 | 2893 | |
d8f43ee6 HK |
2894 | when N_If_Expression => |
2895 | Resolve_If_Expression (N, Ctx_Type); | |
996ae0b0 | 2896 | |
d8f43ee6 HK |
2897 | when N_Indexed_Component => |
2898 | Resolve_Indexed_Component (N, Ctx_Type); | |
996ae0b0 | 2899 | |
d8f43ee6 HK |
2900 | when N_Integer_Literal => |
2901 | Resolve_Integer_Literal (N, Ctx_Type); | |
0669bebe | 2902 | |
d8f43ee6 HK |
2903 | when N_Membership_Test => |
2904 | Resolve_Membership_Op (N, Ctx_Type); | |
996ae0b0 | 2905 | |
d8f43ee6 HK |
2906 | when N_Null => |
2907 | Resolve_Null (N, Ctx_Type); | |
996ae0b0 | 2908 | |
d8f43ee6 HK |
2909 | when N_Op_And |
2910 | | N_Op_Or | |
2911 | | N_Op_Xor | |
2912 | => | |
2913 | Resolve_Logical_Op (N, Ctx_Type); | |
996ae0b0 | 2914 | |
d8f43ee6 HK |
2915 | when N_Op_Eq |
2916 | | N_Op_Ne | |
2917 | => | |
2918 | Resolve_Equality_Op (N, Ctx_Type); | |
996ae0b0 | 2919 | |
d8f43ee6 HK |
2920 | when N_Op_Ge |
2921 | | N_Op_Gt | |
2922 | | N_Op_Le | |
2923 | | N_Op_Lt | |
2924 | => | |
2925 | Resolve_Comparison_Op (N, Ctx_Type); | |
996ae0b0 | 2926 | |
d8f43ee6 HK |
2927 | when N_Op_Not => |
2928 | Resolve_Op_Not (N, Ctx_Type); | |
996ae0b0 | 2929 | |
d8f43ee6 HK |
2930 | when N_Op_Add |
2931 | | N_Op_Divide | |
2932 | | N_Op_Mod | |
2933 | | N_Op_Multiply | |
2934 | | N_Op_Rem | |
2935 | | N_Op_Subtract | |
2936 | => | |
2937 | Resolve_Arithmetic_Op (N, Ctx_Type); | |
996ae0b0 | 2938 | |
d8f43ee6 HK |
2939 | when N_Op_Concat => |
2940 | Resolve_Op_Concat (N, Ctx_Type); | |
996ae0b0 | 2941 | |
d8f43ee6 HK |
2942 | when N_Op_Expon => |
2943 | Resolve_Op_Expon (N, Ctx_Type); | |
996ae0b0 | 2944 | |
d8f43ee6 HK |
2945 | when N_Op_Abs |
2946 | | N_Op_Minus | |
2947 | | N_Op_Plus | |
2948 | => | |
2949 | Resolve_Unary_Op (N, Ctx_Type); | |
996ae0b0 | 2950 | |
d8f43ee6 HK |
2951 | when N_Op_Shift => |
2952 | Resolve_Shift (N, Ctx_Type); | |
996ae0b0 | 2953 | |
d8f43ee6 HK |
2954 | when N_Procedure_Call_Statement => |
2955 | Resolve_Call (N, Ctx_Type); | |
996ae0b0 | 2956 | |
d8f43ee6 HK |
2957 | when N_Operator_Symbol => |
2958 | Resolve_Operator_Symbol (N, Ctx_Type); | |
996ae0b0 | 2959 | |
d8f43ee6 HK |
2960 | when N_Qualified_Expression => |
2961 | Resolve_Qualified_Expression (N, Ctx_Type); | |
996ae0b0 | 2962 | |
c8d63650 RD |
2963 | -- Why is the following null, needs a comment ??? |
2964 | ||
d8f43ee6 HK |
2965 | when N_Quantified_Expression => |
2966 | null; | |
983a3d80 | 2967 | |
d8f43ee6 HK |
2968 | when N_Raise_Expression => |
2969 | Resolve_Raise_Expression (N, Ctx_Type); | |
c8d63650 | 2970 | |
d8f43ee6 HK |
2971 | when N_Raise_xxx_Error => |
2972 | Set_Etype (N, Ctx_Type); | |
996ae0b0 | 2973 | |
d8f43ee6 HK |
2974 | when N_Range => |
2975 | Resolve_Range (N, Ctx_Type); | |
996ae0b0 | 2976 | |
d8f43ee6 HK |
2977 | when N_Real_Literal => |
2978 | Resolve_Real_Literal (N, Ctx_Type); | |
996ae0b0 | 2979 | |
d8f43ee6 HK |
2980 | when N_Reference => |
2981 | Resolve_Reference (N, Ctx_Type); | |
996ae0b0 | 2982 | |
d8f43ee6 HK |
2983 | when N_Selected_Component => |
2984 | Resolve_Selected_Component (N, Ctx_Type); | |
996ae0b0 | 2985 | |
d8f43ee6 HK |
2986 | when N_Slice => |
2987 | Resolve_Slice (N, Ctx_Type); | |
996ae0b0 | 2988 | |
d8f43ee6 HK |
2989 | when N_String_Literal => |
2990 | Resolve_String_Literal (N, Ctx_Type); | |
996ae0b0 | 2991 | |
ae33543c ES |
2992 | when N_Target_Name => |
2993 | Resolve_Target_Name (N, Ctx_Type); | |
2994 | ||
d8f43ee6 HK |
2995 | when N_Type_Conversion => |
2996 | Resolve_Type_Conversion (N, Ctx_Type); | |
996ae0b0 RK |
2997 | |
2998 | when N_Unchecked_Expression => | |
d8f43ee6 | 2999 | Resolve_Unchecked_Expression (N, Ctx_Type); |
996ae0b0 RK |
3000 | |
3001 | when N_Unchecked_Type_Conversion => | |
d8f43ee6 | 3002 | Resolve_Unchecked_Type_Conversion (N, Ctx_Type); |
996ae0b0 RK |
3003 | end case; |
3004 | ||
6cce2156 GD |
3005 | -- Ada 2012 (AI05-0149): Apply an (implicit) conversion to an |
3006 | -- expression of an anonymous access type that occurs in the context | |
3007 | -- of a named general access type, except when the expression is that | |
3008 | -- of a membership test. This ensures proper legality checking in | |
3009 | -- terms of allowed conversions (expressions that would be illegal to | |
3010 | -- convert implicitly are allowed in membership tests). | |
3011 | ||
3012 | if Ada_Version >= Ada_2012 | |
3013 | and then Ekind (Ctx_Type) = E_General_Access_Type | |
3014 | and then Ekind (Etype (N)) = E_Anonymous_Access_Type | |
3015 | and then Nkind (Parent (N)) not in N_Membership_Test | |
3016 | then | |
3017 | Rewrite (N, Convert_To (Ctx_Type, Relocate_Node (N))); | |
3018 | Analyze_And_Resolve (N, Ctx_Type); | |
3019 | end if; | |
3020 | ||
996ae0b0 RK |
3021 | -- If the subexpression was replaced by a non-subexpression, then |
3022 | -- all we do is to expand it. The only legitimate case we know of | |
3023 | -- is converting procedure call statement to entry call statements, | |
3024 | -- but there may be others, so we are making this test general. | |
3025 | ||
3026 | if Nkind (N) not in N_Subexpr then | |
3027 | Debug_A_Exit ("resolving ", N, " (done)"); | |
3028 | Expand (N); | |
3029 | return; | |
3030 | end if; | |
3031 | ||
3032 | -- The expression is definitely NOT overloaded at this point, so | |
3033 | -- we reset the Is_Overloaded flag to avoid any confusion when | |
3034 | -- reanalyzing the node. | |
3035 | ||
3036 | Set_Is_Overloaded (N, False); | |
3037 | ||
3038 | -- Freeze expression type, entity if it is a name, and designated | |
fbf5a39b | 3039 | -- type if it is an allocator (RM 13.14(10,11,13)). |
996ae0b0 | 3040 | |
5cc9353d RD |
3041 | -- Now that the resolution of the type of the node is complete, and |
3042 | -- we did not detect an error, we can expand this node. We skip the | |
3043 | -- expand call if we are in a default expression, see section | |
3044 | -- "Handling of Default Expressions" in Sem spec. | |
996ae0b0 RK |
3045 | |
3046 | Debug_A_Exit ("resolving ", N, " (done)"); | |
3047 | ||
3048 | -- We unconditionally freeze the expression, even if we are in | |
5cc9353d RD |
3049 | -- default expression mode (the Freeze_Expression routine tests this |
3050 | -- flag and only freezes static types if it is set). | |
996ae0b0 | 3051 | |
3e65bfab AC |
3052 | -- Ada 2012 (AI05-177): The declaration of an expression function |
3053 | -- does not cause freezing, but we never reach here in that case. | |
3054 | -- Here we are resolving the corresponding expanded body, so we do | |
3055 | -- need to perform normal freezing. | |
08f8a983 | 3056 | |
3e65bfab | 3057 | Freeze_Expression (N); |
996ae0b0 RK |
3058 | |
3059 | -- Now we can do the expansion | |
3060 | ||
3061 | Expand (N); | |
3062 | end if; | |
996ae0b0 RK |
3063 | end Resolve; |
3064 | ||
fbf5a39b AC |
3065 | ------------- |
3066 | -- Resolve -- | |
3067 | ------------- | |
3068 | ||
996ae0b0 RK |
3069 | -- Version with check(s) suppressed |
3070 | ||
3071 | procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id) is | |
3072 | begin | |
3073 | if Suppress = All_Checks then | |
3074 | declare | |
a7f1b24f | 3075 | Sva : constant Suppress_Array := Scope_Suppress.Suppress; |
996ae0b0 | 3076 | begin |
a7f1b24f | 3077 | Scope_Suppress.Suppress := (others => True); |
996ae0b0 | 3078 | Resolve (N, Typ); |
a7f1b24f | 3079 | Scope_Suppress.Suppress := Sva; |
996ae0b0 RK |
3080 | end; |
3081 | ||
3082 | else | |
3083 | declare | |
3217f71e | 3084 | Svg : constant Boolean := Scope_Suppress.Suppress (Suppress); |
996ae0b0 | 3085 | begin |
3217f71e | 3086 | Scope_Suppress.Suppress (Suppress) := True; |
996ae0b0 | 3087 | Resolve (N, Typ); |
3217f71e | 3088 | Scope_Suppress.Suppress (Suppress) := Svg; |
996ae0b0 RK |
3089 | end; |
3090 | end if; | |
3091 | end Resolve; | |
3092 | ||
fbf5a39b AC |
3093 | ------------- |
3094 | -- Resolve -- | |
3095 | ------------- | |
3096 | ||
3097 | -- Version with implicit type | |
3098 | ||
3099 | procedure Resolve (N : Node_Id) is | |
3100 | begin | |
3101 | Resolve (N, Etype (N)); | |
3102 | end Resolve; | |
3103 | ||
996ae0b0 RK |
3104 | --------------------- |
3105 | -- Resolve_Actuals -- | |
3106 | --------------------- | |
3107 | ||
3108 | procedure Resolve_Actuals (N : Node_Id; Nam : Entity_Id) is | |
3109 | Loc : constant Source_Ptr := Sloc (N); | |
3110 | A : Node_Id; | |
97779c34 | 3111 | A_Id : Entity_Id; |
996ae0b0 | 3112 | A_Typ : Entity_Id; |
97779c34 | 3113 | F : Entity_Id; |
996ae0b0 RK |
3114 | F_Typ : Entity_Id; |
3115 | Prev : Node_Id := Empty; | |
67ce0d7e | 3116 | Orig_A : Node_Id; |
e6b3f5ba ES |
3117 | Real_F : Entity_Id; |
3118 | ||
3119 | Real_Subp : Entity_Id; | |
4d6a38a5 ES |
3120 | -- If the subprogram being called is an inherited operation for |
3121 | -- a formal derived type in an instance, Real_Subp is the subprogram | |
3122 | -- that will be called. It may have different formal names than the | |
3123 | -- operation of the formal in the generic, so after actual is resolved | |
3124 | -- the name of the actual in a named association must carry the name | |
3125 | -- of the actual of the subprogram being called. | |
996ae0b0 | 3126 | |
f3691f46 ES |
3127 | procedure Check_Aliased_Parameter; |
3128 | -- Check rules on aliased parameters and related accessibility rules | |
fc27e20e | 3129 | -- in (RM 3.10.2 (10.2-10.4)). |
f3691f46 | 3130 | |
45fc7ddb HK |
3131 | procedure Check_Argument_Order; |
3132 | -- Performs a check for the case where the actuals are all simple | |
3133 | -- identifiers that correspond to the formal names, but in the wrong | |
3134 | -- order, which is considered suspicious and cause for a warning. | |
3135 | ||
b7d1f17f HK |
3136 | procedure Check_Prefixed_Call; |
3137 | -- If the original node is an overloaded call in prefix notation, | |
3138 | -- insert an 'Access or a dereference as needed over the first actual. | |
3139 | -- Try_Object_Operation has already verified that there is a valid | |
3140 | -- interpretation, but the form of the actual can only be determined | |
3141 | -- once the primitive operation is identified. | |
3142 | ||
888be6b1 AC |
3143 | procedure Flag_Effectively_Volatile_Objects (Expr : Node_Id); |
3144 | -- Emit an error concerning the illegal usage of an effectively volatile | |
3145 | -- object in interfering context (SPARK RM 7.13(12)). | |
3146 | ||
996ae0b0 RK |
3147 | procedure Insert_Default; |
3148 | -- If the actual is missing in a call, insert in the actuals list | |
3149 | -- an instance of the default expression. The insertion is always | |
3150 | -- a named association. | |
3151 | ||
97779c34 AC |
3152 | procedure Property_Error |
3153 | (Var : Node_Id; | |
3154 | Var_Id : Entity_Id; | |
3155 | Prop_Nam : Name_Id); | |
3156 | -- Emit an error concerning variable Var with entity Var_Id that has | |
3157 | -- enabled property Prop_Nam when it acts as an actual parameter in a | |
3158 | -- call and the corresponding formal parameter is of mode IN. | |
3159 | ||
fbf5a39b AC |
3160 | function Same_Ancestor (T1, T2 : Entity_Id) return Boolean; |
3161 | -- Check whether T1 and T2, or their full views, are derived from a | |
3162 | -- common type. Used to enforce the restrictions on array conversions | |
3163 | -- of AI95-00246. | |
3164 | ||
a7a3cf5c AC |
3165 | function Static_Concatenation (N : Node_Id) return Boolean; |
3166 | -- Predicate to determine whether an actual that is a concatenation | |
3167 | -- will be evaluated statically and does not need a transient scope. | |
3168 | -- This must be determined before the actual is resolved and expanded | |
3169 | -- because if needed the transient scope must be introduced earlier. | |
3170 | ||
07a64c02 AC |
3171 | ----------------------------- |
3172 | -- Check_Aliased_Parameter -- | |
3173 | ----------------------------- | |
f3691f46 ES |
3174 | |
3175 | procedure Check_Aliased_Parameter is | |
3176 | Nominal_Subt : Entity_Id; | |
3177 | ||
3178 | begin | |
3179 | if Is_Aliased (F) then | |
3180 | if Is_Tagged_Type (A_Typ) then | |
3181 | null; | |
3182 | ||
3183 | elsif Is_Aliased_View (A) then | |
3184 | if Is_Constr_Subt_For_U_Nominal (A_Typ) then | |
3185 | Nominal_Subt := Base_Type (A_Typ); | |
3186 | else | |
3187 | Nominal_Subt := A_Typ; | |
3188 | end if; | |
3189 | ||
3190 | if Subtypes_Statically_Match (F_Typ, Nominal_Subt) then | |
3191 | null; | |
3192 | ||
3193 | -- In a generic body assume the worst for generic formals: | |
3194 | -- they can have a constrained partial view (AI05-041). | |
3195 | ||
3196 | elsif Has_Discriminants (F_Typ) | |
3197 | and then not Is_Constrained (F_Typ) | |
3198 | and then not Has_Constrained_Partial_View (F_Typ) | |
3199 | and then not Is_Generic_Type (F_Typ) | |
3200 | then | |
3201 | null; | |
3202 | ||
3203 | else | |
3204 | Error_Msg_NE ("untagged actual does not match " | |
fc27e20e | 3205 | & "aliased formal&", A, F); |
f3691f46 ES |
3206 | end if; |
3207 | ||
3208 | else | |
3209 | Error_Msg_NE ("actual for aliased formal& must be " | |
fc27e20e | 3210 | & "aliased object", A, F); |
f3691f46 ES |
3211 | end if; |
3212 | ||
3213 | if Ekind (Nam) = E_Procedure then | |
3214 | null; | |
3215 | ||
3216 | elsif Ekind (Etype (Nam)) = E_Anonymous_Access_Type then | |
3217 | if Nkind (Parent (N)) = N_Type_Conversion | |
fc27e20e RD |
3218 | and then Type_Access_Level (Etype (Parent (N))) < |
3219 | Object_Access_Level (A) | |
f3691f46 ES |
3220 | then |
3221 | Error_Msg_N ("aliased actual has wrong accessibility", A); | |
3222 | end if; | |
3223 | ||
3224 | elsif Nkind (Parent (N)) = N_Qualified_Expression | |
3225 | and then Nkind (Parent (Parent (N))) = N_Allocator | |
fc27e20e RD |
3226 | and then Type_Access_Level (Etype (Parent (Parent (N)))) < |
3227 | Object_Access_Level (A) | |
f3691f46 ES |
3228 | then |
3229 | Error_Msg_N | |
fc27e20e | 3230 | ("aliased actual in allocator has wrong accessibility", A); |
f3691f46 ES |
3231 | end if; |
3232 | end if; | |
3233 | end Check_Aliased_Parameter; | |
3234 | ||
45fc7ddb HK |
3235 | -------------------------- |
3236 | -- Check_Argument_Order -- | |
3237 | -------------------------- | |
3238 | ||
3239 | procedure Check_Argument_Order is | |
3240 | begin | |
3241 | -- Nothing to do if no parameters, or original node is neither a | |
3242 | -- function call nor a procedure call statement (happens in the | |
3243 | -- operator-transformed-to-function call case), or the call does | |
3244 | -- not come from source, or this warning is off. | |
3245 | ||
3246 | if not Warn_On_Parameter_Order | |
19fb051c | 3247 | or else No (Parameter_Associations (N)) |
d3b00ce3 | 3248 | or else Nkind (Original_Node (N)) not in N_Subprogram_Call |
19fb051c | 3249 | or else not Comes_From_Source (N) |
45fc7ddb HK |
3250 | then |
3251 | return; | |
3252 | end if; | |
3253 | ||
3254 | declare | |
3255 | Nargs : constant Nat := List_Length (Parameter_Associations (N)); | |
3256 | ||
3257 | begin | |
3258 | -- Nothing to do if only one parameter | |
3259 | ||
3260 | if Nargs < 2 then | |
3261 | return; | |
3262 | end if; | |
3263 | ||
3264 | -- Here if at least two arguments | |
3265 | ||
3266 | declare | |
3267 | Actuals : array (1 .. Nargs) of Node_Id; | |
3268 | Actual : Node_Id; | |
3269 | Formal : Node_Id; | |
3270 | ||
3271 | Wrong_Order : Boolean := False; | |
3272 | -- Set True if an out of order case is found | |
3273 | ||
3274 | begin | |
3275 | -- Collect identifier names of actuals, fail if any actual is | |
3276 | -- not a simple identifier, and record max length of name. | |
3277 | ||
3278 | Actual := First (Parameter_Associations (N)); | |
3279 | for J in Actuals'Range loop | |
3280 | if Nkind (Actual) /= N_Identifier then | |
3281 | return; | |
3282 | else | |
3283 | Actuals (J) := Actual; | |
3284 | Next (Actual); | |
3285 | end if; | |
3286 | end loop; | |
3287 | ||
3288 | -- If we got this far, all actuals are identifiers and the list | |
3289 | -- of their names is stored in the Actuals array. | |
3290 | ||
3291 | Formal := First_Formal (Nam); | |
3292 | for J in Actuals'Range loop | |
3293 | ||
3294 | -- If we ran out of formals, that's odd, probably an error | |
3295 | -- which will be detected elsewhere, but abandon the search. | |
3296 | ||
3297 | if No (Formal) then | |
3298 | return; | |
3299 | end if; | |
3300 | ||
3301 | -- If name matches and is in order OK | |
3302 | ||
3303 | if Chars (Formal) = Chars (Actuals (J)) then | |
3304 | null; | |
3305 | ||
3306 | else | |
3307 | -- If no match, see if it is elsewhere in list and if so | |
3308 | -- flag potential wrong order if type is compatible. | |
3309 | ||
3310 | for K in Actuals'Range loop | |
3311 | if Chars (Formal) = Chars (Actuals (K)) | |
3312 | and then | |
3313 | Has_Compatible_Type (Actuals (K), Etype (Formal)) | |
3314 | then | |
3315 | Wrong_Order := True; | |
3316 | goto Continue; | |
3317 | end if; | |
3318 | end loop; | |
3319 | ||
3320 | -- No match | |
3321 | ||
3322 | return; | |
3323 | end if; | |
3324 | ||
3325 | <<Continue>> Next_Formal (Formal); | |
3326 | end loop; | |
3327 | ||
3328 | -- If Formals left over, also probably an error, skip warning | |
3329 | ||
3330 | if Present (Formal) then | |
3331 | return; | |
3332 | end if; | |
3333 | ||
3334 | -- Here we give the warning if something was out of order | |
3335 | ||
3336 | if Wrong_Order then | |
3337 | Error_Msg_N | |
a3633438 | 3338 | ("?P?actuals for this call may be in wrong order", N); |
45fc7ddb HK |
3339 | end if; |
3340 | end; | |
3341 | end; | |
3342 | end Check_Argument_Order; | |
3343 | ||
b7d1f17f HK |
3344 | ------------------------- |
3345 | -- Check_Prefixed_Call -- | |
3346 | ------------------------- | |
3347 | ||
3348 | procedure Check_Prefixed_Call is | |
3349 | Act : constant Node_Id := First_Actual (N); | |
3350 | A_Type : constant Entity_Id := Etype (Act); | |
3351 | F_Type : constant Entity_Id := Etype (First_Formal (Nam)); | |
3352 | Orig : constant Node_Id := Original_Node (N); | |
3353 | New_A : Node_Id; | |
3354 | ||
3355 | begin | |
3356 | -- Check whether the call is a prefixed call, with or without | |
3357 | -- additional actuals. | |
3358 | ||
3359 | if Nkind (Orig) = N_Selected_Component | |
3360 | or else | |
3361 | (Nkind (Orig) = N_Indexed_Component | |
3362 | and then Nkind (Prefix (Orig)) = N_Selected_Component | |
3363 | and then Is_Entity_Name (Prefix (Prefix (Orig))) | |
3364 | and then Is_Entity_Name (Act) | |
3365 | and then Chars (Act) = Chars (Prefix (Prefix (Orig)))) | |
3366 | then | |
3367 | if Is_Access_Type (A_Type) | |
3368 | and then not Is_Access_Type (F_Type) | |
3369 | then | |
3370 | -- Introduce dereference on object in prefix | |
3371 | ||
3372 | New_A := | |
3373 | Make_Explicit_Dereference (Sloc (Act), | |
3374 | Prefix => Relocate_Node (Act)); | |
3375 | Rewrite (Act, New_A); | |
3376 | Analyze (Act); | |
3377 | ||
3378 | elsif Is_Access_Type (F_Type) | |
3379 | and then not Is_Access_Type (A_Type) | |
3380 | then | |
3381 | -- Introduce an implicit 'Access in prefix | |
3382 | ||
3383 | if not Is_Aliased_View (Act) then | |
ed2233dc | 3384 | Error_Msg_NE |
039538bc | 3385 | ("object in prefixed call to& must be aliased " |
715e529d | 3386 | & "(RM 4.1.3 (13 1/2))", |
b7d1f17f HK |
3387 | Prefix (Act), Nam); |
3388 | end if; | |
3389 | ||
3390 | Rewrite (Act, | |
3391 | Make_Attribute_Reference (Loc, | |
3392 | Attribute_Name => Name_Access, | |
3393 | Prefix => Relocate_Node (Act))); | |
3394 | end if; | |
3395 | ||
3396 | Analyze (Act); | |
3397 | end if; | |
3398 | end Check_Prefixed_Call; | |
3399 | ||
888be6b1 AC |
3400 | --------------------------------------- |
3401 | -- Flag_Effectively_Volatile_Objects -- | |
3402 | --------------------------------------- | |
3403 | ||
3404 | procedure Flag_Effectively_Volatile_Objects (Expr : Node_Id) is | |
3405 | function Flag_Object (N : Node_Id) return Traverse_Result; | |
3406 | -- Determine whether arbitrary node N denotes an effectively volatile | |
3407 | -- object and if it does, emit an error. | |
3408 | ||
3409 | ----------------- | |
3410 | -- Flag_Object -- | |
3411 | ----------------- | |
3412 | ||
3413 | function Flag_Object (N : Node_Id) return Traverse_Result is | |
3414 | Id : Entity_Id; | |
3415 | ||
3416 | begin | |
3417 | -- Do not consider nested function calls because they have already | |
3418 | -- been processed during their own resolution. | |
3419 | ||
3420 | if Nkind (N) = N_Function_Call then | |
3421 | return Skip; | |
3422 | ||
3423 | elsif Is_Entity_Name (N) and then Present (Entity (N)) then | |
3424 | Id := Entity (N); | |
3425 | ||
3426 | if Is_Object (Id) | |
3427 | and then Is_Effectively_Volatile (Id) | |
3428 | and then (Async_Writers_Enabled (Id) | |
3429 | or else Effective_Reads_Enabled (Id)) | |
3430 | then | |
3431 | Error_Msg_N | |
3432 | ("volatile object cannot appear in this context (SPARK " | |
3433 | & "RM 7.1.3(11))", N); | |
3434 | return Skip; | |
3435 | end if; | |
3436 | end if; | |
3437 | ||
3438 | return OK; | |
3439 | end Flag_Object; | |
3440 | ||
3441 | procedure Flag_Objects is new Traverse_Proc (Flag_Object); | |
3442 | ||
3443 | -- Start of processing for Flag_Effectively_Volatile_Objects | |
3444 | ||
3445 | begin | |
3446 | Flag_Objects (Expr); | |
3447 | end Flag_Effectively_Volatile_Objects; | |
3448 | ||
996ae0b0 RK |
3449 | -------------------- |
3450 | -- Insert_Default -- | |
3451 | -------------------- | |
3452 | ||
3453 | procedure Insert_Default is | |
3454 | Actval : Node_Id; | |
3455 | Assoc : Node_Id; | |
3456 | ||
3457 | begin | |
fbf5a39b | 3458 | -- Missing argument in call, nothing to insert |
996ae0b0 | 3459 | |
fbf5a39b AC |
3460 | if No (Default_Value (F)) then |
3461 | return; | |
3462 | ||
3463 | else | |
3464 | -- Note that we do a full New_Copy_Tree, so that any associated | |
3465 | -- Itypes are properly copied. This may not be needed any more, | |
a90bd866 | 3466 | -- but it does no harm as a safety measure. Defaults of a generic |
fbf5a39b AC |
3467 | -- formal may be out of bounds of the corresponding actual (see |
3468 | -- cc1311b) and an additional check may be required. | |
996ae0b0 | 3469 | |
b7d1f17f HK |
3470 | Actval := |
3471 | New_Copy_Tree | |
3472 | (Default_Value (F), | |
3473 | New_Scope => Current_Scope, | |
3474 | New_Sloc => Loc); | |
996ae0b0 | 3475 | |
e90e9503 AC |
3476 | -- Propagate dimension information, if any. |
3477 | ||
3478 | Copy_Dimensions (Default_Value (F), Actval); | |
3479 | ||
996ae0b0 RK |
3480 | if Is_Concurrent_Type (Scope (Nam)) |
3481 | and then Has_Discriminants (Scope (Nam)) | |
3482 | then | |
3483 | Replace_Actual_Discriminants (N, Actval); | |
3484 | end if; | |
3485 | ||
3486 | if Is_Overloadable (Nam) | |
3487 | and then Present (Alias (Nam)) | |
3488 | then | |
3489 | if Base_Type (Etype (F)) /= Base_Type (Etype (Actval)) | |
3490 | and then not Is_Tagged_Type (Etype (F)) | |
3491 | then | |
3492 | -- If default is a real literal, do not introduce a | |
3493 | -- conversion whose effect may depend on the run-time | |
3494 | -- size of universal real. | |
3495 | ||
3496 | if Nkind (Actval) = N_Real_Literal then | |
3497 | Set_Etype (Actval, Base_Type (Etype (F))); | |
3498 | else | |
3499 | Actval := Unchecked_Convert_To (Etype (F), Actval); | |
3500 | end if; | |
3501 | end if; | |
3502 | ||
3503 | if Is_Scalar_Type (Etype (F)) then | |
3504 | Enable_Range_Check (Actval); | |
3505 | end if; | |
3506 | ||
996ae0b0 RK |
3507 | Set_Parent (Actval, N); |
3508 | ||
3509 | -- Resolve aggregates with their base type, to avoid scope | |
f3d57416 | 3510 | -- anomalies: the subtype was first built in the subprogram |
996ae0b0 RK |
3511 | -- declaration, and the current call may be nested. |
3512 | ||
76b84bf0 AC |
3513 | if Nkind (Actval) = N_Aggregate then |
3514 | Analyze_And_Resolve (Actval, Etype (F)); | |
996ae0b0 RK |
3515 | else |
3516 | Analyze_And_Resolve (Actval, Etype (Actval)); | |
3517 | end if; | |
fbf5a39b AC |
3518 | |
3519 | else | |
3520 | Set_Parent (Actval, N); | |
3521 | ||
a77842bd | 3522 | -- See note above concerning aggregates |
fbf5a39b AC |
3523 | |
3524 | if Nkind (Actval) = N_Aggregate | |
3525 | and then Has_Discriminants (Etype (Actval)) | |
3526 | then | |
3527 | Analyze_And_Resolve (Actval, Base_Type (Etype (Actval))); | |
3528 | ||
5cc9353d RD |
3529 | -- Resolve entities with their own type, which may differ from |
3530 | -- the type of a reference in a generic context (the view | |
3531 | -- swapping mechanism did not anticipate the re-analysis of | |
3532 | -- default values in calls). | |
fbf5a39b AC |
3533 | |
3534 | elsif Is_Entity_Name (Actval) then | |
3535 | Analyze_And_Resolve (Actval, Etype (Entity (Actval))); | |
3536 | ||
3537 | else | |
3538 | Analyze_And_Resolve (Actval, Etype (Actval)); | |
3539 | end if; | |
996ae0b0 RK |
3540 | end if; |
3541 | ||
5cc9353d RD |
3542 | -- If default is a tag indeterminate function call, propagate tag |
3543 | -- to obtain proper dispatching. | |
996ae0b0 RK |
3544 | |
3545 | if Is_Controlling_Formal (F) | |
3546 | and then Nkind (Default_Value (F)) = N_Function_Call | |
3547 | then | |
3548 | Set_Is_Controlling_Actual (Actval); | |
3549 | end if; | |
996ae0b0 RK |
3550 | end if; |
3551 | ||
3552 | -- If the default expression raises constraint error, then just | |
5cc9353d RD |
3553 | -- silently replace it with an N_Raise_Constraint_Error node, since |
3554 | -- we already gave the warning on the subprogram spec. If node is | |
3555 | -- already a Raise_Constraint_Error leave as is, to prevent loops in | |
3556 | -- the warnings removal machinery. | |
996ae0b0 | 3557 | |
2604ec03 AC |
3558 | if Raises_Constraint_Error (Actval) |
3559 | and then Nkind (Actval) /= N_Raise_Constraint_Error | |
3560 | then | |
996ae0b0 | 3561 | Rewrite (Actval, |
07fc65c4 GB |
3562 | Make_Raise_Constraint_Error (Loc, |
3563 | Reason => CE_Range_Check_Failed)); | |
996ae0b0 RK |
3564 | Set_Raises_Constraint_Error (Actval); |
3565 | Set_Etype (Actval, Etype (F)); | |
3566 | end if; | |
3567 | ||
3568 | Assoc := | |
3569 | Make_Parameter_Association (Loc, | |
3570 | Explicit_Actual_Parameter => Actval, | |
3571 | Selector_Name => Make_Identifier (Loc, Chars (F))); | |
3572 | ||
3573 | -- Case of insertion is first named actual | |
3574 | ||
3575 | if No (Prev) or else | |
3576 | Nkind (Parent (Prev)) /= N_Parameter_Association | |
3577 | then | |
3578 | Set_Next_Named_Actual (Assoc, First_Named_Actual (N)); | |
3579 | Set_First_Named_Actual (N, Actval); | |
3580 | ||
3581 | if No (Prev) then | |
c8ef728f | 3582 | if No (Parameter_Associations (N)) then |
996ae0b0 RK |
3583 | Set_Parameter_Associations (N, New_List (Assoc)); |
3584 | else | |
3585 | Append (Assoc, Parameter_Associations (N)); | |
3586 | end if; | |
3587 | ||
3588 | else | |
3589 | Insert_After (Prev, Assoc); | |
3590 | end if; | |
3591 | ||
3592 | -- Case of insertion is not first named actual | |
3593 | ||
3594 | else | |
3595 | Set_Next_Named_Actual | |
3596 | (Assoc, Next_Named_Actual (Parent (Prev))); | |
3597 | Set_Next_Named_Actual (Parent (Prev), Actval); | |
3598 | Append (Assoc, Parameter_Associations (N)); | |
3599 | end if; | |
3600 | ||
3601 | Mark_Rewrite_Insertion (Assoc); | |
3602 | Mark_Rewrite_Insertion (Actval); | |
3603 | ||
3604 | Prev := Actval; | |
3605 | end Insert_Default; | |
3606 | ||
97779c34 AC |
3607 | -------------------- |
3608 | -- Property_Error -- | |
3609 | -------------------- | |
3610 | ||
3611 | procedure Property_Error | |
3612 | (Var : Node_Id; | |
3613 | Var_Id : Entity_Id; | |
3614 | Prop_Nam : Name_Id) | |
3615 | is | |
3616 | begin | |
3617 | Error_Msg_Name_1 := Prop_Nam; | |
3618 | Error_Msg_NE | |
3619 | ("external variable & with enabled property % cannot appear as " | |
db7e3721 | 3620 | & "actual in procedure call (SPARK RM 7.1.3(10))", Var, Var_Id); |
97779c34 AC |
3621 | Error_Msg_N ("\\corresponding formal parameter has mode In", Var); |
3622 | end Property_Error; | |
3623 | ||
fbf5a39b AC |
3624 | ------------------- |
3625 | -- Same_Ancestor -- | |
3626 | ------------------- | |
3627 | ||
3628 | function Same_Ancestor (T1, T2 : Entity_Id) return Boolean is | |
3629 | FT1 : Entity_Id := T1; | |
3630 | FT2 : Entity_Id := T2; | |
3631 | ||
3632 | begin | |
3633 | if Is_Private_Type (T1) | |
3634 | and then Present (Full_View (T1)) | |
3635 | then | |
3636 | FT1 := Full_View (T1); | |
3637 | end if; | |
3638 | ||
3639 | if Is_Private_Type (T2) | |
3640 | and then Present (Full_View (T2)) | |
3641 | then | |
3642 | FT2 := Full_View (T2); | |
3643 | end if; | |
3644 | ||
3645 | return Root_Type (Base_Type (FT1)) = Root_Type (Base_Type (FT2)); | |
3646 | end Same_Ancestor; | |
3647 | ||
a7a3cf5c AC |
3648 | -------------------------- |
3649 | -- Static_Concatenation -- | |
3650 | -------------------------- | |
3651 | ||
3652 | function Static_Concatenation (N : Node_Id) return Boolean is | |
3653 | begin | |
c72a85f2 TQ |
3654 | case Nkind (N) is |
3655 | when N_String_Literal => | |
3656 | return True; | |
a7a3cf5c | 3657 | |
d81b4bfe TQ |
3658 | when N_Op_Concat => |
3659 | ||
5cc9353d RD |
3660 | -- Concatenation is static when both operands are static and |
3661 | -- the concatenation operator is a predefined one. | |
4342eda9 TQ |
3662 | |
3663 | return Scope (Entity (N)) = Standard_Standard | |
3664 | and then | |
3665 | Static_Concatenation (Left_Opnd (N)) | |
c72a85f2 TQ |
3666 | and then |
3667 | Static_Concatenation (Right_Opnd (N)); | |
3668 | ||
3669 | when others => | |
3670 | if Is_Entity_Name (N) then | |
3671 | declare | |
3672 | Ent : constant Entity_Id := Entity (N); | |
3673 | begin | |
3674 | return Ekind (Ent) = E_Constant | |
3675 | and then Present (Constant_Value (Ent)) | |
d81b4bfe | 3676 | and then |
edab6088 | 3677 | Is_OK_Static_Expression (Constant_Value (Ent)); |
c72a85f2 | 3678 | end; |
a7a3cf5c | 3679 | |
a7a3cf5c AC |
3680 | else |
3681 | return False; | |
3682 | end if; | |
c72a85f2 | 3683 | end case; |
a7a3cf5c AC |
3684 | end Static_Concatenation; |
3685 | ||
996ae0b0 RK |
3686 | -- Start of processing for Resolve_Actuals |
3687 | ||
3688 | begin | |
45fc7ddb HK |
3689 | Check_Argument_Order; |
3690 | ||
e6b3f5ba ES |
3691 | if Is_Overloadable (Nam) |
3692 | and then Is_Inherited_Operation (Nam) | |
4d6a38a5 | 3693 | and then In_Instance |
e6b3f5ba ES |
3694 | and then Present (Alias (Nam)) |
3695 | and then Present (Overridden_Operation (Alias (Nam))) | |
3696 | then | |
3697 | Real_Subp := Alias (Nam); | |
3698 | else | |
3699 | Real_Subp := Empty; | |
3700 | end if; | |
3701 | ||
b7d1f17f HK |
3702 | if Present (First_Actual (N)) then |
3703 | Check_Prefixed_Call; | |
3704 | end if; | |
3705 | ||
996ae0b0 RK |
3706 | A := First_Actual (N); |
3707 | F := First_Formal (Nam); | |
e6b3f5ba ES |
3708 | |
3709 | if Present (Real_Subp) then | |
3710 | Real_F := First_Formal (Real_Subp); | |
3711 | end if; | |
3712 | ||
996ae0b0 | 3713 | while Present (F) loop |
fbf5a39b AC |
3714 | if No (A) and then Needs_No_Actuals (Nam) then |
3715 | null; | |
996ae0b0 | 3716 | |
d81b4bfe TQ |
3717 | -- If we have an error in any actual or formal, indicated by a type |
3718 | -- of Any_Type, then abandon resolution attempt, and set result type | |
7610fee8 AC |
3719 | -- to Any_Type. Skip this if the actual is a Raise_Expression, whose |
3720 | -- type is imposed from context. | |
07fc65c4 | 3721 | |
fbf5a39b AC |
3722 | elsif (Present (A) and then Etype (A) = Any_Type) |
3723 | or else Etype (F) = Any_Type | |
07fc65c4 | 3724 | then |
7610fee8 AC |
3725 | if Nkind (A) /= N_Raise_Expression then |
3726 | Set_Etype (N, Any_Type); | |
3727 | return; | |
3728 | end if; | |
07fc65c4 GB |
3729 | end if; |
3730 | ||
e65f50ec ES |
3731 | -- Case where actual is present |
3732 | ||
45fc7ddb | 3733 | -- If the actual is an entity, generate a reference to it now. We |
36fcf362 RD |
3734 | -- do this before the actual is resolved, because a formal of some |
3735 | -- protected subprogram, or a task discriminant, will be rewritten | |
5cc9353d | 3736 | -- during expansion, and the source entity reference may be lost. |
36fcf362 RD |
3737 | |
3738 | if Present (A) | |
3739 | and then Is_Entity_Name (A) | |
0da343bc | 3740 | and then Comes_From_Source (A) |
36fcf362 RD |
3741 | then |
3742 | Orig_A := Entity (A); | |
3743 | ||
3744 | if Present (Orig_A) then | |
3745 | if Is_Formal (Orig_A) | |
3746 | and then Ekind (F) /= E_In_Parameter | |
3747 | then | |
3748 | Generate_Reference (Orig_A, A, 'm'); | |
19fb051c | 3749 | |
36fcf362 | 3750 | elsif not Is_Overloaded (A) then |
ba08ba84 AC |
3751 | if Ekind (F) /= E_Out_Parameter then |
3752 | Generate_Reference (Orig_A, A); | |
3753 | ||
3754 | -- RM 6.4.1(12): For an out parameter that is passed by | |
3755 | -- copy, the formal parameter object is created, and: | |
3756 | ||
3757 | -- * For an access type, the formal parameter is initialized | |
3758 | -- from the value of the actual, without checking that the | |
3759 | -- value satisfies any constraint, any predicate, or any | |
3760 | -- exclusion of the null value. | |
3761 | ||
3762 | -- * For a scalar type that has the Default_Value aspect | |
3763 | -- specified, the formal parameter is initialized from the | |
3764 | -- value of the actual, without checking that the value | |
c91dbd18 AC |
3765 | -- satisfies any constraint or any predicate. |
3766 | -- I do not understand why this case is included??? this is | |
3767 | -- not a case where an OUT parameter is treated as IN OUT. | |
ba08ba84 AC |
3768 | |
3769 | -- * For a composite type with discriminants or that has | |
3770 | -- implicit initial values for any subcomponents, the | |
3771 | -- behavior is as for an in out parameter passed by copy. | |
3772 | ||
3773 | -- Hence for these cases we generate the read reference now | |
3774 | -- (the write reference will be generated later by | |
3775 | -- Note_Possible_Modification). | |
3776 | ||
3777 | elsif Is_By_Copy_Type (Etype (F)) | |
3778 | and then | |
3779 | (Is_Access_Type (Etype (F)) | |
3780 | or else | |
3781 | (Is_Scalar_Type (Etype (F)) | |
3782 | and then | |
3783 | Present (Default_Aspect_Value (Etype (F)))) | |
3784 | or else | |
3785 | (Is_Composite_Type (Etype (F)) | |
c91dbd18 AC |
3786 | and then (Has_Discriminants (Etype (F)) |
3787 | or else Is_Partially_Initialized_Type | |
3788 | (Etype (F))))) | |
ba08ba84 AC |
3789 | then |
3790 | Generate_Reference (Orig_A, A); | |
3791 | end if; | |
36fcf362 RD |
3792 | end if; |
3793 | end if; | |
3794 | end if; | |
3795 | ||
996ae0b0 RK |
3796 | if Present (A) |
3797 | and then (Nkind (Parent (A)) /= N_Parameter_Association | |
19fb051c | 3798 | or else Chars (Selector_Name (Parent (A))) = Chars (F)) |
996ae0b0 | 3799 | then |
45fc7ddb HK |
3800 | -- If style checking mode on, check match of formal name |
3801 | ||
3802 | if Style_Check then | |
3803 | if Nkind (Parent (A)) = N_Parameter_Association then | |
3804 | Check_Identifier (Selector_Name (Parent (A)), F); | |
3805 | end if; | |
3806 | end if; | |
3807 | ||
996ae0b0 RK |
3808 | -- If the formal is Out or In_Out, do not resolve and expand the |
3809 | -- conversion, because it is subsequently expanded into explicit | |
3810 | -- temporaries and assignments. However, the object of the | |
ea985d95 RD |
3811 | -- conversion can be resolved. An exception is the case of tagged |
3812 | -- type conversion with a class-wide actual. In that case we want | |
3813 | -- the tag check to occur and no temporary will be needed (no | |
3814 | -- representation change can occur) and the parameter is passed by | |
3815 | -- reference, so we go ahead and resolve the type conversion. | |
c8ef728f | 3816 | -- Another exception is the case of reference to component or |
ea985d95 RD |
3817 | -- subcomponent of a bit-packed array, in which case we want to |
3818 | -- defer expansion to the point the in and out assignments are | |
3819 | -- performed. | |
996ae0b0 RK |
3820 | |
3821 | if Ekind (F) /= E_In_Parameter | |
3822 | and then Nkind (A) = N_Type_Conversion | |
3823 | and then not Is_Class_Wide_Type (Etype (Expression (A))) | |
3824 | then | |
07fc65c4 GB |
3825 | if Ekind (F) = E_In_Out_Parameter |
3826 | and then Is_Array_Type (Etype (F)) | |
07fc65c4 | 3827 | then |
038140ed AC |
3828 | -- In a view conversion, the conversion must be legal in |
3829 | -- both directions, and thus both component types must be | |
3830 | -- aliased, or neither (4.6 (8)). | |
758c442c | 3831 | |
038140ed AC |
3832 | -- The extra rule in 4.6 (24.9.2) seems unduly restrictive: |
3833 | -- the privacy requirement should not apply to generic | |
3834 | -- types, and should be checked in an instance. ARG query | |
3835 | -- is in order ??? | |
45fc7ddb | 3836 | |
038140ed AC |
3837 | if Has_Aliased_Components (Etype (Expression (A))) /= |
3838 | Has_Aliased_Components (Etype (F)) | |
3839 | then | |
45fc7ddb HK |
3840 | Error_Msg_N |
3841 | ("both component types in a view conversion must be" | |
3842 | & " aliased, or neither", A); | |
3843 | ||
038140ed AC |
3844 | -- Comment here??? what set of cases??? |
3845 | ||
45fc7ddb HK |
3846 | elsif |
3847 | not Same_Ancestor (Etype (F), Etype (Expression (A))) | |
3848 | then | |
038140ed AC |
3849 | -- Check view conv between unrelated by ref array types |
3850 | ||
45fc7ddb HK |
3851 | if Is_By_Reference_Type (Etype (F)) |
3852 | or else Is_By_Reference_Type (Etype (Expression (A))) | |
758c442c GD |
3853 | then |
3854 | Error_Msg_N | |
1486a00e AC |
3855 | ("view conversion between unrelated by reference " |
3856 | & "array types not allowed (\'A'I-00246)", A); | |
038140ed AC |
3857 | |
3858 | -- In Ada 2005 mode, check view conversion component | |
3859 | -- type cannot be private, tagged, or volatile. Note | |
3860 | -- that we only apply this to source conversions. The | |
3861 | -- generated code can contain conversions which are | |
3862 | -- not subject to this test, and we cannot extract the | |
3863 | -- component type in such cases since it is not present. | |
3864 | ||
3865 | elsif Comes_From_Source (A) | |
3866 | and then Ada_Version >= Ada_2005 | |
3867 | then | |
45fc7ddb HK |
3868 | declare |
3869 | Comp_Type : constant Entity_Id := | |
3870 | Component_Type | |
3871 | (Etype (Expression (A))); | |
3872 | begin | |
038140ed AC |
3873 | if (Is_Private_Type (Comp_Type) |
3874 | and then not Is_Generic_Type (Comp_Type)) | |
3875 | or else Is_Tagged_Type (Comp_Type) | |
3876 | or else Is_Volatile (Comp_Type) | |
45fc7ddb HK |
3877 | then |
3878 | Error_Msg_N | |
3879 | ("component type of a view conversion cannot" | |
3880 | & " be private, tagged, or volatile" | |
3881 | & " (RM 4.6 (24))", | |
3882 | Expression (A)); | |
3883 | end if; | |
3884 | end; | |
758c442c | 3885 | end if; |
fbf5a39b | 3886 | end if; |
07fc65c4 GB |
3887 | end if; |
3888 | ||
038140ed AC |
3889 | -- Resolve expression if conversion is all OK |
3890 | ||
16397eff | 3891 | if (Conversion_OK (A) |
038140ed | 3892 | or else Valid_Conversion (A, Etype (A), Expression (A))) |
16397eff | 3893 | and then not Is_Ref_To_Bit_Packed_Array (Expression (A)) |
996ae0b0 | 3894 | then |
fbf5a39b | 3895 | Resolve (Expression (A)); |
996ae0b0 RK |
3896 | end if; |
3897 | ||
b7d1f17f HK |
3898 | -- If the actual is a function call that returns a limited |
3899 | -- unconstrained object that needs finalization, create a | |
3900 | -- transient scope for it, so that it can receive the proper | |
3901 | -- finalization list. | |
3902 | ||
3903 | elsif Nkind (A) = N_Function_Call | |
3904 | and then Is_Limited_Record (Etype (F)) | |
3905 | and then not Is_Constrained (Etype (F)) | |
4460a9bc | 3906 | and then Expander_Active |
19fb051c | 3907 | and then (Is_Controlled (Etype (F)) or else Has_Task (Etype (F))) |
b7d1f17f | 3908 | then |
13b2f7fd | 3909 | Establish_Transient_Scope (A, Sec_Stack => False); |
24a120ac | 3910 | Resolve (A, Etype (F)); |
b7d1f17f | 3911 | |
a52fefe6 AC |
3912 | -- A small optimization: if one of the actuals is a concatenation |
3913 | -- create a block around a procedure call to recover stack space. | |
3914 | -- This alleviates stack usage when several procedure calls in | |
76e776e5 AC |
3915 | -- the same statement list use concatenation. We do not perform |
3916 | -- this wrapping for code statements, where the argument is a | |
3917 | -- static string, and we want to preserve warnings involving | |
3918 | -- sequences of such statements. | |
a52fefe6 AC |
3919 | |
3920 | elsif Nkind (A) = N_Op_Concat | |
3921 | and then Nkind (N) = N_Procedure_Call_Statement | |
4460a9bc | 3922 | and then Expander_Active |
76e776e5 AC |
3923 | and then |
3924 | not (Is_Intrinsic_Subprogram (Nam) | |
3925 | and then Chars (Nam) = Name_Asm) | |
a7a3cf5c | 3926 | and then not Static_Concatenation (A) |
a52fefe6 | 3927 | then |
13b2f7fd | 3928 | Establish_Transient_Scope (A, Sec_Stack => False); |
a52fefe6 AC |
3929 | Resolve (A, Etype (F)); |
3930 | ||
996ae0b0 | 3931 | else |
fbf5a39b AC |
3932 | if Nkind (A) = N_Type_Conversion |
3933 | and then Is_Array_Type (Etype (F)) | |
3934 | and then not Same_Ancestor (Etype (F), Etype (Expression (A))) | |
3935 | and then | |
3936 | (Is_Limited_Type (Etype (F)) | |
2e86f679 | 3937 | or else Is_Limited_Type (Etype (Expression (A)))) |
fbf5a39b AC |
3938 | then |
3939 | Error_Msg_N | |
1486a00e | 3940 | ("conversion between unrelated limited array types " |
2590ef12 | 3941 | & "not allowed ('A'I-00246)", A); |
fbf5a39b | 3942 | |
758c442c GD |
3943 | if Is_Limited_Type (Etype (F)) then |
3944 | Explain_Limited_Type (Etype (F), A); | |
3945 | end if; | |
fbf5a39b | 3946 | |
758c442c GD |
3947 | if Is_Limited_Type (Etype (Expression (A))) then |
3948 | Explain_Limited_Type (Etype (Expression (A)), A); | |
3949 | end if; | |
fbf5a39b AC |
3950 | end if; |
3951 | ||
c8ef728f ES |
3952 | -- (Ada 2005: AI-251): If the actual is an allocator whose |
3953 | -- directly designated type is a class-wide interface, we build | |
3954 | -- an anonymous access type to use it as the type of the | |
3955 | -- allocator. Later, when the subprogram call is expanded, if | |
3956 | -- the interface has a secondary dispatch table the expander | |
3957 | -- will add a type conversion to force the correct displacement | |
3958 | -- of the pointer. | |
3959 | ||
3960 | if Nkind (A) = N_Allocator then | |
3961 | declare | |
3962 | DDT : constant Entity_Id := | |
3963 | Directly_Designated_Type (Base_Type (Etype (F))); | |
45fc7ddb | 3964 | |
c8ef728f | 3965 | New_Itype : Entity_Id; |
45fc7ddb | 3966 | |
c8ef728f ES |
3967 | begin |
3968 | if Is_Class_Wide_Type (DDT) | |
3969 | and then Is_Interface (DDT) | |
3970 | then | |
3971 | New_Itype := Create_Itype (E_Anonymous_Access_Type, A); | |
45fc7ddb | 3972 | Set_Etype (New_Itype, Etype (A)); |
2590ef12 RD |
3973 | Set_Directly_Designated_Type |
3974 | (New_Itype, Directly_Designated_Type (Etype (A))); | |
c8ef728f ES |
3975 | Set_Etype (A, New_Itype); |
3976 | end if; | |
0669bebe GB |
3977 | |
3978 | -- Ada 2005, AI-162:If the actual is an allocator, the | |
3979 | -- innermost enclosing statement is the master of the | |
b7d1f17f HK |
3980 | -- created object. This needs to be done with expansion |
3981 | -- enabled only, otherwise the transient scope will not | |
3982 | -- be removed in the expansion of the wrapped construct. | |
0669bebe | 3983 | |
45fc7ddb | 3984 | if (Is_Controlled (DDT) or else Has_Task (DDT)) |
4460a9bc | 3985 | and then Expander_Active |
0669bebe | 3986 | then |
13b2f7fd | 3987 | Establish_Transient_Scope (A, Sec_Stack => False); |
0669bebe | 3988 | end if; |
c8ef728f | 3989 | end; |
57f4c288 ES |
3990 | |
3991 | if Ekind (Etype (F)) = E_Anonymous_Access_Type then | |
3992 | Check_Restriction (No_Access_Parameter_Allocators, A); | |
3993 | end if; | |
c8ef728f ES |
3994 | end if; |
3995 | ||
2e86f679 RD |
3996 | -- (Ada 2005): The call may be to a primitive operation of a |
3997 | -- tagged synchronized type, declared outside of the type. In | |
3998 | -- this case the controlling actual must be converted to its | |
3999 | -- corresponding record type, which is the formal type. The | |
4000 | -- actual may be a subtype, either because of a constraint or | |
4001 | -- because it is a generic actual, so use base type to locate | |
4002 | -- concurrent type. | |
b7d1f17f | 4003 | |
15e4986c JM |
4004 | F_Typ := Base_Type (Etype (F)); |
4005 | ||
cb7fa356 AC |
4006 | if Is_Tagged_Type (F_Typ) |
4007 | and then (Is_Concurrent_Type (F_Typ) | |
2590ef12 | 4008 | or else Is_Concurrent_Record_Type (F_Typ)) |
cb7fa356 AC |
4009 | then |
4010 | -- If the actual is overloaded, look for an interpretation | |
4011 | -- that has a synchronized type. | |
4012 | ||
4013 | if not Is_Overloaded (A) then | |
4014 | A_Typ := Base_Type (Etype (A)); | |
15e4986c | 4015 | |
15e4986c | 4016 | else |
cb7fa356 AC |
4017 | declare |
4018 | Index : Interp_Index; | |
4019 | It : Interp; | |
218e6dee | 4020 | |
cb7fa356 AC |
4021 | begin |
4022 | Get_First_Interp (A, Index, It); | |
4023 | while Present (It.Typ) loop | |
4024 | if Is_Concurrent_Type (It.Typ) | |
4025 | or else Is_Concurrent_Record_Type (It.Typ) | |
4026 | then | |
4027 | A_Typ := Base_Type (It.Typ); | |
4028 | exit; | |
4029 | end if; | |
4030 | ||
4031 | Get_Next_Interp (Index, It); | |
4032 | end loop; | |
4033 | end; | |
15e4986c | 4034 | end if; |
b7d1f17f | 4035 | |
cb7fa356 AC |
4036 | declare |
4037 | Full_A_Typ : Entity_Id; | |
15e4986c | 4038 | |
cb7fa356 AC |
4039 | begin |
4040 | if Present (Full_View (A_Typ)) then | |
4041 | Full_A_Typ := Base_Type (Full_View (A_Typ)); | |
4042 | else | |
4043 | Full_A_Typ := A_Typ; | |
4044 | end if; | |
4045 | ||
4046 | -- Tagged synchronized type (case 1): the actual is a | |
4047 | -- concurrent type. | |
4048 | ||
4049 | if Is_Concurrent_Type (A_Typ) | |
4050 | and then Corresponding_Record_Type (A_Typ) = F_Typ | |
4051 | then | |
4052 | Rewrite (A, | |
4053 | Unchecked_Convert_To | |
4054 | (Corresponding_Record_Type (A_Typ), A)); | |
4055 | Resolve (A, Etype (F)); | |
15e4986c | 4056 | |
cb7fa356 AC |
4057 | -- Tagged synchronized type (case 2): the formal is a |
4058 | -- concurrent type. | |
15e4986c | 4059 | |
cb7fa356 AC |
4060 | elsif Ekind (Full_A_Typ) = E_Record_Type |
4061 | and then Present | |
15e4986c | 4062 | (Corresponding_Concurrent_Type (Full_A_Typ)) |
cb7fa356 AC |
4063 | and then Is_Concurrent_Type (F_Typ) |
4064 | and then Present (Corresponding_Record_Type (F_Typ)) | |
4065 | and then Full_A_Typ = Corresponding_Record_Type (F_Typ) | |
4066 | then | |
4067 | Resolve (A, Corresponding_Record_Type (F_Typ)); | |
15e4986c | 4068 | |
cb7fa356 | 4069 | -- Common case |
15e4986c | 4070 | |
cb7fa356 AC |
4071 | else |
4072 | Resolve (A, Etype (F)); | |
4073 | end if; | |
4074 | end; | |
cb7fa356 | 4075 | |
2590ef12 | 4076 | -- Not a synchronized operation |
cb7fa356 | 4077 | |
2590ef12 | 4078 | else |
cb7fa356 AC |
4079 | Resolve (A, Etype (F)); |
4080 | end if; | |
996ae0b0 RK |
4081 | end if; |
4082 | ||
4083 | A_Typ := Etype (A); | |
4084 | F_Typ := Etype (F); | |
4085 | ||
1ebc2612 AC |
4086 | -- An actual cannot be an untagged formal incomplete type |
4087 | ||
4088 | if Ekind (A_Typ) = E_Incomplete_Type | |
4089 | and then not Is_Tagged_Type (A_Typ) | |
4090 | and then Is_Generic_Type (A_Typ) | |
4091 | then | |
4092 | Error_Msg_N | |
4093 | ("invalid use of untagged formal incomplete type", A); | |
4094 | end if; | |
4095 | ||
e24329cd | 4096 | if Comes_From_Source (Original_Node (N)) |
6320f5e1 AC |
4097 | and then Nkind_In (Original_Node (N), N_Function_Call, |
4098 | N_Procedure_Call_Statement) | |
b0186f71 | 4099 | then |
e24329cd YM |
4100 | -- In formal mode, check that actual parameters matching |
4101 | -- formals of tagged types are objects (or ancestor type | |
4102 | -- conversions of objects), not general expressions. | |
780d052e | 4103 | |
e24329cd | 4104 | if Is_Actual_Tagged_Parameter (A) then |
ce5ba43a | 4105 | if Is_SPARK_05_Object_Reference (A) then |
e24329cd YM |
4106 | null; |
4107 | ||
4108 | elsif Nkind (A) = N_Type_Conversion then | |
4109 | declare | |
4110 | Operand : constant Node_Id := Expression (A); | |
4111 | Operand_Typ : constant Entity_Id := Etype (Operand); | |
4112 | Target_Typ : constant Entity_Id := A_Typ; | |
4113 | ||
4114 | begin | |
ce5ba43a AC |
4115 | if not Is_SPARK_05_Object_Reference (Operand) then |
4116 | Check_SPARK_05_Restriction | |
e24329cd YM |
4117 | ("object required", Operand); |
4118 | ||
4119 | -- In formal mode, the only view conversions are those | |
4120 | -- involving ancestor conversion of an extended type. | |
4121 | ||
4122 | elsif not | |
4123 | (Is_Tagged_Type (Target_Typ) | |
780d052e RD |
4124 | and then not Is_Class_Wide_Type (Target_Typ) |
4125 | and then Is_Tagged_Type (Operand_Typ) | |
4126 | and then not Is_Class_Wide_Type (Operand_Typ) | |
4127 | and then Is_Ancestor (Target_Typ, Operand_Typ)) | |
e24329cd YM |
4128 | then |
4129 | if Ekind_In | |
4130 | (F, E_Out_Parameter, E_In_Out_Parameter) | |
4131 | then | |
ce5ba43a | 4132 | Check_SPARK_05_Restriction |
e24329cd YM |
4133 | ("ancestor conversion is the only permitted " |
4134 | & "view conversion", A); | |
4135 | else | |
ce5ba43a | 4136 | Check_SPARK_05_Restriction |
e24329cd YM |
4137 | ("ancestor conversion required", A); |
4138 | end if; | |
4139 | ||
4140 | else | |
4141 | null; | |
4142 | end if; | |
4143 | end; | |
4144 | ||
4145 | else | |
ce5ba43a | 4146 | Check_SPARK_05_Restriction ("object required", A); |
b0186f71 | 4147 | end if; |
e24329cd YM |
4148 | |
4149 | -- In formal mode, the only view conversions are those | |
4150 | -- involving ancestor conversion of an extended type. | |
4151 | ||
4152 | elsif Nkind (A) = N_Type_Conversion | |
4153 | and then Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) | |
4154 | then | |
ce5ba43a | 4155 | Check_SPARK_05_Restriction |
e24329cd YM |
4156 | ("ancestor conversion is the only permitted view " |
4157 | & "conversion", A); | |
4158 | end if; | |
b0186f71 AC |
4159 | end if; |
4160 | ||
26570b21 RD |
4161 | -- has warnings suppressed, then we reset Never_Set_In_Source for |
4162 | -- the calling entity. The reason for this is to catch cases like | |
4163 | -- GNAT.Spitbol.Patterns.Vstring_Var where the called subprogram | |
4164 | -- uses trickery to modify an IN parameter. | |
4165 | ||
4166 | if Ekind (F) = E_In_Parameter | |
4167 | and then Is_Entity_Name (A) | |
4168 | and then Present (Entity (A)) | |
4169 | and then Ekind (Entity (A)) = E_Variable | |
4170 | and then Has_Warnings_Off (F_Typ) | |
4171 | then | |
4172 | Set_Never_Set_In_Source (Entity (A), False); | |
4173 | end if; | |
4174 | ||
fbf5a39b AC |
4175 | -- Perform error checks for IN and IN OUT parameters |
4176 | ||
4177 | if Ekind (F) /= E_Out_Parameter then | |
4178 | ||
4179 | -- Check unset reference. For scalar parameters, it is clearly | |
4180 | -- wrong to pass an uninitialized value as either an IN or | |
4181 | -- IN-OUT parameter. For composites, it is also clearly an | |
4182 | -- error to pass a completely uninitialized value as an IN | |
4183 | -- parameter, but the case of IN OUT is trickier. We prefer | |
4184 | -- not to give a warning here. For example, suppose there is | |
4185 | -- a routine that sets some component of a record to False. | |
4186 | -- It is perfectly reasonable to make this IN-OUT and allow | |
4187 | -- either initialized or uninitialized records to be passed | |
4188 | -- in this case. | |
4189 | ||
4190 | -- For partially initialized composite values, we also avoid | |
4191 | -- warnings, since it is quite likely that we are passing a | |
4192 | -- partially initialized value and only the initialized fields | |
4193 | -- will in fact be read in the subprogram. | |
4194 | ||
4195 | if Is_Scalar_Type (A_Typ) | |
4196 | or else (Ekind (F) = E_In_Parameter | |
19fb051c | 4197 | and then not Is_Partially_Initialized_Type (A_Typ)) |
996ae0b0 | 4198 | then |
fbf5a39b | 4199 | Check_Unset_Reference (A); |
996ae0b0 | 4200 | end if; |
996ae0b0 | 4201 | |
758c442c | 4202 | -- In Ada 83 we cannot pass an OUT parameter as an IN or IN OUT |
a921e83c AC |
4203 | -- actual to a nested call, since this constitutes a reading of |
4204 | -- the parameter, which is not allowed. | |
996ae0b0 | 4205 | |
847d950d HK |
4206 | if Ada_Version = Ada_83 |
4207 | and then Is_Entity_Name (A) | |
996ae0b0 RK |
4208 | and then Ekind (Entity (A)) = E_Out_Parameter |
4209 | then | |
847d950d | 4210 | Error_Msg_N ("(Ada 83) illegal reading of out parameter", A); |
996ae0b0 RK |
4211 | end if; |
4212 | end if; | |
4213 | ||
a267d8cc AC |
4214 | -- In -gnatd.q mode, forget that a given array is constant when |
4215 | -- it is passed as an IN parameter to a foreign-convention | |
4216 | -- subprogram. This is in case the subprogram evilly modifies the | |
4217 | -- object. Of course, correct code would use IN OUT. | |
4218 | ||
4219 | if Debug_Flag_Dot_Q | |
4220 | and then Ekind (F) = E_In_Parameter | |
4221 | and then Has_Foreign_Convention (Nam) | |
4222 | and then Is_Array_Type (F_Typ) | |
4223 | and then Nkind (A) in N_Has_Entity | |
4224 | and then Present (Entity (A)) | |
4225 | then | |
4226 | Set_Is_True_Constant (Entity (A), False); | |
4227 | end if; | |
4228 | ||
67ce0d7e RD |
4229 | -- Case of OUT or IN OUT parameter |
4230 | ||
36fcf362 | 4231 | if Ekind (F) /= E_In_Parameter then |
67ce0d7e RD |
4232 | |
4233 | -- For an Out parameter, check for useless assignment. Note | |
45fc7ddb HK |
4234 | -- that we can't set Last_Assignment this early, because we may |
4235 | -- kill current values in Resolve_Call, and that call would | |
4236 | -- clobber the Last_Assignment field. | |
67ce0d7e | 4237 | |
45fc7ddb HK |
4238 | -- Note: call Warn_On_Useless_Assignment before doing the check |
4239 | -- below for Is_OK_Variable_For_Out_Formal so that the setting | |
4240 | -- of Referenced_As_LHS/Referenced_As_Out_Formal properly | |
a90bd866 | 4241 | -- reflects the last assignment, not this one. |
36fcf362 | 4242 | |
67ce0d7e | 4243 | if Ekind (F) = E_Out_Parameter then |
36fcf362 | 4244 | if Warn_On_Modified_As_Out_Parameter (F) |
67ce0d7e RD |
4245 | and then Is_Entity_Name (A) |
4246 | and then Present (Entity (A)) | |
36fcf362 | 4247 | and then Comes_From_Source (N) |
67ce0d7e | 4248 | then |
36fcf362 | 4249 | Warn_On_Useless_Assignment (Entity (A), A); |
67ce0d7e RD |
4250 | end if; |
4251 | end if; | |
4252 | ||
36fcf362 RD |
4253 | -- Validate the form of the actual. Note that the call to |
4254 | -- Is_OK_Variable_For_Out_Formal generates the required | |
4255 | -- reference in this case. | |
4256 | ||
0180fd26 AC |
4257 | -- A call to an initialization procedure for an aggregate |
4258 | -- component may initialize a nested component of a constant | |
4259 | -- designated object. In this context the object is variable. | |
4260 | ||
4261 | if not Is_OK_Variable_For_Out_Formal (A) | |
4262 | and then not Is_Init_Proc (Nam) | |
4263 | then | |
36fcf362 | 4264 | Error_Msg_NE ("actual for& must be a variable", A, F); |
43dbd3e3 | 4265 | |
3ddfabe3 AC |
4266 | if Is_Subprogram (Current_Scope) then |
4267 | if Is_Invariant_Procedure (Current_Scope) | |
4268 | or else Is_Partial_Invariant_Procedure (Current_Scope) | |
4269 | then | |
4270 | Error_Msg_N | |
4271 | ("function used in invariant cannot modify its " | |
4272 | & "argument", F); | |
4273 | ||
4274 | elsif Is_Predicate_Function (Current_Scope) then | |
4275 | Error_Msg_N | |
4276 | ("function used in predicate cannot modify its " | |
4277 | & "argument", F); | |
4278 | end if; | |
43dbd3e3 | 4279 | end if; |
36fcf362 RD |
4280 | end if; |
4281 | ||
67ce0d7e | 4282 | -- What's the following about??? |
fbf5a39b AC |
4283 | |
4284 | if Is_Entity_Name (A) then | |
4285 | Kill_Checks (Entity (A)); | |
4286 | else | |
4287 | Kill_All_Checks; | |
4288 | end if; | |
4289 | end if; | |
4290 | ||
4291 | if Etype (A) = Any_Type then | |
4292 | Set_Etype (N, Any_Type); | |
4293 | return; | |
4294 | end if; | |
4295 | ||
5f6fb720 | 4296 | -- Apply appropriate constraint/predicate checks for IN [OUT] case |
996ae0b0 | 4297 | |
8a95f4e8 | 4298 | if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then |
48f91b44 | 4299 | |
5f6fb720 AC |
4300 | -- Apply predicate tests except in certain special cases. Note |
4301 | -- that it might be more consistent to apply these only when | |
4302 | -- expansion is active (in Exp_Ch6.Expand_Actuals), as we do | |
6eca51ce ES |
4303 | -- for the outbound predicate tests ??? In any case indicate |
4304 | -- the function being called, for better warnings if the call | |
4305 | -- leads to an infinite recursion. | |
48f91b44 | 4306 | |
b8e6830b | 4307 | if Predicate_Tests_On_Arguments (Nam) then |
6eca51ce | 4308 | Apply_Predicate_Check (A, F_Typ, Nam); |
48f91b44 RD |
4309 | end if; |
4310 | ||
4311 | -- Apply required constraint checks | |
4312 | ||
5f6fb720 AC |
4313 | -- Gigi looks at the check flag and uses the appropriate types. |
4314 | -- For now since one flag is used there is an optimization | |
4315 | -- which might not be done in the IN OUT case since Gigi does | |
4316 | -- not do any analysis. More thought required about this ??? | |
4317 | ||
4318 | -- In fact is this comment obsolete??? doesn't the expander now | |
4319 | -- generate all these tests anyway??? | |
4320 | ||
996ae0b0 RK |
4321 | if Is_Scalar_Type (Etype (A)) then |
4322 | Apply_Scalar_Range_Check (A, F_Typ); | |
4323 | ||
4324 | elsif Is_Array_Type (Etype (A)) then | |
4325 | Apply_Length_Check (A, F_Typ); | |
4326 | ||
4327 | elsif Is_Record_Type (F_Typ) | |
4328 | and then Has_Discriminants (F_Typ) | |
4329 | and then Is_Constrained (F_Typ) | |
4330 | and then (not Is_Derived_Type (F_Typ) | |
19fb051c | 4331 | or else Comes_From_Source (Nam)) |
996ae0b0 RK |
4332 | then |
4333 | Apply_Discriminant_Check (A, F_Typ); | |
4334 | ||
f1bd0415 AC |
4335 | -- For view conversions of a discriminated object, apply |
4336 | -- check to object itself, the conversion alreay has the | |
4337 | -- proper type. | |
4338 | ||
4339 | if Nkind (A) = N_Type_Conversion | |
4340 | and then Is_Constrained (Etype (Expression (A))) | |
4341 | then | |
4342 | Apply_Discriminant_Check (Expression (A), F_Typ); | |
4343 | end if; | |
4344 | ||
996ae0b0 RK |
4345 | elsif Is_Access_Type (F_Typ) |
4346 | and then Is_Array_Type (Designated_Type (F_Typ)) | |
4347 | and then Is_Constrained (Designated_Type (F_Typ)) | |
4348 | then | |
4349 | Apply_Length_Check (A, F_Typ); | |
4350 | ||
4351 | elsif Is_Access_Type (F_Typ) | |
4352 | and then Has_Discriminants (Designated_Type (F_Typ)) | |
4353 | and then Is_Constrained (Designated_Type (F_Typ)) | |
4354 | then | |
4355 | Apply_Discriminant_Check (A, F_Typ); | |
4356 | ||
4357 | else | |
4358 | Apply_Range_Check (A, F_Typ); | |
4359 | end if; | |
2820d220 | 4360 | |
0f1a6a0b AC |
4361 | -- Ada 2005 (AI-231): Note that the controlling parameter case |
4362 | -- already existed in Ada 95, which is partially checked | |
4363 | -- elsewhere (see Checks), and we don't want the warning | |
4364 | -- message to differ. | |
2820d220 | 4365 | |
0f1a6a0b | 4366 | if Is_Access_Type (F_Typ) |
1420b484 | 4367 | and then Can_Never_Be_Null (F_Typ) |
aa5147f0 | 4368 | and then Known_Null (A) |
2820d220 | 4369 | then |
0f1a6a0b AC |
4370 | if Is_Controlling_Formal (F) then |
4371 | Apply_Compile_Time_Constraint_Error | |
4372 | (N => A, | |
324ac540 | 4373 | Msg => "null value not allowed here??", |
0f1a6a0b AC |
4374 | Reason => CE_Access_Check_Failed); |
4375 | ||
4376 | elsif Ada_Version >= Ada_2005 then | |
4377 | Apply_Compile_Time_Constraint_Error | |
4378 | (N => A, | |
4379 | Msg => "(Ada 2005) null not allowed in " | |
324ac540 | 4380 | & "null-excluding formal??", |
0f1a6a0b AC |
4381 | Reason => CE_Null_Not_Allowed); |
4382 | end if; | |
2820d220 | 4383 | end if; |
996ae0b0 RK |
4384 | end if; |
4385 | ||
5f6fb720 AC |
4386 | -- Checks for OUT parameters and IN OUT parameters |
4387 | ||
8a95f4e8 | 4388 | if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then |
5f6fb720 | 4389 | |
27bb7941 | 4390 | -- If there is a type conversion, make sure the return value |
5f6fb720 AC |
4391 | -- meets the constraints of the variable before the conversion. |
4392 | ||
996ae0b0 RK |
4393 | if Nkind (A) = N_Type_Conversion then |
4394 | if Is_Scalar_Type (A_Typ) then | |
4395 | Apply_Scalar_Range_Check | |
4396 | (Expression (A), Etype (Expression (A)), A_Typ); | |
27bb7941 | 4397 | |
e4d04166 AC |
4398 | -- In addition, the returned value of the parameter must |
4399 | -- satisfy the bounds of the object type (see comment | |
4400 | -- below). | |
27bb7941 AC |
4401 | |
4402 | Apply_Scalar_Range_Check (A, A_Typ, F_Typ); | |
4403 | ||
996ae0b0 RK |
4404 | else |
4405 | Apply_Range_Check | |
4406 | (Expression (A), Etype (Expression (A)), A_Typ); | |
4407 | end if; | |
4408 | ||
27bb7941 AC |
4409 | -- If no conversion, apply scalar range checks and length check |
4410 | -- based on the subtype of the actual (NOT that of the formal). | |
4411 | -- This indicates that the check takes place on return from the | |
4412 | -- call. During expansion the required constraint checks are | |
4413 | -- inserted. In GNATprove mode, in the absence of expansion, | |
4414 | -- the flag indicates that the returned value is valid. | |
5f6fb720 | 4415 | |
996ae0b0 RK |
4416 | else |
4417 | if Is_Scalar_Type (F_Typ) then | |
4418 | Apply_Scalar_Range_Check (A, A_Typ, F_Typ); | |
27bb7941 | 4419 | |
996ae0b0 RK |
4420 | elsif Is_Array_Type (F_Typ) |
4421 | and then Ekind (F) = E_Out_Parameter | |
4422 | then | |
4423 | Apply_Length_Check (A, F_Typ); | |
996ae0b0 RK |
4424 | else |
4425 | Apply_Range_Check (A, A_Typ, F_Typ); | |
4426 | end if; | |
4427 | end if; | |
5f6fb720 AC |
4428 | |
4429 | -- Note: we do not apply the predicate checks for the case of | |
4430 | -- OUT and IN OUT parameters. They are instead applied in the | |
4431 | -- Expand_Actuals routine in Exp_Ch6. | |
996ae0b0 RK |
4432 | end if; |
4433 | ||
4434 | -- An actual associated with an access parameter is implicitly | |
45fc7ddb HK |
4435 | -- converted to the anonymous access type of the formal and must |
4436 | -- satisfy the legality checks for access conversions. | |
996ae0b0 RK |
4437 | |
4438 | if Ekind (F_Typ) = E_Anonymous_Access_Type then | |
4439 | if not Valid_Conversion (A, F_Typ, A) then | |
4440 | Error_Msg_N | |
4441 | ("invalid implicit conversion for access parameter", A); | |
4442 | end if; | |
de94a7e7 AC |
4443 | |
4444 | -- If the actual is an access selected component of a variable, | |
4445 | -- the call may modify its designated object. It is reasonable | |
4446 | -- to treat this as a potential modification of the enclosing | |
4447 | -- record, to prevent spurious warnings that it should be | |
4448 | -- declared as a constant, because intuitively programmers | |
4449 | -- regard the designated subcomponent as part of the record. | |
4450 | ||
4451 | if Nkind (A) = N_Selected_Component | |
4452 | and then Is_Entity_Name (Prefix (A)) | |
4453 | and then not Is_Constant_Object (Entity (Prefix (A))) | |
4454 | then | |
4455 | Note_Possible_Modification (A, Sure => False); | |
4456 | end if; | |
996ae0b0 RK |
4457 | end if; |
4458 | ||
4459 | -- Check bad case of atomic/volatile argument (RM C.6(12)) | |
4460 | ||
4461 | if Is_By_Reference_Type (Etype (F)) | |
4462 | and then Comes_From_Source (N) | |
4463 | then | |
4464 | if Is_Atomic_Object (A) | |
4465 | and then not Is_Atomic (Etype (F)) | |
4466 | then | |
b5bf3335 AC |
4467 | Error_Msg_NE |
4468 | ("cannot pass atomic argument to non-atomic formal&", | |
4469 | A, F); | |
996ae0b0 RK |
4470 | |
4471 | elsif Is_Volatile_Object (A) | |
4472 | and then not Is_Volatile (Etype (F)) | |
4473 | then | |
b5bf3335 AC |
4474 | Error_Msg_NE |
4475 | ("cannot pass volatile argument to non-volatile formal&", | |
4476 | A, F); | |
996ae0b0 RK |
4477 | end if; |
4478 | end if; | |
4479 | ||
4480 | -- Check that subprograms don't have improper controlling | |
d81b4bfe | 4481 | -- arguments (RM 3.9.2 (9)). |
996ae0b0 | 4482 | |
0669bebe GB |
4483 | -- A primitive operation may have an access parameter of an |
4484 | -- incomplete tagged type, but a dispatching call is illegal | |
4485 | -- if the type is still incomplete. | |
4486 | ||
996ae0b0 RK |
4487 | if Is_Controlling_Formal (F) then |
4488 | Set_Is_Controlling_Actual (A); | |
0669bebe GB |
4489 | |
4490 | if Ekind (Etype (F)) = E_Anonymous_Access_Type then | |
4491 | declare | |
4492 | Desig : constant Entity_Id := Designated_Type (Etype (F)); | |
4493 | begin | |
4494 | if Ekind (Desig) = E_Incomplete_Type | |
4495 | and then No (Full_View (Desig)) | |
4496 | and then No (Non_Limited_View (Desig)) | |
4497 | then | |
4498 | Error_Msg_NE | |
1486a00e AC |
4499 | ("premature use of incomplete type& " |
4500 | & "in dispatching call", A, Desig); | |
0669bebe GB |
4501 | end if; |
4502 | end; | |
4503 | end if; | |
4504 | ||
996ae0b0 RK |
4505 | elsif Nkind (A) = N_Explicit_Dereference then |
4506 | Validate_Remote_Access_To_Class_Wide_Type (A); | |
4507 | end if; | |
4508 | ||
6c802906 AC |
4509 | -- Apply legality rule 3.9.2 (9/1) |
4510 | ||
996ae0b0 RK |
4511 | if (Is_Class_Wide_Type (A_Typ) or else Is_Dynamically_Tagged (A)) |
4512 | and then not Is_Class_Wide_Type (F_Typ) | |
4513 | and then not Is_Controlling_Formal (F) | |
6c802906 | 4514 | and then not In_Instance |
996ae0b0 RK |
4515 | then |
4516 | Error_Msg_N ("class-wide argument not allowed here!", A); | |
07fc65c4 | 4517 | |
b9696ffb | 4518 | if Is_Subprogram (Nam) and then Comes_From_Source (Nam) then |
996ae0b0 RK |
4519 | Error_Msg_Node_2 := F_Typ; |
4520 | Error_Msg_NE | |
82c80734 | 4521 | ("& is not a dispatching operation of &!", A, Nam); |
996ae0b0 RK |
4522 | end if; |
4523 | ||
97216ca8 ES |
4524 | -- Apply the checks described in 3.10.2(27): if the context is a |
4525 | -- specific access-to-object, the actual cannot be class-wide. | |
4526 | -- Use base type to exclude access_to_subprogram cases. | |
4527 | ||
996ae0b0 RK |
4528 | elsif Is_Access_Type (A_Typ) |
4529 | and then Is_Access_Type (F_Typ) | |
97216ca8 | 4530 | and then not Is_Access_Subprogram_Type (Base_Type (F_Typ)) |
996ae0b0 | 4531 | and then (Is_Class_Wide_Type (Designated_Type (A_Typ)) |
07fc65c4 GB |
4532 | or else (Nkind (A) = N_Attribute_Reference |
4533 | and then | |
2590ef12 | 4534 | Is_Class_Wide_Type (Etype (Prefix (A))))) |
996ae0b0 RK |
4535 | and then not Is_Class_Wide_Type (Designated_Type (F_Typ)) |
4536 | and then not Is_Controlling_Formal (F) | |
ae65d635 | 4537 | |
46fe0142 | 4538 | -- Disable these checks for call to imported C++ subprograms |
ae65d635 | 4539 | |
46fe0142 AC |
4540 | and then not |
4541 | (Is_Entity_Name (Name (N)) | |
4542 | and then Is_Imported (Entity (Name (N))) | |
4543 | and then Convention (Entity (Name (N))) = Convention_CPP) | |
996ae0b0 RK |
4544 | then |
4545 | Error_Msg_N | |
4546 | ("access to class-wide argument not allowed here!", A); | |
07fc65c4 | 4547 | |
97216ca8 | 4548 | if Is_Subprogram (Nam) and then Comes_From_Source (Nam) then |
996ae0b0 RK |
4549 | Error_Msg_Node_2 := Designated_Type (F_Typ); |
4550 | Error_Msg_NE | |
82c80734 | 4551 | ("& is not a dispatching operation of &!", A, Nam); |
996ae0b0 RK |
4552 | end if; |
4553 | end if; | |
4554 | ||
f3691f46 ES |
4555 | Check_Aliased_Parameter; |
4556 | ||
996ae0b0 RK |
4557 | Eval_Actual (A); |
4558 | ||
8e4dac80 | 4559 | -- If it is a named association, treat the selector_name as a |
2590ef12 | 4560 | -- proper identifier, and mark the corresponding entity. |
996ae0b0 | 4561 | |
1f9939b5 | 4562 | if Nkind (Parent (A)) = N_Parameter_Association |
2590ef12 RD |
4563 | |
4564 | -- Ignore reference in SPARK mode, as it refers to an entity not | |
4565 | -- in scope at the point of reference, so the reference should | |
4566 | -- be ignored for computing effects of subprograms. | |
4567 | ||
f5da7a97 | 4568 | and then not GNATprove_Mode |
1f9939b5 | 4569 | then |
e6b3f5ba ES |
4570 | -- If subprogram is overridden, use name of formal that |
4571 | -- is being called. | |
4572 | ||
4573 | if Present (Real_Subp) then | |
4574 | Set_Entity (Selector_Name (Parent (A)), Real_F); | |
4575 | Set_Etype (Selector_Name (Parent (A)), Etype (Real_F)); | |
4576 | ||
4577 | else | |
4578 | Set_Entity (Selector_Name (Parent (A)), F); | |
4579 | Generate_Reference (F, Selector_Name (Parent (A))); | |
4580 | Set_Etype (Selector_Name (Parent (A)), F_Typ); | |
4581 | Generate_Reference (F_Typ, N, ' '); | |
4582 | end if; | |
996ae0b0 RK |
4583 | end if; |
4584 | ||
4585 | Prev := A; | |
fbf5a39b AC |
4586 | |
4587 | if Ekind (F) /= E_Out_Parameter then | |
4588 | Check_Unset_Reference (A); | |
4589 | end if; | |
4590 | ||
fb1fdf7d | 4591 | -- The following checks are only relevant when SPARK_Mode is on as |
7b4ebba5 AC |
4592 | -- they are not standard Ada legality rule. Internally generated |
4593 | -- temporaries are ignored. | |
6c3c671e | 4594 | |
888be6b1 AC |
4595 | if SPARK_Mode = On and then Comes_From_Source (A) then |
4596 | ||
ed962eda | 4597 | -- An effectively volatile object may act as an actual when the |
aafc151a | 4598 | -- corresponding formal is of a non-scalar effectively volatile |
db7e3721 | 4599 | -- type (SPARK RM 7.1.3(11)). |
6c3c671e | 4600 | |
aafc151a AC |
4601 | if not Is_Scalar_Type (Etype (F)) |
4602 | and then Is_Effectively_Volatile (Etype (F)) | |
6c3c671e AC |
4603 | then |
4604 | null; | |
4605 | ||
ed962eda AC |
4606 | -- An effectively volatile object may act as an actual in a |
4607 | -- call to an instance of Unchecked_Conversion. | |
db7e3721 | 4608 | -- (SPARK RM 7.1.3(11)). |
6c3c671e AC |
4609 | |
4610 | elsif Is_Unchecked_Conversion_Instance (Nam) then | |
4611 | null; | |
4612 | ||
888be6b1 AC |
4613 | -- The actual denotes an object |
4614 | ||
4615 | elsif Is_Effectively_Volatile_Object (A) then | |
6c3c671e | 4616 | Error_Msg_N |
fb1fdf7d | 4617 | ("volatile object cannot act as actual in a call (SPARK " |
db7e3721 | 4618 | & "RM 7.1.3(11))", A); |
888be6b1 AC |
4619 | |
4620 | -- Otherwise the actual denotes an expression. Inspect the | |
4621 | -- expression and flag each effectively volatile object with | |
4622 | -- enabled property Async_Writers or Effective_Reads as illegal | |
4623 | -- because it apprears within an interfering context. Note that | |
4624 | -- this is usually done in Resolve_Entity_Name, but when the | |
4625 | -- effectively volatile object appears as an actual in a call, | |
4626 | -- the call must be resolved first. | |
4627 | ||
4628 | else | |
4629 | Flag_Effectively_Volatile_Objects (A); | |
6c3c671e | 4630 | end if; |
97779c34 AC |
4631 | |
4632 | -- Detect an external variable with an enabled property that | |
4633 | -- does not match the mode of the corresponding formal in a | |
7b4ebba5 AC |
4634 | -- procedure call. Functions are not considered because they |
4635 | -- cannot have effectively volatile formal parameters in the | |
4636 | -- first place. | |
97779c34 AC |
4637 | |
4638 | if Ekind (Nam) = E_Procedure | |
de4ac038 | 4639 | and then Ekind (F) = E_In_Parameter |
97779c34 AC |
4640 | and then Is_Entity_Name (A) |
4641 | and then Present (Entity (A)) | |
4642 | and then Ekind (Entity (A)) = E_Variable | |
4643 | then | |
4644 | A_Id := Entity (A); | |
4645 | ||
de4ac038 AC |
4646 | if Async_Readers_Enabled (A_Id) then |
4647 | Property_Error (A, A_Id, Name_Async_Readers); | |
4648 | elsif Effective_Reads_Enabled (A_Id) then | |
4649 | Property_Error (A, A_Id, Name_Effective_Reads); | |
4650 | elsif Effective_Writes_Enabled (A_Id) then | |
4651 | Property_Error (A, A_Id, Name_Effective_Writes); | |
97779c34 AC |
4652 | end if; |
4653 | end if; | |
6c3c671e AC |
4654 | end if; |
4655 | ||
039538bc AC |
4656 | -- A formal parameter of a specific tagged type whose related |
4657 | -- subprogram is subject to pragma Extensions_Visible with value | |
4658 | -- "False" cannot act as an actual in a subprogram with value | |
b3407ce0 | 4659 | -- "True" (SPARK RM 6.1.7(3)). |
039538bc AC |
4660 | |
4661 | if Is_EVF_Expression (A) | |
4662 | and then Extensions_Visible_Status (Nam) = | |
4663 | Extensions_Visible_True | |
4664 | then | |
4665 | Error_Msg_N | |
44900051 AC |
4666 | ("formal parameter cannot act as actual parameter when " |
4667 | & "Extensions_Visible is False", A); | |
039538bc AC |
4668 | Error_Msg_NE |
4669 | ("\subprogram & has Extensions_Visible True", A, Nam); | |
4670 | end if; | |
4671 | ||
3c756b76 | 4672 | -- The actual parameter of a Ghost subprogram whose formal is of |
4179af27 | 4673 | -- mode IN OUT or OUT must be a Ghost variable (SPARK RM 6.9(12)). |
3c756b76 | 4674 | |
95fef24f AC |
4675 | if Comes_From_Source (Nam) |
4676 | and then Is_Ghost_Entity (Nam) | |
3c756b76 AC |
4677 | and then Ekind_In (F, E_In_Out_Parameter, E_Out_Parameter) |
4678 | and then Is_Entity_Name (A) | |
4679 | and then Present (Entity (A)) | |
4680 | and then not Is_Ghost_Entity (Entity (A)) | |
4681 | then | |
4682 | Error_Msg_NE | |
4683 | ("non-ghost variable & cannot appear as actual in call to " | |
4684 | & "ghost procedure", A, Entity (A)); | |
4685 | ||
4686 | if Ekind (F) = E_In_Out_Parameter then | |
4687 | Error_Msg_N ("\corresponding formal has mode `IN OUT`", A); | |
4688 | else | |
4689 | Error_Msg_N ("\corresponding formal has mode OUT", A); | |
4690 | end if; | |
4691 | end if; | |
4692 | ||
996ae0b0 RK |
4693 | Next_Actual (A); |
4694 | ||
fbf5a39b AC |
4695 | -- Case where actual is not present |
4696 | ||
996ae0b0 RK |
4697 | else |
4698 | Insert_Default; | |
4699 | end if; | |
4700 | ||
4701 | Next_Formal (F); | |
4d6a38a5 ES |
4702 | |
4703 | if Present (Real_Subp) then | |
4704 | Next_Formal (Real_F); | |
4705 | end if; | |
996ae0b0 | 4706 | end loop; |
996ae0b0 RK |
4707 | end Resolve_Actuals; |
4708 | ||
4709 | ----------------------- | |
4710 | -- Resolve_Allocator -- | |
4711 | ----------------------- | |
4712 | ||
4713 | procedure Resolve_Allocator (N : Node_Id; Typ : Entity_Id) is | |
949a18cc | 4714 | Desig_T : constant Entity_Id := Designated_Type (Typ); |
ee2e3f6b | 4715 | E : constant Node_Id := Expression (N); |
996ae0b0 RK |
4716 | Subtyp : Entity_Id; |
4717 | Discrim : Entity_Id; | |
4718 | Constr : Node_Id; | |
b7d1f17f HK |
4719 | Aggr : Node_Id; |
4720 | Assoc : Node_Id := Empty; | |
996ae0b0 RK |
4721 | Disc_Exp : Node_Id; |
4722 | ||
b7d1f17f HK |
4723 | procedure Check_Allocator_Discrim_Accessibility |
4724 | (Disc_Exp : Node_Id; | |
4725 | Alloc_Typ : Entity_Id); | |
4726 | -- Check that accessibility level associated with an access discriminant | |
4727 | -- initialized in an allocator by the expression Disc_Exp is not deeper | |
4728 | -- than the level of the allocator type Alloc_Typ. An error message is | |
4729 | -- issued if this condition is violated. Specialized checks are done for | |
4730 | -- the cases of a constraint expression which is an access attribute or | |
4731 | -- an access discriminant. | |
4732 | ||
07fc65c4 | 4733 | function In_Dispatching_Context return Boolean; |
b7d1f17f HK |
4734 | -- If the allocator is an actual in a call, it is allowed to be class- |
4735 | -- wide when the context is not because it is a controlling actual. | |
4736 | ||
b7d1f17f HK |
4737 | ------------------------------------------- |
4738 | -- Check_Allocator_Discrim_Accessibility -- | |
4739 | ------------------------------------------- | |
4740 | ||
4741 | procedure Check_Allocator_Discrim_Accessibility | |
4742 | (Disc_Exp : Node_Id; | |
4743 | Alloc_Typ : Entity_Id) | |
4744 | is | |
4745 | begin | |
4746 | if Type_Access_Level (Etype (Disc_Exp)) > | |
f460d8f3 | 4747 | Deepest_Type_Access_Level (Alloc_Typ) |
b7d1f17f HK |
4748 | then |
4749 | Error_Msg_N | |
4750 | ("operand type has deeper level than allocator type", Disc_Exp); | |
4751 | ||
4752 | -- When the expression is an Access attribute the level of the prefix | |
4753 | -- object must not be deeper than that of the allocator's type. | |
4754 | ||
4755 | elsif Nkind (Disc_Exp) = N_Attribute_Reference | |
83e5da69 AC |
4756 | and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) = |
4757 | Attribute_Access | |
4758 | and then Object_Access_Level (Prefix (Disc_Exp)) > | |
4759 | Deepest_Type_Access_Level (Alloc_Typ) | |
b7d1f17f HK |
4760 | then |
4761 | Error_Msg_N | |
4762 | ("prefix of attribute has deeper level than allocator type", | |
4763 | Disc_Exp); | |
4764 | ||
4765 | -- When the expression is an access discriminant the check is against | |
4766 | -- the level of the prefix object. | |
4767 | ||
4768 | elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type | |
4769 | and then Nkind (Disc_Exp) = N_Selected_Component | |
83e5da69 AC |
4770 | and then Object_Access_Level (Prefix (Disc_Exp)) > |
4771 | Deepest_Type_Access_Level (Alloc_Typ) | |
b7d1f17f HK |
4772 | then |
4773 | Error_Msg_N | |
4774 | ("access discriminant has deeper level than allocator type", | |
4775 | Disc_Exp); | |
4776 | ||
4777 | -- All other cases are legal | |
4778 | ||
4779 | else | |
4780 | null; | |
4781 | end if; | |
4782 | end Check_Allocator_Discrim_Accessibility; | |
07fc65c4 GB |
4783 | |
4784 | ---------------------------- | |
4785 | -- In_Dispatching_Context -- | |
4786 | ---------------------------- | |
4787 | ||
4788 | function In_Dispatching_Context return Boolean is | |
4789 | Par : constant Node_Id := Parent (N); | |
b7d1f17f HK |
4790 | |
4791 | begin | |
d3b00ce3 AC |
4792 | return Nkind (Par) in N_Subprogram_Call |
4793 | and then Is_Entity_Name (Name (Par)) | |
4794 | and then Is_Dispatching_Operation (Entity (Name (Par))); | |
df3e68b1 | 4795 | end In_Dispatching_Context; |
b7d1f17f | 4796 | |
07fc65c4 GB |
4797 | -- Start of processing for Resolve_Allocator |
4798 | ||
996ae0b0 RK |
4799 | begin |
4800 | -- Replace general access with specific type | |
4801 | ||
4802 | if Ekind (Etype (N)) = E_Allocator_Type then | |
4803 | Set_Etype (N, Base_Type (Typ)); | |
4804 | end if; | |
4805 | ||
0669bebe | 4806 | if Is_Abstract_Type (Typ) then |
996ae0b0 RK |
4807 | Error_Msg_N ("type of allocator cannot be abstract", N); |
4808 | end if; | |
4809 | ||
2e86f679 RD |
4810 | -- For qualified expression, resolve the expression using the given |
4811 | -- subtype (nothing to do for type mark, subtype indication) | |
996ae0b0 RK |
4812 | |
4813 | if Nkind (E) = N_Qualified_Expression then | |
4814 | if Is_Class_Wide_Type (Etype (E)) | |
949a18cc | 4815 | and then not Is_Class_Wide_Type (Desig_T) |
07fc65c4 | 4816 | and then not In_Dispatching_Context |
996ae0b0 RK |
4817 | then |
4818 | Error_Msg_N | |
4819 | ("class-wide allocator not allowed for this access type", N); | |
4820 | end if; | |
4821 | ||
4822 | Resolve (Expression (E), Etype (E)); | |
f3691f46 | 4823 | Check_Non_Static_Context (Expression (E)); |
996ae0b0 RK |
4824 | Check_Unset_Reference (Expression (E)); |
4825 | ||
7f54dc83 AC |
4826 | -- Allocators generated by the build-in-place expansion mechanism |
4827 | -- are explicitly marked as coming from source but do not need to be | |
4828 | -- checked for limited initialization. To exclude this case, ensure | |
4829 | -- that the parent of the allocator is a source node. | |
4830 | ||
4831 | if Is_Limited_Type (Etype (E)) | |
4832 | and then Comes_From_Source (N) | |
4833 | and then Comes_From_Source (Parent (N)) | |
4834 | and then not In_Instance_Body | |
4835 | then | |
4836 | if not OK_For_Limited_Init (Etype (E), Expression (E)) then | |
a56886e9 AC |
4837 | if Nkind (Parent (N)) = N_Assignment_Statement then |
4838 | Error_Msg_N | |
4839 | ("illegal expression for initialized allocator of a " | |
4840 | & "limited type (RM 7.5 (2.7/2))", N); | |
4841 | else | |
4842 | Error_Msg_N | |
4843 | ("initialization not allowed for limited types", N); | |
4844 | end if; | |
4845 | ||
7f54dc83 AC |
4846 | Explain_Limited_Type (Etype (E), N); |
4847 | end if; | |
4848 | end if; | |
4849 | ||
a56886e9 AC |
4850 | -- A qualified expression requires an exact match of the type. Class- |
4851 | -- wide matching is not allowed. | |
fbf5a39b | 4852 | |
7b4db06c | 4853 | if (Is_Class_Wide_Type (Etype (Expression (E))) |
19fb051c | 4854 | or else Is_Class_Wide_Type (Etype (E))) |
fbf5a39b AC |
4855 | and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E)) |
4856 | then | |
4857 | Wrong_Type (Expression (E), Etype (E)); | |
4858 | end if; | |
4859 | ||
a8551b5f AC |
4860 | -- Calls to build-in-place functions are not currently supported in |
4861 | -- allocators for access types associated with a simple storage pool. | |
4862 | -- Supporting such allocators may require passing additional implicit | |
4863 | -- parameters to build-in-place functions (or a significant revision | |
4864 | -- of the current b-i-p implementation to unify the handling for | |
4865 | -- multiple kinds of storage pools). ??? | |
4866 | ||
51245e2d | 4867 | if Is_Limited_View (Desig_T) |
a8551b5f AC |
4868 | and then Nkind (Expression (E)) = N_Function_Call |
4869 | then | |
4870 | declare | |
260359e3 AC |
4871 | Pool : constant Entity_Id := |
4872 | Associated_Storage_Pool (Root_Type (Typ)); | |
a8551b5f AC |
4873 | begin |
4874 | if Present (Pool) | |
f6205414 AC |
4875 | and then |
4876 | Present (Get_Rep_Pragma | |
4877 | (Etype (Pool), Name_Simple_Storage_Pool_Type)) | |
a8551b5f AC |
4878 | then |
4879 | Error_Msg_N | |
1486a00e AC |
4880 | ("limited function calls not yet supported in simple " |
4881 | & "storage pool allocators", Expression (E)); | |
a8551b5f AC |
4882 | end if; |
4883 | end; | |
4884 | end if; | |
4885 | ||
b7d1f17f HK |
4886 | -- A special accessibility check is needed for allocators that |
4887 | -- constrain access discriminants. The level of the type of the | |
4888 | -- expression used to constrain an access discriminant cannot be | |
f3d57416 | 4889 | -- deeper than the type of the allocator (in contrast to access |
b7d1f17f HK |
4890 | -- parameters, where the level of the actual can be arbitrary). |
4891 | ||
2e86f679 RD |
4892 | -- We can't use Valid_Conversion to perform this check because in |
4893 | -- general the type of the allocator is unrelated to the type of | |
4894 | -- the access discriminant. | |
b7d1f17f HK |
4895 | |
4896 | if Ekind (Typ) /= E_Anonymous_Access_Type | |
4897 | or else Is_Local_Anonymous_Access (Typ) | |
4898 | then | |
4899 | Subtyp := Entity (Subtype_Mark (E)); | |
4900 | ||
4901 | Aggr := Original_Node (Expression (E)); | |
4902 | ||
4903 | if Has_Discriminants (Subtyp) | |
45fc7ddb | 4904 | and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate) |
b7d1f17f HK |
4905 | then |
4906 | Discrim := First_Discriminant (Base_Type (Subtyp)); | |
4907 | ||
4908 | -- Get the first component expression of the aggregate | |
4909 | ||
4910 | if Present (Expressions (Aggr)) then | |
4911 | Disc_Exp := First (Expressions (Aggr)); | |
4912 | ||
4913 | elsif Present (Component_Associations (Aggr)) then | |
4914 | Assoc := First (Component_Associations (Aggr)); | |
4915 | ||
4916 | if Present (Assoc) then | |
4917 | Disc_Exp := Expression (Assoc); | |
4918 | else | |
4919 | Disc_Exp := Empty; | |
4920 | end if; | |
4921 | ||
4922 | else | |
4923 | Disc_Exp := Empty; | |
4924 | end if; | |
4925 | ||
4926 | while Present (Discrim) and then Present (Disc_Exp) loop | |
4927 | if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then | |
4928 | Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); | |
4929 | end if; | |
4930 | ||
4931 | Next_Discriminant (Discrim); | |
4932 | ||
4933 | if Present (Discrim) then | |
4934 | if Present (Assoc) then | |
4935 | Next (Assoc); | |
4936 | Disc_Exp := Expression (Assoc); | |
4937 | ||
4938 | elsif Present (Next (Disc_Exp)) then | |
4939 | Next (Disc_Exp); | |
4940 | ||
4941 | else | |
4942 | Assoc := First (Component_Associations (Aggr)); | |
4943 | ||
4944 | if Present (Assoc) then | |
4945 | Disc_Exp := Expression (Assoc); | |
4946 | else | |
4947 | Disc_Exp := Empty; | |
4948 | end if; | |
4949 | end if; | |
4950 | end if; | |
4951 | end loop; | |
4952 | end if; | |
4953 | end if; | |
4954 | ||
996ae0b0 RK |
4955 | -- For a subtype mark or subtype indication, freeze the subtype |
4956 | ||
4957 | else | |
4958 | Freeze_Expression (E); | |
4959 | ||
4960 | if Is_Access_Constant (Typ) and then not No_Initialization (N) then | |
4961 | Error_Msg_N | |
4962 | ("initialization required for access-to-constant allocator", N); | |
4963 | end if; | |
4964 | ||
4965 | -- A special accessibility check is needed for allocators that | |
4966 | -- constrain access discriminants. The level of the type of the | |
b7d1f17f | 4967 | -- expression used to constrain an access discriminant cannot be |
f3d57416 | 4968 | -- deeper than the type of the allocator (in contrast to access |
996ae0b0 RK |
4969 | -- parameters, where the level of the actual can be arbitrary). |
4970 | -- We can't use Valid_Conversion to perform this check because | |
4971 | -- in general the type of the allocator is unrelated to the type | |
b7d1f17f | 4972 | -- of the access discriminant. |
996ae0b0 RK |
4973 | |
4974 | if Nkind (Original_Node (E)) = N_Subtype_Indication | |
b7d1f17f HK |
4975 | and then (Ekind (Typ) /= E_Anonymous_Access_Type |
4976 | or else Is_Local_Anonymous_Access (Typ)) | |
996ae0b0 RK |
4977 | then |
4978 | Subtyp := Entity (Subtype_Mark (Original_Node (E))); | |
4979 | ||
4980 | if Has_Discriminants (Subtyp) then | |
4981 | Discrim := First_Discriminant (Base_Type (Subtyp)); | |
4982 | Constr := First (Constraints (Constraint (Original_Node (E)))); | |
996ae0b0 RK |
4983 | while Present (Discrim) and then Present (Constr) loop |
4984 | if Ekind (Etype (Discrim)) = E_Anonymous_Access_Type then | |
4985 | if Nkind (Constr) = N_Discriminant_Association then | |
4986 | Disc_Exp := Original_Node (Expression (Constr)); | |
4987 | else | |
4988 | Disc_Exp := Original_Node (Constr); | |
4989 | end if; | |
4990 | ||
b7d1f17f | 4991 | Check_Allocator_Discrim_Accessibility (Disc_Exp, Typ); |
996ae0b0 | 4992 | end if; |
b7d1f17f | 4993 | |
996ae0b0 RK |
4994 | Next_Discriminant (Discrim); |
4995 | Next (Constr); | |
4996 | end loop; | |
4997 | end if; | |
4998 | end if; | |
4999 | end if; | |
5000 | ||
758c442c GD |
5001 | -- Ada 2005 (AI-344): A class-wide allocator requires an accessibility |
5002 | -- check that the level of the type of the created object is not deeper | |
5003 | -- than the level of the allocator's access type, since extensions can | |
5004 | -- now occur at deeper levels than their ancestor types. This is a | |
5005 | -- static accessibility level check; a run-time check is also needed in | |
5006 | -- the case of an initialized allocator with a class-wide argument (see | |
5007 | -- Expand_Allocator_Expression). | |
5008 | ||
0791fbe9 | 5009 | if Ada_Version >= Ada_2005 |
949a18cc | 5010 | and then Is_Class_Wide_Type (Desig_T) |
758c442c GD |
5011 | then |
5012 | declare | |
b7d1f17f | 5013 | Exp_Typ : Entity_Id; |
758c442c GD |
5014 | |
5015 | begin | |
5016 | if Nkind (E) = N_Qualified_Expression then | |
5017 | Exp_Typ := Etype (E); | |
5018 | elsif Nkind (E) = N_Subtype_Indication then | |
5019 | Exp_Typ := Entity (Subtype_Mark (Original_Node (E))); | |
5020 | else | |
5021 | Exp_Typ := Entity (E); | |
5022 | end if; | |
5023 | ||
f460d8f3 | 5024 | if Type_Access_Level (Exp_Typ) > |
83e5da69 AC |
5025 | Deepest_Type_Access_Level (Typ) |
5026 | then | |
758c442c | 5027 | if In_Instance_Body then |
43417b90 | 5028 | Error_Msg_Warn := SPARK_Mode /= On; |
1486a00e | 5029 | Error_Msg_N |
4a28b181 AC |
5030 | ("type in allocator has deeper level than " |
5031 | & "designated class-wide type<<", E); | |
5032 | Error_Msg_N ("\Program_Error [<<", E); | |
758c442c GD |
5033 | Rewrite (N, |
5034 | Make_Raise_Program_Error (Sloc (N), | |
5035 | Reason => PE_Accessibility_Check_Failed)); | |
5036 | Set_Etype (N, Typ); | |
aa180613 RD |
5037 | |
5038 | -- Do not apply Ada 2005 accessibility checks on a class-wide | |
5039 | -- allocator if the type given in the allocator is a formal | |
5040 | -- type. A run-time check will be performed in the instance. | |
5041 | ||
5042 | elsif not Is_Generic_Type (Exp_Typ) then | |
1486a00e AC |
5043 | Error_Msg_N ("type in allocator has deeper level than " |
5044 | & "designated class-wide type", E); | |
758c442c GD |
5045 | end if; |
5046 | end if; | |
5047 | end; | |
5048 | end if; | |
5049 | ||
996ae0b0 RK |
5050 | -- Check for allocation from an empty storage pool |
5051 | ||
5052 | if No_Pool_Assigned (Typ) then | |
8da337c5 | 5053 | Error_Msg_N ("allocation from empty storage pool!", N); |
1420b484 | 5054 | |
5cc9353d RD |
5055 | -- If the context is an unchecked conversion, as may happen within an |
5056 | -- inlined subprogram, the allocator is being resolved with its own | |
5057 | -- anonymous type. In that case, if the target type has a specific | |
1420b484 JM |
5058 | -- storage pool, it must be inherited explicitly by the allocator type. |
5059 | ||
5060 | elsif Nkind (Parent (N)) = N_Unchecked_Type_Conversion | |
5061 | and then No (Associated_Storage_Pool (Typ)) | |
5062 | then | |
5063 | Set_Associated_Storage_Pool | |
5064 | (Typ, Associated_Storage_Pool (Etype (Parent (N)))); | |
996ae0b0 | 5065 | end if; |
b7d1f17f | 5066 | |
e57ab550 AC |
5067 | if Ekind (Etype (N)) = E_Anonymous_Access_Type then |
5068 | Check_Restriction (No_Anonymous_Allocators, N); | |
5069 | end if; | |
5070 | ||
6aaa0587 ES |
5071 | -- Check that an allocator with task parts isn't for a nested access |
5072 | -- type when restriction No_Task_Hierarchy applies. | |
5073 | ||
5074 | if not Is_Library_Level_Entity (Base_Type (Typ)) | |
949a18cc | 5075 | and then Has_Task (Base_Type (Desig_T)) |
6aaa0587 ES |
5076 | then |
5077 | Check_Restriction (No_Task_Hierarchy, N); | |
5078 | end if; | |
5079 | ||
77a40ec1 | 5080 | -- An illegal allocator may be rewritten as a raise Program_Error |
b7d1f17f HK |
5081 | -- statement. |
5082 | ||
5083 | if Nkind (N) = N_Allocator then | |
5084 | ||
5085 | -- An anonymous access discriminant is the definition of a | |
aa5147f0 | 5086 | -- coextension. |
b7d1f17f HK |
5087 | |
5088 | if Ekind (Typ) = E_Anonymous_Access_Type | |
5089 | and then Nkind (Associated_Node_For_Itype (Typ)) = | |
5090 | N_Discriminant_Specification | |
5091 | then | |
949a18cc AC |
5092 | declare |
5093 | Discr : constant Entity_Id := | |
5094 | Defining_Identifier (Associated_Node_For_Itype (Typ)); | |
ee2e3f6b | 5095 | |
949a18cc | 5096 | begin |
57f4c288 ES |
5097 | Check_Restriction (No_Coextensions, N); |
5098 | ||
5d59eef2 AC |
5099 | -- Ada 2012 AI05-0052: If the designated type of the allocator |
5100 | -- is limited, then the allocator shall not be used to define | |
5101 | -- the value of an access discriminant unless the discriminated | |
949a18cc AC |
5102 | -- type is immutably limited. |
5103 | ||
5104 | if Ada_Version >= Ada_2012 | |
5105 | and then Is_Limited_Type (Desig_T) | |
51245e2d | 5106 | and then not Is_Limited_View (Scope (Discr)) |
949a18cc AC |
5107 | then |
5108 | Error_Msg_N | |
5d59eef2 AC |
5109 | ("only immutably limited types can have anonymous " |
5110 | & "access discriminants designating a limited type", N); | |
949a18cc AC |
5111 | end if; |
5112 | end; | |
5113 | ||
b7d1f17f | 5114 | -- Avoid marking an allocator as a dynamic coextension if it is |
aa5147f0 | 5115 | -- within a static construct. |
b7d1f17f HK |
5116 | |
5117 | if not Is_Static_Coextension (N) then | |
aa5147f0 | 5118 | Set_Is_Dynamic_Coextension (N); |
b7d1f17f HK |
5119 | end if; |
5120 | ||
5121 | -- Cleanup for potential static coextensions | |
5122 | ||
5123 | else | |
aa5147f0 ES |
5124 | Set_Is_Dynamic_Coextension (N, False); |
5125 | Set_Is_Static_Coextension (N, False); | |
b7d1f17f | 5126 | end if; |
b7d1f17f | 5127 | end if; |
d9b056ea | 5128 | |
833eaa8a | 5129 | -- Report a simple error: if the designated object is a local task, |
14848f57 AC |
5130 | -- its body has not been seen yet, and its activation will fail an |
5131 | -- elaboration check. | |
d9b056ea | 5132 | |
949a18cc AC |
5133 | if Is_Task_Type (Desig_T) |
5134 | and then Scope (Base_Type (Desig_T)) = Current_Scope | |
d9b056ea AC |
5135 | and then Is_Compilation_Unit (Current_Scope) |
5136 | and then Ekind (Current_Scope) = E_Package | |
5137 | and then not In_Package_Body (Current_Scope) | |
5138 | then | |
43417b90 | 5139 | Error_Msg_Warn := SPARK_Mode /= On; |
4a28b181 AC |
5140 | Error_Msg_N ("cannot activate task before body seen<<", N); |
5141 | Error_Msg_N ("\Program_Error [<<", N); | |
d9b056ea | 5142 | end if; |
14848f57 | 5143 | |
7b2aafc9 HK |
5144 | -- Ada 2012 (AI05-0111-3): Detect an attempt to allocate a task or a |
5145 | -- type with a task component on a subpool. This action must raise | |
5146 | -- Program_Error at runtime. | |
14848f57 AC |
5147 | |
5148 | if Ada_Version >= Ada_2012 | |
dfbcb149 | 5149 | and then Nkind (N) = N_Allocator |
14848f57 AC |
5150 | and then Present (Subpool_Handle_Name (N)) |
5151 | and then Has_Task (Desig_T) | |
5152 | then | |
43417b90 | 5153 | Error_Msg_Warn := SPARK_Mode /= On; |
4a28b181 AC |
5154 | Error_Msg_N ("cannot allocate task on subpool<<", N); |
5155 | Error_Msg_N ("\Program_Error [<<", N); | |
7b2aafc9 HK |
5156 | |
5157 | Rewrite (N, | |
5158 | Make_Raise_Program_Error (Sloc (N), | |
5159 | Reason => PE_Explicit_Raise)); | |
5160 | Set_Etype (N, Typ); | |
14848f57 | 5161 | end if; |
996ae0b0 RK |
5162 | end Resolve_Allocator; |
5163 | ||
5164 | --------------------------- | |
5165 | -- Resolve_Arithmetic_Op -- | |
5166 | --------------------------- | |
5167 | ||
5168 | -- Used for resolving all arithmetic operators except exponentiation | |
5169 | ||
5170 | procedure Resolve_Arithmetic_Op (N : Node_Id; Typ : Entity_Id) is | |
fbf5a39b AC |
5171 | L : constant Node_Id := Left_Opnd (N); |
5172 | R : constant Node_Id := Right_Opnd (N); | |
5173 | TL : constant Entity_Id := Base_Type (Etype (L)); | |
5174 | TR : constant Entity_Id := Base_Type (Etype (R)); | |
5175 | T : Entity_Id; | |
5176 | Rop : Node_Id; | |
996ae0b0 RK |
5177 | |
5178 | B_Typ : constant Entity_Id := Base_Type (Typ); | |
5179 | -- We do the resolution using the base type, because intermediate values | |
5180 | -- in expressions always are of the base type, not a subtype of it. | |
5181 | ||
aa180613 RD |
5182 | function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean; |
5183 | -- Returns True if N is in a context that expects "any real type" | |
5184 | ||
996ae0b0 RK |
5185 | function Is_Integer_Or_Universal (N : Node_Id) return Boolean; |
5186 | -- Return True iff given type is Integer or universal real/integer | |
5187 | ||
5188 | procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id); | |
5189 | -- Choose type of integer literal in fixed-point operation to conform | |
5190 | -- to available fixed-point type. T is the type of the other operand, | |
5191 | -- which is needed to determine the expected type of N. | |
5192 | ||
5193 | procedure Set_Operand_Type (N : Node_Id); | |
5194 | -- Set operand type to T if universal | |
5195 | ||
aa180613 RD |
5196 | ------------------------------- |
5197 | -- Expected_Type_Is_Any_Real -- | |
5198 | ------------------------------- | |
5199 | ||
5200 | function Expected_Type_Is_Any_Real (N : Node_Id) return Boolean is | |
5201 | begin | |
5202 | -- N is the expression after "delta" in a fixed_point_definition; | |
5203 | -- see RM-3.5.9(6): | |
5204 | ||
45fc7ddb HK |
5205 | return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition, |
5206 | N_Decimal_Fixed_Point_Definition, | |
aa180613 RD |
5207 | |
5208 | -- N is one of the bounds in a real_range_specification; | |
5209 | -- see RM-3.5.7(5): | |
5210 | ||
45fc7ddb | 5211 | N_Real_Range_Specification, |
aa180613 RD |
5212 | |
5213 | -- N is the expression of a delta_constraint; | |
5214 | -- see RM-J.3(3): | |
5215 | ||
45fc7ddb | 5216 | N_Delta_Constraint); |
aa180613 RD |
5217 | end Expected_Type_Is_Any_Real; |
5218 | ||
996ae0b0 RK |
5219 | ----------------------------- |
5220 | -- Is_Integer_Or_Universal -- | |
5221 | ----------------------------- | |
5222 | ||
5223 | function Is_Integer_Or_Universal (N : Node_Id) return Boolean is | |
5224 | T : Entity_Id; | |
5225 | Index : Interp_Index; | |
5226 | It : Interp; | |
5227 | ||
5228 | begin | |
5229 | if not Is_Overloaded (N) then | |
5230 | T := Etype (N); | |
5231 | return Base_Type (T) = Base_Type (Standard_Integer) | |
5232 | or else T = Universal_Integer | |
5233 | or else T = Universal_Real; | |
5234 | else | |
5235 | Get_First_Interp (N, Index, It); | |
996ae0b0 | 5236 | while Present (It.Typ) loop |
996ae0b0 RK |
5237 | if Base_Type (It.Typ) = Base_Type (Standard_Integer) |
5238 | or else It.Typ = Universal_Integer | |
5239 | or else It.Typ = Universal_Real | |
5240 | then | |
5241 | return True; | |
5242 | end if; | |
5243 | ||
5244 | Get_Next_Interp (Index, It); | |
5245 | end loop; | |
5246 | end if; | |
5247 | ||
5248 | return False; | |
5249 | end Is_Integer_Or_Universal; | |
5250 | ||
5251 | ---------------------------- | |
5252 | -- Set_Mixed_Mode_Operand -- | |
5253 | ---------------------------- | |
5254 | ||
5255 | procedure Set_Mixed_Mode_Operand (N : Node_Id; T : Entity_Id) is | |
5256 | Index : Interp_Index; | |
5257 | It : Interp; | |
5258 | ||
5259 | begin | |
5260 | if Universal_Interpretation (N) = Universal_Integer then | |
5261 | ||
5262 | -- A universal integer literal is resolved as standard integer | |
758c442c GD |
5263 | -- except in the case of a fixed-point result, where we leave it |
5264 | -- as universal (to be handled by Exp_Fixd later on) | |
996ae0b0 RK |
5265 | |
5266 | if Is_Fixed_Point_Type (T) then | |
5267 | Resolve (N, Universal_Integer); | |
5268 | else | |
5269 | Resolve (N, Standard_Integer); | |
5270 | end if; | |
5271 | ||
5272 | elsif Universal_Interpretation (N) = Universal_Real | |
5273 | and then (T = Base_Type (Standard_Integer) | |
5274 | or else T = Universal_Integer | |
5275 | or else T = Universal_Real) | |
5276 | then | |
5277 | -- A universal real can appear in a fixed-type context. We resolve | |
5278 | -- the literal with that context, even though this might raise an | |
5279 | -- exception prematurely (the other operand may be zero). | |
5280 | ||
5281 | Resolve (N, B_Typ); | |
5282 | ||
5283 | elsif Etype (N) = Base_Type (Standard_Integer) | |
5284 | and then T = Universal_Real | |
5285 | and then Is_Overloaded (N) | |
5286 | then | |
5287 | -- Integer arg in mixed-mode operation. Resolve with universal | |
5288 | -- type, in case preference rule must be applied. | |
5289 | ||
5290 | Resolve (N, Universal_Integer); | |
5291 | ||
5292 | elsif Etype (N) = T | |
5293 | and then B_Typ /= Universal_Fixed | |
5294 | then | |
a77842bd | 5295 | -- Not a mixed-mode operation, resolve with context |
996ae0b0 RK |
5296 | |
5297 | Resolve (N, B_Typ); | |
5298 | ||
5299 | elsif Etype (N) = Any_Fixed then | |
5300 | ||
a77842bd | 5301 | -- N may itself be a mixed-mode operation, so use context type |
996ae0b0 RK |
5302 | |
5303 | Resolve (N, B_Typ); | |
5304 | ||
5305 | elsif Is_Fixed_Point_Type (T) | |
5306 | and then B_Typ = Universal_Fixed | |
5307 | and then Is_Overloaded (N) | |
5308 | then | |
5309 | -- Must be (fixed * fixed) operation, operand must have one | |
5310 | -- compatible interpretation. | |
5311 | ||
5312 | Resolve (N, Any_Fixed); | |
5313 | ||
5314 | elsif Is_Fixed_Point_Type (B_Typ) | |
2e86f679 | 5315 | and then (T = Universal_Real or else Is_Fixed_Point_Type (T)) |
996ae0b0 RK |
5316 | and then Is_Overloaded (N) |
5317 | then | |
5318 | -- C * F(X) in a fixed context, where C is a real literal or a | |
5319 | -- fixed-point expression. F must have either a fixed type | |
5320 | -- interpretation or an integer interpretation, but not both. | |
5321 | ||
5322 | Get_First_Interp (N, Index, It); | |
996ae0b0 | 5323 | while Present (It.Typ) loop |
996ae0b0 | 5324 | if Base_Type (It.Typ) = Base_Type (Standard_Integer) then |
996ae0b0 RK |
5325 | if Analyzed (N) then |
5326 | Error_Msg_N ("ambiguous operand in fixed operation", N); | |
5327 | else | |
5328 | Resolve (N, Standard_Integer); | |
5329 | end if; | |
5330 | ||
5331 | elsif Is_Fixed_Point_Type (It.Typ) then | |
996ae0b0 RK |
5332 | if Analyzed (N) then |
5333 | Error_Msg_N ("ambiguous operand in fixed operation", N); | |
5334 | else | |
5335 | Resolve (N, It.Typ); | |
5336 | end if; | |
5337 | end if; | |
5338 | ||
5339 | Get_Next_Interp (Index, It); | |
5340 | end loop; | |
5341 | ||
758c442c GD |
5342 | -- Reanalyze the literal with the fixed type of the context. If |
5343 | -- context is Universal_Fixed, we are within a conversion, leave | |
5344 | -- the literal as a universal real because there is no usable | |
5345 | -- fixed type, and the target of the conversion plays no role in | |
5346 | -- the resolution. | |
996ae0b0 | 5347 | |
0ab80019 AC |
5348 | declare |
5349 | Op2 : Node_Id; | |
5350 | T2 : Entity_Id; | |
5351 | ||
5352 | begin | |
5353 | if N = L then | |
5354 | Op2 := R; | |
5355 | else | |
5356 | Op2 := L; | |
5357 | end if; | |
5358 | ||
5359 | if B_Typ = Universal_Fixed | |
5360 | and then Nkind (Op2) = N_Real_Literal | |
5361 | then | |
5362 | T2 := Universal_Real; | |
5363 | else | |
5364 | T2 := B_Typ; | |
5365 | end if; | |
5366 | ||
5367 | Set_Analyzed (Op2, False); | |
5368 | Resolve (Op2, T2); | |
5369 | end; | |
996ae0b0 | 5370 | |
b03d3f73 AC |
5371 | -- A universal real conditional expression can appear in a fixed-type |
5372 | -- context and must be resolved with that context to facilitate the | |
5373 | -- code generation to the backend. | |
5374 | ||
5375 | elsif Nkind_In (N, N_Case_Expression, N_If_Expression) | |
5376 | and then Etype (N) = Universal_Real | |
5377 | and then Is_Fixed_Point_Type (B_Typ) | |
5378 | then | |
5379 | Resolve (N, B_Typ); | |
5380 | ||
996ae0b0 | 5381 | else |
fbf5a39b | 5382 | Resolve (N); |
996ae0b0 RK |
5383 | end if; |
5384 | end Set_Mixed_Mode_Operand; | |
5385 | ||
5386 | ---------------------- | |
5387 | -- Set_Operand_Type -- | |
5388 | ---------------------- | |
5389 | ||
5390 | procedure Set_Operand_Type (N : Node_Id) is | |
5391 | begin | |
5392 | if Etype (N) = Universal_Integer | |
5393 | or else Etype (N) = Universal_Real | |
5394 | then | |
5395 | Set_Etype (N, T); | |
5396 | end if; | |
5397 | end Set_Operand_Type; | |
5398 | ||
996ae0b0 RK |
5399 | -- Start of processing for Resolve_Arithmetic_Op |
5400 | ||
5401 | begin | |
5402 | if Comes_From_Source (N) | |
5403 | and then Ekind (Entity (N)) = E_Function | |
5404 | and then Is_Imported (Entity (N)) | |
fbf5a39b | 5405 | and then Is_Intrinsic_Subprogram (Entity (N)) |
996ae0b0 RK |
5406 | then |
5407 | Resolve_Intrinsic_Operator (N, Typ); | |
5408 | return; | |
5409 | ||
5cc9353d RD |
5410 | -- Special-case for mixed-mode universal expressions or fixed point type |
5411 | -- operation: each argument is resolved separately. The same treatment | |
5412 | -- is required if one of the operands of a fixed point operation is | |
5413 | -- universal real, since in this case we don't do a conversion to a | |
5414 | -- specific fixed-point type (instead the expander handles the case). | |
996ae0b0 | 5415 | |
ddf67a1d AC |
5416 | -- Set the type of the node to its universal interpretation because |
5417 | -- legality checks on an exponentiation operand need the context. | |
5418 | ||
45fc7ddb | 5419 | elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real) |
996ae0b0 RK |
5420 | and then Present (Universal_Interpretation (L)) |
5421 | and then Present (Universal_Interpretation (R)) | |
5422 | then | |
ddf67a1d | 5423 | Set_Etype (N, B_Typ); |
996ae0b0 RK |
5424 | Resolve (L, Universal_Interpretation (L)); |
5425 | Resolve (R, Universal_Interpretation (R)); | |
996ae0b0 RK |
5426 | |
5427 | elsif (B_Typ = Universal_Real | |
45fc7ddb HK |
5428 | or else Etype (N) = Universal_Fixed |
5429 | or else (Etype (N) = Any_Fixed | |
5430 | and then Is_Fixed_Point_Type (B_Typ)) | |
5431 | or else (Is_Fixed_Point_Type (B_Typ) | |
5432 | and then (Is_Integer_Or_Universal (L) | |
2e86f679 | 5433 | or else |
45fc7ddb HK |
5434 | Is_Integer_Or_Universal (R)))) |
5435 | and then Nkind_In (N, N_Op_Multiply, N_Op_Divide) | |
996ae0b0 RK |
5436 | then |
5437 | if TL = Universal_Integer or else TR = Universal_Integer then | |
5438 | Check_For_Visible_Operator (N, B_Typ); | |
5439 | end if; | |
5440 | ||
5cc9353d RD |
5441 | -- If context is a fixed type and one operand is integer, the other |
5442 | -- is resolved with the type of the context. | |
996ae0b0 RK |
5443 | |
5444 | if Is_Fixed_Point_Type (B_Typ) | |
5445 | and then (Base_Type (TL) = Base_Type (Standard_Integer) | |
5446 | or else TL = Universal_Integer) | |
5447 | then | |
5448 | Resolve (R, B_Typ); | |
5449 | Resolve (L, TL); | |
5450 | ||
5451 | elsif Is_Fixed_Point_Type (B_Typ) | |
5452 | and then (Base_Type (TR) = Base_Type (Standard_Integer) | |
5453 | or else TR = Universal_Integer) | |
5454 | then | |
5455 | Resolve (L, B_Typ); | |
5456 | Resolve (R, TR); | |
5457 | ||
5458 | else | |
5459 | Set_Mixed_Mode_Operand (L, TR); | |
5460 | Set_Mixed_Mode_Operand (R, TL); | |
5461 | end if; | |
5462 | ||
45fc7ddb HK |
5463 | -- Check the rule in RM05-4.5.5(19.1/2) disallowing universal_fixed |
5464 | -- multiplying operators from being used when the expected type is | |
5465 | -- also universal_fixed. Note that B_Typ will be Universal_Fixed in | |
5466 | -- some cases where the expected type is actually Any_Real; | |
5467 | -- Expected_Type_Is_Any_Real takes care of that case. | |
aa180613 | 5468 | |
996ae0b0 RK |
5469 | if Etype (N) = Universal_Fixed |
5470 | or else Etype (N) = Any_Fixed | |
5471 | then | |
5472 | if B_Typ = Universal_Fixed | |
aa180613 | 5473 | and then not Expected_Type_Is_Any_Real (N) |
45fc7ddb HK |
5474 | and then not Nkind_In (Parent (N), N_Type_Conversion, |
5475 | N_Unchecked_Type_Conversion) | |
996ae0b0 | 5476 | then |
45fc7ddb HK |
5477 | Error_Msg_N ("type cannot be determined from context!", N); |
5478 | Error_Msg_N ("\explicit conversion to result type required", N); | |
996ae0b0 RK |
5479 | |
5480 | Set_Etype (L, Any_Type); | |
5481 | Set_Etype (R, Any_Type); | |
5482 | ||
5483 | else | |
0ab80019 | 5484 | if Ada_Version = Ada_83 |
45fc7ddb HK |
5485 | and then Etype (N) = Universal_Fixed |
5486 | and then not | |
5487 | Nkind_In (Parent (N), N_Type_Conversion, | |
5488 | N_Unchecked_Type_Conversion) | |
996ae0b0 RK |
5489 | then |
5490 | Error_Msg_N | |
a921e83c AC |
5491 | ("(Ada 83) fixed-point operation needs explicit " |
5492 | & "conversion", N); | |
996ae0b0 RK |
5493 | end if; |
5494 | ||
aa180613 | 5495 | -- The expected type is "any real type" in contexts like |
5cc9353d | 5496 | |
aa180613 | 5497 | -- type T is delta <universal_fixed-expression> ... |
5cc9353d | 5498 | |
aa180613 RD |
5499 | -- in which case we need to set the type to Universal_Real |
5500 | -- so that static expression evaluation will work properly. | |
5501 | ||
5502 | if Expected_Type_Is_Any_Real (N) then | |
5503 | Set_Etype (N, Universal_Real); | |
5504 | else | |
5505 | Set_Etype (N, B_Typ); | |
5506 | end if; | |
996ae0b0 RK |
5507 | end if; |
5508 | ||
5509 | elsif Is_Fixed_Point_Type (B_Typ) | |
5510 | and then (Is_Integer_Or_Universal (L) | |
5511 | or else Nkind (L) = N_Real_Literal | |
5512 | or else Nkind (R) = N_Real_Literal | |
45fc7ddb | 5513 | or else Is_Integer_Or_Universal (R)) |
996ae0b0 RK |
5514 | then |
5515 | Set_Etype (N, B_Typ); | |
5516 | ||
5517 | elsif Etype (N) = Any_Fixed then | |
5518 | ||
5cc9353d RD |
5519 | -- If no previous errors, this is only possible if one operand is |
5520 | -- overloaded and the context is universal. Resolve as such. | |
996ae0b0 RK |
5521 | |
5522 | Set_Etype (N, B_Typ); | |
5523 | end if; | |
5524 | ||
5525 | else | |
5526 | if (TL = Universal_Integer or else TL = Universal_Real) | |
2e86f679 | 5527 | and then |
45fc7ddb | 5528 | (TR = Universal_Integer or else TR = Universal_Real) |
996ae0b0 RK |
5529 | then |
5530 | Check_For_Visible_Operator (N, B_Typ); | |
5531 | end if; | |
5532 | ||
5533 | -- If the context is Universal_Fixed and the operands are also | |
5534 | -- universal fixed, this is an error, unless there is only one | |
841dd0f5 | 5535 | -- applicable fixed_point type (usually Duration). |
996ae0b0 | 5536 | |
45fc7ddb | 5537 | if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then |
996ae0b0 RK |
5538 | T := Unique_Fixed_Point_Type (N); |
5539 | ||
5540 | if T = Any_Type then | |
5541 | Set_Etype (N, T); | |
5542 | return; | |
5543 | else | |
5544 | Resolve (L, T); | |
5545 | Resolve (R, T); | |
5546 | end if; | |
5547 | ||
5548 | else | |
5549 | Resolve (L, B_Typ); | |
5550 | Resolve (R, B_Typ); | |
5551 | end if; | |
5552 | ||
5553 | -- If one of the arguments was resolved to a non-universal type. | |
5554 | -- label the result of the operation itself with the same type. | |
5555 | -- Do the same for the universal argument, if any. | |
5556 | ||
5557 | T := Intersect_Types (L, R); | |
5558 | Set_Etype (N, Base_Type (T)); | |
5559 | Set_Operand_Type (L); | |
5560 | Set_Operand_Type (R); | |
5561 | end if; | |
5562 | ||
fbf5a39b | 5563 | Generate_Operator_Reference (N, Typ); |
dec6faf1 | 5564 | Analyze_Dimension (N); |
996ae0b0 RK |
5565 | Eval_Arithmetic_Op (N); |
5566 | ||
2ba431e5 | 5567 | -- In SPARK, a multiplication or division with operands of fixed point |
d18bbd25 | 5568 | -- types must be qualified or explicitly converted to identify the |
2ba431e5 | 5569 | -- result type. |
b0186f71 | 5570 | |
fe5d3068 YM |
5571 | if (Is_Fixed_Point_Type (Etype (L)) |
5572 | or else Is_Fixed_Point_Type (Etype (R))) | |
b0186f71 AC |
5573 | and then Nkind_In (N, N_Op_Multiply, N_Op_Divide) |
5574 | and then | |
5575 | not Nkind_In (Parent (N), N_Qualified_Expression, N_Type_Conversion) | |
5576 | then | |
ce5ba43a | 5577 | Check_SPARK_05_Restriction |
fe5d3068 | 5578 | ("operation should be qualified or explicitly converted", N); |
b0186f71 AC |
5579 | end if; |
5580 | ||
acad3c0a | 5581 | -- Set overflow and division checking bit |
996ae0b0 RK |
5582 | |
5583 | if Nkind (N) in N_Op then | |
5584 | if not Overflow_Checks_Suppressed (Etype (N)) then | |
fbf5a39b | 5585 | Enable_Overflow_Check (N); |
996ae0b0 RK |
5586 | end if; |
5587 | ||
fbf5a39b AC |
5588 | -- Give warning if explicit division by zero |
5589 | ||
45fc7ddb | 5590 | if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod) |
996ae0b0 RK |
5591 | and then not Division_Checks_Suppressed (Etype (N)) |
5592 | then | |
fbf5a39b AC |
5593 | Rop := Right_Opnd (N); |
5594 | ||
5595 | if Compile_Time_Known_Value (Rop) | |
5596 | and then ((Is_Integer_Type (Etype (Rop)) | |
780d052e RD |
5597 | and then Expr_Value (Rop) = Uint_0) |
5598 | or else | |
5599 | (Is_Real_Type (Etype (Rop)) | |
5600 | and then Expr_Value_R (Rop) = Ureal_0)) | |
fbf5a39b | 5601 | then |
ce72a9a3 | 5602 | -- Specialize the warning message according to the operation. |
520c0201 AC |
5603 | -- When SPARK_Mode is On, force a warning instead of an error |
5604 | -- in that case, as this likely corresponds to deactivated | |
5605 | -- code. The following warnings are for the case | |
aa180613 RD |
5606 | |
5607 | case Nkind (N) is | |
5608 | when N_Op_Divide => | |
ce72a9a3 AC |
5609 | |
5610 | -- For division, we have two cases, for float division | |
5611 | -- of an unconstrained float type, on a machine where | |
5612 | -- Machine_Overflows is false, we don't get an exception | |
5613 | -- at run-time, but rather an infinity or Nan. The Nan | |
5614 | -- case is pretty obscure, so just warn about infinities. | |
5615 | ||
5616 | if Is_Floating_Point_Type (Typ) | |
5617 | and then not Is_Constrained (Typ) | |
5618 | and then not Machine_Overflows_On_Target | |
5619 | then | |
5620 | Error_Msg_N | |
1486a00e AC |
5621 | ("float division by zero, may generate " |
5622 | & "'+'/'- infinity??", Right_Opnd (N)); | |
ce72a9a3 | 5623 | |
520c0201 | 5624 | -- For all other cases, we get a Constraint_Error |
ce72a9a3 AC |
5625 | |
5626 | else | |
5627 | Apply_Compile_Time_Constraint_Error | |
324ac540 | 5628 | (N, "division by zero??", CE_Divide_By_Zero, |
520c0201 AC |
5629 | Loc => Sloc (Right_Opnd (N)), |
5630 | Warn => SPARK_Mode = On); | |
ce72a9a3 | 5631 | end if; |
aa180613 RD |
5632 | |
5633 | when N_Op_Rem => | |
5634 | Apply_Compile_Time_Constraint_Error | |
324ac540 | 5635 | (N, "rem with zero divisor??", CE_Divide_By_Zero, |
520c0201 AC |
5636 | Loc => Sloc (Right_Opnd (N)), |
5637 | Warn => SPARK_Mode = On); | |
aa180613 RD |
5638 | |
5639 | when N_Op_Mod => | |
5640 | Apply_Compile_Time_Constraint_Error | |
324ac540 | 5641 | (N, "mod with zero divisor??", CE_Divide_By_Zero, |
520c0201 AC |
5642 | Loc => Sloc (Right_Opnd (N)), |
5643 | Warn => SPARK_Mode = On); | |
aa180613 RD |
5644 | |
5645 | -- Division by zero can only happen with division, rem, | |
5646 | -- and mod operations. | |
5647 | ||
5648 | when others => | |
5649 | raise Program_Error; | |
5650 | end case; | |
fbf5a39b | 5651 | |
520c0201 AC |
5652 | -- In GNATprove mode, we enable the division check so that |
5653 | -- GNATprove will issue a message if it cannot be proved. | |
5654 | ||
5655 | if GNATprove_Mode then | |
5656 | Activate_Division_Check (N); | |
5657 | end if; | |
5658 | ||
fbf5a39b AC |
5659 | -- Otherwise just set the flag to check at run time |
5660 | ||
5661 | else | |
b7d1f17f | 5662 | Activate_Division_Check (N); |
fbf5a39b | 5663 | end if; |
996ae0b0 | 5664 | end if; |
45fc7ddb HK |
5665 | |
5666 | -- If Restriction No_Implicit_Conditionals is active, then it is | |
5667 | -- violated if either operand can be negative for mod, or for rem | |
5668 | -- if both operands can be negative. | |
5669 | ||
7a963087 | 5670 | if Restriction_Check_Required (No_Implicit_Conditionals) |
45fc7ddb HK |
5671 | and then Nkind_In (N, N_Op_Rem, N_Op_Mod) |
5672 | then | |
5673 | declare | |
5674 | Lo : Uint; | |
5675 | Hi : Uint; | |
5676 | OK : Boolean; | |
5677 | ||
5678 | LNeg : Boolean; | |
5679 | RNeg : Boolean; | |
5680 | -- Set if corresponding operand might be negative | |
5681 | ||
5682 | begin | |
5d5e9775 AC |
5683 | Determine_Range |
5684 | (Left_Opnd (N), OK, Lo, Hi, Assume_Valid => True); | |
45fc7ddb HK |
5685 | LNeg := (not OK) or else Lo < 0; |
5686 | ||
5d5e9775 AC |
5687 | Determine_Range |
5688 | (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True); | |
45fc7ddb HK |
5689 | RNeg := (not OK) or else Lo < 0; |
5690 | ||
5d5e9775 AC |
5691 | -- Check if we will be generating conditionals. There are two |
5692 | -- cases where that can happen, first for REM, the only case | |
5693 | -- is largest negative integer mod -1, where the division can | |
5694 | -- overflow, but we still have to give the right result. The | |
5695 | -- front end generates a test for this annoying case. Here we | |
5696 | -- just test if both operands can be negative (that's what the | |
5697 | -- expander does, so we match its logic here). | |
5698 | ||
5699 | -- The second case is mod where either operand can be negative. | |
308e6f3a | 5700 | -- In this case, the back end has to generate additional tests. |
5d5e9775 | 5701 | |
45fc7ddb | 5702 | if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg)) |
2e86f679 | 5703 | or else |
45fc7ddb HK |
5704 | (Nkind (N) = N_Op_Mod and then (LNeg or RNeg)) |
5705 | then | |
5706 | Check_Restriction (No_Implicit_Conditionals, N); | |
5707 | end if; | |
5708 | end; | |
5709 | end if; | |
996ae0b0 RK |
5710 | end if; |
5711 | ||
5712 | Check_Unset_Reference (L); | |
5713 | Check_Unset_Reference (R); | |
996ae0b0 RK |
5714 | end Resolve_Arithmetic_Op; |
5715 | ||
5716 | ------------------ | |
5717 | -- Resolve_Call -- | |
5718 | ------------------ | |
5719 | ||
5720 | procedure Resolve_Call (N : Node_Id; Typ : Entity_Id) is | |
ee81cbe9 AC |
5721 | function Same_Or_Aliased_Subprograms |
5722 | (S : Entity_Id; | |
5723 | E : Entity_Id) return Boolean; | |
5724 | -- Returns True if the subprogram entity S is the same as E or else | |
5725 | -- S is an alias of E. | |
5726 | ||
001c7783 AC |
5727 | --------------------------------- |
5728 | -- Same_Or_Aliased_Subprograms -- | |
5729 | --------------------------------- | |
5730 | ||
ee81cbe9 AC |
5731 | function Same_Or_Aliased_Subprograms |
5732 | (S : Entity_Id; | |
5733 | E : Entity_Id) return Boolean | |
5734 | is | |
5735 | Subp_Alias : constant Entity_Id := Alias (S); | |
ee81cbe9 | 5736 | begin |
b2834fbd | 5737 | return S = E or else (Present (Subp_Alias) and then Subp_Alias = E); |
ee81cbe9 AC |
5738 | end Same_Or_Aliased_Subprograms; |
5739 | ||
bf0b0e5e AC |
5740 | -- Local variables |
5741 | ||
5742 | Loc : constant Source_Ptr := Sloc (N); | |
5743 | Subp : constant Node_Id := Name (N); | |
5744 | Body_Id : Entity_Id; | |
5745 | I : Interp_Index; | |
5746 | It : Interp; | |
5747 | Nam : Entity_Id; | |
5748 | Nam_Decl : Node_Id; | |
5749 | Nam_UA : Entity_Id; | |
5750 | Norm_OK : Boolean; | |
5751 | Rtype : Entity_Id; | |
5752 | Scop : Entity_Id; | |
5753 | ||
ee81cbe9 AC |
5754 | -- Start of processing for Resolve_Call |
5755 | ||
996ae0b0 | 5756 | begin |
758c442c GD |
5757 | -- The context imposes a unique interpretation with type Typ on a |
5758 | -- procedure or function call. Find the entity of the subprogram that | |
5759 | -- yields the expected type, and propagate the corresponding formal | |
5760 | -- constraints on the actuals. The caller has established that an | |
5761 | -- interpretation exists, and emitted an error if not unique. | |
996ae0b0 RK |
5762 | |
5763 | -- First deal with the case of a call to an access-to-subprogram, | |
5764 | -- dereference made explicit in Analyze_Call. | |
5765 | ||
5766 | if Ekind (Etype (Subp)) = E_Subprogram_Type then | |
996ae0b0 RK |
5767 | if not Is_Overloaded (Subp) then |
5768 | Nam := Etype (Subp); | |
5769 | ||
5770 | else | |
758c442c GD |
5771 | -- Find the interpretation whose type (a subprogram type) has a |
5772 | -- return type that is compatible with the context. Analysis of | |
5773 | -- the node has established that one exists. | |
996ae0b0 | 5774 | |
996ae0b0 RK |
5775 | Nam := Empty; |
5776 | ||
1420b484 | 5777 | Get_First_Interp (Subp, I, It); |
996ae0b0 | 5778 | while Present (It.Typ) loop |
996ae0b0 RK |
5779 | if Covers (Typ, Etype (It.Typ)) then |
5780 | Nam := It.Typ; | |
5781 | exit; | |
5782 | end if; | |
5783 | ||
5784 | Get_Next_Interp (I, It); | |
5785 | end loop; | |
5786 | ||
5787 | if No (Nam) then | |
5788 | raise Program_Error; | |
5789 | end if; | |
5790 | end if; | |
5791 | ||
5792 | -- If the prefix is not an entity, then resolve it | |
5793 | ||
5794 | if not Is_Entity_Name (Subp) then | |
5795 | Resolve (Subp, Nam); | |
5796 | end if; | |
5797 | ||
758c442c GD |
5798 | -- For an indirect call, we always invalidate checks, since we do not |
5799 | -- know whether the subprogram is local or global. Yes we could do | |
5800 | -- better here, e.g. by knowing that there are no local subprograms, | |
aa180613 | 5801 | -- but it does not seem worth the effort. Similarly, we kill all |
758c442c | 5802 | -- knowledge of current constant values. |
fbf5a39b AC |
5803 | |
5804 | Kill_Current_Values; | |
5805 | ||
b7d1f17f HK |
5806 | -- If this is a procedure call which is really an entry call, do |
5807 | -- the conversion of the procedure call to an entry call. Protected | |
5808 | -- operations use the same circuitry because the name in the call | |
5809 | -- can be an arbitrary expression with special resolution rules. | |
996ae0b0 | 5810 | |
45fc7ddb | 5811 | elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component) |
996ae0b0 RK |
5812 | or else (Is_Entity_Name (Subp) |
5813 | and then Ekind (Entity (Subp)) = E_Entry) | |
5814 | then | |
5815 | Resolve_Entry_Call (N, Typ); | |
5816 | Check_Elab_Call (N); | |
fbf5a39b AC |
5817 | |
5818 | -- Kill checks and constant values, as above for indirect case | |
5819 | -- Who knows what happens when another task is activated? | |
5820 | ||
5821 | Kill_Current_Values; | |
996ae0b0 RK |
5822 | return; |
5823 | ||
5824 | -- Normal subprogram call with name established in Resolve | |
5825 | ||
5826 | elsif not (Is_Type (Entity (Subp))) then | |
5827 | Nam := Entity (Subp); | |
e7ba564f | 5828 | Set_Entity_With_Checks (Subp, Nam); |
fb12497d | 5829 | |
996ae0b0 RK |
5830 | -- Otherwise we must have the case of an overloaded call |
5831 | ||
5832 | else | |
5833 | pragma Assert (Is_Overloaded (Subp)); | |
d81b4bfe TQ |
5834 | |
5835 | -- Initialize Nam to prevent warning (we know it will be assigned | |
5836 | -- in the loop below, but the compiler does not know that). | |
5837 | ||
5838 | Nam := Empty; | |
996ae0b0 RK |
5839 | |
5840 | Get_First_Interp (Subp, I, It); | |
996ae0b0 RK |
5841 | while Present (It.Typ) loop |
5842 | if Covers (Typ, It.Typ) then | |
5843 | Nam := It.Nam; | |
e7ba564f | 5844 | Set_Entity_With_Checks (Subp, Nam); |
996ae0b0 RK |
5845 | exit; |
5846 | end if; | |
5847 | ||
5848 | Get_Next_Interp (I, It); | |
5849 | end loop; | |
5850 | end if; | |
5851 | ||
c9b99571 | 5852 | if Is_Access_Subprogram_Type (Base_Type (Etype (Nam))) |
c5cec2fe AC |
5853 | and then not Is_Access_Subprogram_Type (Base_Type (Typ)) |
5854 | and then Nkind (Subp) /= N_Explicit_Dereference | |
5855 | and then Present (Parameter_Associations (N)) | |
53cf4600 | 5856 | then |
66aa7643 TQ |
5857 | -- The prefix is a parameterless function call that returns an access |
5858 | -- to subprogram. If parameters are present in the current call, add | |
5859 | -- add an explicit dereference. We use the base type here because | |
5860 | -- within an instance these may be subtypes. | |
53cf4600 ES |
5861 | |
5862 | -- The dereference is added either in Analyze_Call or here. Should | |
5863 | -- be consolidated ??? | |
5864 | ||
5865 | Set_Is_Overloaded (Subp, False); | |
5866 | Set_Etype (Subp, Etype (Nam)); | |
5867 | Insert_Explicit_Dereference (Subp); | |
5868 | Nam := Designated_Type (Etype (Nam)); | |
5869 | Resolve (Subp, Nam); | |
5870 | end if; | |
5871 | ||
996ae0b0 RK |
5872 | -- Check that a call to Current_Task does not occur in an entry body |
5873 | ||
5874 | if Is_RTE (Nam, RE_Current_Task) then | |
5875 | declare | |
5876 | P : Node_Id; | |
5877 | ||
5878 | begin | |
5879 | P := N; | |
5880 | loop | |
5881 | P := Parent (P); | |
45fc7ddb HK |
5882 | |
5883 | -- Exclude calls that occur within the default of a formal | |
5884 | -- parameter of the entry, since those are evaluated outside | |
5885 | -- of the body. | |
5886 | ||
5887 | exit when No (P) or else Nkind (P) = N_Parameter_Specification; | |
996ae0b0 | 5888 | |
aa180613 RD |
5889 | if Nkind (P) = N_Entry_Body |
5890 | or else (Nkind (P) = N_Subprogram_Body | |
45fc7ddb | 5891 | and then Is_Entry_Barrier_Function (P)) |
aa180613 RD |
5892 | then |
5893 | Rtype := Etype (N); | |
43417b90 | 5894 | Error_Msg_Warn := SPARK_Mode /= On; |
996ae0b0 | 5895 | Error_Msg_NE |
4a28b181 | 5896 | ("& should not be used in entry body (RM C.7(17))<<", |
996ae0b0 | 5897 | N, Nam); |
4a28b181 | 5898 | Error_Msg_NE ("\Program_Error [<<", N, Nam); |
aa180613 RD |
5899 | Rewrite (N, |
5900 | Make_Raise_Program_Error (Loc, | |
5901 | Reason => PE_Current_Task_In_Entry_Body)); | |
5902 | Set_Etype (N, Rtype); | |
e65f50ec | 5903 | return; |
996ae0b0 RK |
5904 | end if; |
5905 | end loop; | |
5906 | end; | |
5907 | end if; | |
5908 | ||
758c442c GD |
5909 | -- Check that a procedure call does not occur in the context of the |
5910 | -- entry call statement of a conditional or timed entry call. Note that | |
5911 | -- the case of a call to a subprogram renaming of an entry will also be | |
5912 | -- rejected. The test for N not being an N_Entry_Call_Statement is | |
5913 | -- defensive, covering the possibility that the processing of entry | |
5914 | -- calls might reach this point due to later modifications of the code | |
5915 | -- above. | |
996ae0b0 RK |
5916 | |
5917 | if Nkind (Parent (N)) = N_Entry_Call_Alternative | |
5918 | and then Nkind (N) /= N_Entry_Call_Statement | |
5919 | and then Entry_Call_Statement (Parent (N)) = N | |
5920 | then | |
0791fbe9 | 5921 | if Ada_Version < Ada_2005 then |
1420b484 JM |
5922 | Error_Msg_N ("entry call required in select statement", N); |
5923 | ||
5924 | -- Ada 2005 (AI-345): If a procedure_call_statement is used | |
66aa7643 TQ |
5925 | -- for a procedure_or_entry_call, the procedure_name or |
5926 | -- procedure_prefix of the procedure_call_statement shall denote | |
1420b484 JM |
5927 | -- an entry renamed by a procedure, or (a view of) a primitive |
5928 | -- subprogram of a limited interface whose first parameter is | |
5929 | -- a controlling parameter. | |
5930 | ||
5931 | elsif Nkind (N) = N_Procedure_Call_Statement | |
5932 | and then not Is_Renamed_Entry (Nam) | |
5933 | and then not Is_Controlling_Limited_Procedure (Nam) | |
5934 | then | |
5935 | Error_Msg_N | |
c8ef728f | 5936 | ("entry call or dispatching primitive of interface required", N); |
1420b484 | 5937 | end if; |
996ae0b0 RK |
5938 | end if; |
5939 | ||
3b8056a5 AC |
5940 | -- If the SPARK_05 restriction is active, we are not allowed |
5941 | -- to have a call to a subprogram before we see its completion. | |
5942 | ||
5943 | if not Has_Completion (Nam) | |
5944 | and then Restriction_Check_Required (SPARK_05) | |
5945 | ||
5946 | -- Don't flag strange internal calls | |
5947 | ||
5948 | and then Comes_From_Source (N) | |
5949 | and then Comes_From_Source (Nam) | |
5950 | ||
5951 | -- Only flag calls in extended main source | |
5952 | ||
5953 | and then In_Extended_Main_Source_Unit (Nam) | |
5954 | and then In_Extended_Main_Source_Unit (N) | |
5955 | ||
5956 | -- Exclude enumeration literals from this processing | |
5957 | ||
5958 | and then Ekind (Nam) /= E_Enumeration_Literal | |
5959 | then | |
ce5ba43a | 5960 | Check_SPARK_05_Restriction |
3b8056a5 AC |
5961 | ("call to subprogram cannot appear before its body", N); |
5962 | end if; | |
5963 | ||
66aa7643 TQ |
5964 | -- Check that this is not a call to a protected procedure or entry from |
5965 | -- within a protected function. | |
fbf5a39b | 5966 | |
c92e8586 | 5967 | Check_Internal_Protected_Use (N, Nam); |
fbf5a39b | 5968 | |
2fabf41e AC |
5969 | -- Freeze the subprogram name if not in a spec-expression. Note that |
5970 | -- we freeze procedure calls as well as function calls. Procedure calls | |
5971 | -- are not frozen according to the rules (RM 13.14(14)) because it is | |
5972 | -- impossible to have a procedure call to a non-frozen procedure in | |
5973 | -- pure Ada, but in the code that we generate in the expander, this | |
5974 | -- rule needs extending because we can generate procedure calls that | |
5975 | -- need freezing. | |
996ae0b0 | 5976 | |
a429e6b3 AC |
5977 | -- In Ada 2012, expression functions may be called within pre/post |
5978 | -- conditions of subsequent functions or expression functions. Such | |
dd4e47ab AC |
5979 | -- calls do not freeze when they appear within generated bodies, |
5980 | -- (including the body of another expression function) which would | |
2fabf41e | 5981 | -- place the freeze node in the wrong scope. An expression function |
dd4e47ab AC |
5982 | -- is frozen in the usual fashion, by the appearance of a real body, |
5983 | -- or at the end of a declarative part. | |
a429e6b3 | 5984 | |
2bfad6eb HK |
5985 | if Is_Entity_Name (Subp) |
5986 | and then not In_Spec_Expression | |
5987 | and then not Is_Expression_Function_Or_Completion (Current_Scope) | |
a429e6b3 | 5988 | and then |
2bfad6eb | 5989 | (not Is_Expression_Function_Or_Completion (Entity (Subp)) |
a429e6b3 AC |
5990 | or else Scope (Entity (Subp)) = Current_Scope) |
5991 | then | |
996ae0b0 RK |
5992 | Freeze_Expression (Subp); |
5993 | end if; | |
5994 | ||
758c442c GD |
5995 | -- For a predefined operator, the type of the result is the type imposed |
5996 | -- by context, except for a predefined operation on universal fixed. | |
5997 | -- Otherwise The type of the call is the type returned by the subprogram | |
5998 | -- being called. | |
996ae0b0 RK |
5999 | |
6000 | if Is_Predefined_Op (Nam) then | |
996ae0b0 RK |
6001 | if Etype (N) /= Universal_Fixed then |
6002 | Set_Etype (N, Typ); | |
6003 | end if; | |
6004 | ||
758c442c GD |
6005 | -- If the subprogram returns an array type, and the context requires the |
6006 | -- component type of that array type, the node is really an indexing of | |
6007 | -- the parameterless call. Resolve as such. A pathological case occurs | |
6008 | -- when the type of the component is an access to the array type. In | |
be4e989c BD |
6009 | -- this case the call is truly ambiguous. If the call is to an intrinsic |
6010 | -- subprogram, it can't be an indexed component. This check is necessary | |
6011 | -- because if it's Unchecked_Conversion, and we have "type T_Ptr is | |
6012 | -- access T;" and "type T is array (...) of T_Ptr;" (i.e. an array of | |
6013 | -- pointers to the same array), the compiler gets confused and does an | |
6014 | -- infinite recursion. | |
996ae0b0 | 6015 | |
0669bebe | 6016 | elsif (Needs_No_Actuals (Nam) or else Needs_One_Actual (Nam)) |
996ae0b0 RK |
6017 | and then |
6018 | ((Is_Array_Type (Etype (Nam)) | |
19fb051c | 6019 | and then Covers (Typ, Component_Type (Etype (Nam)))) |
84f80f5b AC |
6020 | or else |
6021 | (Is_Access_Type (Etype (Nam)) | |
6022 | and then Is_Array_Type (Designated_Type (Etype (Nam))) | |
6023 | and then | |
be4e989c BD |
6024 | Covers (Typ, Component_Type (Designated_Type (Etype (Nam)))) |
6025 | and then not Is_Intrinsic_Subprogram (Entity (Subp)))) | |
996ae0b0 RK |
6026 | then |
6027 | declare | |
6028 | Index_Node : Node_Id; | |
fbf5a39b AC |
6029 | New_Subp : Node_Id; |
6030 | Ret_Type : constant Entity_Id := Etype (Nam); | |
996ae0b0 RK |
6031 | |
6032 | begin | |
fbf5a39b AC |
6033 | if Is_Access_Type (Ret_Type) |
6034 | and then Ret_Type = Component_Type (Designated_Type (Ret_Type)) | |
6035 | then | |
6036 | Error_Msg_N | |
6037 | ("cannot disambiguate function call and indexing", N); | |
6038 | else | |
6039 | New_Subp := Relocate_Node (Subp); | |
4bb9c7b9 AC |
6040 | |
6041 | -- The called entity may be an explicit dereference, in which | |
6042 | -- case there is no entity to set. | |
6043 | ||
6044 | if Nkind (New_Subp) /= N_Explicit_Dereference then | |
6045 | Set_Entity (Subp, Nam); | |
6046 | end if; | |
fbf5a39b | 6047 | |
7205254b | 6048 | if (Is_Array_Type (Ret_Type) |
5d5e9775 | 6049 | and then Component_Type (Ret_Type) /= Any_Type) |
7205254b JM |
6050 | or else |
6051 | (Is_Access_Type (Ret_Type) | |
5d5e9775 AC |
6052 | and then |
6053 | Component_Type (Designated_Type (Ret_Type)) /= Any_Type) | |
7205254b | 6054 | then |
0669bebe GB |
6055 | if Needs_No_Actuals (Nam) then |
6056 | ||
6057 | -- Indexed call to a parameterless function | |
6058 | ||
6059 | Index_Node := | |
6060 | Make_Indexed_Component (Loc, | |
fc999c5d RD |
6061 | Prefix => |
6062 | Make_Function_Call (Loc, Name => New_Subp), | |
0669bebe GB |
6063 | Expressions => Parameter_Associations (N)); |
6064 | else | |
6065 | -- An Ada 2005 prefixed call to a primitive operation | |
6066 | -- whose first parameter is the prefix. This prefix was | |
6067 | -- prepended to the parameter list, which is actually a | |
3b42c566 | 6068 | -- list of indexes. Remove the prefix in order to build |
0669bebe GB |
6069 | -- the proper indexed component. |
6070 | ||
6071 | Index_Node := | |
6072 | Make_Indexed_Component (Loc, | |
fc999c5d | 6073 | Prefix => |
0669bebe | 6074 | Make_Function_Call (Loc, |
fc999c5d | 6075 | Name => New_Subp, |
0669bebe GB |
6076 | Parameter_Associations => |
6077 | New_List | |
6078 | (Remove_Head (Parameter_Associations (N)))), | |
6079 | Expressions => Parameter_Associations (N)); | |
6080 | end if; | |
fbf5a39b | 6081 | |
74e7891f RD |
6082 | -- Preserve the parenthesis count of the node |
6083 | ||
6084 | Set_Paren_Count (Index_Node, Paren_Count (N)); | |
6085 | ||
fbf5a39b AC |
6086 | -- Since we are correcting a node classification error made |
6087 | -- by the parser, we call Replace rather than Rewrite. | |
6088 | ||
6089 | Replace (N, Index_Node); | |
74e7891f | 6090 | |
fbf5a39b AC |
6091 | Set_Etype (Prefix (N), Ret_Type); |
6092 | Set_Etype (N, Typ); | |
6093 | Resolve_Indexed_Component (N, Typ); | |
6094 | Check_Elab_Call (Prefix (N)); | |
6095 | end if; | |
996ae0b0 RK |
6096 | end if; |
6097 | ||
6098 | return; | |
6099 | end; | |
6100 | ||
6101 | else | |
6e9e35e1 AC |
6102 | -- If the called function is not declared in the main unit and it |
6103 | -- returns the limited view of type then use the available view (as | |
6104 | -- is done in Try_Object_Operation) to prevent back-end confusion; | |
7a71a7c4 AC |
6105 | -- for the function entity itself. The call must appear in a context |
6106 | -- where the nonlimited view is available. If the function entity is | |
6107 | -- in the extended main unit then no action is needed, because the | |
6108 | -- back end handles this case. In either case the type of the call | |
6109 | -- is the nonlimited view. | |
6110 | ||
6111 | if From_Limited_With (Etype (Nam)) | |
6112 | and then Present (Available_View (Etype (Nam))) | |
6e9e35e1 | 6113 | then |
7a71a7c4 AC |
6114 | Set_Etype (N, Available_View (Etype (Nam))); |
6115 | ||
6116 | if not In_Extended_Main_Code_Unit (Nam) then | |
6117 | Set_Etype (Nam, Available_View (Etype (Nam))); | |
6118 | end if; | |
fc3a3580 | 6119 | |
7a71a7c4 AC |
6120 | else |
6121 | Set_Etype (N, Etype (Nam)); | |
6122 | end if; | |
996ae0b0 RK |
6123 | end if; |
6124 | ||
6125 | -- In the case where the call is to an overloaded subprogram, Analyze | |
6126 | -- calls Normalize_Actuals once per overloaded subprogram. Therefore in | |
6127 | -- such a case Normalize_Actuals needs to be called once more to order | |
6128 | -- the actuals correctly. Otherwise the call will have the ordering | |
6129 | -- given by the last overloaded subprogram whether this is the correct | |
6130 | -- one being called or not. | |
6131 | ||
6132 | if Is_Overloaded (Subp) then | |
6133 | Normalize_Actuals (N, Nam, False, Norm_OK); | |
6134 | pragma Assert (Norm_OK); | |
6135 | end if; | |
6136 | ||
6137 | -- In any case, call is fully resolved now. Reset Overload flag, to | |
6138 | -- prevent subsequent overload resolution if node is analyzed again | |
6139 | ||
6140 | Set_Is_Overloaded (Subp, False); | |
6141 | Set_Is_Overloaded (N, False); | |
6142 | ||
c5cec2fe AC |
6143 | -- A Ghost entity must appear in a specific context |
6144 | ||
6145 | if Is_Ghost_Entity (Nam) and then Comes_From_Source (N) then | |
6146 | Check_Ghost_Context (Nam, N); | |
6147 | end if; | |
6148 | ||
758c442c GD |
6149 | -- If we are calling the current subprogram from immediately within its |
6150 | -- body, then that is the case where we can sometimes detect cases of | |
6151 | -- infinite recursion statically. Do not try this in case restriction | |
b7d1f17f | 6152 | -- No_Recursion is in effect anyway, and do it only for source calls. |
996ae0b0 | 6153 | |
b7d1f17f HK |
6154 | if Comes_From_Source (N) then |
6155 | Scop := Current_Scope; | |
996ae0b0 | 6156 | |
b2834fbd AC |
6157 | -- Check violation of SPARK_05 restriction which does not permit |
6158 | -- a subprogram body to contain a call to the subprogram directly. | |
6159 | ||
6160 | if Restriction_Check_Required (SPARK_05) | |
6161 | and then Same_Or_Aliased_Subprograms (Nam, Scop) | |
6162 | then | |
ce5ba43a | 6163 | Check_SPARK_05_Restriction |
b2834fbd AC |
6164 | ("subprogram may not contain direct call to itself", N); |
6165 | end if; | |
6166 | ||
26570b21 RD |
6167 | -- Issue warning for possible infinite recursion in the absence |
6168 | -- of the No_Recursion restriction. | |
6169 | ||
ee81cbe9 | 6170 | if Same_Or_Aliased_Subprograms (Nam, Scop) |
b7d1f17f HK |
6171 | and then not Restriction_Active (No_Recursion) |
6172 | and then Check_Infinite_Recursion (N) | |
6173 | then | |
6174 | -- Here we detected and flagged an infinite recursion, so we do | |
da20aa43 RD |
6175 | -- not need to test the case below for further warnings. Also we |
6176 | -- are all done if we now have a raise SE node. | |
996ae0b0 | 6177 | |
26570b21 RD |
6178 | if Nkind (N) = N_Raise_Storage_Error then |
6179 | return; | |
6180 | end if; | |
996ae0b0 | 6181 | |
26570b21 RD |
6182 | -- If call is to immediately containing subprogram, then check for |
6183 | -- the case of a possible run-time detectable infinite recursion. | |
996ae0b0 | 6184 | |
b7d1f17f HK |
6185 | else |
6186 | Scope_Loop : while Scop /= Standard_Standard loop | |
ee81cbe9 | 6187 | if Same_Or_Aliased_Subprograms (Nam, Scop) then |
b7d1f17f HK |
6188 | |
6189 | -- Although in general case, recursion is not statically | |
6190 | -- checkable, the case of calling an immediately containing | |
6191 | -- subprogram is easy to catch. | |
6192 | ||
6193 | Check_Restriction (No_Recursion, N); | |
6194 | ||
6195 | -- If the recursive call is to a parameterless subprogram, | |
6196 | -- then even if we can't statically detect infinite | |
6197 | -- recursion, this is pretty suspicious, and we output a | |
6198 | -- warning. Furthermore, we will try later to detect some | |
6199 | -- cases here at run time by expanding checking code (see | |
6200 | -- Detect_Infinite_Recursion in package Exp_Ch6). | |
6201 | ||
6202 | -- If the recursive call is within a handler, do not emit a | |
6203 | -- warning, because this is a common idiom: loop until input | |
6204 | -- is correct, catch illegal input in handler and restart. | |
6205 | ||
6206 | if No (First_Formal (Nam)) | |
6207 | and then Etype (Nam) = Standard_Void_Type | |
6208 | and then not Error_Posted (N) | |
6209 | and then Nkind (Parent (N)) /= N_Exception_Handler | |
aa180613 | 6210 | then |
b7d1f17f HK |
6211 | -- For the case of a procedure call. We give the message |
6212 | -- only if the call is the first statement in a sequence | |
6213 | -- of statements, or if all previous statements are | |
6214 | -- simple assignments. This is simply a heuristic to | |
6215 | -- decrease false positives, without losing too many good | |
6216 | -- warnings. The idea is that these previous statements | |
6217 | -- may affect global variables the procedure depends on. | |
78efd712 AC |
6218 | -- We also exclude raise statements, that may arise from |
6219 | -- constraint checks and are probably unrelated to the | |
6220 | -- intended control flow. | |
b7d1f17f HK |
6221 | |
6222 | if Nkind (N) = N_Procedure_Call_Statement | |
6223 | and then Is_List_Member (N) | |
6224 | then | |
6225 | declare | |
6226 | P : Node_Id; | |
6227 | begin | |
6228 | P := Prev (N); | |
6229 | while Present (P) loop | |
fc999c5d RD |
6230 | if not Nkind_In (P, N_Assignment_Statement, |
6231 | N_Raise_Constraint_Error) | |
78efd712 | 6232 | then |
b7d1f17f HK |
6233 | exit Scope_Loop; |
6234 | end if; | |
6235 | ||
6236 | Prev (P); | |
6237 | end loop; | |
6238 | end; | |
6239 | end if; | |
6240 | ||
6241 | -- Do not give warning if we are in a conditional context | |
6242 | ||
aa180613 | 6243 | declare |
b7d1f17f | 6244 | K : constant Node_Kind := Nkind (Parent (N)); |
aa180613 | 6245 | begin |
b7d1f17f | 6246 | if (K = N_Loop_Statement |
b5c739f9 | 6247 | and then Present (Iteration_Scheme (Parent (N)))) |
b7d1f17f HK |
6248 | or else K = N_If_Statement |
6249 | or else K = N_Elsif_Part | |
6250 | or else K = N_Case_Statement_Alternative | |
6251 | then | |
6252 | exit Scope_Loop; | |
6253 | end if; | |
aa180613 | 6254 | end; |
aa180613 | 6255 | |
b7d1f17f | 6256 | -- Here warning is to be issued |
aa180613 | 6257 | |
b7d1f17f | 6258 | Set_Has_Recursive_Call (Nam); |
43417b90 | 6259 | Error_Msg_Warn := SPARK_Mode /= On; |
4a28b181 AC |
6260 | Error_Msg_N ("possible infinite recursion<<!", N); |
6261 | Error_Msg_N ("\Storage_Error ]<<!", N); | |
b7d1f17f | 6262 | end if; |
aa180613 | 6263 | |
b7d1f17f | 6264 | exit Scope_Loop; |
996ae0b0 RK |
6265 | end if; |
6266 | ||
b7d1f17f HK |
6267 | Scop := Scope (Scop); |
6268 | end loop Scope_Loop; | |
6269 | end if; | |
996ae0b0 RK |
6270 | end if; |
6271 | ||
b5c739f9 RD |
6272 | -- Check obsolescent reference to Ada.Characters.Handling subprogram |
6273 | ||
6274 | Check_Obsolescent_2005_Entity (Nam, Subp); | |
6275 | ||
996ae0b0 RK |
6276 | -- If subprogram name is a predefined operator, it was given in |
6277 | -- functional notation. Replace call node with operator node, so | |
6278 | -- that actuals can be resolved appropriately. | |
6279 | ||
6280 | if Is_Predefined_Op (Nam) or else Ekind (Nam) = E_Operator then | |
6281 | Make_Call_Into_Operator (N, Typ, Entity (Name (N))); | |
6282 | return; | |
6283 | ||
6284 | elsif Present (Alias (Nam)) | |
6285 | and then Is_Predefined_Op (Alias (Nam)) | |
6286 | then | |
6287 | Resolve_Actuals (N, Nam); | |
6288 | Make_Call_Into_Operator (N, Typ, Alias (Nam)); | |
6289 | return; | |
6290 | end if; | |
6291 | ||
fbf5a39b AC |
6292 | -- Create a transient scope if the resulting type requires it |
6293 | ||
4017021b AC |
6294 | -- There are several notable exceptions: |
6295 | ||
4d2907fd | 6296 | -- a) In init procs, the transient scope overhead is not needed, and is |
4017021b AC |
6297 | -- even incorrect when the call is a nested initialization call for a |
6298 | -- component whose expansion may generate adjust calls. However, if the | |
6299 | -- call is some other procedure call within an initialization procedure | |
6300 | -- (for example a call to Create_Task in the init_proc of the task | |
6301 | -- run-time record) a transient scope must be created around this call. | |
6302 | ||
4d2907fd | 6303 | -- b) Enumeration literal pseudo-calls need no transient scope |
4017021b | 6304 | |
4d2907fd | 6305 | -- c) Intrinsic subprograms (Unchecked_Conversion and source info |
4017021b | 6306 | -- functions) do not use the secondary stack even though the return |
4d2907fd | 6307 | -- type may be unconstrained. |
4017021b | 6308 | |
4d2907fd | 6309 | -- d) Calls to a build-in-place function, since such functions may |
4017021b AC |
6310 | -- allocate their result directly in a target object, and cases where |
6311 | -- the result does get allocated in the secondary stack are checked for | |
6312 | -- within the specialized Exp_Ch6 procedures for expanding those | |
6313 | -- build-in-place calls. | |
6314 | ||
b5f3c913 AC |
6315 | -- e) Calls to inlinable expression functions do not use the secondary |
6316 | -- stack (since the call will be replaced by its returned object). | |
6317 | ||
6318 | -- f) If the subprogram is marked Inline_Always, then even if it returns | |
c8ef728f | 6319 | -- an unconstrained type the call does not require use of the secondary |
45fc7ddb HK |
6320 | -- stack. However, inlining will only take place if the body to inline |
6321 | -- is already present. It may not be available if e.g. the subprogram is | |
6322 | -- declared in a child instance. | |
c8ef728f | 6323 | |
4017021b AC |
6324 | -- If this is an initialization call for a type whose construction |
6325 | -- uses the secondary stack, and it is not a nested call to initialize | |
6326 | -- a component, we do need to create a transient scope for it. We | |
6327 | -- check for this by traversing the type in Check_Initialization_Call. | |
6328 | ||
c8ef728f | 6329 | if Is_Inlined (Nam) |
84f4072a JM |
6330 | and then Has_Pragma_Inline (Nam) |
6331 | and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration | |
6332 | and then Present (Body_To_Inline (Unit_Declaration_Node (Nam))) | |
c8ef728f ES |
6333 | then |
6334 | null; | |
6335 | ||
4017021b AC |
6336 | elsif Ekind (Nam) = E_Enumeration_Literal |
6337 | or else Is_Build_In_Place_Function (Nam) | |
6338 | or else Is_Intrinsic_Subprogram (Nam) | |
b5f3c913 | 6339 | or else Is_Inlinable_Expression_Function (Nam) |
4017021b AC |
6340 | then |
6341 | null; | |
6342 | ||
4460a9bc | 6343 | elsif Expander_Active |
996ae0b0 RK |
6344 | and then Is_Type (Etype (Nam)) |
6345 | and then Requires_Transient_Scope (Etype (Nam)) | |
4017021b AC |
6346 | and then |
6347 | (not Within_Init_Proc | |
6348 | or else | |
6349 | (not Is_Init_Proc (Nam) and then Ekind (Nam) /= E_Function)) | |
996ae0b0 | 6350 | then |
0669bebe | 6351 | Establish_Transient_Scope (N, Sec_Stack => True); |
996ae0b0 | 6352 | |
a9f4e3d2 AC |
6353 | -- If the call appears within the bounds of a loop, it will |
6354 | -- be rewritten and reanalyzed, nothing left to do here. | |
6355 | ||
6356 | if Nkind (N) /= N_Function_Call then | |
6357 | return; | |
6358 | end if; | |
6359 | ||
fbf5a39b | 6360 | elsif Is_Init_Proc (Nam) |
996ae0b0 RK |
6361 | and then not Within_Init_Proc |
6362 | then | |
6363 | Check_Initialization_Call (N, Nam); | |
6364 | end if; | |
6365 | ||
6366 | -- A protected function cannot be called within the definition of the | |
88f7d2d1 | 6367 | -- enclosing protected type, unless it is part of a pre/postcondition |
ffa168bc AC |
6368 | -- on another protected operation. This may appear in the entry wrapper |
6369 | -- created for an entry with preconditions. | |
996ae0b0 RK |
6370 | |
6371 | if Is_Protected_Type (Scope (Nam)) | |
6372 | and then In_Open_Scopes (Scope (Nam)) | |
6373 | and then not Has_Completion (Scope (Nam)) | |
88f7d2d1 | 6374 | and then not In_Spec_Expression |
9ca67d3f | 6375 | and then not Is_Entry_Wrapper (Current_Scope) |
996ae0b0 RK |
6376 | then |
6377 | Error_Msg_NE | |
6378 | ("& cannot be called before end of protected definition", N, Nam); | |
6379 | end if; | |
6380 | ||
6381 | -- Propagate interpretation to actuals, and add default expressions | |
6382 | -- where needed. | |
6383 | ||
6384 | if Present (First_Formal (Nam)) then | |
6385 | Resolve_Actuals (N, Nam); | |
6386 | ||
d81b4bfe TQ |
6387 | -- Overloaded literals are rewritten as function calls, for purpose of |
6388 | -- resolution. After resolution, we can replace the call with the | |
6389 | -- literal itself. | |
996ae0b0 RK |
6390 | |
6391 | elsif Ekind (Nam) = E_Enumeration_Literal then | |
6392 | Copy_Node (Subp, N); | |
6393 | Resolve_Entity_Name (N, Typ); | |
6394 | ||
fbf5a39b | 6395 | -- Avoid validation, since it is a static function call |
996ae0b0 | 6396 | |
e65f50ec | 6397 | Generate_Reference (Nam, Subp); |
996ae0b0 RK |
6398 | return; |
6399 | end if; | |
6400 | ||
b7d1f17f HK |
6401 | -- If the subprogram is not global, then kill all saved values and |
6402 | -- checks. This is a bit conservative, since in many cases we could do | |
6403 | -- better, but it is not worth the effort. Similarly, we kill constant | |
6404 | -- values. However we do not need to do this for internal entities | |
6405 | -- (unless they are inherited user-defined subprograms), since they | |
6406 | -- are not in the business of molesting local values. | |
6407 | ||
6408 | -- If the flag Suppress_Value_Tracking_On_Calls is set, then we also | |
6409 | -- kill all checks and values for calls to global subprograms. This | |
6410 | -- takes care of the case where an access to a local subprogram is | |
6411 | -- taken, and could be passed directly or indirectly and then called | |
6412 | -- from almost any context. | |
aa180613 RD |
6413 | |
6414 | -- Note: we do not do this step till after resolving the actuals. That | |
6415 | -- way we still take advantage of the current value information while | |
6416 | -- scanning the actuals. | |
6417 | ||
45fc7ddb HK |
6418 | -- We suppress killing values if we are processing the nodes associated |
6419 | -- with N_Freeze_Entity nodes. Otherwise the declaration of a tagged | |
6420 | -- type kills all the values as part of analyzing the code that | |
6421 | -- initializes the dispatch tables. | |
6422 | ||
6423 | if Inside_Freezing_Actions = 0 | |
6424 | and then (not Is_Library_Level_Entity (Nam) | |
24357840 RD |
6425 | or else Suppress_Value_Tracking_On_Call |
6426 | (Nearest_Dynamic_Scope (Current_Scope))) | |
aa180613 RD |
6427 | and then (Comes_From_Source (Nam) |
6428 | or else (Present (Alias (Nam)) | |
6429 | and then Comes_From_Source (Alias (Nam)))) | |
6430 | then | |
6431 | Kill_Current_Values; | |
6432 | end if; | |
6433 | ||
36fcf362 RD |
6434 | -- If we are warning about unread OUT parameters, this is the place to |
6435 | -- set Last_Assignment for OUT and IN OUT parameters. We have to do this | |
6436 | -- after the above call to Kill_Current_Values (since that call clears | |
6437 | -- the Last_Assignment field of all local variables). | |
67ce0d7e | 6438 | |
36fcf362 | 6439 | if (Warn_On_Modified_Unread or Warn_On_All_Unread_Out_Parameters) |
67ce0d7e RD |
6440 | and then Comes_From_Source (N) |
6441 | and then In_Extended_Main_Source_Unit (N) | |
6442 | then | |
6443 | declare | |
6444 | F : Entity_Id; | |
6445 | A : Node_Id; | |
6446 | ||
6447 | begin | |
6448 | F := First_Formal (Nam); | |
6449 | A := First_Actual (N); | |
6450 | while Present (F) and then Present (A) loop | |
964f13da | 6451 | if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) |
36fcf362 | 6452 | and then Warn_On_Modified_As_Out_Parameter (F) |
67ce0d7e RD |
6453 | and then Is_Entity_Name (A) |
6454 | and then Present (Entity (A)) | |
36fcf362 | 6455 | and then Comes_From_Source (N) |
67ce0d7e RD |
6456 | and then Safe_To_Capture_Value (N, Entity (A)) |
6457 | then | |
6458 | Set_Last_Assignment (Entity (A), A); | |
6459 | end if; | |
6460 | ||
6461 | Next_Formal (F); | |
6462 | Next_Actual (A); | |
6463 | end loop; | |
6464 | end; | |
6465 | end if; | |
6466 | ||
996ae0b0 RK |
6467 | -- If the subprogram is a primitive operation, check whether or not |
6468 | -- it is a correct dispatching call. | |
6469 | ||
6470 | if Is_Overloadable (Nam) | |
6471 | and then Is_Dispatching_Operation (Nam) | |
6472 | then | |
6473 | Check_Dispatching_Call (N); | |
6474 | ||
0669bebe GB |
6475 | elsif Ekind (Nam) /= E_Subprogram_Type |
6476 | and then Is_Abstract_Subprogram (Nam) | |
996ae0b0 RK |
6477 | and then not In_Instance |
6478 | then | |
6479 | Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam); | |
6480 | end if; | |
6481 | ||
e65f50ec ES |
6482 | -- If this is a dispatching call, generate the appropriate reference, |
6483 | -- for better source navigation in GPS. | |
6484 | ||
6485 | if Is_Overloadable (Nam) | |
6486 | and then Present (Controlling_Argument (N)) | |
6487 | then | |
6488 | Generate_Reference (Nam, Subp, 'R'); | |
c5d91669 | 6489 | |
5cc9353d | 6490 | -- Normal case, not a dispatching call: generate a call reference |
c5d91669 | 6491 | |
e65f50ec | 6492 | else |
9c870c90 | 6493 | Generate_Reference (Nam, Subp, 's'); |
e65f50ec ES |
6494 | end if; |
6495 | ||
996ae0b0 RK |
6496 | if Is_Intrinsic_Subprogram (Nam) then |
6497 | Check_Intrinsic_Call (N); | |
6498 | end if; | |
6499 | ||
5b2217f8 | 6500 | -- Check for violation of restriction No_Specific_Termination_Handlers |
dce86910 | 6501 | -- and warn on a potentially blocking call to Abort_Task. |
5b2217f8 | 6502 | |
273adcdf AC |
6503 | if Restriction_Check_Required (No_Specific_Termination_Handlers) |
6504 | and then (Is_RTE (Nam, RE_Set_Specific_Handler) | |
6505 | or else | |
6506 | Is_RTE (Nam, RE_Specific_Handler)) | |
5b2217f8 RD |
6507 | then |
6508 | Check_Restriction (No_Specific_Termination_Handlers, N); | |
dce86910 AC |
6509 | |
6510 | elsif Is_RTE (Nam, RE_Abort_Task) then | |
6511 | Check_Potentially_Blocking_Operation (N); | |
5b2217f8 RD |
6512 | end if; |
6513 | ||
806f6d37 AC |
6514 | -- A call to Ada.Real_Time.Timing_Events.Set_Handler to set a relative |
6515 | -- timing event violates restriction No_Relative_Delay (AI-0211). We | |
6516 | -- need to check the second argument to determine whether it is an | |
6517 | -- absolute or relative timing event. | |
afbcdf5e | 6518 | |
273adcdf AC |
6519 | if Restriction_Check_Required (No_Relative_Delay) |
6520 | and then Is_RTE (Nam, RE_Set_Handler) | |
806f6d37 AC |
6521 | and then Is_RTE (Etype (Next_Actual (First_Actual (N))), RE_Time_Span) |
6522 | then | |
afbcdf5e AC |
6523 | Check_Restriction (No_Relative_Delay, N); |
6524 | end if; | |
6525 | ||
21791d97 AC |
6526 | -- Issue an error for a call to an eliminated subprogram. This routine |
6527 | -- will not perform the check if the call appears within a default | |
6528 | -- expression. | |
16212e89 | 6529 | |
df378148 | 6530 | Check_For_Eliminated_Subprogram (Subp, Nam); |
16212e89 | 6531 | |
12f0c50c AC |
6532 | -- In formal mode, the primitive operations of a tagged type or type |
6533 | -- extension do not include functions that return the tagged type. | |
6534 | ||
f6820c2d AC |
6535 | if Nkind (N) = N_Function_Call |
6536 | and then Is_Tagged_Type (Etype (N)) | |
6537 | and then Is_Entity_Name (Name (N)) | |
1a83142e | 6538 | and then Is_Inherited_Operation_For_Type (Entity (Name (N)), Etype (N)) |
f6820c2d | 6539 | then |
ce5ba43a | 6540 | Check_SPARK_05_Restriction ("function not inherited", N); |
f6820c2d | 6541 | end if; |
12f0c50c | 6542 | |
e8374e7a AC |
6543 | -- Implement rule in 12.5.1 (23.3/2): In an instance, if the actual is |
6544 | -- class-wide and the call dispatches on result in a context that does | |
6545 | -- not provide a tag, the call raises Program_Error. | |
1f6439e3 AC |
6546 | |
6547 | if Nkind (N) = N_Function_Call | |
6548 | and then In_Instance | |
6549 | and then Is_Generic_Actual_Type (Typ) | |
6550 | and then Is_Class_Wide_Type (Typ) | |
6551 | and then Has_Controlling_Result (Nam) | |
6552 | and then Nkind (Parent (N)) = N_Object_Declaration | |
6553 | then | |
e8374e7a | 6554 | -- Verify that none of the formals are controlling |
1f6439e3 AC |
6555 | |
6556 | declare | |
e8374e7a | 6557 | Call_OK : Boolean := False; |
1f6439e3 AC |
6558 | F : Entity_Id; |
6559 | ||
6560 | begin | |
6561 | F := First_Formal (Nam); | |
6562 | while Present (F) loop | |
6563 | if Is_Controlling_Formal (F) then | |
6564 | Call_OK := True; | |
6565 | exit; | |
6566 | end if; | |
e8374e7a | 6567 | |
1f6439e3 AC |
6568 | Next_Formal (F); |
6569 | end loop; | |
6570 | ||
6571 | if not Call_OK then | |
43417b90 | 6572 | Error_Msg_Warn := SPARK_Mode /= On; |
4a28b181 AC |
6573 | Error_Msg_N ("!cannot determine tag of result<<", N); |
6574 | Error_Msg_N ("\Program_Error [<<!", N); | |
1f6439e3 AC |
6575 | Insert_Action (N, |
6576 | Make_Raise_Program_Error (Sloc (N), | |
6577 | Reason => PE_Explicit_Raise)); | |
6578 | end if; | |
6579 | end; | |
6580 | end if; | |
6581 | ||
fc999c5d RD |
6582 | -- Check for calling a function with OUT or IN OUT parameter when the |
6583 | -- calling context (us right now) is not Ada 2012, so does not allow | |
ef2c20e7 AC |
6584 | -- OUT or IN OUT parameters in function calls. Functions declared in |
6585 | -- a predefined unit are OK, as they may be called indirectly from a | |
6586 | -- user-declared instantiation. | |
fc999c5d RD |
6587 | |
6588 | if Ada_Version < Ada_2012 | |
6589 | and then Ekind (Nam) = E_Function | |
6590 | and then Has_Out_Or_In_Out_Parameter (Nam) | |
ef2c20e7 | 6591 | and then not In_Predefined_Unit (Nam) |
fc999c5d RD |
6592 | then |
6593 | Error_Msg_NE ("& has at least one OUT or `IN OUT` parameter", N, Nam); | |
6594 | Error_Msg_N ("\call to this function only allowed in Ada 2012", N); | |
6595 | end if; | |
6596 | ||
0929eaeb AC |
6597 | -- Check the dimensions of the actuals in the call. For function calls, |
6598 | -- propagate the dimensions from the returned type to N. | |
6599 | ||
6600 | Analyze_Dimension_Call (N, Nam); | |
dec6faf1 | 6601 | |
67ce0d7e RD |
6602 | -- All done, evaluate call and deal with elaboration issues |
6603 | ||
c01a9391 | 6604 | Eval_Call (N); |
996ae0b0 | 6605 | Check_Elab_Call (N); |
ecad37f3 | 6606 | |
10671e7a AC |
6607 | -- In GNATprove mode, expansion is disabled, but we want to inline some |
6608 | -- subprograms to facilitate formal verification. Indirect calls through | |
6609 | -- a subprogram type or within a generic cannot be inlined. Inlining is | |
6610 | -- performed only for calls subject to SPARK_Mode on. | |
ecad37f3 ES |
6611 | |
6612 | if GNATprove_Mode | |
2d180af1 | 6613 | and then SPARK_Mode = On |
10671e7a AC |
6614 | and then Is_Overloadable (Nam) |
6615 | and then not Inside_A_Generic | |
ecad37f3 | 6616 | then |
bf0b0e5e AC |
6617 | Nam_UA := Ultimate_Alias (Nam); |
6618 | Nam_Decl := Unit_Declaration_Node (Nam_UA); | |
e5c4e2bc | 6619 | |
bf0b0e5e AC |
6620 | if Nkind (Nam_Decl) = N_Subprogram_Declaration then |
6621 | Body_Id := Corresponding_Body (Nam_Decl); | |
eb1ee757 | 6622 | |
bf0b0e5e AC |
6623 | -- Nothing to do if the subprogram is not eligible for inlining in |
6624 | -- GNATprove mode. | |
2178830b | 6625 | |
bf0b0e5e | 6626 | if not Is_Inlined_Always (Nam_UA) |
39521a94 | 6627 | or else not Can_Be_Inlined_In_GNATprove_Mode (Nam_UA, Body_Id) |
4bd4bb7f | 6628 | then |
2178830b AC |
6629 | null; |
6630 | ||
6631 | -- Calls cannot be inlined inside assertions, as GNATprove treats | |
6632 | -- assertions as logic expressions. | |
6633 | ||
6634 | elsif In_Assertion_Expr /= 0 then | |
fd22e260 AC |
6635 | Cannot_Inline |
6636 | ("cannot inline & (in assertion expression)?", N, Nam_UA); | |
4bd4bb7f | 6637 | |
3dd7e28d YM |
6638 | -- Calls cannot be inlined inside default expressions |
6639 | ||
6640 | elsif In_Default_Expr then | |
fd22e260 AC |
6641 | Cannot_Inline |
6642 | ("cannot inline & (in default expression)?", N, Nam_UA); | |
3dd7e28d | 6643 | |
2178830b AC |
6644 | -- Inlining should not be performed during pre-analysis |
6645 | ||
6646 | elsif Full_Analysis then | |
6647 | ||
6648 | -- With the one-pass inlining technique, a call cannot be | |
6649 | -- inlined if the corresponding body has not been seen yet. | |
6650 | ||
39521a94 | 6651 | if No (Body_Id) then |
fd22e260 AC |
6652 | Cannot_Inline |
6653 | ("cannot inline & (body not seen yet)?", N, Nam_UA); | |
2178830b AC |
6654 | |
6655 | -- Nothing to do if there is no body to inline, indicating that | |
6656 | -- the subprogram is not suitable for inlining in GNATprove | |
6657 | -- mode. | |
6658 | ||
bf0b0e5e | 6659 | elsif No (Body_To_Inline (Nam_Decl)) then |
2178830b AC |
6660 | null; |
6661 | ||
fd22e260 AC |
6662 | -- Do not inline calls inside expression functions, as this |
6663 | -- would prevent interpreting them as logical formulas in | |
6664 | -- GNATprove. | |
6665 | ||
6666 | elsif Present (Current_Subprogram) | |
6667 | and then | |
6668 | Is_Expression_Function_Or_Completion (Current_Subprogram) | |
6669 | then | |
6670 | Cannot_Inline | |
6671 | ("cannot inline & (inside expression function)?", | |
6672 | N, Nam_UA); | |
6673 | ||
2178830b AC |
6674 | -- Calls cannot be inlined inside potentially unevaluated |
6675 | -- expressions, as this would create complex actions inside | |
6676 | -- expressions, that are not handled by GNATprove. | |
6677 | ||
6678 | elsif Is_Potentially_Unevaluated (N) then | |
fd22e260 AC |
6679 | Cannot_Inline |
6680 | ("cannot inline & (in potentially unevaluated context)?", | |
6681 | N, Nam_UA); | |
2178830b | 6682 | |
3de3a1be YM |
6683 | -- Do not inline calls which would possibly lead to missing a |
6684 | -- type conversion check on an input parameter. | |
6685 | ||
6686 | elsif not Call_Can_Be_Inlined_In_GNATprove_Mode (N, Nam) then | |
6687 | Cannot_Inline | |
6688 | ("cannot inline & (possible check on input parameters)?", | |
6689 | N, Nam_UA); | |
6690 | ||
2178830b AC |
6691 | -- Otherwise, inline the call |
6692 | ||
52c1498c | 6693 | else |
eb1ee757 | 6694 | Expand_Inlined_Call (N, Nam_UA, Nam); |
52c1498c | 6695 | end if; |
e5c4e2bc | 6696 | end if; |
bf0b0e5e | 6697 | end if; |
ecad37f3 ES |
6698 | end if; |
6699 | ||
76b84bf0 | 6700 | Warn_On_Overlapping_Actuals (Nam, N); |
996ae0b0 RK |
6701 | end Resolve_Call; |
6702 | ||
19d846a0 RD |
6703 | ----------------------------- |
6704 | -- Resolve_Case_Expression -- | |
6705 | ----------------------------- | |
6706 | ||
6707 | procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id) is | |
bc795e3e YM |
6708 | Alt : Node_Id; |
6709 | Alt_Expr : Node_Id; | |
6710 | Alt_Typ : Entity_Id; | |
6711 | Is_Dyn : Boolean; | |
19d846a0 RD |
6712 | |
6713 | begin | |
6714 | Alt := First (Alternatives (N)); | |
6715 | while Present (Alt) loop | |
bc795e3e YM |
6716 | Alt_Expr := Expression (Alt); |
6717 | Resolve (Alt_Expr, Typ); | |
6718 | Alt_Typ := Etype (Alt_Expr); | |
6719 | ||
6720 | -- When the expression is of a scalar subtype different from the | |
6721 | -- result subtype, then insert a conversion to ensure the generation | |
6722 | -- of a constraint check. | |
6723 | ||
6724 | if Is_Scalar_Type (Alt_Typ) and then Alt_Typ /= Typ then | |
6725 | Rewrite (Alt_Expr, Convert_To (Typ, Alt_Expr)); | |
6726 | Analyze_And_Resolve (Alt_Expr, Typ); | |
6727 | end if; | |
6728 | ||
19d846a0 RD |
6729 | Next (Alt); |
6730 | end loop; | |
6731 | ||
b6dd03dd ES |
6732 | -- Apply RM 4.5.7 (17/3): whether the expression is statically or |
6733 | -- dynamically tagged must be known statically. | |
6734 | ||
6735 | if Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) then | |
bc795e3e | 6736 | Alt := First (Alternatives (N)); |
b6dd03dd ES |
6737 | Is_Dyn := Is_Dynamically_Tagged (Expression (Alt)); |
6738 | ||
6739 | while Present (Alt) loop | |
6740 | if Is_Dynamically_Tagged (Expression (Alt)) /= Is_Dyn then | |
bc795e3e YM |
6741 | Error_Msg_N |
6742 | ("all or none of the dependent expressions can be " | |
6743 | & "dynamically tagged", N); | |
b6dd03dd ES |
6744 | end if; |
6745 | ||
6746 | Next (Alt); | |
6747 | end loop; | |
6748 | end if; | |
6749 | ||
19d846a0 RD |
6750 | Set_Etype (N, Typ); |
6751 | Eval_Case_Expression (N); | |
6752 | end Resolve_Case_Expression; | |
6753 | ||
996ae0b0 RK |
6754 | ------------------------------- |
6755 | -- Resolve_Character_Literal -- | |
6756 | ------------------------------- | |
6757 | ||
6758 | procedure Resolve_Character_Literal (N : Node_Id; Typ : Entity_Id) is | |
6759 | B_Typ : constant Entity_Id := Base_Type (Typ); | |
6760 | C : Entity_Id; | |
6761 | ||
6762 | begin | |
6763 | -- Verify that the character does belong to the type of the context | |
6764 | ||
6765 | Set_Etype (N, B_Typ); | |
6766 | Eval_Character_Literal (N); | |
6767 | ||
82c80734 RD |
6768 | -- Wide_Wide_Character literals must always be defined, since the set |
6769 | -- of wide wide character literals is complete, i.e. if a character | |
6770 | -- literal is accepted by the parser, then it is OK for wide wide | |
6771 | -- character (out of range character literals are rejected). | |
996ae0b0 | 6772 | |
82c80734 | 6773 | if Root_Type (B_Typ) = Standard_Wide_Wide_Character then |
996ae0b0 RK |
6774 | return; |
6775 | ||
6776 | -- Always accept character literal for type Any_Character, which | |
6777 | -- occurs in error situations and in comparisons of literals, both | |
6778 | -- of which should accept all literals. | |
6779 | ||
6780 | elsif B_Typ = Any_Character then | |
6781 | return; | |
6782 | ||
5cc9353d RD |
6783 | -- For Standard.Character or a type derived from it, check that the |
6784 | -- literal is in range. | |
996ae0b0 RK |
6785 | |
6786 | elsif Root_Type (B_Typ) = Standard_Character then | |
82c80734 RD |
6787 | if In_Character_Range (UI_To_CC (Char_Literal_Value (N))) then |
6788 | return; | |
6789 | end if; | |
6790 | ||
5cc9353d RD |
6791 | -- For Standard.Wide_Character or a type derived from it, check that the |
6792 | -- literal is in range. | |
82c80734 RD |
6793 | |
6794 | elsif Root_Type (B_Typ) = Standard_Wide_Character then | |
6795 | if In_Wide_Character_Range (UI_To_CC (Char_Literal_Value (N))) then | |
996ae0b0 RK |
6796 | return; |
6797 | end if; | |
6798 | ||
82c80734 | 6799 | -- For Standard.Wide_Wide_Character or a type derived from it, we |
159a5104 | 6800 | -- know the literal is in range, since the parser checked. |
82c80734 RD |
6801 | |
6802 | elsif Root_Type (B_Typ) = Standard_Wide_Wide_Character then | |
6803 | return; | |
6804 | ||
d81b4bfe TQ |
6805 | -- If the entity is already set, this has already been resolved in a |
6806 | -- generic context, or comes from expansion. Nothing else to do. | |
996ae0b0 RK |
6807 | |
6808 | elsif Present (Entity (N)) then | |
6809 | return; | |
6810 | ||
d81b4bfe TQ |
6811 | -- Otherwise we have a user defined character type, and we can use the |
6812 | -- standard visibility mechanisms to locate the referenced entity. | |
996ae0b0 RK |
6813 | |
6814 | else | |
6815 | C := Current_Entity (N); | |
996ae0b0 RK |
6816 | while Present (C) loop |
6817 | if Etype (C) = B_Typ then | |
e7ba564f | 6818 | Set_Entity_With_Checks (N, C); |
996ae0b0 RK |
6819 | Generate_Reference (C, N); |
6820 | return; | |
6821 | end if; | |
6822 | ||
6823 | C := Homonym (C); | |
6824 | end loop; | |
6825 | end if; | |
6826 | ||
6827 | -- If we fall through, then the literal does not match any of the | |
5cc9353d RD |
6828 | -- entries of the enumeration type. This isn't just a constraint error |
6829 | -- situation, it is an illegality (see RM 4.2). | |
996ae0b0 RK |
6830 | |
6831 | Error_Msg_NE | |
6832 | ("character not defined for }", N, First_Subtype (B_Typ)); | |
996ae0b0 RK |
6833 | end Resolve_Character_Literal; |
6834 | ||
6835 | --------------------------- | |
6836 | -- Resolve_Comparison_Op -- | |
6837 | --------------------------- | |
6838 | ||
6839 | -- Context requires a boolean type, and plays no role in resolution. | |
5cc9353d RD |
6840 | -- Processing identical to that for equality operators. The result type is |
6841 | -- the base type, which matters when pathological subtypes of booleans with | |
6842 | -- limited ranges are used. | |
996ae0b0 RK |
6843 | |
6844 | procedure Resolve_Comparison_Op (N : Node_Id; Typ : Entity_Id) is | |
6845 | L : constant Node_Id := Left_Opnd (N); | |
6846 | R : constant Node_Id := Right_Opnd (N); | |
6847 | T : Entity_Id; | |
6848 | ||
6849 | begin | |
d81b4bfe TQ |
6850 | -- If this is an intrinsic operation which is not predefined, use the |
6851 | -- types of its declared arguments to resolve the possibly overloaded | |
6852 | -- operands. Otherwise the operands are unambiguous and specify the | |
6853 | -- expected type. | |
996ae0b0 RK |
6854 | |
6855 | if Scope (Entity (N)) /= Standard_Standard then | |
6856 | T := Etype (First_Entity (Entity (N))); | |
1420b484 | 6857 | |
996ae0b0 RK |
6858 | else |
6859 | T := Find_Unique_Type (L, R); | |
6860 | ||
6861 | if T = Any_Fixed then | |
6862 | T := Unique_Fixed_Point_Type (L); | |
6863 | end if; | |
6864 | end if; | |
6865 | ||
fbf5a39b | 6866 | Set_Etype (N, Base_Type (Typ)); |
996ae0b0 RK |
6867 | Generate_Reference (T, N, ' '); |
6868 | ||
bd29d519 | 6869 | -- Skip remaining processing if already set to Any_Type |
996ae0b0 | 6870 | |
bd29d519 AC |
6871 | if T = Any_Type then |
6872 | return; | |
6873 | end if; | |
6874 | ||
6875 | -- Deal with other error cases | |
996ae0b0 | 6876 | |
bd29d519 AC |
6877 | if T = Any_String or else |
6878 | T = Any_Composite or else | |
6879 | T = Any_Character | |
6880 | then | |
6881 | if T = Any_Character then | |
6882 | Ambiguous_Character (L); | |
996ae0b0 | 6883 | else |
bd29d519 | 6884 | Error_Msg_N ("ambiguous operands for comparison", N); |
996ae0b0 | 6885 | end if; |
bd29d519 AC |
6886 | |
6887 | Set_Etype (N, Any_Type); | |
6888 | return; | |
996ae0b0 | 6889 | end if; |
bd29d519 AC |
6890 | |
6891 | -- Resolve the operands if types OK | |
6892 | ||
6893 | Resolve (L, T); | |
6894 | Resolve (R, T); | |
6895 | Check_Unset_Reference (L); | |
6896 | Check_Unset_Reference (R); | |
6897 | Generate_Operator_Reference (N, T); | |
6898 | Check_Low_Bound_Tested (N); | |
6899 | ||
2ba431e5 YM |
6900 | -- In SPARK, ordering operators <, <=, >, >= are not defined for Boolean |
6901 | -- types or array types except String. | |
b0186f71 | 6902 | |
fe5d3068 | 6903 | if Is_Boolean_Type (T) then |
ce5ba43a | 6904 | Check_SPARK_05_Restriction |
fe5d3068 | 6905 | ("comparison is not defined on Boolean type", N); |
975c6896 | 6906 | |
ad05f2e9 AC |
6907 | elsif Is_Array_Type (T) |
6908 | and then Base_Type (T) /= Standard_String | |
6909 | then | |
ce5ba43a | 6910 | Check_SPARK_05_Restriction |
ad05f2e9 | 6911 | ("comparison is not defined on array types other than String", N); |
b0186f71 AC |
6912 | end if; |
6913 | ||
bd29d519 AC |
6914 | -- Check comparison on unordered enumeration |
6915 | ||
f6636994 | 6916 | if Bad_Unordered_Enumeration_Reference (N, Etype (L)) then |
b1d12996 AC |
6917 | Error_Msg_Sloc := Sloc (Etype (L)); |
6918 | Error_Msg_NE | |
6919 | ("comparison on unordered enumeration type& declared#?U?", | |
6920 | N, Etype (L)); | |
bd29d519 AC |
6921 | end if; |
6922 | ||
ded462b0 AC |
6923 | Analyze_Dimension (N); |
6924 | ||
5cc9353d | 6925 | -- Evaluate the relation (note we do this after the above check since |
ded462b0 AC |
6926 | -- this Eval call may change N to True/False. Skip this evaluation |
6927 | -- inside assertions, in order to keep assertions as written by users | |
6928 | -- for tools that rely on these, e.g. GNATprove for loop invariants. | |
bd29d519 | 6929 | |
ded462b0 AC |
6930 | if In_Assertion_Expr = 0 then |
6931 | Eval_Relational_Op (N); | |
6932 | end if; | |
996ae0b0 RK |
6933 | end Resolve_Comparison_Op; |
6934 | ||
996ae0b0 RK |
6935 | ----------------------------------------- |
6936 | -- Resolve_Discrete_Subtype_Indication -- | |
6937 | ----------------------------------------- | |
6938 | ||
6939 | procedure Resolve_Discrete_Subtype_Indication | |
6940 | (N : Node_Id; | |
6941 | Typ : Entity_Id) | |
6942 | is | |
6943 | R : Node_Id; | |
6944 | S : Entity_Id; | |
6945 | ||
6946 | begin | |
6947 | Analyze (Subtype_Mark (N)); | |
6948 | S := Entity (Subtype_Mark (N)); | |
6949 | ||
6950 | if Nkind (Constraint (N)) /= N_Range_Constraint then | |
6951 | Error_Msg_N ("expect range constraint for discrete type", N); | |
6952 | Set_Etype (N, Any_Type); | |
6953 | ||
6954 | else | |
6955 | R := Range_Expression (Constraint (N)); | |
5c736541 RD |
6956 | |
6957 | if R = Error then | |
6958 | return; | |
6959 | end if; | |
6960 | ||
996ae0b0 RK |
6961 | Analyze (R); |
6962 | ||
6963 | if Base_Type (S) /= Base_Type (Typ) then | |
6964 | Error_Msg_NE | |
6965 | ("expect subtype of }", N, First_Subtype (Typ)); | |
6966 | ||
6967 | -- Rewrite the constraint as a range of Typ | |
6968 | -- to allow compilation to proceed further. | |
6969 | ||
6970 | Set_Etype (N, Typ); | |
6971 | Rewrite (Low_Bound (R), | |
6972 | Make_Attribute_Reference (Sloc (Low_Bound (R)), | |
5cc9353d | 6973 | Prefix => New_Occurrence_Of (Typ, Sloc (R)), |
996ae0b0 RK |
6974 | Attribute_Name => Name_First)); |
6975 | Rewrite (High_Bound (R), | |
6976 | Make_Attribute_Reference (Sloc (High_Bound (R)), | |
5cc9353d | 6977 | Prefix => New_Occurrence_Of (Typ, Sloc (R)), |
996ae0b0 RK |
6978 | Attribute_Name => Name_First)); |
6979 | ||
6980 | else | |
6981 | Resolve (R, Typ); | |
6982 | Set_Etype (N, Etype (R)); | |
6983 | ||
6984 | -- Additionally, we must check that the bounds are compatible | |
6985 | -- with the given subtype, which might be different from the | |
6986 | -- type of the context. | |
6987 | ||
6988 | Apply_Range_Check (R, S); | |
6989 | ||
6990 | -- ??? If the above check statically detects a Constraint_Error | |
6991 | -- it replaces the offending bound(s) of the range R with a | |
6992 | -- Constraint_Error node. When the itype which uses these bounds | |
6993 | -- is frozen the resulting call to Duplicate_Subexpr generates | |
6994 | -- a new temporary for the bounds. | |
6995 | ||
6996 | -- Unfortunately there are other itypes that are also made depend | |
6997 | -- on these bounds, so when Duplicate_Subexpr is called they get | |
6998 | -- a forward reference to the newly created temporaries and Gigi | |
6999 | -- aborts on such forward references. This is probably sign of a | |
7000 | -- more fundamental problem somewhere else in either the order of | |
7001 | -- itype freezing or the way certain itypes are constructed. | |
7002 | ||
7003 | -- To get around this problem we call Remove_Side_Effects right | |
7004 | -- away if either bounds of R are a Constraint_Error. | |
7005 | ||
7006 | declare | |
fbf5a39b AC |
7007 | L : constant Node_Id := Low_Bound (R); |
7008 | H : constant Node_Id := High_Bound (R); | |
996ae0b0 RK |
7009 | |
7010 | begin | |
7011 | if Nkind (L) = N_Raise_Constraint_Error then | |
7012 | Remove_Side_Effects (L); | |
7013 | end if; | |
7014 | ||
7015 | if Nkind (H) = N_Raise_Constraint_Error then | |
7016 | Remove_Side_Effects (H); | |
7017 | end if; | |
7018 | end; | |
7019 | ||
7020 | Check_Unset_Reference (Low_Bound (R)); | |
7021 | Check_Unset_Reference (High_Bound (R)); | |
7022 | end if; | |
7023 | end if; | |
7024 | end Resolve_Discrete_Subtype_Indication; | |
7025 | ||
7026 | ------------------------- | |
7027 | -- Resolve_Entity_Name -- | |
7028 | ------------------------- | |
7029 | ||
7030 | -- Used to resolve identifiers and expanded names | |
7031 | ||
7032 | procedure Resolve_Entity_Name (N : Node_Id; Typ : Entity_Id) is | |
a921e83c AC |
7033 | function Is_Assignment_Or_Object_Expression |
7034 | (Context : Node_Id; | |
7035 | Expr : Node_Id) return Boolean; | |
7036 | -- Determine whether node Context denotes an assignment statement or an | |
7037 | -- object declaration whose expression is node Expr. | |
7038 | ||
a921e83c AC |
7039 | ---------------------------------------- |
7040 | -- Is_Assignment_Or_Object_Expression -- | |
7041 | ---------------------------------------- | |
7042 | ||
7043 | function Is_Assignment_Or_Object_Expression | |
7044 | (Context : Node_Id; | |
7045 | Expr : Node_Id) return Boolean | |
7046 | is | |
7047 | begin | |
7048 | if Nkind_In (Context, N_Assignment_Statement, | |
7049 | N_Object_Declaration) | |
7050 | and then Expression (Context) = Expr | |
7051 | then | |
7052 | return True; | |
7053 | ||
7054 | -- Check whether a construct that yields a name is the expression of | |
7055 | -- an assignment statement or an object declaration. | |
7056 | ||
7057 | elsif (Nkind_In (Context, N_Attribute_Reference, | |
7058 | N_Explicit_Dereference, | |
7059 | N_Indexed_Component, | |
7060 | N_Selected_Component, | |
7061 | N_Slice) | |
7062 | and then Prefix (Context) = Expr) | |
7063 | or else | |
7064 | (Nkind_In (Context, N_Type_Conversion, | |
7065 | N_Unchecked_Type_Conversion) | |
7066 | and then Expression (Context) = Expr) | |
7067 | then | |
7068 | return | |
7069 | Is_Assignment_Or_Object_Expression | |
7070 | (Context => Parent (Context), | |
7071 | Expr => Context); | |
7072 | ||
7073 | -- Otherwise the context is not an assignment statement or an object | |
7074 | -- declaration. | |
7075 | ||
7076 | else | |
7077 | return False; | |
7078 | end if; | |
7079 | end Is_Assignment_Or_Object_Expression; | |
7080 | ||
f9966234 AC |
7081 | -- Local variables |
7082 | ||
7083 | E : constant Entity_Id := Entity (N); | |
d99565f8 | 7084 | Par : Node_Id; |
f9966234 AC |
7085 | |
7086 | -- Start of processing for Resolve_Entity_Name | |
996ae0b0 RK |
7087 | |
7088 | begin | |
07fc65c4 GB |
7089 | -- If garbage from errors, set to Any_Type and return |
7090 | ||
7091 | if No (E) and then Total_Errors_Detected /= 0 then | |
7092 | Set_Etype (N, Any_Type); | |
7093 | return; | |
7094 | end if; | |
7095 | ||
996ae0b0 RK |
7096 | -- Replace named numbers by corresponding literals. Note that this is |
7097 | -- the one case where Resolve_Entity_Name must reset the Etype, since | |
7098 | -- it is currently marked as universal. | |
7099 | ||
7100 | if Ekind (E) = E_Named_Integer then | |
7101 | Set_Etype (N, Typ); | |
7102 | Eval_Named_Integer (N); | |
7103 | ||
7104 | elsif Ekind (E) = E_Named_Real then | |
7105 | Set_Etype (N, Typ); | |
7106 | Eval_Named_Real (N); | |
7107 | ||
6989bc1f AC |
7108 | -- For enumeration literals, we need to make sure that a proper style |
7109 | -- check is done, since such literals are overloaded, and thus we did | |
7110 | -- not do a style check during the first phase of analysis. | |
7111 | ||
7112 | elsif Ekind (E) = E_Enumeration_Literal then | |
e7ba564f | 7113 | Set_Entity_With_Checks (N, E); |
6989bc1f AC |
7114 | Eval_Entity_Name (N); |
7115 | ||
596b25f9 AC |
7116 | -- Case of (sub)type name appearing in a context where an expression |
7117 | -- is expected. This is legal if occurrence is a current instance. | |
7118 | -- See RM 8.6 (17/3). | |
996ae0b0 RK |
7119 | |
7120 | elsif Is_Type (E) then | |
596b25f9 | 7121 | if Is_Current_Instance (N) then |
996ae0b0 | 7122 | null; |
e606088a | 7123 | |
308e6f3a | 7124 | -- Any other use is an error |
e606088a | 7125 | |
996ae0b0 RK |
7126 | else |
7127 | Error_Msg_N | |
758c442c | 7128 | ("invalid use of subtype mark in expression or call", N); |
996ae0b0 RK |
7129 | end if; |
7130 | ||
7131 | -- Check discriminant use if entity is discriminant in current scope, | |
7132 | -- i.e. discriminant of record or concurrent type currently being | |
7133 | -- analyzed. Uses in corresponding body are unrestricted. | |
7134 | ||
7135 | elsif Ekind (E) = E_Discriminant | |
7136 | and then Scope (E) = Current_Scope | |
7137 | and then not Has_Completion (Current_Scope) | |
7138 | then | |
7139 | Check_Discriminant_Use (N); | |
7140 | ||
7141 | -- A parameterless generic function cannot appear in a context that | |
7142 | -- requires resolution. | |
7143 | ||
7144 | elsif Ekind (E) = E_Generic_Function then | |
7145 | Error_Msg_N ("illegal use of generic function", N); | |
7146 | ||
a921e83c AC |
7147 | -- In Ada 83 an OUT parameter cannot be read |
7148 | ||
996ae0b0 | 7149 | elsif Ekind (E) = E_Out_Parameter |
996ae0b0 | 7150 | and then (Nkind (Parent (N)) in N_Op |
a921e83c AC |
7151 | or else Nkind (Parent (N)) = N_Explicit_Dereference |
7152 | or else Is_Assignment_Or_Object_Expression | |
7153 | (Context => Parent (N), | |
7154 | Expr => N)) | |
996ae0b0 | 7155 | then |
a921e83c AC |
7156 | if Ada_Version = Ada_83 then |
7157 | Error_Msg_N ("(Ada 83) illegal reading of out parameter", N); | |
a921e83c | 7158 | end if; |
996ae0b0 RK |
7159 | |
7160 | -- In all other cases, just do the possible static evaluation | |
7161 | ||
7162 | else | |
d81b4bfe TQ |
7163 | -- A deferred constant that appears in an expression must have a |
7164 | -- completion, unless it has been removed by in-place expansion of | |
3f8c04e7 AC |
7165 | -- an aggregate. A constant that is a renaming does not need |
7166 | -- initialization. | |
996ae0b0 RK |
7167 | |
7168 | if Ekind (E) = E_Constant | |
7169 | and then Comes_From_Source (E) | |
7170 | and then No (Constant_Value (E)) | |
7171 | and then Is_Frozen (Etype (E)) | |
45fc7ddb | 7172 | and then not In_Spec_Expression |
996ae0b0 | 7173 | and then not Is_Imported (E) |
3f8c04e7 | 7174 | and then Nkind (Parent (E)) /= N_Object_Renaming_Declaration |
996ae0b0 | 7175 | then |
996ae0b0 RK |
7176 | if No_Initialization (Parent (E)) |
7177 | or else (Present (Full_View (E)) | |
7178 | and then No_Initialization (Parent (Full_View (E)))) | |
7179 | then | |
7180 | null; | |
7181 | else | |
b4213ffd AC |
7182 | Error_Msg_N |
7183 | ("deferred constant is frozen before completion", N); | |
996ae0b0 RK |
7184 | end if; |
7185 | end if; | |
7186 | ||
7187 | Eval_Entity_Name (N); | |
7188 | end if; | |
6c3c671e | 7189 | |
d99565f8 AC |
7190 | Par := Parent (N); |
7191 | ||
7192 | -- When the entity appears in a parameter association, retrieve the | |
7193 | -- related subprogram call. | |
7194 | ||
7195 | if Nkind (Par) = N_Parameter_Association then | |
7196 | Par := Parent (Par); | |
7197 | end if; | |
7198 | ||
ed37f25a | 7199 | if Comes_From_Source (N) then |
d950f051 | 7200 | |
ed37f25a AC |
7201 | -- The following checks are only relevant when SPARK_Mode is on as |
7202 | -- they are not standard Ada legality rules. | |
6c3c671e | 7203 | |
ed37f25a | 7204 | if SPARK_Mode = On then |
c5cec2fe | 7205 | |
ed37f25a AC |
7206 | -- An effectively volatile object subject to enabled properties |
7207 | -- Async_Writers or Effective_Reads must appear in non-interfering | |
7208 | -- context (SPARK RM 7.1.3(12)). | |
c5cec2fe | 7209 | |
ed37f25a AC |
7210 | if Is_Object (E) |
7211 | and then Is_Effectively_Volatile (E) | |
7212 | and then (Async_Writers_Enabled (E) | |
7213 | or else Effective_Reads_Enabled (E)) | |
7214 | and then not Is_OK_Volatile_Context (Par, N) | |
7215 | then | |
7216 | SPARK_Msg_N | |
7217 | ("volatile object cannot appear in this context " | |
7218 | & "(SPARK RM 7.1.3(12))", N); | |
7219 | end if; | |
c5cec2fe | 7220 | |
5904016a AC |
7221 | -- Check for possible elaboration issues with respect to reads of |
7222 | -- variables. The act of renaming the variable is not considered a | |
7223 | -- read as it simply establishes an alias. | |
ed37f25a | 7224 | |
5904016a | 7225 | if Ekind (E) = E_Variable |
d4b56371 | 7226 | and then Dynamic_Elaboration_Checks |
5904016a AC |
7227 | and then Nkind (Par) /= N_Object_Renaming_Declaration |
7228 | then | |
ed37f25a AC |
7229 | Check_Elab_Call (N); |
7230 | end if; | |
fdc54be6 AC |
7231 | |
7232 | -- The variable may eventually become a constituent of a single | |
7233 | -- protected/task type. Record the reference now and verify its | |
7234 | -- legality when analyzing the contract of the variable | |
7235 | -- (SPARK RM 9.3). | |
7236 | ||
7237 | if Ekind (E) = E_Variable then | |
7238 | Record_Possible_Part_Of_Reference (E, N); | |
7239 | end if; | |
ed37f25a | 7240 | end if; |
de4899bb | 7241 | |
ed37f25a | 7242 | -- A Ghost entity must appear in a specific context |
de4899bb | 7243 | |
ed37f25a AC |
7244 | if Is_Ghost_Entity (E) then |
7245 | Check_Ghost_Context (E, N); | |
7246 | end if; | |
de4899bb | 7247 | end if; |
996ae0b0 RK |
7248 | end Resolve_Entity_Name; |
7249 | ||
7250 | ------------------- | |
7251 | -- Resolve_Entry -- | |
7252 | ------------------- | |
7253 | ||
7254 | procedure Resolve_Entry (Entry_Name : Node_Id) is | |
7255 | Loc : constant Source_Ptr := Sloc (Entry_Name); | |
7256 | Nam : Entity_Id; | |
7257 | New_N : Node_Id; | |
7258 | S : Entity_Id; | |
7259 | Tsk : Entity_Id; | |
7260 | E_Name : Node_Id; | |
7261 | Index : Node_Id; | |
7262 | ||
7263 | function Actual_Index_Type (E : Entity_Id) return Entity_Id; | |
7264 | -- If the bounds of the entry family being called depend on task | |
7265 | -- discriminants, build a new index subtype where a discriminant is | |
7266 | -- replaced with the value of the discriminant of the target task. | |
7267 | -- The target task is the prefix of the entry name in the call. | |
7268 | ||
7269 | ----------------------- | |
7270 | -- Actual_Index_Type -- | |
7271 | ----------------------- | |
7272 | ||
7273 | function Actual_Index_Type (E : Entity_Id) return Entity_Id is | |
fbf5a39b AC |
7274 | Typ : constant Entity_Id := Entry_Index_Type (E); |
7275 | Tsk : constant Entity_Id := Scope (E); | |
7276 | Lo : constant Node_Id := Type_Low_Bound (Typ); | |
7277 | Hi : constant Node_Id := Type_High_Bound (Typ); | |
996ae0b0 RK |
7278 | New_T : Entity_Id; |
7279 | ||
7280 | function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id; | |
7281 | -- If the bound is given by a discriminant, replace with a reference | |
d81b4bfe TQ |
7282 | -- to the discriminant of the same name in the target task. If the |
7283 | -- entry name is the target of a requeue statement and the entry is | |
7284 | -- in the current protected object, the bound to be used is the | |
008f6fd3 | 7285 | -- discriminal of the object (see Apply_Range_Checks for details of |
d81b4bfe | 7286 | -- the transformation). |
996ae0b0 RK |
7287 | |
7288 | ----------------------------- | |
7289 | -- Actual_Discriminant_Ref -- | |
7290 | ----------------------------- | |
7291 | ||
7292 | function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is | |
fbf5a39b | 7293 | Typ : constant Entity_Id := Etype (Bound); |
996ae0b0 RK |
7294 | Ref : Node_Id; |
7295 | ||
7296 | begin | |
7297 | Remove_Side_Effects (Bound); | |
7298 | ||
7299 | if not Is_Entity_Name (Bound) | |
7300 | or else Ekind (Entity (Bound)) /= E_Discriminant | |
7301 | then | |
7302 | return Bound; | |
7303 | ||
7304 | elsif Is_Protected_Type (Tsk) | |
7305 | and then In_Open_Scopes (Tsk) | |
7306 | and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement | |
7307 | then | |
6ca9ec9c AC |
7308 | -- Note: here Bound denotes a discriminant of the corresponding |
7309 | -- record type tskV, whose discriminal is a formal of the | |
7310 | -- init-proc tskVIP. What we want is the body discriminal, | |
7311 | -- which is associated to the discriminant of the original | |
7312 | -- concurrent type tsk. | |
7313 | ||
5a153b27 AC |
7314 | return New_Occurrence_Of |
7315 | (Find_Body_Discriminal (Entity (Bound)), Loc); | |
996ae0b0 RK |
7316 | |
7317 | else | |
7318 | Ref := | |
7319 | Make_Selected_Component (Loc, | |
7320 | Prefix => New_Copy_Tree (Prefix (Prefix (Entry_Name))), | |
7321 | Selector_Name => New_Occurrence_Of (Entity (Bound), Loc)); | |
7322 | Analyze (Ref); | |
7323 | Resolve (Ref, Typ); | |
7324 | return Ref; | |
7325 | end if; | |
7326 | end Actual_Discriminant_Ref; | |
7327 | ||
7328 | -- Start of processing for Actual_Index_Type | |
7329 | ||
7330 | begin | |
7331 | if not Has_Discriminants (Tsk) | |
19fb051c | 7332 | or else (not Is_Entity_Name (Lo) and then not Is_Entity_Name (Hi)) |
996ae0b0 RK |
7333 | then |
7334 | return Entry_Index_Type (E); | |
7335 | ||
7336 | else | |
7337 | New_T := Create_Itype (Ekind (Typ), Parent (Entry_Name)); | |
7338 | Set_Etype (New_T, Base_Type (Typ)); | |
7339 | Set_Size_Info (New_T, Typ); | |
7340 | Set_RM_Size (New_T, RM_Size (Typ)); | |
7341 | Set_Scalar_Range (New_T, | |
7342 | Make_Range (Sloc (Entry_Name), | |
7343 | Low_Bound => Actual_Discriminant_Ref (Lo), | |
7344 | High_Bound => Actual_Discriminant_Ref (Hi))); | |
7345 | ||
7346 | return New_T; | |
7347 | end if; | |
7348 | end Actual_Index_Type; | |
7349 | ||
704228bd | 7350 | -- Start of processing for Resolve_Entry |
996ae0b0 RK |
7351 | |
7352 | begin | |
5cc9353d RD |
7353 | -- Find name of entry being called, and resolve prefix of name with its |
7354 | -- own type. The prefix can be overloaded, and the name and signature of | |
7355 | -- the entry must be taken into account. | |
996ae0b0 RK |
7356 | |
7357 | if Nkind (Entry_Name) = N_Indexed_Component then | |
7358 | ||
7359 | -- Case of dealing with entry family within the current tasks | |
7360 | ||
7361 | E_Name := Prefix (Entry_Name); | |
7362 | ||
7363 | else | |
7364 | E_Name := Entry_Name; | |
7365 | end if; | |
7366 | ||
7367 | if Is_Entity_Name (E_Name) then | |
996ae0b0 | 7368 | |
d81b4bfe TQ |
7369 | -- Entry call to an entry (or entry family) in the current task. This |
7370 | -- is legal even though the task will deadlock. Rewrite as call to | |
7371 | -- current task. | |
996ae0b0 | 7372 | |
d81b4bfe TQ |
7373 | -- This can also be a call to an entry in an enclosing task. If this |
7374 | -- is a single task, we have to retrieve its name, because the scope | |
7375 | -- of the entry is the task type, not the object. If the enclosing | |
7376 | -- task is a task type, the identity of the task is given by its own | |
7377 | -- self variable. | |
7378 | ||
7379 | -- Finally this can be a requeue on an entry of the same task or | |
7380 | -- protected object. | |
996ae0b0 RK |
7381 | |
7382 | S := Scope (Entity (E_Name)); | |
7383 | ||
7384 | for J in reverse 0 .. Scope_Stack.Last loop | |
996ae0b0 RK |
7385 | if Is_Task_Type (Scope_Stack.Table (J).Entity) |
7386 | and then not Comes_From_Source (S) | |
7387 | then | |
7388 | -- S is an enclosing task or protected object. The concurrent | |
7389 | -- declaration has been converted into a type declaration, and | |
7390 | -- the object itself has an object declaration that follows | |
7391 | -- the type in the same declarative part. | |
7392 | ||
7393 | Tsk := Next_Entity (S); | |
996ae0b0 RK |
7394 | while Etype (Tsk) /= S loop |
7395 | Next_Entity (Tsk); | |
7396 | end loop; | |
7397 | ||
7398 | S := Tsk; | |
7399 | exit; | |
7400 | ||
7401 | elsif S = Scope_Stack.Table (J).Entity then | |
7402 | ||
7403 | -- Call to current task. Will be transformed into call to Self | |
7404 | ||
7405 | exit; | |
7406 | ||
7407 | end if; | |
7408 | end loop; | |
7409 | ||
7410 | New_N := | |
7411 | Make_Selected_Component (Loc, | |
7412 | Prefix => New_Occurrence_Of (S, Loc), | |
7413 | Selector_Name => | |
7414 | New_Occurrence_Of (Entity (E_Name), Loc)); | |
7415 | Rewrite (E_Name, New_N); | |
7416 | Analyze (E_Name); | |
7417 | ||
7418 | elsif Nkind (Entry_Name) = N_Selected_Component | |
7419 | and then Is_Overloaded (Prefix (Entry_Name)) | |
7420 | then | |
d81b4bfe | 7421 | -- Use the entry name (which must be unique at this point) to find |
5cc9353d | 7422 | -- the prefix that returns the corresponding task/protected type. |
996ae0b0 RK |
7423 | |
7424 | declare | |
fbf5a39b | 7425 | Pref : constant Node_Id := Prefix (Entry_Name); |
c8307596 | 7426 | Ent : constant Entity_Id := Entity (Selector_Name (Entry_Name)); |
996ae0b0 RK |
7427 | I : Interp_Index; |
7428 | It : Interp; | |
996ae0b0 RK |
7429 | |
7430 | begin | |
7431 | Get_First_Interp (Pref, I, It); | |
996ae0b0 | 7432 | while Present (It.Typ) loop |
996ae0b0 RK |
7433 | if Scope (Ent) = It.Typ then |
7434 | Set_Etype (Pref, It.Typ); | |
7435 | exit; | |
7436 | end if; | |
7437 | ||
7438 | Get_Next_Interp (I, It); | |
7439 | end loop; | |
7440 | end; | |
7441 | end if; | |
7442 | ||
7443 | if Nkind (Entry_Name) = N_Selected_Component then | |
fbf5a39b | 7444 | Resolve (Prefix (Entry_Name)); |
996ae0b0 RK |
7445 | |
7446 | else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); | |
7447 | Nam := Entity (Selector_Name (Prefix (Entry_Name))); | |
fbf5a39b | 7448 | Resolve (Prefix (Prefix (Entry_Name))); |
c8307596 | 7449 | Index := First (Expressions (Entry_Name)); |
996ae0b0 RK |
7450 | Resolve (Index, Entry_Index_Type (Nam)); |
7451 | ||
d81b4bfe TQ |
7452 | -- Up to this point the expression could have been the actual in a |
7453 | -- simple entry call, and be given by a named association. | |
996ae0b0 RK |
7454 | |
7455 | if Nkind (Index) = N_Parameter_Association then | |
7456 | Error_Msg_N ("expect expression for entry index", Index); | |
7457 | else | |
7458 | Apply_Range_Check (Index, Actual_Index_Type (Nam)); | |
7459 | end if; | |
7460 | end if; | |
996ae0b0 RK |
7461 | end Resolve_Entry; |
7462 | ||
7463 | ------------------------ | |
7464 | -- Resolve_Entry_Call -- | |
7465 | ------------------------ | |
7466 | ||
7467 | procedure Resolve_Entry_Call (N : Node_Id; Typ : Entity_Id) is | |
7468 | Entry_Name : constant Node_Id := Name (N); | |
7469 | Loc : constant Source_Ptr := Sloc (Entry_Name); | |
7470 | Actuals : List_Id; | |
7471 | First_Named : Node_Id; | |
7472 | Nam : Entity_Id; | |
7473 | Norm_OK : Boolean; | |
7474 | Obj : Node_Id; | |
7475 | Was_Over : Boolean; | |
7476 | ||
7477 | begin | |
d81b4bfe TQ |
7478 | -- We kill all checks here, because it does not seem worth the effort to |
7479 | -- do anything better, an entry call is a big operation. | |
fbf5a39b AC |
7480 | |
7481 | Kill_All_Checks; | |
7482 | ||
996ae0b0 RK |
7483 | -- Processing of the name is similar for entry calls and protected |
7484 | -- operation calls. Once the entity is determined, we can complete | |
7485 | -- the resolution of the actuals. | |
7486 | ||
7487 | -- The selector may be overloaded, in the case of a protected object | |
7488 | -- with overloaded functions. The type of the context is used for | |
7489 | -- resolution. | |
7490 | ||
7491 | if Nkind (Entry_Name) = N_Selected_Component | |
7492 | and then Is_Overloaded (Selector_Name (Entry_Name)) | |
7493 | and then Typ /= Standard_Void_Type | |
7494 | then | |
7495 | declare | |
7496 | I : Interp_Index; | |
7497 | It : Interp; | |
7498 | ||
7499 | begin | |
7500 | Get_First_Interp (Selector_Name (Entry_Name), I, It); | |
996ae0b0 | 7501 | while Present (It.Typ) loop |
996ae0b0 RK |
7502 | if Covers (Typ, It.Typ) then |
7503 | Set_Entity (Selector_Name (Entry_Name), It.Nam); | |
7504 | Set_Etype (Entry_Name, It.Typ); | |
7505 | ||
7506 | Generate_Reference (It.Typ, N, ' '); | |
7507 | end if; | |
7508 | ||
7509 | Get_Next_Interp (I, It); | |
7510 | end loop; | |
7511 | end; | |
7512 | end if; | |
7513 | ||
7514 | Resolve_Entry (Entry_Name); | |
7515 | ||
7516 | if Nkind (Entry_Name) = N_Selected_Component then | |
7517 | ||
a77842bd | 7518 | -- Simple entry call |
996ae0b0 RK |
7519 | |
7520 | Nam := Entity (Selector_Name (Entry_Name)); | |
7521 | Obj := Prefix (Entry_Name); | |
7522 | Was_Over := Is_Overloaded (Selector_Name (Entry_Name)); | |
7523 | ||
7524 | else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); | |
7525 | ||
a77842bd | 7526 | -- Call to member of entry family |
996ae0b0 RK |
7527 | |
7528 | Nam := Entity (Selector_Name (Prefix (Entry_Name))); | |
7529 | Obj := Prefix (Prefix (Entry_Name)); | |
7530 | Was_Over := Is_Overloaded (Selector_Name (Prefix (Entry_Name))); | |
7531 | end if; | |
7532 | ||
5cc9353d RD |
7533 | -- We cannot in general check the maximum depth of protected entry calls |
7534 | -- at compile time. But we can tell that any protected entry call at all | |
7535 | -- violates a specified nesting depth of zero. | |
fbf5a39b AC |
7536 | |
7537 | if Is_Protected_Type (Scope (Nam)) then | |
9f4fd324 | 7538 | Check_Restriction (Max_Entry_Queue_Length, N); |
fbf5a39b AC |
7539 | end if; |
7540 | ||
996ae0b0 | 7541 | -- Use context type to disambiguate a protected function that can be |
5cc9353d RD |
7542 | -- called without actuals and that returns an array type, and where the |
7543 | -- argument list may be an indexing of the returned value. | |
996ae0b0 RK |
7544 | |
7545 | if Ekind (Nam) = E_Function | |
7546 | and then Needs_No_Actuals (Nam) | |
7547 | and then Present (Parameter_Associations (N)) | |
7548 | and then | |
7549 | ((Is_Array_Type (Etype (Nam)) | |
7550 | and then Covers (Typ, Component_Type (Etype (Nam)))) | |
7551 | ||
7552 | or else (Is_Access_Type (Etype (Nam)) | |
7553 | and then Is_Array_Type (Designated_Type (Etype (Nam))) | |
19fb051c AC |
7554 | and then |
7555 | Covers | |
7556 | (Typ, | |
7557 | Component_Type (Designated_Type (Etype (Nam)))))) | |
996ae0b0 RK |
7558 | then |
7559 | declare | |
7560 | Index_Node : Node_Id; | |
7561 | ||
7562 | begin | |
7563 | Index_Node := | |
7564 | Make_Indexed_Component (Loc, | |
7565 | Prefix => | |
19fb051c | 7566 | Make_Function_Call (Loc, Name => Relocate_Node (Entry_Name)), |
996ae0b0 RK |
7567 | Expressions => Parameter_Associations (N)); |
7568 | ||
5cc9353d RD |
7569 | -- Since we are correcting a node classification error made by the |
7570 | -- parser, we call Replace rather than Rewrite. | |
996ae0b0 RK |
7571 | |
7572 | Replace (N, Index_Node); | |
7573 | Set_Etype (Prefix (N), Etype (Nam)); | |
7574 | Set_Etype (N, Typ); | |
7575 | Resolve_Indexed_Component (N, Typ); | |
7576 | return; | |
7577 | end; | |
7578 | end if; | |
7579 | ||
b7f17b20 | 7580 | if Ekind_In (Nam, E_Entry, E_Entry_Family) |
8a0183fd HK |
7581 | and then Present (Contract_Wrapper (Nam)) |
7582 | and then Current_Scope /= Contract_Wrapper (Nam) | |
b7f17b20 | 7583 | then |
87fd6836 AC |
7584 | |
7585 | -- Note the entity being called before rewriting the call, so that | |
7586 | -- it appears used at this point. | |
7587 | ||
7588 | Generate_Reference (Nam, Entry_Name, 'r'); | |
7589 | ||
468ee96a | 7590 | -- Rewrite as call to the precondition wrapper, adding the task |
5cc9353d RD |
7591 | -- object to the list of actuals. If the call is to a member of an |
7592 | -- entry family, include the index as well. | |
b7f17b20 ES |
7593 | |
7594 | declare | |
468ee96a | 7595 | New_Call : Node_Id; |
b7f17b20 | 7596 | New_Actuals : List_Id; |
19fb051c | 7597 | |
b7f17b20 ES |
7598 | begin |
7599 | New_Actuals := New_List (Obj); | |
3fd9f17c | 7600 | |
9fe696a3 | 7601 | if Nkind (Entry_Name) = N_Indexed_Component then |
3fd9f17c AC |
7602 | Append_To (New_Actuals, |
7603 | New_Copy_Tree (First (Expressions (Entry_Name)))); | |
7604 | end if; | |
7605 | ||
b7f17b20 | 7606 | Append_List (Parameter_Associations (N), New_Actuals); |
468ee96a AC |
7607 | New_Call := |
7608 | Make_Procedure_Call_Statement (Loc, | |
7609 | Name => | |
8a0183fd | 7610 | New_Occurrence_Of (Contract_Wrapper (Nam), Loc), |
468ee96a | 7611 | Parameter_Associations => New_Actuals); |
b7f17b20 | 7612 | Rewrite (N, New_Call); |
ecda544d ES |
7613 | |
7614 | -- Preanalyze and resolve new call. Current procedure is called | |
7615 | -- from Resolve_Call, after which expansion will take place. | |
7616 | ||
7617 | Preanalyze_And_Resolve (N); | |
b7f17b20 ES |
7618 | return; |
7619 | end; | |
7620 | end if; | |
7621 | ||
996ae0b0 | 7622 | -- The operation name may have been overloaded. Order the actuals |
5cc9353d RD |
7623 | -- according to the formals of the resolved entity, and set the return |
7624 | -- type to that of the operation. | |
996ae0b0 RK |
7625 | |
7626 | if Was_Over then | |
7627 | Normalize_Actuals (N, Nam, False, Norm_OK); | |
7628 | pragma Assert (Norm_OK); | |
fbf5a39b | 7629 | Set_Etype (N, Etype (Nam)); |
9d4f9832 AC |
7630 | |
7631 | -- Reset the Is_Overloaded flag, since resolution is now completed | |
7632 | ||
be035558 AC |
7633 | -- Simple entry call |
7634 | ||
9d4f9832 | 7635 | if Nkind (Entry_Name) = N_Selected_Component then |
9d4f9832 AC |
7636 | Set_Is_Overloaded (Selector_Name (Entry_Name), False); |
7637 | ||
be035558 AC |
7638 | -- Call to a member of an entry family |
7639 | ||
9d4f9832 | 7640 | else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component); |
9d4f9832 | 7641 | Set_Is_Overloaded (Selector_Name (Prefix (Entry_Name)), False); |
9d4f9832 | 7642 | end if; |
996ae0b0 RK |
7643 | end if; |
7644 | ||
7645 | Resolve_Actuals (N, Nam); | |
c92e8586 | 7646 | Check_Internal_Protected_Use (N, Nam); |
ae6ede77 AC |
7647 | |
7648 | -- Create a call reference to the entry | |
7649 | ||
7650 | Generate_Reference (Nam, Entry_Name, 's'); | |
996ae0b0 | 7651 | |
8a95f4e8 | 7652 | if Ekind_In (Nam, E_Entry, E_Entry_Family) then |
996ae0b0 RK |
7653 | Check_Potentially_Blocking_Operation (N); |
7654 | end if; | |
7655 | ||
7656 | -- Verify that a procedure call cannot masquerade as an entry | |
7657 | -- call where an entry call is expected. | |
7658 | ||
7659 | if Ekind (Nam) = E_Procedure then | |
996ae0b0 RK |
7660 | if Nkind (Parent (N)) = N_Entry_Call_Alternative |
7661 | and then N = Entry_Call_Statement (Parent (N)) | |
7662 | then | |
7663 | Error_Msg_N ("entry call required in select statement", N); | |
7664 | ||
7665 | elsif Nkind (Parent (N)) = N_Triggering_Alternative | |
7666 | and then N = Triggering_Statement (Parent (N)) | |
7667 | then | |
7668 | Error_Msg_N ("triggering statement cannot be procedure call", N); | |
7669 | ||
7670 | elsif Ekind (Scope (Nam)) = E_Task_Type | |
7671 | and then not In_Open_Scopes (Scope (Nam)) | |
7672 | then | |
758c442c | 7673 | Error_Msg_N ("task has no entry with this name", Entry_Name); |
996ae0b0 RK |
7674 | end if; |
7675 | end if; | |
7676 | ||
d81b4bfe TQ |
7677 | -- After resolution, entry calls and protected procedure calls are |
7678 | -- changed into entry calls, for expansion. The structure of the node | |
7679 | -- does not change, so it can safely be done in place. Protected | |
7680 | -- function calls must keep their structure because they are | |
7681 | -- subexpressions. | |
996ae0b0 RK |
7682 | |
7683 | if Ekind (Nam) /= E_Function then | |
7684 | ||
7685 | -- A protected operation that is not a function may modify the | |
d81b4bfe TQ |
7686 | -- corresponding object, and cannot apply to a constant. If this |
7687 | -- is an internal call, the prefix is the type itself. | |
996ae0b0 RK |
7688 | |
7689 | if Is_Protected_Type (Scope (Nam)) | |
7690 | and then not Is_Variable (Obj) | |
7691 | and then (not Is_Entity_Name (Obj) | |
7692 | or else not Is_Type (Entity (Obj))) | |
7693 | then | |
7694 | Error_Msg_N | |
7695 | ("prefix of protected procedure or entry call must be variable", | |
7696 | Entry_Name); | |
7697 | end if; | |
7698 | ||
7699 | Actuals := Parameter_Associations (N); | |
7700 | First_Named := First_Named_Actual (N); | |
7701 | ||
7702 | Rewrite (N, | |
7703 | Make_Entry_Call_Statement (Loc, | |
7704 | Name => Entry_Name, | |
7705 | Parameter_Associations => Actuals)); | |
7706 | ||
7707 | Set_First_Named_Actual (N, First_Named); | |
7708 | Set_Analyzed (N, True); | |
7709 | ||
7710 | -- Protected functions can return on the secondary stack, in which | |
1420b484 | 7711 | -- case we must trigger the transient scope mechanism. |
996ae0b0 | 7712 | |
4460a9bc | 7713 | elsif Expander_Active |
996ae0b0 RK |
7714 | and then Requires_Transient_Scope (Etype (Nam)) |
7715 | then | |
0669bebe | 7716 | Establish_Transient_Scope (N, Sec_Stack => True); |
996ae0b0 | 7717 | end if; |
996ae0b0 RK |
7718 | end Resolve_Entry_Call; |
7719 | ||
7720 | ------------------------- | |
7721 | -- Resolve_Equality_Op -- | |
7722 | ------------------------- | |
7723 | ||
d81b4bfe TQ |
7724 | -- Both arguments must have the same type, and the boolean context does |
7725 | -- not participate in the resolution. The first pass verifies that the | |
7726 | -- interpretation is not ambiguous, and the type of the left argument is | |
7727 | -- correctly set, or is Any_Type in case of ambiguity. If both arguments | |
7728 | -- are strings or aggregates, allocators, or Null, they are ambiguous even | |
7729 | -- though they carry a single (universal) type. Diagnose this case here. | |
996ae0b0 RK |
7730 | |
7731 | procedure Resolve_Equality_Op (N : Node_Id; Typ : Entity_Id) is | |
7732 | L : constant Node_Id := Left_Opnd (N); | |
7733 | R : constant Node_Id := Right_Opnd (N); | |
7734 | T : Entity_Id := Find_Unique_Type (L, R); | |
7735 | ||
9b16cb57 RD |
7736 | procedure Check_If_Expression (Cond : Node_Id); |
7737 | -- The resolution rule for if expressions requires that each such must | |
7738 | -- have a unique type. This means that if several dependent expressions | |
7739 | -- are of a non-null anonymous access type, and the context does not | |
7740 | -- impose an expected type (as can be the case in an equality operation) | |
7741 | -- the expression must be rejected. | |
a8930b80 | 7742 | |
327b1ba4 AC |
7743 | procedure Explain_Redundancy (N : Node_Id); |
7744 | -- Attempt to explain the nature of a redundant comparison with True. If | |
7745 | -- the expression N is too complex, this routine issues a general error | |
7746 | -- message. | |
7747 | ||
996ae0b0 | 7748 | function Find_Unique_Access_Type return Entity_Id; |
289a994b AC |
7749 | -- In the case of allocators and access attributes, the context must |
7750 | -- provide an indication of the specific access type to be used. If | |
7751 | -- one operand is of such a "generic" access type, check whether there | |
7752 | -- is a specific visible access type that has the same designated type. | |
7753 | -- This is semantically dubious, and of no interest to any real code, | |
7754 | -- but c48008a makes it all worthwhile. | |
996ae0b0 | 7755 | |
9b16cb57 RD |
7756 | ------------------------- |
7757 | -- Check_If_Expression -- | |
7758 | ------------------------- | |
a8930b80 | 7759 | |
9b16cb57 | 7760 | procedure Check_If_Expression (Cond : Node_Id) is |
a8930b80 AC |
7761 | Then_Expr : Node_Id; |
7762 | Else_Expr : Node_Id; | |
7763 | ||
7764 | begin | |
9b16cb57 | 7765 | if Nkind (Cond) = N_If_Expression then |
a8930b80 AC |
7766 | Then_Expr := Next (First (Expressions (Cond))); |
7767 | Else_Expr := Next (Then_Expr); | |
7768 | ||
7769 | if Nkind (Then_Expr) /= N_Null | |
7770 | and then Nkind (Else_Expr) /= N_Null | |
7771 | then | |
9b16cb57 | 7772 | Error_Msg_N ("cannot determine type of if expression", Cond); |
a8930b80 AC |
7773 | end if; |
7774 | end if; | |
9b16cb57 | 7775 | end Check_If_Expression; |
a8930b80 | 7776 | |
327b1ba4 AC |
7777 | ------------------------ |
7778 | -- Explain_Redundancy -- | |
7779 | ------------------------ | |
7780 | ||
7781 | procedure Explain_Redundancy (N : Node_Id) is | |
7782 | Error : Name_Id; | |
7783 | Val : Node_Id; | |
7784 | Val_Id : Entity_Id; | |
7785 | ||
7786 | begin | |
7787 | Val := N; | |
7788 | ||
7789 | -- Strip the operand down to an entity | |
7790 | ||
7791 | loop | |
7792 | if Nkind (Val) = N_Selected_Component then | |
7793 | Val := Selector_Name (Val); | |
7794 | else | |
7795 | exit; | |
7796 | end if; | |
7797 | end loop; | |
7798 | ||
7799 | -- The construct denotes an entity | |
7800 | ||
7801 | if Is_Entity_Name (Val) and then Present (Entity (Val)) then | |
7802 | Val_Id := Entity (Val); | |
7803 | ||
7804 | -- Do not generate an error message when the comparison is done | |
7805 | -- against the enumeration literal Standard.True. | |
7806 | ||
7807 | if Ekind (Val_Id) /= E_Enumeration_Literal then | |
7808 | ||
7809 | -- Build a customized error message | |
7810 | ||
7811 | Name_Len := 0; | |
7812 | Add_Str_To_Name_Buffer ("?r?"); | |
7813 | ||
7814 | if Ekind (Val_Id) = E_Component then | |
7815 | Add_Str_To_Name_Buffer ("component "); | |
7816 | ||
7817 | elsif Ekind (Val_Id) = E_Constant then | |
7818 | Add_Str_To_Name_Buffer ("constant "); | |
7819 | ||
7820 | elsif Ekind (Val_Id) = E_Discriminant then | |
7821 | Add_Str_To_Name_Buffer ("discriminant "); | |
7822 | ||
7823 | elsif Is_Formal (Val_Id) then | |
7824 | Add_Str_To_Name_Buffer ("parameter "); | |
7825 | ||
7826 | elsif Ekind (Val_Id) = E_Variable then | |
7827 | Add_Str_To_Name_Buffer ("variable "); | |
7828 | end if; | |
7829 | ||
7830 | Add_Str_To_Name_Buffer ("& is always True!"); | |
7831 | Error := Name_Find; | |
7832 | ||
7833 | Error_Msg_NE (Get_Name_String (Error), Val, Val_Id); | |
7834 | end if; | |
7835 | ||
7836 | -- The construct is too complex to disect, issue a general message | |
7837 | ||
7838 | else | |
7839 | Error_Msg_N ("?r?expression is always True!", Val); | |
7840 | end if; | |
7841 | end Explain_Redundancy; | |
7842 | ||
996ae0b0 RK |
7843 | ----------------------------- |
7844 | -- Find_Unique_Access_Type -- | |
7845 | ----------------------------- | |
7846 | ||
7847 | function Find_Unique_Access_Type return Entity_Id is | |
7848 | Acc : Entity_Id; | |
7849 | E : Entity_Id; | |
1420b484 | 7850 | S : Entity_Id; |
996ae0b0 RK |
7851 | |
7852 | begin | |
59fad002 AC |
7853 | if Ekind_In (Etype (R), E_Allocator_Type, |
7854 | E_Access_Attribute_Type) | |
289a994b | 7855 | then |
996ae0b0 | 7856 | Acc := Designated_Type (Etype (R)); |
289a994b | 7857 | |
59fad002 AC |
7858 | elsif Ekind_In (Etype (L), E_Allocator_Type, |
7859 | E_Access_Attribute_Type) | |
289a994b | 7860 | then |
996ae0b0 | 7861 | Acc := Designated_Type (Etype (L)); |
996ae0b0 RK |
7862 | else |
7863 | return Empty; | |
7864 | end if; | |
7865 | ||
1420b484 | 7866 | S := Current_Scope; |
996ae0b0 RK |
7867 | while S /= Standard_Standard loop |
7868 | E := First_Entity (S); | |
996ae0b0 | 7869 | while Present (E) loop |
996ae0b0 RK |
7870 | if Is_Type (E) |
7871 | and then Is_Access_Type (E) | |
7872 | and then Ekind (E) /= E_Allocator_Type | |
7873 | and then Designated_Type (E) = Base_Type (Acc) | |
7874 | then | |
7875 | return E; | |
7876 | end if; | |
7877 | ||
7878 | Next_Entity (E); | |
7879 | end loop; | |
7880 | ||
7881 | S := Scope (S); | |
7882 | end loop; | |
7883 | ||
7884 | return Empty; | |
7885 | end Find_Unique_Access_Type; | |
7886 | ||
7887 | -- Start of processing for Resolve_Equality_Op | |
7888 | ||
7889 | begin | |
7890 | Set_Etype (N, Base_Type (Typ)); | |
7891 | Generate_Reference (T, N, ' '); | |
7892 | ||
7893 | if T = Any_Fixed then | |
7894 | T := Unique_Fixed_Point_Type (L); | |
7895 | end if; | |
7896 | ||
7897 | if T /= Any_Type then | |
19fb051c AC |
7898 | if T = Any_String or else |
7899 | T = Any_Composite or else | |
7900 | T = Any_Character | |
996ae0b0 | 7901 | then |
996ae0b0 RK |
7902 | if T = Any_Character then |
7903 | Ambiguous_Character (L); | |
7904 | else | |
7905 | Error_Msg_N ("ambiguous operands for equality", N); | |
7906 | end if; | |
7907 | ||
7908 | Set_Etype (N, Any_Type); | |
7909 | return; | |
7910 | ||
7911 | elsif T = Any_Access | |
964f13da | 7912 | or else Ekind_In (T, E_Allocator_Type, E_Access_Attribute_Type) |
996ae0b0 RK |
7913 | then |
7914 | T := Find_Unique_Access_Type; | |
7915 | ||
7916 | if No (T) then | |
7917 | Error_Msg_N ("ambiguous operands for equality", N); | |
7918 | Set_Etype (N, Any_Type); | |
7919 | return; | |
7920 | end if; | |
a8930b80 | 7921 | |
9b16cb57 RD |
7922 | -- If expressions must have a single type, and if the context does |
7923 | -- not impose one the dependent expressions cannot be anonymous | |
7924 | -- access types. | |
7925 | ||
7926 | -- Why no similar processing for case expressions??? | |
a8930b80 AC |
7927 | |
7928 | elsif Ada_Version >= Ada_2012 | |
ae2aa109 AC |
7929 | and then Ekind_In (Etype (L), E_Anonymous_Access_Type, |
7930 | E_Anonymous_Access_Subprogram_Type) | |
7931 | and then Ekind_In (Etype (R), E_Anonymous_Access_Type, | |
7932 | E_Anonymous_Access_Subprogram_Type) | |
a8930b80 | 7933 | then |
9b16cb57 RD |
7934 | Check_If_Expression (L); |
7935 | Check_If_Expression (R); | |
996ae0b0 RK |
7936 | end if; |
7937 | ||
996ae0b0 RK |
7938 | Resolve (L, T); |
7939 | Resolve (R, T); | |
fbf5a39b | 7940 | |
2ba431e5 YM |
7941 | -- In SPARK, equality operators = and /= for array types other than |
7942 | -- String are only defined when, for each index position, the | |
7943 | -- operands have equal static bounds. | |
b0186f71 | 7944 | |
975c6896 | 7945 | if Is_Array_Type (T) then |
9b16cb57 | 7946 | |
7b98672f YM |
7947 | -- Protect call to Matching_Static_Array_Bounds to avoid costly |
7948 | -- operation if not needed. | |
7949 | ||
6480338a | 7950 | if Restriction_Check_Required (SPARK_05) |
7b98672f | 7951 | and then Base_Type (T) /= Standard_String |
975c6896 YM |
7952 | and then Base_Type (Etype (L)) = Base_Type (Etype (R)) |
7953 | and then Etype (L) /= Any_Composite -- or else L in error | |
7954 | and then Etype (R) /= Any_Composite -- or else R in error | |
7955 | and then not Matching_Static_Array_Bounds (Etype (L), Etype (R)) | |
7956 | then | |
ce5ba43a | 7957 | Check_SPARK_05_Restriction |
975c6896 YM |
7958 | ("array types should have matching static bounds", N); |
7959 | end if; | |
b0186f71 AC |
7960 | end if; |
7961 | ||
0669bebe GB |
7962 | -- If the unique type is a class-wide type then it will be expanded |
7963 | -- into a dispatching call to the predefined primitive. Therefore we | |
7964 | -- check here for potential violation of such restriction. | |
7965 | ||
7966 | if Is_Class_Wide_Type (T) then | |
7967 | Check_Restriction (No_Dispatching_Calls, N); | |
7968 | end if; | |
7969 | ||
fbf5a39b AC |
7970 | if Warn_On_Redundant_Constructs |
7971 | and then Comes_From_Source (N) | |
327b1ba4 | 7972 | and then Comes_From_Source (R) |
fbf5a39b AC |
7973 | and then Is_Entity_Name (R) |
7974 | and then Entity (R) = Standard_True | |
fbf5a39b | 7975 | then |
305caf42 | 7976 | Error_Msg_N -- CODEFIX |
327b1ba4 AC |
7977 | ("?r?comparison with True is redundant!", N); |
7978 | Explain_Redundancy (Original_Node (R)); | |
fbf5a39b AC |
7979 | end if; |
7980 | ||
996ae0b0 RK |
7981 | Check_Unset_Reference (L); |
7982 | Check_Unset_Reference (R); | |
fbf5a39b | 7983 | Generate_Operator_Reference (N, T); |
fad0600d | 7984 | Check_Low_Bound_Tested (N); |
996ae0b0 RK |
7985 | |
7986 | -- If this is an inequality, it may be the implicit inequality | |
7987 | -- created for a user-defined operation, in which case the corres- | |
7988 | -- ponding equality operation is not intrinsic, and the operation | |
7989 | -- cannot be constant-folded. Else fold. | |
7990 | ||
7991 | if Nkind (N) = N_Op_Eq | |
7992 | or else Comes_From_Source (Entity (N)) | |
7993 | or else Ekind (Entity (N)) = E_Operator | |
7994 | or else Is_Intrinsic_Subprogram | |
19fb051c | 7995 | (Corresponding_Equality (Entity (N))) |
996ae0b0 | 7996 | then |
dec6faf1 | 7997 | Analyze_Dimension (N); |
996ae0b0 | 7998 | Eval_Relational_Op (N); |
45fc7ddb | 7999 | |
996ae0b0 | 8000 | elsif Nkind (N) = N_Op_Ne |
0669bebe | 8001 | and then Is_Abstract_Subprogram (Entity (N)) |
996ae0b0 RK |
8002 | then |
8003 | Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N)); | |
8004 | end if; | |
758c442c | 8005 | |
d81b4bfe TQ |
8006 | -- Ada 2005: If one operand is an anonymous access type, convert the |
8007 | -- other operand to it, to ensure that the underlying types match in | |
8008 | -- the back-end. Same for access_to_subprogram, and the conversion | |
8009 | -- verifies that the types are subtype conformant. | |
b7d1f17f | 8010 | |
d81b4bfe TQ |
8011 | -- We apply the same conversion in the case one of the operands is a |
8012 | -- private subtype of the type of the other. | |
c8ef728f | 8013 | |
b7d1f17f HK |
8014 | -- Why the Expander_Active test here ??? |
8015 | ||
4460a9bc | 8016 | if Expander_Active |
b7d1f17f | 8017 | and then |
964f13da RD |
8018 | (Ekind_In (T, E_Anonymous_Access_Type, |
8019 | E_Anonymous_Access_Subprogram_Type) | |
b7d1f17f | 8020 | or else Is_Private_Type (T)) |
c8ef728f ES |
8021 | then |
8022 | if Etype (L) /= T then | |
8023 | Rewrite (L, | |
8024 | Make_Unchecked_Type_Conversion (Sloc (L), | |
8025 | Subtype_Mark => New_Occurrence_Of (T, Sloc (L)), | |
8026 | Expression => Relocate_Node (L))); | |
8027 | Analyze_And_Resolve (L, T); | |
8028 | end if; | |
8029 | ||
8030 | if (Etype (R)) /= T then | |
8031 | Rewrite (R, | |
8032 | Make_Unchecked_Type_Conversion (Sloc (R), | |
8033 | Subtype_Mark => New_Occurrence_Of (Etype (L), Sloc (R)), | |
8034 | Expression => Relocate_Node (R))); | |
8035 | Analyze_And_Resolve (R, T); | |
8036 | end if; | |
8037 | end if; | |
996ae0b0 RK |
8038 | end if; |
8039 | end Resolve_Equality_Op; | |
8040 | ||
8041 | ---------------------------------- | |
8042 | -- Resolve_Explicit_Dereference -- | |
8043 | ---------------------------------- | |
8044 | ||
8045 | procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id) is | |
bc5f3720 RD |
8046 | Loc : constant Source_Ptr := Sloc (N); |
8047 | New_N : Node_Id; | |
8048 | P : constant Node_Id := Prefix (N); | |
50878404 AC |
8049 | |
8050 | P_Typ : Entity_Id; | |
8051 | -- The candidate prefix type, if overloaded | |
8052 | ||
bc5f3720 RD |
8053 | I : Interp_Index; |
8054 | It : Interp; | |
996ae0b0 RK |
8055 | |
8056 | begin | |
c8ef728f | 8057 | Check_Fully_Declared_Prefix (Typ, P); |
50878404 | 8058 | P_Typ := Empty; |
996ae0b0 | 8059 | |
3e586e10 AC |
8060 | -- A useful optimization: check whether the dereference denotes an |
8061 | -- element of a container, and if so rewrite it as a call to the | |
8062 | -- corresponding Element function. | |
ebb6b0bd | 8063 | |
3e586e10 AC |
8064 | -- Disabled for now, on advice of ARG. A more restricted form of the |
8065 | -- predicate might be acceptable ??? | |
8066 | ||
8067 | -- if Is_Container_Element (N) then | |
8068 | -- return; | |
8069 | -- end if; | |
8070 | ||
996ae0b0 RK |
8071 | if Is_Overloaded (P) then |
8072 | ||
758c442c | 8073 | -- Use the context type to select the prefix that has the correct |
d7a44b14 AC |
8074 | -- designated type. Keep the first match, which will be the inner- |
8075 | -- most. | |
996ae0b0 RK |
8076 | |
8077 | Get_First_Interp (P, I, It); | |
50878404 | 8078 | |
996ae0b0 | 8079 | while Present (It.Typ) loop |
50878404 AC |
8080 | if Is_Access_Type (It.Typ) |
8081 | and then Covers (Typ, Designated_Type (It.Typ)) | |
8082 | then | |
d7a44b14 AC |
8083 | if No (P_Typ) then |
8084 | P_Typ := It.Typ; | |
8085 | end if; | |
50878404 AC |
8086 | |
8087 | -- Remove access types that do not match, but preserve access | |
8088 | -- to subprogram interpretations, in case a further dereference | |
8089 | -- is needed (see below). | |
8090 | ||
8091 | elsif Ekind (It.Typ) /= E_Access_Subprogram_Type then | |
8092 | Remove_Interp (I); | |
8093 | end if; | |
8094 | ||
996ae0b0 RK |
8095 | Get_Next_Interp (I, It); |
8096 | end loop; | |
8097 | ||
50878404 AC |
8098 | if Present (P_Typ) then |
8099 | Resolve (P, P_Typ); | |
8100 | Set_Etype (N, Designated_Type (P_Typ)); | |
8101 | ||
bc5f3720 | 8102 | else |
758c442c GD |
8103 | -- If no interpretation covers the designated type of the prefix, |
8104 | -- this is the pathological case where not all implementations of | |
8105 | -- the prefix allow the interpretation of the node as a call. Now | |
8106 | -- that the expected type is known, Remove other interpretations | |
8107 | -- from prefix, rewrite it as a call, and resolve again, so that | |
8108 | -- the proper call node is generated. | |
bc5f3720 RD |
8109 | |
8110 | Get_First_Interp (P, I, It); | |
8111 | while Present (It.Typ) loop | |
8112 | if Ekind (It.Typ) /= E_Access_Subprogram_Type then | |
8113 | Remove_Interp (I); | |
8114 | end if; | |
8115 | ||
8116 | Get_Next_Interp (I, It); | |
8117 | end loop; | |
8118 | ||
8119 | New_N := | |
8120 | Make_Function_Call (Loc, | |
8121 | Name => | |
8122 | Make_Explicit_Dereference (Loc, | |
8123 | Prefix => P), | |
8124 | Parameter_Associations => New_List); | |
8125 | ||
8126 | Save_Interps (N, New_N); | |
8127 | Rewrite (N, New_N); | |
8128 | Analyze_And_Resolve (N, Typ); | |
8129 | return; | |
8130 | end if; | |
8131 | ||
29ba9f52 | 8132 | -- If not overloaded, resolve P with its own type |
50878404 | 8133 | |
29ba9f52 | 8134 | else |
fbf5a39b | 8135 | Resolve (P); |
996ae0b0 RK |
8136 | end if; |
8137 | ||
72d5c70b AC |
8138 | -- If the prefix might be null, add an access check |
8139 | ||
8140 | if Is_Access_Type (Etype (P)) | |
8141 | and then not Can_Never_Be_Null (Etype (P)) | |
8142 | then | |
996ae0b0 RK |
8143 | Apply_Access_Check (N); |
8144 | end if; | |
8145 | ||
758c442c GD |
8146 | -- If the designated type is a packed unconstrained array type, and the |
8147 | -- explicit dereference is not in the context of an attribute reference, | |
8148 | -- then we must compute and set the actual subtype, since it is needed | |
8149 | -- by Gigi. The reason we exclude the attribute case is that this is | |
8150 | -- handled fine by Gigi, and in fact we use such attributes to build the | |
8151 | -- actual subtype. We also exclude generated code (which builds actual | |
8152 | -- subtypes directly if they are needed). | |
996ae0b0 RK |
8153 | |
8154 | if Is_Array_Type (Etype (N)) | |
8155 | and then Is_Packed (Etype (N)) | |
8156 | and then not Is_Constrained (Etype (N)) | |
8157 | and then Nkind (Parent (N)) /= N_Attribute_Reference | |
8158 | and then Comes_From_Source (N) | |
8159 | then | |
8160 | Set_Etype (N, Get_Actual_Subtype (N)); | |
8161 | end if; | |
8162 | ||
d29f68cf | 8163 | Analyze_Dimension (N); |
3373589b | 8164 | |
09494c32 AC |
8165 | -- Note: No Eval processing is required for an explicit dereference, |
8166 | -- because such a name can never be static. | |
996ae0b0 RK |
8167 | |
8168 | end Resolve_Explicit_Dereference; | |
8169 | ||
955871d3 AC |
8170 | ------------------------------------- |
8171 | -- Resolve_Expression_With_Actions -- | |
8172 | ------------------------------------- | |
8173 | ||
8174 | procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id) is | |
8175 | begin | |
8176 | Set_Etype (N, Typ); | |
064f4527 TQ |
8177 | |
8178 | -- If N has no actions, and its expression has been constant folded, | |
8179 | -- then rewrite N as just its expression. Note, we can't do this in | |
8180 | -- the general case of Is_Empty_List (Actions (N)) as this would cause | |
8181 | -- Expression (N) to be expanded again. | |
8182 | ||
8183 | if Is_Empty_List (Actions (N)) | |
8184 | and then Compile_Time_Known_Value (Expression (N)) | |
8185 | then | |
8186 | Rewrite (N, Expression (N)); | |
8187 | end if; | |
955871d3 AC |
8188 | end Resolve_Expression_With_Actions; |
8189 | ||
5f50020a ES |
8190 | ---------------------------------- |
8191 | -- Resolve_Generalized_Indexing -- | |
8192 | ---------------------------------- | |
8193 | ||
8194 | procedure Resolve_Generalized_Indexing (N : Node_Id; Typ : Entity_Id) is | |
8195 | Indexing : constant Node_Id := Generalized_Indexing (N); | |
8196 | Call : Node_Id; | |
0566484a | 8197 | Indexes : List_Id; |
5f50020a ES |
8198 | Pref : Node_Id; |
8199 | ||
8200 | begin | |
0566484a | 8201 | -- In ASIS mode, propagate the information about the indexes back to |
5f50020a ES |
8202 | -- to the original indexing node. The generalized indexing is either |
8203 | -- a function call, or a dereference of one. The actuals include the | |
8204 | -- prefix of the original node, which is the container expression. | |
8205 | ||
8206 | if ASIS_Mode then | |
8207 | Resolve (Indexing, Typ); | |
8208 | Set_Etype (N, Etype (Indexing)); | |
8209 | Set_Is_Overloaded (N, False); | |
32bba3c9 | 8210 | |
5f50020a | 8211 | Call := Indexing; |
32bba3c9 | 8212 | while Nkind_In (Call, N_Explicit_Dereference, N_Selected_Component) |
5f50020a ES |
8213 | loop |
8214 | Call := Prefix (Call); | |
8215 | end loop; | |
8216 | ||
8217 | if Nkind (Call) = N_Function_Call then | |
66340e0e | 8218 | Indexes := New_Copy_List (Parameter_Associations (Call)); |
0566484a AC |
8219 | Pref := Remove_Head (Indexes); |
8220 | Set_Expressions (N, Indexes); | |
4039e173 AC |
8221 | |
8222 | -- If expression is to be reanalyzed, reset Generalized_Indexing | |
8223 | -- to recreate call node, as is the case when the expression is | |
8224 | -- part of an expression function. | |
8225 | ||
8226 | if In_Spec_Expression then | |
8227 | Set_Generalized_Indexing (N, Empty); | |
8228 | end if; | |
8229 | ||
5f50020a ES |
8230 | Set_Prefix (N, Pref); |
8231 | end if; | |
8232 | ||
8233 | else | |
8234 | Rewrite (N, Indexing); | |
8235 | Resolve (N, Typ); | |
8236 | end if; | |
8237 | end Resolve_Generalized_Indexing; | |
8238 | ||
9b16cb57 RD |
8239 | --------------------------- |
8240 | -- Resolve_If_Expression -- | |
8241 | --------------------------- | |
8242 | ||
8243 | procedure Resolve_If_Expression (N : Node_Id; Typ : Entity_Id) is | |
8244 | Condition : constant Node_Id := First (Expressions (N)); | |
8245 | Then_Expr : constant Node_Id := Next (Condition); | |
8246 | Else_Expr : Node_Id := Next (Then_Expr); | |
8247 | Else_Typ : Entity_Id; | |
8248 | Then_Typ : Entity_Id; | |
8249 | ||
8250 | begin | |
8251 | Resolve (Condition, Any_Boolean); | |
8252 | Resolve (Then_Expr, Typ); | |
8253 | Then_Typ := Etype (Then_Expr); | |
8254 | ||
30ebb114 AC |
8255 | -- When the "then" expression is of a scalar subtype different from the |
8256 | -- result subtype, then insert a conversion to ensure the generation of | |
8257 | -- a constraint check. The same is done for the else part below, again | |
8258 | -- comparing subtypes rather than base types. | |
9b16cb57 RD |
8259 | |
8260 | if Is_Scalar_Type (Then_Typ) | |
30ebb114 | 8261 | and then Then_Typ /= Typ |
9b16cb57 RD |
8262 | then |
8263 | Rewrite (Then_Expr, Convert_To (Typ, Then_Expr)); | |
8264 | Analyze_And_Resolve (Then_Expr, Typ); | |
8265 | end if; | |
8266 | ||
8267 | -- If ELSE expression present, just resolve using the determined type | |
93e90bf4 | 8268 | -- If type is universal, resolve to any member of the class. |
9b16cb57 RD |
8269 | |
8270 | if Present (Else_Expr) then | |
93e90bf4 AC |
8271 | if Typ = Universal_Integer then |
8272 | Resolve (Else_Expr, Any_Integer); | |
8273 | ||
8274 | elsif Typ = Universal_Real then | |
8275 | Resolve (Else_Expr, Any_Real); | |
8276 | ||
8277 | else | |
8278 | Resolve (Else_Expr, Typ); | |
8279 | end if; | |
8280 | ||
9b16cb57 RD |
8281 | Else_Typ := Etype (Else_Expr); |
8282 | ||
b6dd03dd | 8283 | if Is_Scalar_Type (Else_Typ) and then Else_Typ /= Typ then |
9b16cb57 RD |
8284 | Rewrite (Else_Expr, Convert_To (Typ, Else_Expr)); |
8285 | Analyze_And_Resolve (Else_Expr, Typ); | |
b6dd03dd ES |
8286 | |
8287 | -- Apply RM 4.5.7 (17/3): whether the expression is statically or | |
8288 | -- dynamically tagged must be known statically. | |
8289 | ||
8290 | elsif Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) then | |
8291 | if Is_Dynamically_Tagged (Then_Expr) /= | |
8292 | Is_Dynamically_Tagged (Else_Expr) | |
8293 | then | |
8294 | Error_Msg_N ("all or none of the dependent expressions " | |
8295 | & "can be dynamically tagged", N); | |
8296 | end if; | |
9b16cb57 RD |
8297 | end if; |
8298 | ||
8299 | -- If no ELSE expression is present, root type must be Standard.Boolean | |
8300 | -- and we provide a Standard.True result converted to the appropriate | |
8301 | -- Boolean type (in case it is a derived boolean type). | |
8302 | ||
8303 | elsif Root_Type (Typ) = Standard_Boolean then | |
8304 | Else_Expr := | |
8305 | Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N))); | |
8306 | Analyze_And_Resolve (Else_Expr, Typ); | |
8307 | Append_To (Expressions (N), Else_Expr); | |
8308 | ||
8309 | else | |
8310 | Error_Msg_N ("can only omit ELSE expression in Boolean case", N); | |
8311 | Append_To (Expressions (N), Error); | |
8312 | end if; | |
8313 | ||
8314 | Set_Etype (N, Typ); | |
8315 | Eval_If_Expression (N); | |
9b16cb57 RD |
8316 | end Resolve_If_Expression; |
8317 | ||
996ae0b0 RK |
8318 | ------------------------------- |
8319 | -- Resolve_Indexed_Component -- | |
8320 | ------------------------------- | |
8321 | ||
8322 | procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id) is | |
8323 | Name : constant Node_Id := Prefix (N); | |
8324 | Expr : Node_Id; | |
8325 | Array_Type : Entity_Id := Empty; -- to prevent junk warning | |
8326 | Index : Node_Id; | |
8327 | ||
8328 | begin | |
5f50020a ES |
8329 | if Present (Generalized_Indexing (N)) then |
8330 | Resolve_Generalized_Indexing (N, Typ); | |
8331 | return; | |
8332 | end if; | |
8333 | ||
996ae0b0 RK |
8334 | if Is_Overloaded (Name) then |
8335 | ||
758c442c GD |
8336 | -- Use the context type to select the prefix that yields the correct |
8337 | -- component type. | |
996ae0b0 RK |
8338 | |
8339 | declare | |
8340 | I : Interp_Index; | |
8341 | It : Interp; | |
8342 | I1 : Interp_Index := 0; | |
8343 | P : constant Node_Id := Prefix (N); | |
8344 | Found : Boolean := False; | |
8345 | ||
8346 | begin | |
8347 | Get_First_Interp (P, I, It); | |
996ae0b0 | 8348 | while Present (It.Typ) loop |
996ae0b0 RK |
8349 | if (Is_Array_Type (It.Typ) |
8350 | and then Covers (Typ, Component_Type (It.Typ))) | |
8351 | or else (Is_Access_Type (It.Typ) | |
8352 | and then Is_Array_Type (Designated_Type (It.Typ)) | |
19fb051c AC |
8353 | and then |
8354 | Covers | |
8355 | (Typ, | |
8356 | Component_Type (Designated_Type (It.Typ)))) | |
996ae0b0 RK |
8357 | then |
8358 | if Found then | |
8359 | It := Disambiguate (P, I1, I, Any_Type); | |
8360 | ||
8361 | if It = No_Interp then | |
8362 | Error_Msg_N ("ambiguous prefix for indexing", N); | |
8363 | Set_Etype (N, Typ); | |
8364 | return; | |
8365 | ||
8366 | else | |
8367 | Found := True; | |
8368 | Array_Type := It.Typ; | |
8369 | I1 := I; | |
8370 | end if; | |
8371 | ||
8372 | else | |
8373 | Found := True; | |
8374 | Array_Type := It.Typ; | |
8375 | I1 := I; | |
8376 | end if; | |
8377 | end if; | |
8378 | ||
8379 | Get_Next_Interp (I, It); | |
8380 | end loop; | |
8381 | end; | |
8382 | ||
8383 | else | |
8384 | Array_Type := Etype (Name); | |
8385 | end if; | |
8386 | ||
8387 | Resolve (Name, Array_Type); | |
8388 | Array_Type := Get_Actual_Subtype_If_Available (Name); | |
8389 | ||
8390 | -- If prefix is access type, dereference to get real array type. | |
8391 | -- Note: we do not apply an access check because the expander always | |
8392 | -- introduces an explicit dereference, and the check will happen there. | |
8393 | ||
8394 | if Is_Access_Type (Array_Type) then | |
8395 | Array_Type := Designated_Type (Array_Type); | |
8396 | end if; | |
8397 | ||
a77842bd | 8398 | -- If name was overloaded, set component type correctly now |
f3d57416 | 8399 | -- If a misplaced call to an entry family (which has no index types) |
b7d1f17f | 8400 | -- return. Error will be diagnosed from calling context. |
996ae0b0 | 8401 | |
b7d1f17f HK |
8402 | if Is_Array_Type (Array_Type) then |
8403 | Set_Etype (N, Component_Type (Array_Type)); | |
8404 | else | |
8405 | return; | |
8406 | end if; | |
996ae0b0 RK |
8407 | |
8408 | Index := First_Index (Array_Type); | |
8409 | Expr := First (Expressions (N)); | |
8410 | ||
758c442c GD |
8411 | -- The prefix may have resolved to a string literal, in which case its |
8412 | -- etype has a special representation. This is only possible currently | |
8413 | -- if the prefix is a static concatenation, written in functional | |
8414 | -- notation. | |
996ae0b0 RK |
8415 | |
8416 | if Ekind (Array_Type) = E_String_Literal_Subtype then | |
8417 | Resolve (Expr, Standard_Positive); | |
8418 | ||
8419 | else | |
8420 | while Present (Index) and Present (Expr) loop | |
8421 | Resolve (Expr, Etype (Index)); | |
8422 | Check_Unset_Reference (Expr); | |
8423 | ||
8424 | if Is_Scalar_Type (Etype (Expr)) then | |
8425 | Apply_Scalar_Range_Check (Expr, Etype (Index)); | |
8426 | else | |
8427 | Apply_Range_Check (Expr, Get_Actual_Subtype (Index)); | |
8428 | end if; | |
8429 | ||
8430 | Next_Index (Index); | |
8431 | Next (Expr); | |
8432 | end loop; | |
8433 | end if; | |
8434 | ||
dec6faf1 AC |
8435 | Analyze_Dimension (N); |
8436 | ||
0669bebe GB |
8437 | -- Do not generate the warning on suspicious index if we are analyzing |
8438 | -- package Ada.Tags; otherwise we will report the warning with the | |
8439 | -- Prims_Ptr field of the dispatch table. | |
8440 | ||
8441 | if Scope (Etype (Prefix (N))) = Standard_Standard | |
8442 | or else not | |
8443 | Is_RTU (Cunit_Entity (Get_Source_Unit (Etype (Prefix (N)))), | |
8444 | Ada_Tags) | |
8445 | then | |
8446 | Warn_On_Suspicious_Index (Name, First (Expressions (N))); | |
8447 | Eval_Indexed_Component (N); | |
8448 | end if; | |
c28408b7 | 8449 | |
c2a2dbcc RD |
8450 | -- If the array type is atomic, and the component is not atomic, then |
8451 | -- this is worth a warning, since we have a situation where the access | |
8452 | -- to the component may cause extra read/writes of the atomic array | |
8453 | -- object, or partial word accesses, which could be unexpected. | |
c28408b7 RD |
8454 | |
8455 | if Nkind (N) = N_Indexed_Component | |
c2a2dbcc RD |
8456 | and then Is_Atomic_Ref_With_Address (N) |
8457 | and then not (Has_Atomic_Components (Array_Type) | |
8458 | or else (Is_Entity_Name (Prefix (N)) | |
8459 | and then Has_Atomic_Components | |
8460 | (Entity (Prefix (N))))) | |
8461 | and then not Is_Atomic (Component_Type (Array_Type)) | |
c28408b7 | 8462 | then |
b6dd03dd ES |
8463 | Error_Msg_N |
8464 | ("??access to non-atomic component of atomic array", Prefix (N)); | |
8465 | Error_Msg_N | |
8466 | ("??\may cause unexpected accesses to atomic object", Prefix (N)); | |
c28408b7 | 8467 | end if; |
996ae0b0 RK |
8468 | end Resolve_Indexed_Component; |
8469 | ||
8470 | ----------------------------- | |
8471 | -- Resolve_Integer_Literal -- | |
8472 | ----------------------------- | |
8473 | ||
8474 | procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id) is | |
8475 | begin | |
8476 | Set_Etype (N, Typ); | |
8477 | Eval_Integer_Literal (N); | |
8478 | end Resolve_Integer_Literal; | |
8479 | ||
15ce9ca2 AC |
8480 | -------------------------------- |
8481 | -- Resolve_Intrinsic_Operator -- | |
8482 | -------------------------------- | |
996ae0b0 RK |
8483 | |
8484 | procedure Resolve_Intrinsic_Operator (N : Node_Id; Typ : Entity_Id) is | |
7a5b62b0 AC |
8485 | Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); |
8486 | Op : Entity_Id; | |
8487 | Arg1 : Node_Id; | |
8488 | Arg2 : Node_Id; | |
996ae0b0 | 8489 | |
78efd712 AC |
8490 | function Convert_Operand (Opnd : Node_Id) return Node_Id; |
8491 | -- If the operand is a literal, it cannot be the expression in a | |
8492 | -- conversion. Use a qualified expression instead. | |
8493 | ||
b6dd03dd ES |
8494 | --------------------- |
8495 | -- Convert_Operand -- | |
8496 | --------------------- | |
8497 | ||
78efd712 AC |
8498 | function Convert_Operand (Opnd : Node_Id) return Node_Id is |
8499 | Loc : constant Source_Ptr := Sloc (Opnd); | |
8500 | Res : Node_Id; | |
b6dd03dd | 8501 | |
78efd712 AC |
8502 | begin |
8503 | if Nkind_In (Opnd, N_Integer_Literal, N_Real_Literal) then | |
8504 | Res := | |
8505 | Make_Qualified_Expression (Loc, | |
8506 | Subtype_Mark => New_Occurrence_Of (Btyp, Loc), | |
8507 | Expression => Relocate_Node (Opnd)); | |
8508 | Analyze (Res); | |
8509 | ||
8510 | else | |
8511 | Res := Unchecked_Convert_To (Btyp, Opnd); | |
8512 | end if; | |
8513 | ||
8514 | return Res; | |
8515 | end Convert_Operand; | |
8516 | ||
d72e7628 | 8517 | -- Start of processing for Resolve_Intrinsic_Operator |
7109f4f5 | 8518 | |
996ae0b0 | 8519 | begin |
305caf42 AC |
8520 | -- We must preserve the original entity in a generic setting, so that |
8521 | -- the legality of the operation can be verified in an instance. | |
8522 | ||
4460a9bc | 8523 | if not Expander_Active then |
305caf42 AC |
8524 | return; |
8525 | end if; | |
8526 | ||
996ae0b0 | 8527 | Op := Entity (N); |
996ae0b0 RK |
8528 | while Scope (Op) /= Standard_Standard loop |
8529 | Op := Homonym (Op); | |
8530 | pragma Assert (Present (Op)); | |
8531 | end loop; | |
8532 | ||
8533 | Set_Entity (N, Op); | |
af152989 | 8534 | Set_Is_Overloaded (N, False); |
996ae0b0 | 8535 | |
7109f4f5 AC |
8536 | -- If the result or operand types are private, rewrite with unchecked |
8537 | -- conversions on the operands and the result, to expose the proper | |
8538 | -- underlying numeric type. | |
996ae0b0 | 8539 | |
7109f4f5 AC |
8540 | if Is_Private_Type (Typ) |
8541 | or else Is_Private_Type (Etype (Left_Opnd (N))) | |
8542 | or else Is_Private_Type (Etype (Right_Opnd (N))) | |
8543 | then | |
78efd712 | 8544 | Arg1 := Convert_Operand (Left_Opnd (N)); |
fbf5a39b AC |
8545 | |
8546 | if Nkind (N) = N_Op_Expon then | |
8547 | Arg2 := Unchecked_Convert_To (Standard_Integer, Right_Opnd (N)); | |
8548 | else | |
78efd712 | 8549 | Arg2 := Convert_Operand (Right_Opnd (N)); |
fbf5a39b AC |
8550 | end if; |
8551 | ||
bb481772 AC |
8552 | if Nkind (Arg1) = N_Type_Conversion then |
8553 | Save_Interps (Left_Opnd (N), Expression (Arg1)); | |
8554 | end if; | |
8555 | ||
8556 | if Nkind (Arg2) = N_Type_Conversion then | |
8557 | Save_Interps (Right_Opnd (N), Expression (Arg2)); | |
8558 | end if; | |
996ae0b0 | 8559 | |
fbf5a39b AC |
8560 | Set_Left_Opnd (N, Arg1); |
8561 | Set_Right_Opnd (N, Arg2); | |
8562 | ||
8563 | Set_Etype (N, Btyp); | |
8564 | Rewrite (N, Unchecked_Convert_To (Typ, N)); | |
8565 | Resolve (N, Typ); | |
8566 | ||
8567 | elsif Typ /= Etype (Left_Opnd (N)) | |
8568 | or else Typ /= Etype (Right_Opnd (N)) | |
8569 | then | |
d81b4bfe | 8570 | -- Add explicit conversion where needed, and save interpretations in |
7a5b62b0 | 8571 | -- case operands are overloaded. |
fbf5a39b | 8572 | |
af152989 | 8573 | Arg1 := Convert_To (Typ, Left_Opnd (N)); |
fbf5a39b AC |
8574 | Arg2 := Convert_To (Typ, Right_Opnd (N)); |
8575 | ||
8576 | if Nkind (Arg1) = N_Type_Conversion then | |
8577 | Save_Interps (Left_Opnd (N), Expression (Arg1)); | |
af152989 AC |
8578 | else |
8579 | Save_Interps (Left_Opnd (N), Arg1); | |
fbf5a39b AC |
8580 | end if; |
8581 | ||
8582 | if Nkind (Arg2) = N_Type_Conversion then | |
8583 | Save_Interps (Right_Opnd (N), Expression (Arg2)); | |
af152989 | 8584 | else |
0ab80019 | 8585 | Save_Interps (Right_Opnd (N), Arg2); |
fbf5a39b AC |
8586 | end if; |
8587 | ||
8588 | Rewrite (Left_Opnd (N), Arg1); | |
8589 | Rewrite (Right_Opnd (N), Arg2); | |
8590 | Analyze (Arg1); | |
8591 | Analyze (Arg2); | |
8592 | Resolve_Arithmetic_Op (N, Typ); | |
8593 | ||
8594 | else | |
8595 | Resolve_Arithmetic_Op (N, Typ); | |
8596 | end if; | |
996ae0b0 RK |
8597 | end Resolve_Intrinsic_Operator; |
8598 | ||
fbf5a39b AC |
8599 | -------------------------------------- |
8600 | -- Resolve_Intrinsic_Unary_Operator -- | |
8601 | -------------------------------------- | |
8602 | ||
8603 | procedure Resolve_Intrinsic_Unary_Operator | |
8604 | (N : Node_Id; | |
8605 | Typ : Entity_Id) | |
8606 | is | |
8607 | Btyp : constant Entity_Id := Base_Type (Underlying_Type (Typ)); | |
8608 | Op : Entity_Id; | |
8609 | Arg2 : Node_Id; | |
8610 | ||
8611 | begin | |
8612 | Op := Entity (N); | |
fbf5a39b AC |
8613 | while Scope (Op) /= Standard_Standard loop |
8614 | Op := Homonym (Op); | |
8615 | pragma Assert (Present (Op)); | |
8616 | end loop; | |
8617 | ||
8618 | Set_Entity (N, Op); | |
8619 | ||
8620 | if Is_Private_Type (Typ) then | |
8621 | Arg2 := Unchecked_Convert_To (Btyp, Right_Opnd (N)); | |
8622 | Save_Interps (Right_Opnd (N), Expression (Arg2)); | |
8623 | ||
8624 | Set_Right_Opnd (N, Arg2); | |
8625 | ||
8626 | Set_Etype (N, Btyp); | |
8627 | Rewrite (N, Unchecked_Convert_To (Typ, N)); | |
8628 | Resolve (N, Typ); | |
8629 | ||
8630 | else | |
8631 | Resolve_Unary_Op (N, Typ); | |
8632 | end if; | |
8633 | end Resolve_Intrinsic_Unary_Operator; | |
8634 | ||
996ae0b0 RK |
8635 | ------------------------ |
8636 | -- Resolve_Logical_Op -- | |
8637 | ------------------------ | |
8638 | ||
8639 | procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id) is | |
8640 | B_Typ : Entity_Id; | |
8641 | ||
8642 | begin | |
f61580d4 AC |
8643 | Check_No_Direct_Boolean_Operators (N); |
8644 | ||
758c442c GD |
8645 | -- Predefined operations on scalar types yield the base type. On the |
8646 | -- other hand, logical operations on arrays yield the type of the | |
8647 | -- arguments (and the context). | |
996ae0b0 RK |
8648 | |
8649 | if Is_Array_Type (Typ) then | |
8650 | B_Typ := Typ; | |
8651 | else | |
8652 | B_Typ := Base_Type (Typ); | |
8653 | end if; | |
8654 | ||
8655 | -- The following test is required because the operands of the operation | |
8656 | -- may be literals, in which case the resulting type appears to be | |
8657 | -- compatible with a signed integer type, when in fact it is compatible | |
8658 | -- only with modular types. If the context itself is universal, the | |
8659 | -- operation is illegal. | |
8660 | ||
7a5b62b0 | 8661 | if not Valid_Boolean_Arg (Typ) then |
996ae0b0 RK |
8662 | Error_Msg_N ("invalid context for logical operation", N); |
8663 | Set_Etype (N, Any_Type); | |
8664 | return; | |
8665 | ||
8666 | elsif Typ = Any_Modular then | |
8667 | Error_Msg_N | |
8668 | ("no modular type available in this context", N); | |
8669 | Set_Etype (N, Any_Type); | |
8670 | return; | |
19fb051c | 8671 | |
07fc65c4 GB |
8672 | elsif Is_Modular_Integer_Type (Typ) |
8673 | and then Etype (Left_Opnd (N)) = Universal_Integer | |
8674 | and then Etype (Right_Opnd (N)) = Universal_Integer | |
8675 | then | |
8676 | Check_For_Visible_Operator (N, B_Typ); | |
996ae0b0 RK |
8677 | end if; |
8678 | ||
f2d10a02 AC |
8679 | -- Replace AND by AND THEN, or OR by OR ELSE, if Short_Circuit_And_Or |
8680 | -- is active and the result type is standard Boolean (do not mess with | |
8681 | -- ops that return a nonstandard Boolean type, because something strange | |
8682 | -- is going on). | |
8683 | ||
8684 | -- Note: you might expect this replacement to be done during expansion, | |
8685 | -- but that doesn't work, because when the pragma Short_Circuit_And_Or | |
8686 | -- is used, no part of the right operand of an "and" or "or" operator | |
8687 | -- should be executed if the left operand would short-circuit the | |
8688 | -- evaluation of the corresponding "and then" or "or else". If we left | |
8689 | -- the replacement to expansion time, then run-time checks associated | |
8690 | -- with such operands would be evaluated unconditionally, due to being | |
af89615f | 8691 | -- before the condition prior to the rewriting as short-circuit forms |
f2d10a02 AC |
8692 | -- during expansion. |
8693 | ||
8694 | if Short_Circuit_And_Or | |
8695 | and then B_Typ = Standard_Boolean | |
8696 | and then Nkind_In (N, N_Op_And, N_Op_Or) | |
8697 | then | |
0566484a AC |
8698 | -- Mark the corresponding putative SCO operator as truly a logical |
8699 | -- (and short-circuit) operator. | |
8700 | ||
8701 | if Generate_SCO and then Comes_From_Source (N) then | |
8702 | Set_SCO_Logical_Operator (N); | |
8703 | end if; | |
8704 | ||
f2d10a02 AC |
8705 | if Nkind (N) = N_Op_And then |
8706 | Rewrite (N, | |
8707 | Make_And_Then (Sloc (N), | |
8708 | Left_Opnd => Relocate_Node (Left_Opnd (N)), | |
8709 | Right_Opnd => Relocate_Node (Right_Opnd (N)))); | |
8710 | Analyze_And_Resolve (N, B_Typ); | |
8711 | ||
8712 | -- Case of OR changed to OR ELSE | |
8713 | ||
8714 | else | |
8715 | Rewrite (N, | |
8716 | Make_Or_Else (Sloc (N), | |
8717 | Left_Opnd => Relocate_Node (Left_Opnd (N)), | |
8718 | Right_Opnd => Relocate_Node (Right_Opnd (N)))); | |
8719 | Analyze_And_Resolve (N, B_Typ); | |
8720 | end if; | |
8721 | ||
8722 | -- Return now, since analysis of the rewritten ops will take care of | |
8723 | -- other reference bookkeeping and expression folding. | |
8724 | ||
8725 | return; | |
8726 | end if; | |
8727 | ||
996ae0b0 RK |
8728 | Resolve (Left_Opnd (N), B_Typ); |
8729 | Resolve (Right_Opnd (N), B_Typ); | |
8730 | ||
8731 | Check_Unset_Reference (Left_Opnd (N)); | |
8732 | Check_Unset_Reference (Right_Opnd (N)); | |
8733 | ||
8734 | Set_Etype (N, B_Typ); | |
fbf5a39b | 8735 | Generate_Operator_Reference (N, B_Typ); |
996ae0b0 | 8736 | Eval_Logical_Op (N); |
9f90d123 | 8737 | |
2ba431e5 YM |
8738 | -- In SPARK, logical operations AND, OR and XOR for arrays are defined |
8739 | -- only when both operands have same static lower and higher bounds. Of | |
8740 | -- course the types have to match, so only check if operands are | |
8741 | -- compatible and the node itself has no errors. | |
9f90d123 | 8742 | |
f5afb270 AC |
8743 | if Is_Array_Type (B_Typ) |
8744 | and then Nkind (N) in N_Binary_Op | |
8745 | then | |
8746 | declare | |
8747 | Left_Typ : constant Node_Id := Etype (Left_Opnd (N)); | |
8748 | Right_Typ : constant Node_Id := Etype (Right_Opnd (N)); | |
2598ee6d | 8749 | |
f5afb270 | 8750 | begin |
7b98672f YM |
8751 | -- Protect call to Matching_Static_Array_Bounds to avoid costly |
8752 | -- operation if not needed. | |
8753 | ||
6480338a | 8754 | if Restriction_Check_Required (SPARK_05) |
7b98672f | 8755 | and then Base_Type (Left_Typ) = Base_Type (Right_Typ) |
f5afb270 AC |
8756 | and then Left_Typ /= Any_Composite -- or Left_Opnd in error |
8757 | and then Right_Typ /= Any_Composite -- or Right_Opnd in error | |
8758 | and then not Matching_Static_Array_Bounds (Left_Typ, Right_Typ) | |
8759 | then | |
ce5ba43a | 8760 | Check_SPARK_05_Restriction |
f5afb270 AC |
8761 | ("array types should have matching static bounds", N); |
8762 | end if; | |
8763 | end; | |
8764 | end if; | |
996ae0b0 RK |
8765 | end Resolve_Logical_Op; |
8766 | ||
8767 | --------------------------- | |
8768 | -- Resolve_Membership_Op -- | |
8769 | --------------------------- | |
8770 | ||
5cc9353d RD |
8771 | -- The context can only be a boolean type, and does not determine the |
8772 | -- arguments. Arguments should be unambiguous, but the preference rule for | |
8773 | -- universal types applies. | |
996ae0b0 RK |
8774 | |
8775 | procedure Resolve_Membership_Op (N : Node_Id; Typ : Entity_Id) is | |
07fc65c4 GB |
8776 | pragma Warnings (Off, Typ); |
8777 | ||
197e4514 | 8778 | L : constant Node_Id := Left_Opnd (N); |
b1c11e0e | 8779 | R : constant Node_Id := Right_Opnd (N); |
996ae0b0 RK |
8780 | T : Entity_Id; |
8781 | ||
197e4514 | 8782 | procedure Resolve_Set_Membership; |
5cc9353d RD |
8783 | -- Analysis has determined a unique type for the left operand. Use it to |
8784 | -- resolve the disjuncts. | |
197e4514 AC |
8785 | |
8786 | ---------------------------- | |
8787 | -- Resolve_Set_Membership -- | |
8788 | ---------------------------- | |
8789 | ||
8790 | procedure Resolve_Set_Membership is | |
9cb62ce3 | 8791 | Alt : Node_Id; |
cd1a470a | 8792 | Ltyp : Entity_Id; |
197e4514 AC |
8793 | |
8794 | begin | |
cd1a470a AC |
8795 | -- If the left operand is overloaded, find type compatible with not |
8796 | -- overloaded alternative of the right operand. | |
8797 | ||
8798 | if Is_Overloaded (L) then | |
8799 | Ltyp := Empty; | |
8800 | Alt := First (Alternatives (N)); | |
8801 | while Present (Alt) loop | |
8802 | if not Is_Overloaded (Alt) then | |
8803 | Ltyp := Intersect_Types (L, Alt); | |
8804 | exit; | |
8805 | else | |
8806 | Next (Alt); | |
8807 | end if; | |
8808 | end loop; | |
8809 | ||
8810 | -- Unclear how to resolve expression if all alternatives are also | |
8811 | -- overloaded. | |
8812 | ||
8813 | if No (Ltyp) then | |
8814 | Error_Msg_N ("ambiguous expression", N); | |
8815 | end if; | |
8816 | ||
8817 | else | |
8818 | Ltyp := Etype (L); | |
8819 | end if; | |
8820 | ||
9cb62ce3 | 8821 | Resolve (L, Ltyp); |
197e4514 AC |
8822 | |
8823 | Alt := First (Alternatives (N)); | |
8824 | while Present (Alt) loop | |
8825 | ||
8826 | -- Alternative is an expression, a range | |
8827 | -- or a subtype mark. | |
8828 | ||
8829 | if not Is_Entity_Name (Alt) | |
8830 | or else not Is_Type (Entity (Alt)) | |
8831 | then | |
9cb62ce3 | 8832 | Resolve (Alt, Ltyp); |
197e4514 AC |
8833 | end if; |
8834 | ||
8835 | Next (Alt); | |
8836 | end loop; | |
9cb62ce3 AC |
8837 | |
8838 | -- Check for duplicates for discrete case | |
8839 | ||
8840 | if Is_Discrete_Type (Ltyp) then | |
8841 | declare | |
8842 | type Ent is record | |
8843 | Alt : Node_Id; | |
8844 | Val : Uint; | |
8845 | end record; | |
8846 | ||
8847 | Alts : array (0 .. List_Length (Alternatives (N))) of Ent; | |
8848 | Nalts : Nat; | |
8849 | ||
8850 | begin | |
8851 | -- Loop checking duplicates. This is quadratic, but giant sets | |
8852 | -- are unlikely in this context so it's a reasonable choice. | |
8853 | ||
8854 | Nalts := 0; | |
8855 | Alt := First (Alternatives (N)); | |
8856 | while Present (Alt) loop | |
edab6088 | 8857 | if Is_OK_Static_Expression (Alt) |
9cb62ce3 | 8858 | and then (Nkind_In (Alt, N_Integer_Literal, |
324ac540 | 8859 | N_Character_Literal) |
9cb62ce3 AC |
8860 | or else Nkind (Alt) in N_Has_Entity) |
8861 | then | |
8862 | Nalts := Nalts + 1; | |
8863 | Alts (Nalts) := (Alt, Expr_Value (Alt)); | |
8864 | ||
8865 | for J in 1 .. Nalts - 1 loop | |
8866 | if Alts (J).Val = Alts (Nalts).Val then | |
8867 | Error_Msg_Sloc := Sloc (Alts (J).Alt); | |
324ac540 | 8868 | Error_Msg_N ("duplicate of value given#??", Alt); |
9cb62ce3 AC |
8869 | end if; |
8870 | end loop; | |
8871 | end if; | |
8872 | ||
8873 | Alt := Next (Alt); | |
8874 | end loop; | |
8875 | end; | |
8876 | end if; | |
197e4514 AC |
8877 | end Resolve_Set_Membership; |
8878 | ||
442c0581 | 8879 | -- Start of processing for Resolve_Membership_Op |
197e4514 | 8880 | |
996ae0b0 RK |
8881 | begin |
8882 | if L = Error or else R = Error then | |
8883 | return; | |
8884 | end if; | |
8885 | ||
197e4514 AC |
8886 | if Present (Alternatives (N)) then |
8887 | Resolve_Set_Membership; | |
edab6088 | 8888 | goto SM_Exit; |
197e4514 AC |
8889 | |
8890 | elsif not Is_Overloaded (R) | |
996ae0b0 | 8891 | and then |
19fb051c AC |
8892 | (Etype (R) = Universal_Integer |
8893 | or else | |
996ae0b0 RK |
8894 | Etype (R) = Universal_Real) |
8895 | and then Is_Overloaded (L) | |
8896 | then | |
8897 | T := Etype (R); | |
1420b484 | 8898 | |
d81b4bfe | 8899 | -- Ada 2005 (AI-251): Support the following case: |
1420b484 JM |
8900 | |
8901 | -- type I is interface; | |
8902 | -- type T is tagged ... | |
8903 | ||
c8ef728f | 8904 | -- function Test (O : I'Class) is |
1420b484 JM |
8905 | -- begin |
8906 | -- return O in T'Class. | |
8907 | -- end Test; | |
8908 | ||
d81b4bfe | 8909 | -- In this case we have nothing else to do. The membership test will be |
e7c0dd39 | 8910 | -- done at run time. |
1420b484 | 8911 | |
0791fbe9 | 8912 | elsif Ada_Version >= Ada_2005 |
1420b484 JM |
8913 | and then Is_Class_Wide_Type (Etype (L)) |
8914 | and then Is_Interface (Etype (L)) | |
8915 | and then Is_Class_Wide_Type (Etype (R)) | |
8916 | and then not Is_Interface (Etype (R)) | |
8917 | then | |
8918 | return; | |
996ae0b0 RK |
8919 | else |
8920 | T := Intersect_Types (L, R); | |
8921 | end if; | |
8922 | ||
9a0ddeee AC |
8923 | -- If mixed-mode operations are present and operands are all literal, |
8924 | -- the only interpretation involves Duration, which is probably not | |
8925 | -- the intention of the programmer. | |
8926 | ||
8927 | if T = Any_Fixed then | |
8928 | T := Unique_Fixed_Point_Type (N); | |
8929 | ||
8930 | if T = Any_Type then | |
8931 | return; | |
8932 | end if; | |
8933 | end if; | |
8934 | ||
996ae0b0 RK |
8935 | Resolve (L, T); |
8936 | Check_Unset_Reference (L); | |
8937 | ||
8938 | if Nkind (R) = N_Range | |
8939 | and then not Is_Scalar_Type (T) | |
8940 | then | |
8941 | Error_Msg_N ("scalar type required for range", R); | |
8942 | end if; | |
8943 | ||
8944 | if Is_Entity_Name (R) then | |
8945 | Freeze_Expression (R); | |
8946 | else | |
8947 | Resolve (R, T); | |
8948 | Check_Unset_Reference (R); | |
8949 | end if; | |
8950 | ||
edab6088 RD |
8951 | -- Here after resolving membership operation |
8952 | ||
8953 | <<SM_Exit>> | |
8954 | ||
996ae0b0 RK |
8955 | Eval_Membership_Op (N); |
8956 | end Resolve_Membership_Op; | |
8957 | ||
8958 | ------------------ | |
8959 | -- Resolve_Null -- | |
8960 | ------------------ | |
8961 | ||
8962 | procedure Resolve_Null (N : Node_Id; Typ : Entity_Id) is | |
b1c11e0e JM |
8963 | Loc : constant Source_Ptr := Sloc (N); |
8964 | ||
996ae0b0 | 8965 | begin |
758c442c | 8966 | -- Handle restriction against anonymous null access values This |
6ba6b1e3 | 8967 | -- restriction can be turned off using -gnatdj. |
996ae0b0 | 8968 | |
0ab80019 | 8969 | -- Ada 2005 (AI-231): Remove restriction |
2820d220 | 8970 | |
0791fbe9 | 8971 | if Ada_Version < Ada_2005 |
2820d220 | 8972 | and then not Debug_Flag_J |
996ae0b0 RK |
8973 | and then Ekind (Typ) = E_Anonymous_Access_Type |
8974 | and then Comes_From_Source (N) | |
8975 | then | |
d81b4bfe TQ |
8976 | -- In the common case of a call which uses an explicitly null value |
8977 | -- for an access parameter, give specialized error message. | |
996ae0b0 | 8978 | |
d3b00ce3 | 8979 | if Nkind (Parent (N)) in N_Subprogram_Call then |
996ae0b0 RK |
8980 | Error_Msg_N |
8981 | ("null is not allowed as argument for an access parameter", N); | |
8982 | ||
8983 | -- Standard message for all other cases (are there any?) | |
8984 | ||
8985 | else | |
8986 | Error_Msg_N | |
8987 | ("null cannot be of an anonymous access type", N); | |
8988 | end if; | |
8989 | end if; | |
8990 | ||
b1c11e0e JM |
8991 | -- Ada 2005 (AI-231): Generate the null-excluding check in case of |
8992 | -- assignment to a null-excluding object | |
8993 | ||
0791fbe9 | 8994 | if Ada_Version >= Ada_2005 |
b1c11e0e JM |
8995 | and then Can_Never_Be_Null (Typ) |
8996 | and then Nkind (Parent (N)) = N_Assignment_Statement | |
8997 | then | |
8998 | if not Inside_Init_Proc then | |
8999 | Insert_Action | |
9000 | (Compile_Time_Constraint_Error (N, | |
324ac540 | 9001 | "(Ada 2005) null not allowed in null-excluding objects??"), |
b1c11e0e JM |
9002 | Make_Raise_Constraint_Error (Loc, |
9003 | Reason => CE_Access_Check_Failed)); | |
9004 | else | |
9005 | Insert_Action (N, | |
9006 | Make_Raise_Constraint_Error (Loc, | |
9007 | Reason => CE_Access_Check_Failed)); | |
9008 | end if; | |
9009 | end if; | |
9010 | ||
d81b4bfe TQ |
9011 | -- In a distributed context, null for a remote access to subprogram may |
9012 | -- need to be replaced with a special record aggregate. In this case, | |
9013 | -- return after having done the transformation. | |
996ae0b0 RK |
9014 | |
9015 | if (Ekind (Typ) = E_Record_Type | |
9016 | or else Is_Remote_Access_To_Subprogram_Type (Typ)) | |
9017 | and then Remote_AST_Null_Value (N, Typ) | |
9018 | then | |
9019 | return; | |
9020 | end if; | |
9021 | ||
a77842bd | 9022 | -- The null literal takes its type from the context |
996ae0b0 RK |
9023 | |
9024 | Set_Etype (N, Typ); | |
9025 | end Resolve_Null; | |
9026 | ||
9027 | ----------------------- | |
9028 | -- Resolve_Op_Concat -- | |
9029 | ----------------------- | |
9030 | ||
9031 | procedure Resolve_Op_Concat (N : Node_Id; Typ : Entity_Id) is | |
996ae0b0 | 9032 | |
10303118 BD |
9033 | -- We wish to avoid deep recursion, because concatenations are often |
9034 | -- deeply nested, as in A&B&...&Z. Therefore, we walk down the left | |
9035 | -- operands nonrecursively until we find something that is not a simple | |
9036 | -- concatenation (A in this case). We resolve that, and then walk back | |
9037 | -- up the tree following Parent pointers, calling Resolve_Op_Concat_Rest | |
9038 | -- to do the rest of the work at each level. The Parent pointers allow | |
9039 | -- us to avoid recursion, and thus avoid running out of memory. See also | |
d81b4bfe | 9040 | -- Sem_Ch4.Analyze_Concatenation, where a similar approach is used. |
996ae0b0 | 9041 | |
10303118 BD |
9042 | NN : Node_Id := N; |
9043 | Op1 : Node_Id; | |
996ae0b0 | 9044 | |
10303118 BD |
9045 | begin |
9046 | -- The following code is equivalent to: | |
996ae0b0 | 9047 | |
10303118 BD |
9048 | -- Resolve_Op_Concat_First (NN, Typ); |
9049 | -- Resolve_Op_Concat_Arg (N, ...); | |
9050 | -- Resolve_Op_Concat_Rest (N, Typ); | |
996ae0b0 | 9051 | |
10303118 BD |
9052 | -- where the Resolve_Op_Concat_Arg call recurses back here if the left |
9053 | -- operand is a concatenation. | |
996ae0b0 | 9054 | |
10303118 | 9055 | -- Walk down left operands |
996ae0b0 | 9056 | |
10303118 BD |
9057 | loop |
9058 | Resolve_Op_Concat_First (NN, Typ); | |
9059 | Op1 := Left_Opnd (NN); | |
9060 | exit when not (Nkind (Op1) = N_Op_Concat | |
9061 | and then not Is_Array_Type (Component_Type (Typ)) | |
9062 | and then Entity (Op1) = Entity (NN)); | |
9063 | NN := Op1; | |
9064 | end loop; | |
996ae0b0 | 9065 | |
10303118 | 9066 | -- Now (given the above example) NN is A&B and Op1 is A |
996ae0b0 | 9067 | |
10303118 | 9068 | -- First resolve Op1 ... |
9ebe3743 | 9069 | |
10303118 | 9070 | Resolve_Op_Concat_Arg (NN, Op1, Typ, Is_Component_Left_Opnd (NN)); |
9ebe3743 | 9071 | |
10303118 BD |
9072 | -- ... then walk NN back up until we reach N (where we started), calling |
9073 | -- Resolve_Op_Concat_Rest along the way. | |
9ebe3743 | 9074 | |
10303118 BD |
9075 | loop |
9076 | Resolve_Op_Concat_Rest (NN, Typ); | |
9077 | exit when NN = N; | |
9078 | NN := Parent (NN); | |
9079 | end loop; | |
2933b16c | 9080 | |
fe5d3068 | 9081 | if Base_Type (Etype (N)) /= Standard_String then |
ce5ba43a | 9082 | Check_SPARK_05_Restriction |
fe5d3068 | 9083 | ("result of concatenation should have type String", N); |
2933b16c | 9084 | end if; |
10303118 | 9085 | end Resolve_Op_Concat; |
9ebe3743 | 9086 | |
10303118 BD |
9087 | --------------------------- |
9088 | -- Resolve_Op_Concat_Arg -- | |
9089 | --------------------------- | |
996ae0b0 | 9090 | |
10303118 BD |
9091 | procedure Resolve_Op_Concat_Arg |
9092 | (N : Node_Id; | |
9093 | Arg : Node_Id; | |
9094 | Typ : Entity_Id; | |
9095 | Is_Comp : Boolean) | |
9096 | is | |
9097 | Btyp : constant Entity_Id := Base_Type (Typ); | |
668a19bc | 9098 | Ctyp : constant Entity_Id := Component_Type (Typ); |
996ae0b0 | 9099 | |
10303118 BD |
9100 | begin |
9101 | if In_Instance then | |
9102 | if Is_Comp | |
9103 | or else (not Is_Overloaded (Arg) | |
9104 | and then Etype (Arg) /= Any_Composite | |
668a19bc | 9105 | and then Covers (Ctyp, Etype (Arg))) |
10303118 | 9106 | then |
668a19bc | 9107 | Resolve (Arg, Ctyp); |
10303118 BD |
9108 | else |
9109 | Resolve (Arg, Btyp); | |
9110 | end if; | |
fbf5a39b | 9111 | |
668a19bc ES |
9112 | -- If both Array & Array and Array & Component are visible, there is a |
9113 | -- potential ambiguity that must be reported. | |
9114 | ||
9115 | elsif Has_Compatible_Type (Arg, Ctyp) then | |
10303118 | 9116 | if Nkind (Arg) = N_Aggregate |
668a19bc | 9117 | and then Is_Composite_Type (Ctyp) |
10303118 | 9118 | then |
668a19bc | 9119 | if Is_Private_Type (Ctyp) then |
10303118 | 9120 | Resolve (Arg, Btyp); |
668a19bc ES |
9121 | |
9122 | -- If the operation is user-defined and not overloaded use its | |
9123 | -- profile. The operation may be a renaming, in which case it has | |
9124 | -- been rewritten, and we want the original profile. | |
9125 | ||
9126 | elsif not Is_Overloaded (N) | |
9127 | and then Comes_From_Source (Entity (Original_Node (N))) | |
9128 | and then Ekind (Entity (Original_Node (N))) = E_Function | |
9129 | then | |
9130 | Resolve (Arg, | |
9131 | Etype | |
9132 | (Next_Formal (First_Formal (Entity (Original_Node (N)))))); | |
9133 | return; | |
9134 | ||
9135 | -- Otherwise an aggregate may match both the array type and the | |
9136 | -- component type. | |
9137 | ||
10303118 BD |
9138 | else |
9139 | Error_Msg_N ("ambiguous aggregate must be qualified", Arg); | |
9140 | Set_Etype (Arg, Any_Type); | |
996ae0b0 RK |
9141 | end if; |
9142 | ||
9143 | else | |
10303118 BD |
9144 | if Is_Overloaded (Arg) |
9145 | and then Has_Compatible_Type (Arg, Typ) | |
9146 | and then Etype (Arg) /= Any_Type | |
9147 | then | |
9148 | declare | |
9149 | I : Interp_Index; | |
9150 | It : Interp; | |
9151 | Func : Entity_Id; | |
9152 | ||
9153 | begin | |
9154 | Get_First_Interp (Arg, I, It); | |
9155 | Func := It.Nam; | |
9156 | Get_Next_Interp (I, It); | |
9157 | ||
9158 | -- Special-case the error message when the overloading is | |
9159 | -- caused by a function that yields an array and can be | |
9160 | -- called without parameters. | |
9161 | ||
9162 | if It.Nam = Func then | |
9163 | Error_Msg_Sloc := Sloc (Func); | |
9164 | Error_Msg_N ("ambiguous call to function#", Arg); | |
9165 | Error_Msg_NE | |
9166 | ("\\interpretation as call yields&", Arg, Typ); | |
9167 | Error_Msg_NE | |
9168 | ("\\interpretation as indexing of call yields&", | |
9169 | Arg, Component_Type (Typ)); | |
9170 | ||
9171 | else | |
668a19bc | 9172 | Error_Msg_N ("ambiguous operand for concatenation!", Arg); |
19fb051c | 9173 | |
10303118 BD |
9174 | Get_First_Interp (Arg, I, It); |
9175 | while Present (It.Nam) loop | |
9176 | Error_Msg_Sloc := Sloc (It.Nam); | |
9177 | ||
668a19bc ES |
9178 | if Base_Type (It.Typ) = Btyp |
9179 | or else | |
9180 | Base_Type (It.Typ) = Base_Type (Ctyp) | |
10303118 | 9181 | then |
4e7a4f6e AC |
9182 | Error_Msg_N -- CODEFIX |
9183 | ("\\possible interpretation#", Arg); | |
10303118 BD |
9184 | end if; |
9185 | ||
9186 | Get_Next_Interp (I, It); | |
9187 | end loop; | |
9188 | end if; | |
9189 | end; | |
9190 | end if; | |
9191 | ||
9192 | Resolve (Arg, Component_Type (Typ)); | |
9193 | ||
9194 | if Nkind (Arg) = N_String_Literal then | |
9195 | Set_Etype (Arg, Component_Type (Typ)); | |
9196 | end if; | |
9197 | ||
9198 | if Arg = Left_Opnd (N) then | |
9199 | Set_Is_Component_Left_Opnd (N); | |
9200 | else | |
9201 | Set_Is_Component_Right_Opnd (N); | |
9202 | end if; | |
996ae0b0 RK |
9203 | end if; |
9204 | ||
10303118 BD |
9205 | else |
9206 | Resolve (Arg, Btyp); | |
9207 | end if; | |
9208 | ||
2ba431e5 | 9209 | -- Concatenation is restricted in SPARK: each operand must be either a |
92e77027 AC |
9210 | -- string literal, the name of a string constant, a static character or |
9211 | -- string expression, or another concatenation. Arg cannot be a | |
9212 | -- concatenation here as callers of Resolve_Op_Concat_Arg call it | |
9213 | -- separately on each final operand, past concatenation operations. | |
2933b16c | 9214 | |
fe5d3068 | 9215 | if Is_Character_Type (Etype (Arg)) then |
edab6088 | 9216 | if not Is_OK_Static_Expression (Arg) then |
ce5ba43a | 9217 | Check_SPARK_05_Restriction |
5b5588dd | 9218 | ("character operand for concatenation should be static", Arg); |
fe5d3068 | 9219 | end if; |
2933b16c | 9220 | |
fe5d3068 | 9221 | elsif Is_String_Type (Etype (Arg)) then |
92e77027 AC |
9222 | if not (Nkind_In (Arg, N_Identifier, N_Expanded_Name) |
9223 | and then Is_Constant_Object (Entity (Arg))) | |
edab6088 | 9224 | and then not Is_OK_Static_Expression (Arg) |
92e77027 | 9225 | then |
ce5ba43a | 9226 | Check_SPARK_05_Restriction |
5b5588dd | 9227 | ("string operand for concatenation should be static", Arg); |
fe5d3068 | 9228 | end if; |
2933b16c | 9229 | |
b9e48541 AC |
9230 | -- Do not issue error on an operand that is neither a character nor a |
9231 | -- string, as the error is issued in Resolve_Op_Concat. | |
2933b16c | 9232 | |
fe5d3068 YM |
9233 | else |
9234 | null; | |
2933b16c RD |
9235 | end if; |
9236 | ||
10303118 BD |
9237 | Check_Unset_Reference (Arg); |
9238 | end Resolve_Op_Concat_Arg; | |
996ae0b0 | 9239 | |
10303118 BD |
9240 | ----------------------------- |
9241 | -- Resolve_Op_Concat_First -- | |
9242 | ----------------------------- | |
9243 | ||
9244 | procedure Resolve_Op_Concat_First (N : Node_Id; Typ : Entity_Id) is | |
9245 | Btyp : constant Entity_Id := Base_Type (Typ); | |
9246 | Op1 : constant Node_Id := Left_Opnd (N); | |
9247 | Op2 : constant Node_Id := Right_Opnd (N); | |
996ae0b0 RK |
9248 | |
9249 | begin | |
dae2b8ea HK |
9250 | -- The parser folds an enormous sequence of concatenations of string |
9251 | -- literals into "" & "...", where the Is_Folded_In_Parser flag is set | |
4fc26524 | 9252 | -- in the right operand. If the expression resolves to a predefined "&" |
dae2b8ea HK |
9253 | -- operator, all is well. Otherwise, the parser's folding is wrong, so |
9254 | -- we give an error. See P_Simple_Expression in Par.Ch4. | |
9255 | ||
9256 | if Nkind (Op2) = N_String_Literal | |
9257 | and then Is_Folded_In_Parser (Op2) | |
9258 | and then Ekind (Entity (N)) = E_Function | |
9259 | then | |
9260 | pragma Assert (Nkind (Op1) = N_String_Literal -- should be "" | |
9261 | and then String_Length (Strval (Op1)) = 0); | |
9262 | Error_Msg_N ("too many user-defined concatenations", N); | |
9263 | return; | |
9264 | end if; | |
9265 | ||
996ae0b0 RK |
9266 | Set_Etype (N, Btyp); |
9267 | ||
9268 | if Is_Limited_Composite (Btyp) then | |
9269 | Error_Msg_N ("concatenation not available for limited array", N); | |
fbf5a39b | 9270 | Explain_Limited_Type (Btyp, N); |
996ae0b0 | 9271 | end if; |
10303118 | 9272 | end Resolve_Op_Concat_First; |
996ae0b0 | 9273 | |
10303118 BD |
9274 | ---------------------------- |
9275 | -- Resolve_Op_Concat_Rest -- | |
9276 | ---------------------------- | |
996ae0b0 | 9277 | |
10303118 BD |
9278 | procedure Resolve_Op_Concat_Rest (N : Node_Id; Typ : Entity_Id) is |
9279 | Op1 : constant Node_Id := Left_Opnd (N); | |
9280 | Op2 : constant Node_Id := Right_Opnd (N); | |
996ae0b0 | 9281 | |
10303118 BD |
9282 | begin |
9283 | Resolve_Op_Concat_Arg (N, Op2, Typ, Is_Component_Right_Opnd (N)); | |
996ae0b0 | 9284 | |
fbf5a39b | 9285 | Generate_Operator_Reference (N, Typ); |
996ae0b0 RK |
9286 | |
9287 | if Is_String_Type (Typ) then | |
9288 | Eval_Concatenation (N); | |
9289 | end if; | |
9290 | ||
d81b4bfe TQ |
9291 | -- If this is not a static concatenation, but the result is a string |
9292 | -- type (and not an array of strings) ensure that static string operands | |
9293 | -- have their subtypes properly constructed. | |
996ae0b0 RK |
9294 | |
9295 | if Nkind (N) /= N_String_Literal | |
9296 | and then Is_Character_Type (Component_Type (Typ)) | |
9297 | then | |
9298 | Set_String_Literal_Subtype (Op1, Typ); | |
9299 | Set_String_Literal_Subtype (Op2, Typ); | |
9300 | end if; | |
10303118 | 9301 | end Resolve_Op_Concat_Rest; |
996ae0b0 RK |
9302 | |
9303 | ---------------------- | |
9304 | -- Resolve_Op_Expon -- | |
9305 | ---------------------- | |
9306 | ||
9307 | procedure Resolve_Op_Expon (N : Node_Id; Typ : Entity_Id) is | |
9308 | B_Typ : constant Entity_Id := Base_Type (Typ); | |
9309 | ||
9310 | begin | |
f3d57416 | 9311 | -- Catch attempts to do fixed-point exponentiation with universal |
758c442c | 9312 | -- operands, which is a case where the illegality is not caught during |
4530b919 AC |
9313 | -- normal operator analysis. This is not done in preanalysis mode |
9314 | -- since the tree is not fully decorated during preanalysis. | |
996ae0b0 | 9315 | |
4530b919 AC |
9316 | if Full_Analysis then |
9317 | if Is_Fixed_Point_Type (Typ) and then Comes_From_Source (N) then | |
9318 | Error_Msg_N ("exponentiation not available for fixed point", N); | |
9319 | return; | |
4d792549 | 9320 | |
4530b919 AC |
9321 | elsif Nkind (Parent (N)) in N_Op |
9322 | and then Is_Fixed_Point_Type (Etype (Parent (N))) | |
9323 | and then Etype (N) = Universal_Real | |
9324 | and then Comes_From_Source (N) | |
9325 | then | |
9326 | Error_Msg_N ("exponentiation not available for fixed point", N); | |
9327 | return; | |
9328 | end if; | |
996ae0b0 RK |
9329 | end if; |
9330 | ||
fbf5a39b AC |
9331 | if Comes_From_Source (N) |
9332 | and then Ekind (Entity (N)) = E_Function | |
9333 | and then Is_Imported (Entity (N)) | |
9334 | and then Is_Intrinsic_Subprogram (Entity (N)) | |
9335 | then | |
9336 | Resolve_Intrinsic_Operator (N, Typ); | |
9337 | return; | |
9338 | end if; | |
9339 | ||
996ae0b0 RK |
9340 | if Etype (Left_Opnd (N)) = Universal_Integer |
9341 | or else Etype (Left_Opnd (N)) = Universal_Real | |
9342 | then | |
9343 | Check_For_Visible_Operator (N, B_Typ); | |
9344 | end if; | |
9345 | ||
9346 | -- We do the resolution using the base type, because intermediate values | |
4530b919 | 9347 | -- in expressions are always of the base type, not a subtype of it. |
996ae0b0 RK |
9348 | |
9349 | Resolve (Left_Opnd (N), B_Typ); | |
9350 | Resolve (Right_Opnd (N), Standard_Integer); | |
9351 | ||
7dbd3de9 RD |
9352 | -- For integer types, right argument must be in Natural range |
9353 | ||
9354 | if Is_Integer_Type (Typ) then | |
9355 | Apply_Scalar_Range_Check (Right_Opnd (N), Standard_Natural); | |
9356 | end if; | |
9357 | ||
996ae0b0 RK |
9358 | Check_Unset_Reference (Left_Opnd (N)); |
9359 | Check_Unset_Reference (Right_Opnd (N)); | |
9360 | ||
9361 | Set_Etype (N, B_Typ); | |
fbf5a39b | 9362 | Generate_Operator_Reference (N, B_Typ); |
dec6faf1 AC |
9363 | |
9364 | Analyze_Dimension (N); | |
9365 | ||
15954beb | 9366 | if Ada_Version >= Ada_2012 and then Has_Dimension_System (B_Typ) then |
6c57023b | 9367 | -- Evaluate the exponentiation operator for dimensioned type |
dec6faf1 | 9368 | |
6c57023b AC |
9369 | Eval_Op_Expon_For_Dimensioned_Type (N, B_Typ); |
9370 | else | |
9371 | Eval_Op_Expon (N); | |
dec6faf1 AC |
9372 | end if; |
9373 | ||
996ae0b0 RK |
9374 | -- Set overflow checking bit. Much cleverer code needed here eventually |
9375 | -- and perhaps the Resolve routines should be separated for the various | |
9376 | -- arithmetic operations, since they will need different processing. ??? | |
9377 | ||
9378 | if Nkind (N) in N_Op then | |
9379 | if not Overflow_Checks_Suppressed (Etype (N)) then | |
fbf5a39b | 9380 | Enable_Overflow_Check (N); |
996ae0b0 RK |
9381 | end if; |
9382 | end if; | |
996ae0b0 RK |
9383 | end Resolve_Op_Expon; |
9384 | ||
9385 | -------------------- | |
9386 | -- Resolve_Op_Not -- | |
9387 | -------------------- | |
9388 | ||
9389 | procedure Resolve_Op_Not (N : Node_Id; Typ : Entity_Id) is | |
9390 | B_Typ : Entity_Id; | |
9391 | ||
9392 | function Parent_Is_Boolean return Boolean; | |
5cc9353d RD |
9393 | -- This function determines if the parent node is a boolean operator or |
9394 | -- operation (comparison op, membership test, or short circuit form) and | |
9395 | -- the not in question is the left operand of this operation. Note that | |
9396 | -- if the not is in parens, then false is returned. | |
996ae0b0 | 9397 | |
aa180613 RD |
9398 | ----------------------- |
9399 | -- Parent_Is_Boolean -- | |
9400 | ----------------------- | |
9401 | ||
996ae0b0 RK |
9402 | function Parent_Is_Boolean return Boolean is |
9403 | begin | |
9404 | if Paren_Count (N) /= 0 then | |
9405 | return False; | |
9406 | ||
9407 | else | |
9408 | case Nkind (Parent (N)) is | |
d8f43ee6 HK |
9409 | when N_And_Then |
9410 | | N_In | |
9411 | | N_Not_In | |
9412 | | N_Op_And | |
9413 | | N_Op_Eq | |
9414 | | N_Op_Ge | |
9415 | | N_Op_Gt | |
9416 | | N_Op_Le | |
9417 | | N_Op_Lt | |
9418 | | N_Op_Ne | |
9419 | | N_Op_Or | |
9420 | | N_Op_Xor | |
9421 | | N_Or_Else | |
9422 | => | |
996ae0b0 RK |
9423 | return Left_Opnd (Parent (N)) = N; |
9424 | ||
9425 | when others => | |
9426 | return False; | |
9427 | end case; | |
9428 | end if; | |
9429 | end Parent_Is_Boolean; | |
9430 | ||
9431 | -- Start of processing for Resolve_Op_Not | |
9432 | ||
9433 | begin | |
758c442c GD |
9434 | -- Predefined operations on scalar types yield the base type. On the |
9435 | -- other hand, logical operations on arrays yield the type of the | |
9436 | -- arguments (and the context). | |
996ae0b0 RK |
9437 | |
9438 | if Is_Array_Type (Typ) then | |
9439 | B_Typ := Typ; | |
9440 | else | |
9441 | B_Typ := Base_Type (Typ); | |
9442 | end if; | |
9443 | ||
f3d57416 | 9444 | -- Straightforward case of incorrect arguments |
aa180613 | 9445 | |
7a5b62b0 | 9446 | if not Valid_Boolean_Arg (Typ) then |
996ae0b0 RK |
9447 | Error_Msg_N ("invalid operand type for operator&", N); |
9448 | Set_Etype (N, Any_Type); | |
9449 | return; | |
9450 | ||
aa180613 RD |
9451 | -- Special case of probable missing parens |
9452 | ||
fbf5a39b | 9453 | elsif Typ = Universal_Integer or else Typ = Any_Modular then |
996ae0b0 | 9454 | if Parent_Is_Boolean then |
ed2233dc | 9455 | Error_Msg_N |
996ae0b0 RK |
9456 | ("operand of not must be enclosed in parentheses", |
9457 | Right_Opnd (N)); | |
9458 | else | |
9459 | Error_Msg_N | |
9460 | ("no modular type available in this context", N); | |
9461 | end if; | |
9462 | ||
9463 | Set_Etype (N, Any_Type); | |
9464 | return; | |
9465 | ||
5cc9353d | 9466 | -- OK resolution of NOT |
aa180613 | 9467 | |
996ae0b0 | 9468 | else |
aa180613 RD |
9469 | -- Warn if non-boolean types involved. This is a case like not a < b |
9470 | -- where a and b are modular, where we will get (not a) < b and most | |
9471 | -- likely not (a < b) was intended. | |
9472 | ||
9473 | if Warn_On_Questionable_Missing_Parens | |
9474 | and then not Is_Boolean_Type (Typ) | |
996ae0b0 RK |
9475 | and then Parent_Is_Boolean |
9476 | then | |
324ac540 | 9477 | Error_Msg_N ("?q?not expression should be parenthesized here!", N); |
996ae0b0 RK |
9478 | end if; |
9479 | ||
09bc9ab6 RD |
9480 | -- Warn on double negation if checking redundant constructs |
9481 | ||
9482 | if Warn_On_Redundant_Constructs | |
9483 | and then Comes_From_Source (N) | |
9484 | and then Comes_From_Source (Right_Opnd (N)) | |
9485 | and then Root_Type (Typ) = Standard_Boolean | |
9486 | and then Nkind (Right_Opnd (N)) = N_Op_Not | |
9487 | then | |
324ac540 | 9488 | Error_Msg_N ("redundant double negation?r?", N); |
09bc9ab6 RD |
9489 | end if; |
9490 | ||
9491 | -- Complete resolution and evaluation of NOT | |
9492 | ||
996ae0b0 RK |
9493 | Resolve (Right_Opnd (N), B_Typ); |
9494 | Check_Unset_Reference (Right_Opnd (N)); | |
9495 | Set_Etype (N, B_Typ); | |
fbf5a39b | 9496 | Generate_Operator_Reference (N, B_Typ); |
996ae0b0 RK |
9497 | Eval_Op_Not (N); |
9498 | end if; | |
9499 | end Resolve_Op_Not; | |
9500 | ||
9501 | ----------------------------- | |
9502 | -- Resolve_Operator_Symbol -- | |
9503 | ----------------------------- | |
9504 | ||
9505 | -- Nothing to be done, all resolved already | |
9506 | ||
9507 | procedure Resolve_Operator_Symbol (N : Node_Id; Typ : Entity_Id) is | |
07fc65c4 GB |
9508 | pragma Warnings (Off, N); |
9509 | pragma Warnings (Off, Typ); | |
9510 | ||
996ae0b0 RK |
9511 | begin |
9512 | null; | |
9513 | end Resolve_Operator_Symbol; | |
9514 | ||
9515 | ---------------------------------- | |
9516 | -- Resolve_Qualified_Expression -- | |
9517 | ---------------------------------- | |
9518 | ||
9519 | procedure Resolve_Qualified_Expression (N : Node_Id; Typ : Entity_Id) is | |
07fc65c4 GB |
9520 | pragma Warnings (Off, Typ); |
9521 | ||
996ae0b0 RK |
9522 | Target_Typ : constant Entity_Id := Entity (Subtype_Mark (N)); |
9523 | Expr : constant Node_Id := Expression (N); | |
9524 | ||
9525 | begin | |
9526 | Resolve (Expr, Target_Typ); | |
9527 | ||
7b98672f YM |
9528 | -- Protect call to Matching_Static_Array_Bounds to avoid costly |
9529 | -- operation if not needed. | |
9530 | ||
6480338a | 9531 | if Restriction_Check_Required (SPARK_05) |
7b98672f | 9532 | and then Is_Array_Type (Target_Typ) |
b0186f71 | 9533 | and then Is_Array_Type (Etype (Expr)) |
db72f10a | 9534 | and then Etype (Expr) /= Any_Composite -- or else Expr in error |
b0186f71 AC |
9535 | and then not Matching_Static_Array_Bounds (Target_Typ, Etype (Expr)) |
9536 | then | |
ce5ba43a | 9537 | Check_SPARK_05_Restriction |
fe5d3068 | 9538 | ("array types should have matching static bounds", N); |
b0186f71 AC |
9539 | end if; |
9540 | ||
5cc9353d RD |
9541 | -- A qualified expression requires an exact match of the type, class- |
9542 | -- wide matching is not allowed. However, if the qualifying type is | |
9543 | -- specific and the expression has a class-wide type, it may still be | |
9544 | -- okay, since it can be the result of the expansion of a call to a | |
9545 | -- dispatching function, so we also have to check class-wideness of the | |
9546 | -- type of the expression's original node. | |
1420b484 JM |
9547 | |
9548 | if (Is_Class_Wide_Type (Target_Typ) | |
9549 | or else | |
9550 | (Is_Class_Wide_Type (Etype (Expr)) | |
9551 | and then Is_Class_Wide_Type (Etype (Original_Node (Expr))))) | |
996ae0b0 RK |
9552 | and then Base_Type (Etype (Expr)) /= Base_Type (Target_Typ) |
9553 | then | |
9554 | Wrong_Type (Expr, Target_Typ); | |
9555 | end if; | |
9556 | ||
90c63b09 AC |
9557 | -- If the target type is unconstrained, then we reset the type of the |
9558 | -- result from the type of the expression. For other cases, the actual | |
9559 | -- subtype of the expression is the target type. | |
996ae0b0 RK |
9560 | |
9561 | if Is_Composite_Type (Target_Typ) | |
9562 | and then not Is_Constrained (Target_Typ) | |
9563 | then | |
9564 | Set_Etype (N, Etype (Expr)); | |
9565 | end if; | |
9566 | ||
dec6faf1 | 9567 | Analyze_Dimension (N); |
996ae0b0 | 9568 | Eval_Qualified_Expression (N); |
6cf7eae6 AC |
9569 | |
9570 | -- If we still have a qualified expression after the static evaluation, | |
9571 | -- then apply a scalar range check if needed. The reason that we do this | |
9572 | -- after the Eval call is that otherwise, the application of the range | |
9573 | -- check may convert an illegal static expression and result in warning | |
9574 | -- rather than giving an error (e.g Integer'(Integer'Last + 1)). | |
9575 | ||
9576 | if Nkind (N) = N_Qualified_Expression and then Is_Scalar_Type (Typ) then | |
9577 | Apply_Scalar_Range_Check (Expr, Typ); | |
9578 | end if; | |
1e60643a | 9579 | |
558fbeb0 HK |
9580 | -- Finally, check whether a predicate applies to the target type. This |
9581 | -- comes from AI12-0100. As for type conversions, check the enclosing | |
9582 | -- context to prevent an infinite expansion. | |
1e60643a AC |
9583 | |
9584 | if Has_Predicates (Target_Typ) then | |
9585 | if Nkind (Parent (N)) = N_Function_Call | |
9586 | and then Present (Name (Parent (N))) | |
9587 | and then (Is_Predicate_Function (Entity (Name (Parent (N)))) | |
9588 | or else | |
9589 | Is_Predicate_Function_M (Entity (Name (Parent (N))))) | |
9590 | then | |
9591 | null; | |
9592 | ||
0026dd0a AC |
9593 | -- In the case of a qualified expression in an allocator, the check |
9594 | -- is applied when expanding the allocator, so avoid redundant check. | |
9595 | ||
9596 | elsif Nkind (N) = N_Qualified_Expression | |
9597 | and then Nkind (Parent (N)) /= N_Allocator | |
9598 | then | |
1e60643a AC |
9599 | Apply_Predicate_Check (N, Target_Typ); |
9600 | end if; | |
9601 | end if; | |
996ae0b0 RK |
9602 | end Resolve_Qualified_Expression; |
9603 | ||
7610fee8 AC |
9604 | ------------------------------ |
9605 | -- Resolve_Raise_Expression -- | |
9606 | ------------------------------ | |
9607 | ||
9608 | procedure Resolve_Raise_Expression (N : Node_Id; Typ : Entity_Id) is | |
9609 | begin | |
3e586e10 AC |
9610 | if Typ = Raise_Type then |
9611 | Error_Msg_N ("cannot find unique type for raise expression", N); | |
9612 | Set_Etype (N, Any_Type); | |
9613 | else | |
9614 | Set_Etype (N, Typ); | |
9615 | end if; | |
7610fee8 AC |
9616 | end Resolve_Raise_Expression; |
9617 | ||
996ae0b0 RK |
9618 | ------------------- |
9619 | -- Resolve_Range -- | |
9620 | ------------------- | |
9621 | ||
9622 | procedure Resolve_Range (N : Node_Id; Typ : Entity_Id) is | |
9623 | L : constant Node_Id := Low_Bound (N); | |
9624 | H : constant Node_Id := High_Bound (N); | |
9625 | ||
bd29d519 AC |
9626 | function First_Last_Ref return Boolean; |
9627 | -- Returns True if N is of the form X'First .. X'Last where X is the | |
9628 | -- same entity for both attributes. | |
9629 | ||
9630 | -------------------- | |
9631 | -- First_Last_Ref -- | |
9632 | -------------------- | |
9633 | ||
9634 | function First_Last_Ref return Boolean is | |
9635 | Lorig : constant Node_Id := Original_Node (L); | |
9636 | Horig : constant Node_Id := Original_Node (H); | |
9637 | ||
9638 | begin | |
9639 | if Nkind (Lorig) = N_Attribute_Reference | |
9640 | and then Nkind (Horig) = N_Attribute_Reference | |
9641 | and then Attribute_Name (Lorig) = Name_First | |
9642 | and then Attribute_Name (Horig) = Name_Last | |
9643 | then | |
9644 | declare | |
9645 | PL : constant Node_Id := Prefix (Lorig); | |
9646 | PH : constant Node_Id := Prefix (Horig); | |
9647 | begin | |
9648 | if Is_Entity_Name (PL) | |
9649 | and then Is_Entity_Name (PH) | |
9650 | and then Entity (PL) = Entity (PH) | |
9651 | then | |
9652 | return True; | |
9653 | end if; | |
9654 | end; | |
9655 | end if; | |
9656 | ||
9657 | return False; | |
9658 | end First_Last_Ref; | |
9659 | ||
9660 | -- Start of processing for Resolve_Range | |
9661 | ||
996ae0b0 RK |
9662 | begin |
9663 | Set_Etype (N, Typ); | |
6d67bea9 AC |
9664 | |
9665 | -- The lower bound should be in Typ. The higher bound can be in Typ's | |
9666 | -- base type if the range is null. It may still be invalid if it is | |
9667 | -- higher than the lower bound. This is checked later in the context in | |
9668 | -- which the range appears. | |
9669 | ||
996ae0b0 | 9670 | Resolve (L, Typ); |
6d67bea9 | 9671 | Resolve (H, Base_Type (Typ)); |
996ae0b0 | 9672 | |
bd29d519 AC |
9673 | -- Check for inappropriate range on unordered enumeration type |
9674 | ||
9675 | if Bad_Unordered_Enumeration_Reference (N, Typ) | |
9676 | ||
9677 | -- Exclude X'First .. X'Last if X is the same entity for both | |
9678 | ||
9679 | and then not First_Last_Ref | |
9680 | then | |
b1d12996 AC |
9681 | Error_Msg_Sloc := Sloc (Typ); |
9682 | Error_Msg_NE | |
9683 | ("subrange of unordered enumeration type& declared#?U?", N, Typ); | |
498d1b80 AC |
9684 | end if; |
9685 | ||
996ae0b0 RK |
9686 | Check_Unset_Reference (L); |
9687 | Check_Unset_Reference (H); | |
9688 | ||
9689 | -- We have to check the bounds for being within the base range as | |
758c442c GD |
9690 | -- required for a non-static context. Normally this is automatic and |
9691 | -- done as part of evaluating expressions, but the N_Range node is an | |
9692 | -- exception, since in GNAT we consider this node to be a subexpression, | |
9693 | -- even though in Ada it is not. The circuit in Sem_Eval could check for | |
9694 | -- this, but that would put the test on the main evaluation path for | |
9695 | -- expressions. | |
996ae0b0 RK |
9696 | |
9697 | Check_Non_Static_Context (L); | |
9698 | Check_Non_Static_Context (H); | |
9699 | ||
b7d1f17f HK |
9700 | -- Check for an ambiguous range over character literals. This will |
9701 | -- happen with a membership test involving only literals. | |
9702 | ||
9703 | if Typ = Any_Character then | |
9704 | Ambiguous_Character (L); | |
9705 | Set_Etype (N, Any_Type); | |
9706 | return; | |
9707 | end if; | |
9708 | ||
5cc9353d RD |
9709 | -- If bounds are static, constant-fold them, so size computations are |
9710 | -- identical between front-end and back-end. Do not perform this | |
fbf5a39b | 9711 | -- transformation while analyzing generic units, as type information |
5cc9353d | 9712 | -- would be lost when reanalyzing the constant node in the instance. |
fbf5a39b | 9713 | |
4460a9bc | 9714 | if Is_Discrete_Type (Typ) and then Expander_Active then |
fbf5a39b | 9715 | if Is_OK_Static_Expression (L) then |
edab6088 | 9716 | Fold_Uint (L, Expr_Value (L), Is_OK_Static_Expression (L)); |
fbf5a39b AC |
9717 | end if; |
9718 | ||
9719 | if Is_OK_Static_Expression (H) then | |
edab6088 | 9720 | Fold_Uint (H, Expr_Value (H), Is_OK_Static_Expression (H)); |
fbf5a39b AC |
9721 | end if; |
9722 | end if; | |
996ae0b0 RK |
9723 | end Resolve_Range; |
9724 | ||
9725 | -------------------------- | |
9726 | -- Resolve_Real_Literal -- | |
9727 | -------------------------- | |
9728 | ||
9729 | procedure Resolve_Real_Literal (N : Node_Id; Typ : Entity_Id) is | |
9730 | Actual_Typ : constant Entity_Id := Etype (N); | |
9731 | ||
9732 | begin | |
9733 | -- Special processing for fixed-point literals to make sure that the | |
5cc9353d RD |
9734 | -- value is an exact multiple of small where this is required. We skip |
9735 | -- this for the universal real case, and also for generic types. | |
996ae0b0 RK |
9736 | |
9737 | if Is_Fixed_Point_Type (Typ) | |
9738 | and then Typ /= Universal_Fixed | |
9739 | and then Typ /= Any_Fixed | |
9740 | and then not Is_Generic_Type (Typ) | |
9741 | then | |
9742 | declare | |
9743 | Val : constant Ureal := Realval (N); | |
9744 | Cintr : constant Ureal := Val / Small_Value (Typ); | |
9745 | Cint : constant Uint := UR_Trunc (Cintr); | |
9746 | Den : constant Uint := Norm_Den (Cintr); | |
9747 | Stat : Boolean; | |
9748 | ||
9749 | begin | |
9750 | -- Case of literal is not an exact multiple of the Small | |
9751 | ||
9752 | if Den /= 1 then | |
9753 | ||
5cc9353d RD |
9754 | -- For a source program literal for a decimal fixed-point type, |
9755 | -- this is statically illegal (RM 4.9(36)). | |
996ae0b0 RK |
9756 | |
9757 | if Is_Decimal_Fixed_Point_Type (Typ) | |
9758 | and then Actual_Typ = Universal_Real | |
9759 | and then Comes_From_Source (N) | |
9760 | then | |
9761 | Error_Msg_N ("value has extraneous low order digits", N); | |
9762 | end if; | |
9763 | ||
bc5f3720 RD |
9764 | -- Generate a warning if literal from source |
9765 | ||
edab6088 | 9766 | if Is_OK_Static_Expression (N) |
bc5f3720 RD |
9767 | and then Warn_On_Bad_Fixed_Value |
9768 | then | |
9769 | Error_Msg_N | |
324ac540 | 9770 | ("?b?static fixed-point value is not a multiple of Small!", |
bc5f3720 RD |
9771 | N); |
9772 | end if; | |
9773 | ||
996ae0b0 RK |
9774 | -- Replace literal by a value that is the exact representation |
9775 | -- of a value of the type, i.e. a multiple of the small value, | |
9776 | -- by truncation, since Machine_Rounds is false for all GNAT | |
9777 | -- fixed-point types (RM 4.9(38)). | |
9778 | ||
edab6088 | 9779 | Stat := Is_OK_Static_Expression (N); |
996ae0b0 RK |
9780 | Rewrite (N, |
9781 | Make_Real_Literal (Sloc (N), | |
9782 | Realval => Small_Value (Typ) * Cint)); | |
9783 | ||
9784 | Set_Is_Static_Expression (N, Stat); | |
9785 | end if; | |
9786 | ||
9787 | -- In all cases, set the corresponding integer field | |
9788 | ||
9789 | Set_Corresponding_Integer_Value (N, Cint); | |
9790 | end; | |
9791 | end if; | |
9792 | ||
9793 | -- Now replace the actual type by the expected type as usual | |
9794 | ||
9795 | Set_Etype (N, Typ); | |
9796 | Eval_Real_Literal (N); | |
9797 | end Resolve_Real_Literal; | |
9798 | ||
9799 | ----------------------- | |
9800 | -- Resolve_Reference -- | |
9801 | ----------------------- | |
9802 | ||
9803 | procedure Resolve_Reference (N : Node_Id; Typ : Entity_Id) is | |
9804 | P : constant Node_Id := Prefix (N); | |
9805 | ||
9806 | begin | |
9807 | -- Replace general access with specific type | |
9808 | ||
9809 | if Ekind (Etype (N)) = E_Allocator_Type then | |
9810 | Set_Etype (N, Base_Type (Typ)); | |
9811 | end if; | |
9812 | ||
9813 | Resolve (P, Designated_Type (Etype (N))); | |
9814 | ||
5cc9353d RD |
9815 | -- If we are taking the reference of a volatile entity, then treat it as |
9816 | -- a potential modification of this entity. This is too conservative, | |
9817 | -- but necessary because remove side effects can cause transformations | |
9818 | -- of normal assignments into reference sequences that otherwise fail to | |
9819 | -- notice the modification. | |
996ae0b0 | 9820 | |
fbf5a39b | 9821 | if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then |
45fc7ddb | 9822 | Note_Possible_Modification (P, Sure => False); |
996ae0b0 RK |
9823 | end if; |
9824 | end Resolve_Reference; | |
9825 | ||
9826 | -------------------------------- | |
9827 | -- Resolve_Selected_Component -- | |
9828 | -------------------------------- | |
9829 | ||
9830 | procedure Resolve_Selected_Component (N : Node_Id; Typ : Entity_Id) is | |
9831 | Comp : Entity_Id; | |
9832 | Comp1 : Entity_Id := Empty; -- prevent junk warning | |
c2a2dbcc | 9833 | P : constant Node_Id := Prefix (N); |
996ae0b0 RK |
9834 | S : constant Node_Id := Selector_Name (N); |
9835 | T : Entity_Id := Etype (P); | |
9836 | I : Interp_Index; | |
9837 | I1 : Interp_Index := 0; -- prevent junk warning | |
9838 | It : Interp; | |
9839 | It1 : Interp; | |
9840 | Found : Boolean; | |
9841 | ||
6510f4c9 GB |
9842 | function Init_Component return Boolean; |
9843 | -- Check whether this is the initialization of a component within an | |
fbf5a39b | 9844 | -- init proc (by assignment or call to another init proc). If true, |
6510f4c9 GB |
9845 | -- there is no need for a discriminant check. |
9846 | ||
9847 | -------------------- | |
9848 | -- Init_Component -- | |
9849 | -------------------- | |
9850 | ||
9851 | function Init_Component return Boolean is | |
9852 | begin | |
9853 | return Inside_Init_Proc | |
9854 | and then Nkind (Prefix (N)) = N_Identifier | |
9855 | and then Chars (Prefix (N)) = Name_uInit | |
9856 | and then Nkind (Parent (Parent (N))) = N_Case_Statement_Alternative; | |
9857 | end Init_Component; | |
9858 | ||
9859 | -- Start of processing for Resolve_Selected_Component | |
9860 | ||
996ae0b0 RK |
9861 | begin |
9862 | if Is_Overloaded (P) then | |
9863 | ||
9864 | -- Use the context type to select the prefix that has a selector | |
9865 | -- of the correct name and type. | |
9866 | ||
9867 | Found := False; | |
9868 | Get_First_Interp (P, I, It); | |
9869 | ||
9870 | Search : while Present (It.Typ) loop | |
9871 | if Is_Access_Type (It.Typ) then | |
9872 | T := Designated_Type (It.Typ); | |
9873 | else | |
9874 | T := It.Typ; | |
9875 | end if; | |
9876 | ||
95eb8b69 AC |
9877 | -- Locate selected component. For a private prefix the selector |
9878 | -- can denote a discriminant. | |
9879 | ||
9880 | if Is_Record_Type (T) or else Is_Private_Type (T) then | |
36fcf362 RD |
9881 | |
9882 | -- The visible components of a class-wide type are those of | |
9883 | -- the root type. | |
9884 | ||
9885 | if Is_Class_Wide_Type (T) then | |
9886 | T := Etype (T); | |
9887 | end if; | |
9888 | ||
996ae0b0 | 9889 | Comp := First_Entity (T); |
996ae0b0 | 9890 | while Present (Comp) loop |
996ae0b0 | 9891 | if Chars (Comp) = Chars (S) |
dda38714 | 9892 | and then Covers (Typ, Etype (Comp)) |
996ae0b0 RK |
9893 | then |
9894 | if not Found then | |
9895 | Found := True; | |
9896 | I1 := I; | |
9897 | It1 := It; | |
9898 | Comp1 := Comp; | |
9899 | ||
9900 | else | |
9901 | It := Disambiguate (P, I1, I, Any_Type); | |
9902 | ||
9903 | if It = No_Interp then | |
9904 | Error_Msg_N | |
9905 | ("ambiguous prefix for selected component", N); | |
9906 | Set_Etype (N, Typ); | |
9907 | return; | |
9908 | ||
9909 | else | |
9910 | It1 := It; | |
9911 | ||
c8ef728f ES |
9912 | -- There may be an implicit dereference. Retrieve |
9913 | -- designated record type. | |
9914 | ||
9915 | if Is_Access_Type (It1.Typ) then | |
9916 | T := Designated_Type (It1.Typ); | |
9917 | else | |
9918 | T := It1.Typ; | |
9919 | end if; | |
9920 | ||
9921 | if Scope (Comp1) /= T then | |
996ae0b0 RK |
9922 | |
9923 | -- Resolution chooses the new interpretation. | |
9924 | -- Find the component with the right name. | |
9925 | ||
c8ef728f | 9926 | Comp1 := First_Entity (T); |
996ae0b0 RK |
9927 | while Present (Comp1) |
9928 | and then Chars (Comp1) /= Chars (S) | |
9929 | loop | |
9930 | Comp1 := Next_Entity (Comp1); | |
9931 | end loop; | |
9932 | end if; | |
9933 | ||
9934 | exit Search; | |
9935 | end if; | |
9936 | end if; | |
9937 | end if; | |
9938 | ||
9939 | Comp := Next_Entity (Comp); | |
9940 | end loop; | |
996ae0b0 RK |
9941 | end if; |
9942 | ||
9943 | Get_Next_Interp (I, It); | |
996ae0b0 RK |
9944 | end loop Search; |
9945 | ||
9926efec | 9946 | -- There must be a legal interpretation at this point |
dda38714 AC |
9947 | |
9948 | pragma Assert (Found); | |
996ae0b0 RK |
9949 | Resolve (P, It1.Typ); |
9950 | Set_Etype (N, Typ); | |
e7ba564f | 9951 | Set_Entity_With_Checks (S, Comp1); |
996ae0b0 RK |
9952 | |
9953 | else | |
fbf5a39b | 9954 | -- Resolve prefix with its type |
996ae0b0 RK |
9955 | |
9956 | Resolve (P, T); | |
9957 | end if; | |
9958 | ||
aa180613 RD |
9959 | -- Generate cross-reference. We needed to wait until full overloading |
9960 | -- resolution was complete to do this, since otherwise we can't tell if | |
01e17342 | 9961 | -- we are an lvalue or not. |
aa180613 RD |
9962 | |
9963 | if May_Be_Lvalue (N) then | |
9964 | Generate_Reference (Entity (S), S, 'm'); | |
9965 | else | |
9966 | Generate_Reference (Entity (S), S, 'r'); | |
9967 | end if; | |
9968 | ||
c8ef728f ES |
9969 | -- If prefix is an access type, the node will be transformed into an |
9970 | -- explicit dereference during expansion. The type of the node is the | |
9971 | -- designated type of that of the prefix. | |
996ae0b0 RK |
9972 | |
9973 | if Is_Access_Type (Etype (P)) then | |
996ae0b0 | 9974 | T := Designated_Type (Etype (P)); |
c8ef728f | 9975 | Check_Fully_Declared_Prefix (T, P); |
996ae0b0 RK |
9976 | else |
9977 | T := Etype (P); | |
9978 | end if; | |
9979 | ||
c386239f AC |
9980 | -- Set flag for expander if discriminant check required on a component |
9981 | -- appearing within a variant. | |
ef1c0511 | 9982 | |
996ae0b0 | 9983 | if Has_Discriminants (T) |
1b1d88b1 | 9984 | and then Ekind (Entity (S)) = E_Component |
996ae0b0 RK |
9985 | and then Present (Original_Record_Component (Entity (S))) |
9986 | and then Ekind (Original_Record_Component (Entity (S))) = E_Component | |
c96c518f AC |
9987 | and then |
9988 | Is_Declared_Within_Variant (Original_Record_Component (Entity (S))) | |
996ae0b0 | 9989 | and then not Discriminant_Checks_Suppressed (T) |
6510f4c9 | 9990 | and then not Init_Component |
996ae0b0 RK |
9991 | then |
9992 | Set_Do_Discriminant_Check (N); | |
9993 | end if; | |
9994 | ||
9995 | if Ekind (Entity (S)) = E_Void then | |
9996 | Error_Msg_N ("premature use of component", S); | |
9997 | end if; | |
9998 | ||
9999 | -- If the prefix is a record conversion, this may be a renamed | |
10000 | -- discriminant whose bounds differ from those of the original | |
10001 | -- one, so we must ensure that a range check is performed. | |
10002 | ||
10003 | if Nkind (P) = N_Type_Conversion | |
10004 | and then Ekind (Entity (S)) = E_Discriminant | |
fbf5a39b | 10005 | and then Is_Discrete_Type (Typ) |
996ae0b0 RK |
10006 | then |
10007 | Set_Etype (N, Base_Type (Typ)); | |
10008 | end if; | |
10009 | ||
10010 | -- Note: No Eval processing is required, because the prefix is of a | |
10011 | -- record type, or protected type, and neither can possibly be static. | |
10012 | ||
c2a2dbcc RD |
10013 | -- If the record type is atomic, and the component is non-atomic, then |
10014 | -- this is worth a warning, since we have a situation where the access | |
10015 | -- to the component may cause extra read/writes of the atomic array | |
10016 | -- object, or partial word accesses, both of which may be unexpected. | |
c28408b7 RD |
10017 | |
10018 | if Nkind (N) = N_Selected_Component | |
c2a2dbcc RD |
10019 | and then Is_Atomic_Ref_With_Address (N) |
10020 | and then not Is_Atomic (Entity (S)) | |
10021 | and then not Is_Atomic (Etype (Entity (S))) | |
c28408b7 | 10022 | then |
54c04d6c | 10023 | Error_Msg_N |
c2a2dbcc RD |
10024 | ("??access to non-atomic component of atomic record", |
10025 | Prefix (N)); | |
54c04d6c | 10026 | Error_Msg_N |
c2a2dbcc RD |
10027 | ("\??may cause unexpected accesses to atomic object", |
10028 | Prefix (N)); | |
c28408b7 | 10029 | end if; |
54c04d6c | 10030 | |
dec6faf1 | 10031 | Analyze_Dimension (N); |
996ae0b0 RK |
10032 | end Resolve_Selected_Component; |
10033 | ||
10034 | ------------------- | |
10035 | -- Resolve_Shift -- | |
10036 | ------------------- | |
10037 | ||
10038 | procedure Resolve_Shift (N : Node_Id; Typ : Entity_Id) is | |
10039 | B_Typ : constant Entity_Id := Base_Type (Typ); | |
10040 | L : constant Node_Id := Left_Opnd (N); | |
10041 | R : constant Node_Id := Right_Opnd (N); | |
10042 | ||
10043 | begin | |
10044 | -- We do the resolution using the base type, because intermediate values | |
10045 | -- in expressions always are of the base type, not a subtype of it. | |
10046 | ||
10047 | Resolve (L, B_Typ); | |
10048 | Resolve (R, Standard_Natural); | |
10049 | ||
10050 | Check_Unset_Reference (L); | |
10051 | Check_Unset_Reference (R); | |
10052 | ||
10053 | Set_Etype (N, B_Typ); | |
fbf5a39b | 10054 | Generate_Operator_Reference (N, B_Typ); |
996ae0b0 RK |
10055 | Eval_Shift (N); |
10056 | end Resolve_Shift; | |
10057 | ||
10058 | --------------------------- | |
10059 | -- Resolve_Short_Circuit -- | |
10060 | --------------------------- | |
10061 | ||
10062 | procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id) is | |
10063 | B_Typ : constant Entity_Id := Base_Type (Typ); | |
10064 | L : constant Node_Id := Left_Opnd (N); | |
10065 | R : constant Node_Id := Right_Opnd (N); | |
10066 | ||
10067 | begin | |
064f4527 | 10068 | -- Ensure all actions associated with the left operand (e.g. |
937e9676 AC |
10069 | -- finalization of transient objects) are fully evaluated locally within |
10070 | -- an expression with actions. This is particularly helpful for coverage | |
10071 | -- analysis. However this should not happen in generics or if option | |
10072 | -- Minimize_Expression_With_Actions is set. | |
064f4527 | 10073 | |
f916243b | 10074 | if Expander_Active and not Minimize_Expression_With_Actions then |
064f4527 TQ |
10075 | declare |
10076 | Reloc_L : constant Node_Id := Relocate_Node (L); | |
10077 | begin | |
10078 | Save_Interps (Old_N => L, New_N => Reloc_L); | |
10079 | ||
10080 | Rewrite (L, | |
10081 | Make_Expression_With_Actions (Sloc (L), | |
10082 | Actions => New_List, | |
10083 | Expression => Reloc_L)); | |
10084 | ||
10085 | -- Set Comes_From_Source on L to preserve warnings for unset | |
10086 | -- reference. | |
10087 | ||
10088 | Set_Comes_From_Source (L, Comes_From_Source (Reloc_L)); | |
10089 | end; | |
10090 | end if; | |
10091 | ||
996ae0b0 RK |
10092 | Resolve (L, B_Typ); |
10093 | Resolve (R, B_Typ); | |
10094 | ||
45fc7ddb HK |
10095 | -- Check for issuing warning for always False assert/check, this happens |
10096 | -- when assertions are turned off, in which case the pragma Assert/Check | |
36fcf362 RD |
10097 | -- was transformed into: |
10098 | ||
10099 | -- if False and then <condition> then ... | |
10100 | ||
10101 | -- and we detect this pattern | |
10102 | ||
10103 | if Warn_On_Assertion_Failure | |
10104 | and then Is_Entity_Name (R) | |
10105 | and then Entity (R) = Standard_False | |
10106 | and then Nkind (Parent (N)) = N_If_Statement | |
10107 | and then Nkind (N) = N_And_Then | |
10108 | and then Is_Entity_Name (L) | |
10109 | and then Entity (L) = Standard_False | |
10110 | then | |
10111 | declare | |
10112 | Orig : constant Node_Id := Original_Node (Parent (N)); | |
45fc7ddb | 10113 | |
36fcf362 | 10114 | begin |
20a65dcb RD |
10115 | -- Special handling of Asssert pragma |
10116 | ||
36fcf362 | 10117 | if Nkind (Orig) = N_Pragma |
6e759c2a | 10118 | and then Pragma_Name (Orig) = Name_Assert |
36fcf362 | 10119 | then |
36fcf362 RD |
10120 | declare |
10121 | Expr : constant Node_Id := | |
10122 | Original_Node | |
10123 | (Expression | |
10124 | (First (Pragma_Argument_Associations (Orig)))); | |
20a65dcb | 10125 | |
36fcf362 | 10126 | begin |
20a65dcb RD |
10127 | -- Don't warn if original condition is explicit False, |
10128 | -- since obviously the failure is expected in this case. | |
10129 | ||
36fcf362 RD |
10130 | if Is_Entity_Name (Expr) |
10131 | and then Entity (Expr) = Standard_False | |
10132 | then | |
10133 | null; | |
51bf9bdf | 10134 | |
20a65dcb RD |
10135 | -- Issue warning. We do not want the deletion of the |
10136 | -- IF/AND-THEN to take this message with it. We achieve this | |
10137 | -- by making sure that the expanded code points to the Sloc | |
10138 | -- of the expression, not the original pragma. | |
10139 | ||
10140 | else | |
8a06151a RD |
10141 | -- Note: Use Error_Msg_F here rather than Error_Msg_N. |
10142 | -- The source location of the expression is not usually | |
10143 | -- the best choice here. For example, it gets located on | |
10144 | -- the last AND keyword in a chain of boolean expressiond | |
10145 | -- AND'ed together. It is best to put the message on the | |
10146 | -- first character of the assertion, which is the effect | |
10147 | -- of the First_Node call here. | |
10148 | ||
ca20a08e | 10149 | Error_Msg_F |
685bc70f | 10150 | ("?A?assertion would fail at run time!", |
51bf9bdf AC |
10151 | Expression |
10152 | (First (Pragma_Argument_Associations (Orig)))); | |
36fcf362 RD |
10153 | end if; |
10154 | end; | |
45fc7ddb HK |
10155 | |
10156 | -- Similar processing for Check pragma | |
10157 | ||
10158 | elsif Nkind (Orig) = N_Pragma | |
6e759c2a | 10159 | and then Pragma_Name (Orig) = Name_Check |
45fc7ddb HK |
10160 | then |
10161 | -- Don't want to warn if original condition is explicit False | |
10162 | ||
10163 | declare | |
10164 | Expr : constant Node_Id := | |
324ac540 AC |
10165 | Original_Node |
10166 | (Expression | |
10167 | (Next (First (Pragma_Argument_Associations (Orig))))); | |
45fc7ddb HK |
10168 | begin |
10169 | if Is_Entity_Name (Expr) | |
10170 | and then Entity (Expr) = Standard_False | |
10171 | then | |
10172 | null; | |
8a06151a RD |
10173 | |
10174 | -- Post warning | |
10175 | ||
45fc7ddb | 10176 | else |
8a06151a RD |
10177 | -- Again use Error_Msg_F rather than Error_Msg_N, see |
10178 | -- comment above for an explanation of why we do this. | |
10179 | ||
ca20a08e | 10180 | Error_Msg_F |
685bc70f | 10181 | ("?A?check would fail at run time!", |
51bf9bdf AC |
10182 | Expression |
10183 | (Last (Pragma_Argument_Associations (Orig)))); | |
45fc7ddb HK |
10184 | end if; |
10185 | end; | |
36fcf362 RD |
10186 | end if; |
10187 | end; | |
10188 | end if; | |
10189 | ||
10190 | -- Continue with processing of short circuit | |
10191 | ||
996ae0b0 RK |
10192 | Check_Unset_Reference (L); |
10193 | Check_Unset_Reference (R); | |
10194 | ||
10195 | Set_Etype (N, B_Typ); | |
10196 | Eval_Short_Circuit (N); | |
10197 | end Resolve_Short_Circuit; | |
10198 | ||
10199 | ------------------- | |
10200 | -- Resolve_Slice -- | |
10201 | ------------------- | |
10202 | ||
10203 | procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id) is | |
996ae0b0 | 10204 | Drange : constant Node_Id := Discrete_Range (N); |
5f44f0d4 | 10205 | Name : constant Node_Id := Prefix (N); |
996ae0b0 | 10206 | Array_Type : Entity_Id := Empty; |
800da977 | 10207 | Dexpr : Node_Id := Empty; |
5f44f0d4 | 10208 | Index_Type : Entity_Id; |
996ae0b0 RK |
10209 | |
10210 | begin | |
10211 | if Is_Overloaded (Name) then | |
10212 | ||
d81b4bfe TQ |
10213 | -- Use the context type to select the prefix that yields the correct |
10214 | -- array type. | |
996ae0b0 RK |
10215 | |
10216 | declare | |
10217 | I : Interp_Index; | |
10218 | I1 : Interp_Index := 0; | |
10219 | It : Interp; | |
10220 | P : constant Node_Id := Prefix (N); | |
10221 | Found : Boolean := False; | |
10222 | ||
10223 | begin | |
10224 | Get_First_Interp (P, I, It); | |
996ae0b0 | 10225 | while Present (It.Typ) loop |
996ae0b0 RK |
10226 | if (Is_Array_Type (It.Typ) |
10227 | and then Covers (Typ, It.Typ)) | |
10228 | or else (Is_Access_Type (It.Typ) | |
10229 | and then Is_Array_Type (Designated_Type (It.Typ)) | |
10230 | and then Covers (Typ, Designated_Type (It.Typ))) | |
10231 | then | |
10232 | if Found then | |
10233 | It := Disambiguate (P, I1, I, Any_Type); | |
10234 | ||
10235 | if It = No_Interp then | |
10236 | Error_Msg_N ("ambiguous prefix for slicing", N); | |
10237 | Set_Etype (N, Typ); | |
10238 | return; | |
10239 | else | |
10240 | Found := True; | |
10241 | Array_Type := It.Typ; | |
10242 | I1 := I; | |
10243 | end if; | |
10244 | else | |
10245 | Found := True; | |
10246 | Array_Type := It.Typ; | |
10247 | I1 := I; | |
10248 | end if; | |
10249 | end if; | |
10250 | ||
10251 | Get_Next_Interp (I, It); | |
10252 | end loop; | |
10253 | end; | |
10254 | ||
10255 | else | |
10256 | Array_Type := Etype (Name); | |
10257 | end if; | |
10258 | ||
10259 | Resolve (Name, Array_Type); | |
10260 | ||
10261 | if Is_Access_Type (Array_Type) then | |
10262 | Apply_Access_Check (N); | |
10263 | Array_Type := Designated_Type (Array_Type); | |
10264 | ||
c8ef728f ES |
10265 | -- If the prefix is an access to an unconstrained array, we must use |
10266 | -- the actual subtype of the object to perform the index checks. The | |
10267 | -- object denoted by the prefix is implicit in the node, so we build | |
10268 | -- an explicit representation for it in order to compute the actual | |
10269 | -- subtype. | |
82c80734 RD |
10270 | |
10271 | if not Is_Constrained (Array_Type) then | |
10272 | Remove_Side_Effects (Prefix (N)); | |
10273 | ||
10274 | declare | |
10275 | Obj : constant Node_Id := | |
10276 | Make_Explicit_Dereference (Sloc (N), | |
10277 | Prefix => New_Copy_Tree (Prefix (N))); | |
10278 | begin | |
10279 | Set_Etype (Obj, Array_Type); | |
10280 | Set_Parent (Obj, Parent (N)); | |
10281 | Array_Type := Get_Actual_Subtype (Obj); | |
10282 | end; | |
10283 | end if; | |
10284 | ||
996ae0b0 | 10285 | elsif Is_Entity_Name (Name) |
6c994759 | 10286 | or else Nkind (Name) = N_Explicit_Dereference |
996ae0b0 RK |
10287 | or else (Nkind (Name) = N_Function_Call |
10288 | and then not Is_Constrained (Etype (Name))) | |
10289 | then | |
10290 | Array_Type := Get_Actual_Subtype (Name); | |
aa5147f0 ES |
10291 | |
10292 | -- If the name is a selected component that depends on discriminants, | |
10293 | -- build an actual subtype for it. This can happen only when the name | |
10294 | -- itself is overloaded; otherwise the actual subtype is created when | |
10295 | -- the selected component is analyzed. | |
10296 | ||
10297 | elsif Nkind (Name) = N_Selected_Component | |
10298 | and then Full_Analysis | |
10299 | and then Depends_On_Discriminant (First_Index (Array_Type)) | |
10300 | then | |
10301 | declare | |
10302 | Act_Decl : constant Node_Id := | |
10303 | Build_Actual_Subtype_Of_Component (Array_Type, Name); | |
10304 | begin | |
10305 | Insert_Action (N, Act_Decl); | |
10306 | Array_Type := Defining_Identifier (Act_Decl); | |
10307 | end; | |
d79e621a GD |
10308 | |
10309 | -- Maybe this should just be "else", instead of checking for the | |
5cc9353d RD |
10310 | -- specific case of slice??? This is needed for the case where the |
10311 | -- prefix is an Image attribute, which gets expanded to a slice, and so | |
10312 | -- has a constrained subtype which we want to use for the slice range | |
10313 | -- check applied below (the range check won't get done if the | |
10314 | -- unconstrained subtype of the 'Image is used). | |
d79e621a GD |
10315 | |
10316 | elsif Nkind (Name) = N_Slice then | |
10317 | Array_Type := Etype (Name); | |
996ae0b0 RK |
10318 | end if; |
10319 | ||
800da977 AC |
10320 | -- Obtain the type of the array index |
10321 | ||
10322 | if Ekind (Array_Type) = E_String_Literal_Subtype then | |
10323 | Index_Type := Etype (String_Literal_Low_Bound (Array_Type)); | |
10324 | else | |
10325 | Index_Type := Etype (First_Index (Array_Type)); | |
10326 | end if; | |
10327 | ||
996ae0b0 RK |
10328 | -- If name was overloaded, set slice type correctly now |
10329 | ||
10330 | Set_Etype (N, Array_Type); | |
10331 | ||
800da977 AC |
10332 | -- Handle the generation of a range check that compares the array index |
10333 | -- against the discrete_range. The check is not applied to internally | |
10334 | -- built nodes associated with the expansion of dispatch tables. Check | |
10335 | -- that Ada.Tags has already been loaded to avoid extra dependencies on | |
10336 | -- the unit. | |
10337 | ||
10338 | if Tagged_Type_Expansion | |
10339 | and then RTU_Loaded (Ada_Tags) | |
10340 | and then Nkind (Prefix (N)) = N_Selected_Component | |
10341 | and then Present (Entity (Selector_Name (Prefix (N)))) | |
10342 | and then Entity (Selector_Name (Prefix (N))) = | |
10343 | RTE_Record_Component (RE_Prims_Ptr) | |
10344 | then | |
10345 | null; | |
996ae0b0 | 10346 | |
800da977 AC |
10347 | -- The discrete_range is specified by a subtype indication. Create a |
10348 | -- shallow copy and inherit the type, parent and source location from | |
10349 | -- the discrete_range. This ensures that the range check is inserted | |
10350 | -- relative to the slice and that the runtime exception points to the | |
10351 | -- proper construct. | |
5f44f0d4 | 10352 | |
800da977 AC |
10353 | elsif Is_Entity_Name (Drange) then |
10354 | Dexpr := New_Copy (Scalar_Range (Entity (Drange))); | |
996ae0b0 | 10355 | |
800da977 AC |
10356 | Set_Etype (Dexpr, Etype (Drange)); |
10357 | Set_Parent (Dexpr, Parent (Drange)); | |
10358 | Set_Sloc (Dexpr, Sloc (Drange)); | |
dbe945f1 | 10359 | |
800da977 AC |
10360 | -- The discrete_range is a regular range. Resolve the bounds and remove |
10361 | -- their side effects. | |
dbe945f1 | 10362 | |
800da977 AC |
10363 | else |
10364 | Resolve (Drange, Base_Type (Index_Type)); | |
10365 | ||
10366 | if Nkind (Drange) = N_Range then | |
10367 | Force_Evaluation (Low_Bound (Drange)); | |
cae81f17 | 10368 | Force_Evaluation (High_Bound (Drange)); |
0669bebe | 10369 | |
800da977 | 10370 | Dexpr := Drange; |
996ae0b0 RK |
10371 | end if; |
10372 | end if; | |
10373 | ||
800da977 AC |
10374 | if Present (Dexpr) then |
10375 | Apply_Range_Check (Dexpr, Index_Type); | |
10376 | end if; | |
10377 | ||
996ae0b0 | 10378 | Set_Slice_Subtype (N); |
aa180613 | 10379 | |
ea034236 AC |
10380 | -- Check bad use of type with predicates |
10381 | ||
24de083f AC |
10382 | declare |
10383 | Subt : Entity_Id; | |
10384 | ||
10385 | begin | |
10386 | if Nkind (Drange) = N_Subtype_Indication | |
b330e3c8 | 10387 | and then Has_Predicates (Entity (Subtype_Mark (Drange))) |
24de083f AC |
10388 | then |
10389 | Subt := Entity (Subtype_Mark (Drange)); | |
24de083f AC |
10390 | else |
10391 | Subt := Etype (Drange); | |
10392 | end if; | |
10393 | ||
10394 | if Has_Predicates (Subt) then | |
10395 | Bad_Predicated_Subtype_Use | |
10396 | ("subtype& has predicate, not allowed in slice", Drange, Subt); | |
10397 | end if; | |
10398 | end; | |
ea034236 AC |
10399 | |
10400 | -- Otherwise here is where we check suspicious indexes | |
10401 | ||
24de083f | 10402 | if Nkind (Drange) = N_Range then |
aa180613 RD |
10403 | Warn_On_Suspicious_Index (Name, Low_Bound (Drange)); |
10404 | Warn_On_Suspicious_Index (Name, High_Bound (Drange)); | |
10405 | end if; | |
10406 | ||
dec6faf1 | 10407 | Analyze_Dimension (N); |
996ae0b0 | 10408 | Eval_Slice (N); |
996ae0b0 RK |
10409 | end Resolve_Slice; |
10410 | ||
10411 | ---------------------------- | |
10412 | -- Resolve_String_Literal -- | |
10413 | ---------------------------- | |
10414 | ||
10415 | procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id) is | |
10416 | C_Typ : constant Entity_Id := Component_Type (Typ); | |
10417 | R_Typ : constant Entity_Id := Root_Type (C_Typ); | |
10418 | Loc : constant Source_Ptr := Sloc (N); | |
10419 | Str : constant String_Id := Strval (N); | |
10420 | Strlen : constant Nat := String_Length (Str); | |
10421 | Subtype_Id : Entity_Id; | |
10422 | Need_Check : Boolean; | |
10423 | ||
10424 | begin | |
10425 | -- For a string appearing in a concatenation, defer creation of the | |
10426 | -- string_literal_subtype until the end of the resolution of the | |
c8ef728f ES |
10427 | -- concatenation, because the literal may be constant-folded away. This |
10428 | -- is a useful optimization for long concatenation expressions. | |
996ae0b0 | 10429 | |
c8ef728f | 10430 | -- If the string is an aggregate built for a single character (which |
996ae0b0 | 10431 | -- happens in a non-static context) or a is null string to which special |
c8ef728f ES |
10432 | -- checks may apply, we build the subtype. Wide strings must also get a |
10433 | -- string subtype if they come from a one character aggregate. Strings | |
996ae0b0 RK |
10434 | -- generated by attributes might be static, but it is often hard to |
10435 | -- determine whether the enclosing context is static, so we generate | |
10436 | -- subtypes for them as well, thus losing some rarer optimizations ??? | |
10437 | -- Same for strings that come from a static conversion. | |
10438 | ||
10439 | Need_Check := | |
10440 | (Strlen = 0 and then Typ /= Standard_String) | |
10441 | or else Nkind (Parent (N)) /= N_Op_Concat | |
10442 | or else (N /= Left_Opnd (Parent (N)) | |
10443 | and then N /= Right_Opnd (Parent (N))) | |
82c80734 RD |
10444 | or else ((Typ = Standard_Wide_String |
10445 | or else Typ = Standard_Wide_Wide_String) | |
996ae0b0 RK |
10446 | and then Nkind (Original_Node (N)) /= N_String_Literal); |
10447 | ||
d81b4bfe TQ |
10448 | -- If the resolving type is itself a string literal subtype, we can just |
10449 | -- reuse it, since there is no point in creating another. | |
996ae0b0 RK |
10450 | |
10451 | if Ekind (Typ) = E_String_Literal_Subtype then | |
10452 | Subtype_Id := Typ; | |
10453 | ||
10454 | elsif Nkind (Parent (N)) = N_Op_Concat | |
10455 | and then not Need_Check | |
45fc7ddb HK |
10456 | and then not Nkind_In (Original_Node (N), N_Character_Literal, |
10457 | N_Attribute_Reference, | |
10458 | N_Qualified_Expression, | |
10459 | N_Type_Conversion) | |
996ae0b0 RK |
10460 | then |
10461 | Subtype_Id := Typ; | |
10462 | ||
79904ebc AC |
10463 | -- Do not generate a string literal subtype for the default expression |
10464 | -- of a formal parameter in GNATprove mode. This is because the string | |
10465 | -- subtype is associated with the freezing actions of the subprogram, | |
10466 | -- however freezing is disabled in GNATprove mode and as a result the | |
10467 | -- subtype is unavailable. | |
10468 | ||
10469 | elsif GNATprove_Mode | |
10470 | and then Nkind (Parent (N)) = N_Parameter_Specification | |
10471 | then | |
10472 | Subtype_Id := Typ; | |
10473 | ||
996ae0b0 RK |
10474 | -- Otherwise we must create a string literal subtype. Note that the |
10475 | -- whole idea of string literal subtypes is simply to avoid the need | |
10476 | -- for building a full fledged array subtype for each literal. | |
45fc7ddb | 10477 | |
996ae0b0 RK |
10478 | else |
10479 | Set_String_Literal_Subtype (N, Typ); | |
10480 | Subtype_Id := Etype (N); | |
10481 | end if; | |
10482 | ||
10483 | if Nkind (Parent (N)) /= N_Op_Concat | |
10484 | or else Need_Check | |
10485 | then | |
10486 | Set_Etype (N, Subtype_Id); | |
10487 | Eval_String_Literal (N); | |
10488 | end if; | |
10489 | ||
10490 | if Is_Limited_Composite (Typ) | |
10491 | or else Is_Private_Composite (Typ) | |
10492 | then | |
10493 | Error_Msg_N ("string literal not available for private array", N); | |
10494 | Set_Etype (N, Any_Type); | |
10495 | return; | |
10496 | end if; | |
10497 | ||
d81b4bfe TQ |
10498 | -- The validity of a null string has been checked in the call to |
10499 | -- Eval_String_Literal. | |
996ae0b0 RK |
10500 | |
10501 | if Strlen = 0 then | |
10502 | return; | |
10503 | ||
c8ef728f ES |
10504 | -- Always accept string literal with component type Any_Character, which |
10505 | -- occurs in error situations and in comparisons of literals, both of | |
10506 | -- which should accept all literals. | |
996ae0b0 RK |
10507 | |
10508 | elsif R_Typ = Any_Character then | |
10509 | return; | |
10510 | ||
f3d57416 RW |
10511 | -- If the type is bit-packed, then we always transform the string |
10512 | -- literal into a full fledged aggregate. | |
996ae0b0 RK |
10513 | |
10514 | elsif Is_Bit_Packed_Array (Typ) then | |
10515 | null; | |
10516 | ||
82c80734 | 10517 | -- Deal with cases of Wide_Wide_String, Wide_String, and String |
996ae0b0 RK |
10518 | |
10519 | else | |
82c80734 RD |
10520 | -- For Standard.Wide_Wide_String, or any other type whose component |
10521 | -- type is Standard.Wide_Wide_Character, we know that all the | |
996ae0b0 RK |
10522 | -- characters in the string must be acceptable, since the parser |
10523 | -- accepted the characters as valid character literals. | |
10524 | ||
82c80734 | 10525 | if R_Typ = Standard_Wide_Wide_Character then |
996ae0b0 RK |
10526 | null; |
10527 | ||
c8ef728f ES |
10528 | -- For the case of Standard.String, or any other type whose component |
10529 | -- type is Standard.Character, we must make sure that there are no | |
10530 | -- wide characters in the string, i.e. that it is entirely composed | |
10531 | -- of characters in range of type Character. | |
996ae0b0 | 10532 | |
c8ef728f ES |
10533 | -- If the string literal is the result of a static concatenation, the |
10534 | -- test has already been performed on the components, and need not be | |
10535 | -- repeated. | |
996ae0b0 RK |
10536 | |
10537 | elsif R_Typ = Standard_Character | |
10538 | and then Nkind (Original_Node (N)) /= N_Op_Concat | |
10539 | then | |
10540 | for J in 1 .. Strlen loop | |
10541 | if not In_Character_Range (Get_String_Char (Str, J)) then | |
10542 | ||
10543 | -- If we are out of range, post error. This is one of the | |
10544 | -- very few places that we place the flag in the middle of | |
d81b4bfe TQ |
10545 | -- a token, right under the offending wide character. Not |
10546 | -- quite clear if this is right wrt wide character encoding | |
a90bd866 | 10547 | -- sequences, but it's only an error message. |
996ae0b0 RK |
10548 | |
10549 | Error_Msg | |
82c80734 RD |
10550 | ("literal out of range of type Standard.Character", |
10551 | Source_Ptr (Int (Loc) + J)); | |
10552 | return; | |
10553 | end if; | |
10554 | end loop; | |
10555 | ||
10556 | -- For the case of Standard.Wide_String, or any other type whose | |
10557 | -- component type is Standard.Wide_Character, we must make sure that | |
10558 | -- there are no wide characters in the string, i.e. that it is | |
10559 | -- entirely composed of characters in range of type Wide_Character. | |
10560 | ||
10561 | -- If the string literal is the result of a static concatenation, | |
10562 | -- the test has already been performed on the components, and need | |
10563 | -- not be repeated. | |
10564 | ||
10565 | elsif R_Typ = Standard_Wide_Character | |
10566 | and then Nkind (Original_Node (N)) /= N_Op_Concat | |
10567 | then | |
10568 | for J in 1 .. Strlen loop | |
10569 | if not In_Wide_Character_Range (Get_String_Char (Str, J)) then | |
10570 | ||
10571 | -- If we are out of range, post error. This is one of the | |
10572 | -- very few places that we place the flag in the middle of | |
10573 | -- a token, right under the offending wide character. | |
10574 | ||
10575 | -- This is not quite right, because characters in general | |
10576 | -- will take more than one character position ??? | |
10577 | ||
10578 | Error_Msg | |
10579 | ("literal out of range of type Standard.Wide_Character", | |
996ae0b0 RK |
10580 | Source_Ptr (Int (Loc) + J)); |
10581 | return; | |
10582 | end if; | |
10583 | end loop; | |
10584 | ||
10585 | -- If the root type is not a standard character, then we will convert | |
10586 | -- the string into an aggregate and will let the aggregate code do | |
82c80734 | 10587 | -- the checking. Standard Wide_Wide_Character is also OK here. |
996ae0b0 RK |
10588 | |
10589 | else | |
10590 | null; | |
996ae0b0 RK |
10591 | end if; |
10592 | ||
c8ef728f ES |
10593 | -- See if the component type of the array corresponding to the string |
10594 | -- has compile time known bounds. If yes we can directly check | |
10595 | -- whether the evaluation of the string will raise constraint error. | |
10596 | -- Otherwise we need to transform the string literal into the | |
5cc9353d RD |
10597 | -- corresponding character aggregate and let the aggregate code do |
10598 | -- the checking. | |
996ae0b0 | 10599 | |
45fc7ddb HK |
10600 | if Is_Standard_Character_Type (R_Typ) then |
10601 | ||
996ae0b0 RK |
10602 | -- Check for the case of full range, where we are definitely OK |
10603 | ||
10604 | if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then | |
10605 | return; | |
10606 | end if; | |
10607 | ||
10608 | -- Here the range is not the complete base type range, so check | |
10609 | ||
10610 | declare | |
10611 | Comp_Typ_Lo : constant Node_Id := | |
10612 | Type_Low_Bound (Component_Type (Typ)); | |
10613 | Comp_Typ_Hi : constant Node_Id := | |
10614 | Type_High_Bound (Component_Type (Typ)); | |
10615 | ||
10616 | Char_Val : Uint; | |
10617 | ||
10618 | begin | |
10619 | if Compile_Time_Known_Value (Comp_Typ_Lo) | |
10620 | and then Compile_Time_Known_Value (Comp_Typ_Hi) | |
10621 | then | |
10622 | for J in 1 .. Strlen loop | |
10623 | Char_Val := UI_From_Int (Int (Get_String_Char (Str, J))); | |
10624 | ||
10625 | if Char_Val < Expr_Value (Comp_Typ_Lo) | |
10626 | or else Char_Val > Expr_Value (Comp_Typ_Hi) | |
10627 | then | |
10628 | Apply_Compile_Time_Constraint_Error | |
324ac540 AC |
10629 | (N, "character out of range??", |
10630 | CE_Range_Check_Failed, | |
996ae0b0 RK |
10631 | Loc => Source_Ptr (Int (Loc) + J)); |
10632 | end if; | |
10633 | end loop; | |
10634 | ||
10635 | return; | |
10636 | end if; | |
10637 | end; | |
10638 | end if; | |
10639 | end if; | |
10640 | ||
10641 | -- If we got here we meed to transform the string literal into the | |
10642 | -- equivalent qualified positional array aggregate. This is rather | |
10643 | -- heavy artillery for this situation, but it is hard work to avoid. | |
10644 | ||
10645 | declare | |
fbf5a39b | 10646 | Lits : constant List_Id := New_List; |
996ae0b0 RK |
10647 | P : Source_Ptr := Loc + 1; |
10648 | C : Char_Code; | |
10649 | ||
10650 | begin | |
c8ef728f ES |
10651 | -- Build the character literals, we give them source locations that |
10652 | -- correspond to the string positions, which is a bit tricky given | |
10653 | -- the possible presence of wide character escape sequences. | |
996ae0b0 RK |
10654 | |
10655 | for J in 1 .. Strlen loop | |
10656 | C := Get_String_Char (Str, J); | |
10657 | Set_Character_Literal_Name (C); | |
10658 | ||
10659 | Append_To (Lits, | |
82c80734 RD |
10660 | Make_Character_Literal (P, |
10661 | Chars => Name_Find, | |
10662 | Char_Literal_Value => UI_From_CC (C))); | |
996ae0b0 RK |
10663 | |
10664 | if In_Character_Range (C) then | |
10665 | P := P + 1; | |
10666 | ||
10667 | -- Should we have a call to Skip_Wide here ??? | |
5cc9353d | 10668 | |
996ae0b0 RK |
10669 | -- ??? else |
10670 | -- Skip_Wide (P); | |
10671 | ||
10672 | end if; | |
10673 | end loop; | |
10674 | ||
10675 | Rewrite (N, | |
10676 | Make_Qualified_Expression (Loc, | |
e4494292 | 10677 | Subtype_Mark => New_Occurrence_Of (Typ, Loc), |
996ae0b0 RK |
10678 | Expression => |
10679 | Make_Aggregate (Loc, Expressions => Lits))); | |
10680 | ||
10681 | Analyze_And_Resolve (N, Typ); | |
10682 | end; | |
10683 | end Resolve_String_Literal; | |
10684 | ||
ae33543c ES |
10685 | ------------------------- |
10686 | -- Resolve_Target_Name -- | |
10687 | ------------------------- | |
10688 | ||
10689 | procedure Resolve_Target_Name (N : Node_Id; Typ : Entity_Id) is | |
10690 | begin | |
10691 | Set_Etype (N, Typ); | |
10692 | end Resolve_Target_Name; | |
10693 | ||
996ae0b0 RK |
10694 | ----------------------------- |
10695 | -- Resolve_Type_Conversion -- | |
10696 | ----------------------------- | |
10697 | ||
10698 | procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id) is | |
4b2d2c13 AC |
10699 | Conv_OK : constant Boolean := Conversion_OK (N); |
10700 | Operand : constant Node_Id := Expression (N); | |
b7d1f17f HK |
10701 | Operand_Typ : constant Entity_Id := Etype (Operand); |
10702 | Target_Typ : constant Entity_Id := Etype (N); | |
996ae0b0 | 10703 | Rop : Node_Id; |
fbf5a39b AC |
10704 | Orig_N : Node_Id; |
10705 | Orig_T : Node_Id; | |
996ae0b0 | 10706 | |
ae2aa109 AC |
10707 | Test_Redundant : Boolean := Warn_On_Redundant_Constructs; |
10708 | -- Set to False to suppress cases where we want to suppress the test | |
10709 | -- for redundancy to avoid possible false positives on this warning. | |
10710 | ||
996ae0b0 | 10711 | begin |
996ae0b0 | 10712 | if not Conv_OK |
b7d1f17f | 10713 | and then not Valid_Conversion (N, Target_Typ, Operand) |
996ae0b0 RK |
10714 | then |
10715 | return; | |
10716 | end if; | |
10717 | ||
ae2aa109 AC |
10718 | -- If the Operand Etype is Universal_Fixed, then the conversion is |
10719 | -- never redundant. We need this check because by the time we have | |
10720 | -- finished the rather complex transformation, the conversion looks | |
10721 | -- redundant when it is not. | |
10722 | ||
10723 | if Operand_Typ = Universal_Fixed then | |
10724 | Test_Redundant := False; | |
10725 | ||
10726 | -- If the operand is marked as Any_Fixed, then special processing is | |
10727 | -- required. This is also a case where we suppress the test for a | |
10728 | -- redundant conversion, since most certainly it is not redundant. | |
10729 | ||
10730 | elsif Operand_Typ = Any_Fixed then | |
10731 | Test_Redundant := False; | |
996ae0b0 RK |
10732 | |
10733 | -- Mixed-mode operation involving a literal. Context must be a fixed | |
10734 | -- type which is applied to the literal subsequently. | |
10735 | ||
cccb761b AC |
10736 | -- Multiplication and division involving two fixed type operands must |
10737 | -- yield a universal real because the result is computed in arbitrary | |
10738 | -- precision. | |
10739 | ||
10740 | if Is_Fixed_Point_Type (Typ) | |
10741 | and then Nkind_In (Operand, N_Op_Divide, N_Op_Multiply) | |
10742 | and then Etype (Left_Opnd (Operand)) = Any_Fixed | |
10743 | and then Etype (Right_Opnd (Operand)) = Any_Fixed | |
10744 | then | |
996ae0b0 RK |
10745 | Set_Etype (Operand, Universal_Real); |
10746 | ||
10747 | elsif Is_Numeric_Type (Typ) | |
45fc7ddb | 10748 | and then Nkind_In (Operand, N_Op_Multiply, N_Op_Divide) |
996ae0b0 | 10749 | and then (Etype (Right_Opnd (Operand)) = Universal_Real |
45fc7ddb HK |
10750 | or else |
10751 | Etype (Left_Opnd (Operand)) = Universal_Real) | |
996ae0b0 | 10752 | then |
a77842bd TQ |
10753 | -- Return if expression is ambiguous |
10754 | ||
996ae0b0 | 10755 | if Unique_Fixed_Point_Type (N) = Any_Type then |
a77842bd | 10756 | return; |
82c80734 | 10757 | |
a77842bd TQ |
10758 | -- If nothing else, the available fixed type is Duration |
10759 | ||
10760 | else | |
996ae0b0 RK |
10761 | Set_Etype (Operand, Standard_Duration); |
10762 | end if; | |
10763 | ||
bc5f3720 | 10764 | -- Resolve the real operand with largest available precision |
9ebe3743 | 10765 | |
996ae0b0 RK |
10766 | if Etype (Right_Opnd (Operand)) = Universal_Real then |
10767 | Rop := New_Copy_Tree (Right_Opnd (Operand)); | |
10768 | else | |
10769 | Rop := New_Copy_Tree (Left_Opnd (Operand)); | |
10770 | end if; | |
10771 | ||
9ebe3743 | 10772 | Resolve (Rop, Universal_Real); |
996ae0b0 | 10773 | |
82c80734 RD |
10774 | -- If the operand is a literal (it could be a non-static and |
10775 | -- illegal exponentiation) check whether the use of Duration | |
10776 | -- is potentially inaccurate. | |
10777 | ||
10778 | if Nkind (Rop) = N_Real_Literal | |
10779 | and then Realval (Rop) /= Ureal_0 | |
996ae0b0 RK |
10780 | and then abs (Realval (Rop)) < Delta_Value (Standard_Duration) |
10781 | then | |
aa180613 | 10782 | Error_Msg_N |
67b8ac46 AC |
10783 | ("??universal real operand can only " |
10784 | & "be interpreted as Duration!", Rop); | |
aa180613 | 10785 | Error_Msg_N |
324ac540 | 10786 | ("\??precision will be lost in the conversion!", Rop); |
996ae0b0 RK |
10787 | end if; |
10788 | ||
891a6e79 AC |
10789 | elsif Is_Numeric_Type (Typ) |
10790 | and then Nkind (Operand) in N_Op | |
10791 | and then Unique_Fixed_Point_Type (N) /= Any_Type | |
10792 | then | |
10793 | Set_Etype (Operand, Standard_Duration); | |
10794 | ||
996ae0b0 RK |
10795 | else |
10796 | Error_Msg_N ("invalid context for mixed mode operation", N); | |
10797 | Set_Etype (Operand, Any_Type); | |
10798 | return; | |
10799 | end if; | |
10800 | end if; | |
10801 | ||
fbf5a39b | 10802 | Resolve (Operand); |
996ae0b0 | 10803 | |
2ba431e5 YM |
10804 | -- In SPARK, a type conversion between array types should be restricted |
10805 | -- to types which have matching static bounds. | |
b0186f71 | 10806 | |
7b98672f YM |
10807 | -- Protect call to Matching_Static_Array_Bounds to avoid costly |
10808 | -- operation if not needed. | |
10809 | ||
6480338a | 10810 | if Restriction_Check_Required (SPARK_05) |
7b98672f | 10811 | and then Is_Array_Type (Target_Typ) |
b0186f71 | 10812 | and then Is_Array_Type (Operand_Typ) |
db72f10a | 10813 | and then Operand_Typ /= Any_Composite -- or else Operand in error |
b0186f71 AC |
10814 | and then not Matching_Static_Array_Bounds (Target_Typ, Operand_Typ) |
10815 | then | |
ce5ba43a | 10816 | Check_SPARK_05_Restriction |
fe5d3068 | 10817 | ("array types should have matching static bounds", N); |
b0186f71 AC |
10818 | end if; |
10819 | ||
e24329cd YM |
10820 | -- In formal mode, the operand of an ancestor type conversion must be an |
10821 | -- object (not an expression). | |
10822 | ||
10823 | if Is_Tagged_Type (Target_Typ) | |
10824 | and then not Is_Class_Wide_Type (Target_Typ) | |
10825 | and then Is_Tagged_Type (Operand_Typ) | |
10826 | and then not Is_Class_Wide_Type (Operand_Typ) | |
10827 | and then Is_Ancestor (Target_Typ, Operand_Typ) | |
ce5ba43a | 10828 | and then not Is_SPARK_05_Object_Reference (Operand) |
e24329cd | 10829 | then |
ce5ba43a | 10830 | Check_SPARK_05_Restriction ("object required", Operand); |
e24329cd YM |
10831 | end if; |
10832 | ||
dec6faf1 AC |
10833 | Analyze_Dimension (N); |
10834 | ||
996ae0b0 | 10835 | -- Note: we do the Eval_Type_Conversion call before applying the |
d81b4bfe TQ |
10836 | -- required checks for a subtype conversion. This is important, since |
10837 | -- both are prepared under certain circumstances to change the type | |
10838 | -- conversion to a constraint error node, but in the case of | |
10839 | -- Eval_Type_Conversion this may reflect an illegality in the static | |
10840 | -- case, and we would miss the illegality (getting only a warning | |
10841 | -- message), if we applied the type conversion checks first. | |
996ae0b0 RK |
10842 | |
10843 | Eval_Type_Conversion (N); | |
10844 | ||
d81b4bfe TQ |
10845 | -- Even when evaluation is not possible, we may be able to simplify the |
10846 | -- conversion or its expression. This needs to be done before applying | |
10847 | -- checks, since otherwise the checks may use the original expression | |
10848 | -- and defeat the simplifications. This is specifically the case for | |
10849 | -- elimination of the floating-point Truncation attribute in | |
10850 | -- float-to-int conversions. | |
0669bebe GB |
10851 | |
10852 | Simplify_Type_Conversion (N); | |
10853 | ||
d81b4bfe TQ |
10854 | -- If after evaluation we still have a type conversion, then we may need |
10855 | -- to apply checks required for a subtype conversion. | |
996ae0b0 RK |
10856 | |
10857 | -- Skip these type conversion checks if universal fixed operands | |
10858 | -- operands involved, since range checks are handled separately for | |
10859 | -- these cases (in the appropriate Expand routines in unit Exp_Fixd). | |
10860 | ||
10861 | if Nkind (N) = N_Type_Conversion | |
b7d1f17f HK |
10862 | and then not Is_Generic_Type (Root_Type (Target_Typ)) |
10863 | and then Target_Typ /= Universal_Fixed | |
10864 | and then Operand_Typ /= Universal_Fixed | |
996ae0b0 RK |
10865 | then |
10866 | Apply_Type_Conversion_Checks (N); | |
10867 | end if; | |
10868 | ||
d81b4bfe TQ |
10869 | -- Issue warning for conversion of simple object to its own type. We |
10870 | -- have to test the original nodes, since they may have been rewritten | |
10871 | -- by various optimizations. | |
fbf5a39b AC |
10872 | |
10873 | Orig_N := Original_Node (N); | |
996ae0b0 | 10874 | |
ae2aa109 AC |
10875 | -- Here we test for a redundant conversion if the warning mode is |
10876 | -- active (and was not locally reset), and we have a type conversion | |
10877 | -- from source not appearing in a generic instance. | |
10878 | ||
10879 | if Test_Redundant | |
fbf5a39b | 10880 | and then Nkind (Orig_N) = N_Type_Conversion |
ae2aa109 | 10881 | and then Comes_From_Source (Orig_N) |
5453d5bd | 10882 | and then not In_Instance |
996ae0b0 | 10883 | then |
fbf5a39b | 10884 | Orig_N := Original_Node (Expression (Orig_N)); |
b7d1f17f | 10885 | Orig_T := Target_Typ; |
fbf5a39b AC |
10886 | |
10887 | -- If the node is part of a larger expression, the Target_Type | |
10888 | -- may not be the original type of the node if the context is a | |
10889 | -- condition. Recover original type to see if conversion is needed. | |
10890 | ||
10891 | if Is_Boolean_Type (Orig_T) | |
10892 | and then Nkind (Parent (N)) in N_Op | |
10893 | then | |
10894 | Orig_T := Etype (Parent (N)); | |
10895 | end if; | |
10896 | ||
4adf3c50 | 10897 | -- If we have an entity name, then give the warning if the entity |
ae2aa109 AC |
10898 | -- is the right type, or if it is a loop parameter covered by the |
10899 | -- original type (that's needed because loop parameters have an | |
10900 | -- odd subtype coming from the bounds). | |
10901 | ||
10902 | if (Is_Entity_Name (Orig_N) | |
98bf4cf4 AC |
10903 | and then |
10904 | (Etype (Entity (Orig_N)) = Orig_T | |
10905 | or else | |
10906 | (Ekind (Entity (Orig_N)) = E_Loop_Parameter | |
10907 | and then Covers (Orig_T, Etype (Entity (Orig_N)))))) | |
ae2aa109 | 10908 | |
477bd732 | 10909 | -- If not an entity, then type of expression must match |
ae2aa109 AC |
10910 | |
10911 | or else Etype (Orig_N) = Orig_T | |
fbf5a39b | 10912 | then |
4b2d2c13 AC |
10913 | -- One more check, do not give warning if the analyzed conversion |
10914 | -- has an expression with non-static bounds, and the bounds of the | |
10915 | -- target are static. This avoids junk warnings in cases where the | |
10916 | -- conversion is necessary to establish staticness, for example in | |
10917 | -- a case statement. | |
10918 | ||
10919 | if not Is_OK_Static_Subtype (Operand_Typ) | |
10920 | and then Is_OK_Static_Subtype (Target_Typ) | |
10921 | then | |
10922 | null; | |
10923 | ||
5cc9353d RD |
10924 | -- Finally, if this type conversion occurs in a context requiring |
10925 | -- a prefix, and the expression is a qualified expression then the | |
10926 | -- type conversion is not redundant, since a qualified expression | |
10927 | -- is not a prefix, whereas a type conversion is. For example, "X | |
10928 | -- := T'(Funx(...)).Y;" is illegal because a selected component | |
10929 | -- requires a prefix, but a type conversion makes it legal: "X := | |
10930 | -- T(T'(Funx(...))).Y;" | |
4adf3c50 | 10931 | |
9db0b232 AC |
10932 | -- In Ada 2012, a qualified expression is a name, so this idiom is |
10933 | -- no longer needed, but we still suppress the warning because it | |
10934 | -- seems unfriendly for warnings to pop up when you switch to the | |
10935 | -- newer language version. | |
be257e99 AC |
10936 | |
10937 | elsif Nkind (Orig_N) = N_Qualified_Expression | |
f5d96d00 AC |
10938 | and then Nkind_In (Parent (N), N_Attribute_Reference, |
10939 | N_Indexed_Component, | |
10940 | N_Selected_Component, | |
10941 | N_Slice, | |
10942 | N_Explicit_Dereference) | |
be257e99 AC |
10943 | then |
10944 | null; | |
10945 | ||
2352eadb AC |
10946 | -- Never warn on conversion to Long_Long_Integer'Base since |
10947 | -- that is most likely an artifact of the extended overflow | |
10948 | -- checking and comes from complex expanded code. | |
10949 | ||
10950 | elsif Orig_T = Base_Type (Standard_Long_Long_Integer) then | |
10951 | null; | |
10952 | ||
ae2aa109 AC |
10953 | -- Here we give the redundant conversion warning. If it is an |
10954 | -- entity, give the name of the entity in the message. If not, | |
10955 | -- just mention the expression. | |
4b2d2c13 | 10956 | |
324ac540 AC |
10957 | -- Shoudn't we test Warn_On_Redundant_Constructs here ??? |
10958 | ||
4b2d2c13 | 10959 | else |
ae2aa109 AC |
10960 | if Is_Entity_Name (Orig_N) then |
10961 | Error_Msg_Node_2 := Orig_T; | |
10962 | Error_Msg_NE -- CODEFIX | |
324ac540 | 10963 | ("??redundant conversion, & is of type &!", |
ae2aa109 AC |
10964 | N, Entity (Orig_N)); |
10965 | else | |
10966 | Error_Msg_NE | |
324ac540 | 10967 | ("??redundant conversion, expression is of type&!", |
ae2aa109 AC |
10968 | N, Orig_T); |
10969 | end if; | |
4b2d2c13 | 10970 | end if; |
fbf5a39b | 10971 | end if; |
996ae0b0 | 10972 | end if; |
758c442c | 10973 | |
b7d1f17f | 10974 | -- Ada 2005 (AI-251): Handle class-wide interface type conversions. |
0669bebe GB |
10975 | -- No need to perform any interface conversion if the type of the |
10976 | -- expression coincides with the target type. | |
758c442c | 10977 | |
0791fbe9 | 10978 | if Ada_Version >= Ada_2005 |
4460a9bc | 10979 | and then Expander_Active |
b7d1f17f | 10980 | and then Operand_Typ /= Target_Typ |
0669bebe | 10981 | then |
b7d1f17f HK |
10982 | declare |
10983 | Opnd : Entity_Id := Operand_Typ; | |
10984 | Target : Entity_Id := Target_Typ; | |
758c442c | 10985 | |
b7d1f17f | 10986 | begin |
e4dc3327 AC |
10987 | -- If the type of the operand is a limited view, use nonlimited |
10988 | -- view when available. If it is a class-wide type, recover the | |
10989 | -- class-wide type of the nonlimited view. | |
414c6563 | 10990 | |
47346923 AC |
10991 | if From_Limited_With (Opnd) |
10992 | and then Has_Non_Limited_View (Opnd) | |
10993 | then | |
10994 | Opnd := Non_Limited_View (Opnd); | |
10995 | Set_Etype (Expression (N), Opnd); | |
414c6563 AC |
10996 | end if; |
10997 | ||
b7d1f17f | 10998 | if Is_Access_Type (Opnd) then |
841dd0f5 | 10999 | Opnd := Designated_Type (Opnd); |
1420b484 JM |
11000 | end if; |
11001 | ||
b7d1f17f | 11002 | if Is_Access_Type (Target_Typ) then |
841dd0f5 | 11003 | Target := Designated_Type (Target); |
4197ae1e | 11004 | end if; |
c8ef728f | 11005 | |
b7d1f17f HK |
11006 | if Opnd = Target then |
11007 | null; | |
c8ef728f | 11008 | |
b7d1f17f | 11009 | -- Conversion from interface type |
ea985d95 | 11010 | |
b7d1f17f | 11011 | elsif Is_Interface (Opnd) then |
ea985d95 | 11012 | |
b7d1f17f | 11013 | -- Ada 2005 (AI-217): Handle entities from limited views |
aa180613 | 11014 | |
7b56a91b | 11015 | if From_Limited_With (Opnd) then |
b7d1f17f | 11016 | Error_Msg_Qual_Level := 99; |
305caf42 AC |
11017 | Error_Msg_NE -- CODEFIX |
11018 | ("missing WITH clause on package &", N, | |
b7d1f17f HK |
11019 | Cunit_Entity (Get_Source_Unit (Base_Type (Opnd)))); |
11020 | Error_Msg_N | |
11021 | ("type conversions require visibility of the full view", | |
11022 | N); | |
aa180613 | 11023 | |
7b56a91b | 11024 | elsif From_Limited_With (Target) |
aa5147f0 ES |
11025 | and then not |
11026 | (Is_Access_Type (Target_Typ) | |
11027 | and then Present (Non_Limited_View (Etype (Target)))) | |
11028 | then | |
b7d1f17f | 11029 | Error_Msg_Qual_Level := 99; |
305caf42 AC |
11030 | Error_Msg_NE -- CODEFIX |
11031 | ("missing WITH clause on package &", N, | |
b7d1f17f HK |
11032 | Cunit_Entity (Get_Source_Unit (Base_Type (Target)))); |
11033 | Error_Msg_N | |
11034 | ("type conversions require visibility of the full view", | |
11035 | N); | |
aa180613 | 11036 | |
b7d1f17f | 11037 | else |
f6f4d8d4 | 11038 | Expand_Interface_Conversion (N); |
b7d1f17f HK |
11039 | end if; |
11040 | ||
11041 | -- Conversion to interface type | |
11042 | ||
11043 | elsif Is_Interface (Target) then | |
11044 | ||
11045 | -- Handle subtypes | |
11046 | ||
8a95f4e8 | 11047 | if Ekind_In (Opnd, E_Protected_Subtype, E_Task_Subtype) then |
b7d1f17f HK |
11048 | Opnd := Etype (Opnd); |
11049 | end if; | |
11050 | ||
f6f4d8d4 JM |
11051 | if Is_Class_Wide_Type (Opnd) |
11052 | or else Interface_Present_In_Ancestor | |
11053 | (Typ => Opnd, | |
11054 | Iface => Target) | |
b7d1f17f | 11055 | then |
b7d1f17f | 11056 | Expand_Interface_Conversion (N); |
f6f4d8d4 JM |
11057 | else |
11058 | Error_Msg_Name_1 := Chars (Etype (Target)); | |
11059 | Error_Msg_Name_2 := Chars (Opnd); | |
11060 | Error_Msg_N | |
11061 | ("wrong interface conversion (% is not a progenitor " | |
11062 | & "of %)", N); | |
b7d1f17f HK |
11063 | end if; |
11064 | end if; | |
11065 | end; | |
758c442c | 11066 | end if; |
804fc056 | 11067 | |
6cbfce7e AC |
11068 | -- Ada 2012: once the type conversion is resolved, check whether the |
11069 | -- operand statisfies the static predicate of the target type. | |
804fc056 AC |
11070 | |
11071 | if Has_Predicates (Target_Typ) then | |
6cbfce7e | 11072 | Check_Expression_Against_Static_Predicate (N, Target_Typ); |
804fc056 | 11073 | end if; |
98bf4cf4 | 11074 | |
d8ee014f YM |
11075 | -- If at this stage we have a real to integer conversion, make sure that |
11076 | -- the Do_Range_Check flag is set, because such conversions in general | |
b0cd50fd AC |
11077 | -- need a range check. We only need this if expansion is off. |
11078 | -- In GNATprove mode, we only do that when converting from fixed-point | |
d8ee014f YM |
11079 | -- (as floating-point to integer conversions are now handled in |
11080 | -- GNATprove mode). | |
98bf4cf4 AC |
11081 | |
11082 | if Nkind (N) = N_Type_Conversion | |
d8ee014f | 11083 | and then not Expander_Active |
98bf4cf4 | 11084 | and then Is_Integer_Type (Target_Typ) |
b0cd50fd AC |
11085 | and then (Is_Fixed_Point_Type (Operand_Typ) |
11086 | or else (not GNATprove_Mode | |
11087 | and then Is_Floating_Point_Type (Operand_Typ))) | |
98bf4cf4 AC |
11088 | then |
11089 | Set_Do_Range_Check (Operand); | |
11090 | end if; | |
6905a049 AC |
11091 | |
11092 | -- Generating C code a type conversion of an access to constrained | |
11093 | -- array type to access to unconstrained array type involves building | |
11094 | -- a fat pointer which in general cannot be generated on the fly. We | |
11095 | -- remove side effects in order to store the result of the conversion | |
11096 | -- into a temporary. | |
11097 | ||
c63a2ad6 | 11098 | if Modify_Tree_For_C |
6905a049 AC |
11099 | and then Nkind (N) = N_Type_Conversion |
11100 | and then Nkind (Parent (N)) /= N_Object_Declaration | |
11101 | and then Is_Access_Type (Etype (N)) | |
11102 | and then Is_Array_Type (Designated_Type (Etype (N))) | |
11103 | and then not Is_Constrained (Designated_Type (Etype (N))) | |
11104 | and then Is_Constrained (Designated_Type (Etype (Expression (N)))) | |
11105 | then | |
11106 | Remove_Side_Effects (N); | |
11107 | end if; | |
996ae0b0 RK |
11108 | end Resolve_Type_Conversion; |
11109 | ||
11110 | ---------------------- | |
11111 | -- Resolve_Unary_Op -- | |
11112 | ---------------------- | |
11113 | ||
11114 | procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id) is | |
fbf5a39b AC |
11115 | B_Typ : constant Entity_Id := Base_Type (Typ); |
11116 | R : constant Node_Id := Right_Opnd (N); | |
11117 | OK : Boolean; | |
11118 | Lo : Uint; | |
11119 | Hi : Uint; | |
996ae0b0 RK |
11120 | |
11121 | begin | |
7a489a2b AC |
11122 | if Is_Modular_Integer_Type (Typ) and then Nkind (N) /= N_Op_Not then |
11123 | Error_Msg_Name_1 := Chars (Typ); | |
ce5ba43a | 11124 | Check_SPARK_05_Restriction |
7a489a2b AC |
11125 | ("unary operator not defined for modular type%", N); |
11126 | end if; | |
11127 | ||
b7d1f17f | 11128 | -- Deal with intrinsic unary operators |
996ae0b0 | 11129 | |
fbf5a39b AC |
11130 | if Comes_From_Source (N) |
11131 | and then Ekind (Entity (N)) = E_Function | |
11132 | and then Is_Imported (Entity (N)) | |
11133 | and then Is_Intrinsic_Subprogram (Entity (N)) | |
11134 | then | |
11135 | Resolve_Intrinsic_Unary_Operator (N, Typ); | |
11136 | return; | |
11137 | end if; | |
11138 | ||
0669bebe GB |
11139 | -- Deal with universal cases |
11140 | ||
996ae0b0 | 11141 | if Etype (R) = Universal_Integer |
0669bebe GB |
11142 | or else |
11143 | Etype (R) = Universal_Real | |
996ae0b0 RK |
11144 | then |
11145 | Check_For_Visible_Operator (N, B_Typ); | |
11146 | end if; | |
11147 | ||
11148 | Set_Etype (N, B_Typ); | |
11149 | Resolve (R, B_Typ); | |
fbf5a39b | 11150 | |
9ebe3743 HK |
11151 | -- Generate warning for expressions like abs (x mod 2) |
11152 | ||
11153 | if Warn_On_Redundant_Constructs | |
11154 | and then Nkind (N) = N_Op_Abs | |
11155 | then | |
11156 | Determine_Range (Right_Opnd (N), OK, Lo, Hi); | |
11157 | ||
11158 | if OK and then Hi >= Lo and then Lo >= 0 then | |
305caf42 | 11159 | Error_Msg_N -- CODEFIX |
324ac540 | 11160 | ("?r?abs applied to known non-negative value has no effect", N); |
9ebe3743 HK |
11161 | end if; |
11162 | end if; | |
11163 | ||
0669bebe GB |
11164 | -- Deal with reference generation |
11165 | ||
996ae0b0 | 11166 | Check_Unset_Reference (R); |
fbf5a39b | 11167 | Generate_Operator_Reference (N, B_Typ); |
dec6faf1 | 11168 | Analyze_Dimension (N); |
996ae0b0 RK |
11169 | Eval_Unary_Op (N); |
11170 | ||
11171 | -- Set overflow checking bit. Much cleverer code needed here eventually | |
11172 | -- and perhaps the Resolve routines should be separated for the various | |
11173 | -- arithmetic operations, since they will need different processing ??? | |
11174 | ||
11175 | if Nkind (N) in N_Op then | |
11176 | if not Overflow_Checks_Suppressed (Etype (N)) then | |
fbf5a39b | 11177 | Enable_Overflow_Check (N); |
996ae0b0 RK |
11178 | end if; |
11179 | end if; | |
0669bebe | 11180 | |
d81b4bfe TQ |
11181 | -- Generate warning for expressions like -5 mod 3 for integers. No need |
11182 | -- to worry in the floating-point case, since parens do not affect the | |
11183 | -- result so there is no point in giving in a warning. | |
0669bebe GB |
11184 | |
11185 | declare | |
11186 | Norig : constant Node_Id := Original_Node (N); | |
11187 | Rorig : Node_Id; | |
11188 | Val : Uint; | |
11189 | HB : Uint; | |
11190 | LB : Uint; | |
11191 | Lval : Uint; | |
11192 | Opnd : Node_Id; | |
11193 | ||
11194 | begin | |
11195 | if Warn_On_Questionable_Missing_Parens | |
11196 | and then Comes_From_Source (Norig) | |
11197 | and then Is_Integer_Type (Typ) | |
11198 | and then Nkind (Norig) = N_Op_Minus | |
11199 | then | |
11200 | Rorig := Original_Node (Right_Opnd (Norig)); | |
11201 | ||
11202 | -- We are looking for cases where the right operand is not | |
f3d57416 | 11203 | -- parenthesized, and is a binary operator, multiply, divide, or |
0669bebe GB |
11204 | -- mod. These are the cases where the grouping can affect results. |
11205 | ||
11206 | if Paren_Count (Rorig) = 0 | |
45fc7ddb | 11207 | and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide) |
0669bebe GB |
11208 | then |
11209 | -- For mod, we always give the warning, since the value is | |
11210 | -- affected by the parenthesization (e.g. (-5) mod 315 /= | |
d81b4bfe | 11211 | -- -(5 mod 315)). But for the other cases, the only concern is |
0669bebe GB |
11212 | -- overflow, e.g. for the case of 8 big signed (-(2 * 64) |
11213 | -- overflows, but (-2) * 64 does not). So we try to give the | |
11214 | -- message only when overflow is possible. | |
11215 | ||
11216 | if Nkind (Rorig) /= N_Op_Mod | |
11217 | and then Compile_Time_Known_Value (R) | |
11218 | then | |
11219 | Val := Expr_Value (R); | |
11220 | ||
11221 | if Compile_Time_Known_Value (Type_High_Bound (Typ)) then | |
11222 | HB := Expr_Value (Type_High_Bound (Typ)); | |
11223 | else | |
11224 | HB := Expr_Value (Type_High_Bound (Base_Type (Typ))); | |
11225 | end if; | |
11226 | ||
11227 | if Compile_Time_Known_Value (Type_Low_Bound (Typ)) then | |
11228 | LB := Expr_Value (Type_Low_Bound (Typ)); | |
11229 | else | |
11230 | LB := Expr_Value (Type_Low_Bound (Base_Type (Typ))); | |
11231 | end if; | |
11232 | ||
d81b4bfe TQ |
11233 | -- Note that the test below is deliberately excluding the |
11234 | -- largest negative number, since that is a potentially | |
0669bebe GB |
11235 | -- troublesome case (e.g. -2 * x, where the result is the |
11236 | -- largest negative integer has an overflow with 2 * x). | |
11237 | ||
11238 | if Val > LB and then Val <= HB then | |
11239 | return; | |
11240 | end if; | |
11241 | end if; | |
11242 | ||
11243 | -- For the multiplication case, the only case we have to worry | |
11244 | -- about is when (-a)*b is exactly the largest negative number | |
11245 | -- so that -(a*b) can cause overflow. This can only happen if | |
11246 | -- a is a power of 2, and more generally if any operand is a | |
11247 | -- constant that is not a power of 2, then the parentheses | |
11248 | -- cannot affect whether overflow occurs. We only bother to | |
11249 | -- test the left most operand | |
11250 | ||
11251 | -- Loop looking at left operands for one that has known value | |
11252 | ||
11253 | Opnd := Rorig; | |
11254 | Opnd_Loop : while Nkind (Opnd) = N_Op_Multiply loop | |
11255 | if Compile_Time_Known_Value (Left_Opnd (Opnd)) then | |
11256 | Lval := UI_Abs (Expr_Value (Left_Opnd (Opnd))); | |
11257 | ||
11258 | -- Operand value of 0 or 1 skips warning | |
11259 | ||
11260 | if Lval <= 1 then | |
11261 | return; | |
11262 | ||
11263 | -- Otherwise check power of 2, if power of 2, warn, if | |
11264 | -- anything else, skip warning. | |
11265 | ||
11266 | else | |
11267 | while Lval /= 2 loop | |
11268 | if Lval mod 2 = 1 then | |
11269 | return; | |
11270 | else | |
11271 | Lval := Lval / 2; | |
11272 | end if; | |
11273 | end loop; | |
11274 | ||
11275 | exit Opnd_Loop; | |
11276 | end if; | |
11277 | end if; | |
11278 | ||
11279 | -- Keep looking at left operands | |
11280 | ||
11281 | Opnd := Left_Opnd (Opnd); | |
11282 | end loop Opnd_Loop; | |
11283 | ||
11284 | -- For rem or "/" we can only have a problematic situation | |
11285 | -- if the divisor has a value of minus one or one. Otherwise | |
11286 | -- overflow is impossible (divisor > 1) or we have a case of | |
11287 | -- division by zero in any case. | |
11288 | ||
45fc7ddb | 11289 | if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem) |
0669bebe GB |
11290 | and then Compile_Time_Known_Value (Right_Opnd (Rorig)) |
11291 | and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1 | |
11292 | then | |
11293 | return; | |
11294 | end if; | |
11295 | ||
11296 | -- If we fall through warning should be issued | |
11297 | ||
324ac540 AC |
11298 | -- Shouldn't we test Warn_On_Questionable_Missing_Parens ??? |
11299 | ||
ed2233dc | 11300 | Error_Msg_N |
324ac540 | 11301 | ("??unary minus expression should be parenthesized here!", N); |
0669bebe GB |
11302 | end if; |
11303 | end if; | |
11304 | end; | |
996ae0b0 RK |
11305 | end Resolve_Unary_Op; |
11306 | ||
11307 | ---------------------------------- | |
11308 | -- Resolve_Unchecked_Expression -- | |
11309 | ---------------------------------- | |
11310 | ||
11311 | procedure Resolve_Unchecked_Expression | |
11312 | (N : Node_Id; | |
11313 | Typ : Entity_Id) | |
11314 | is | |
11315 | begin | |
11316 | Resolve (Expression (N), Typ, Suppress => All_Checks); | |
11317 | Set_Etype (N, Typ); | |
11318 | end Resolve_Unchecked_Expression; | |
11319 | ||
11320 | --------------------------------------- | |
11321 | -- Resolve_Unchecked_Type_Conversion -- | |
11322 | --------------------------------------- | |
11323 | ||
11324 | procedure Resolve_Unchecked_Type_Conversion | |
11325 | (N : Node_Id; | |
11326 | Typ : Entity_Id) | |
11327 | is | |
07fc65c4 GB |
11328 | pragma Warnings (Off, Typ); |
11329 | ||
996ae0b0 RK |
11330 | Operand : constant Node_Id := Expression (N); |
11331 | Opnd_Type : constant Entity_Id := Etype (Operand); | |
11332 | ||
11333 | begin | |
a77842bd | 11334 | -- Resolve operand using its own type |
996ae0b0 RK |
11335 | |
11336 | Resolve (Operand, Opnd_Type); | |
36428cc4 AC |
11337 | |
11338 | -- In an inlined context, the unchecked conversion may be applied | |
11339 | -- to a literal, in which case its type is the type of the context. | |
11340 | -- (In other contexts conversions cannot apply to literals). | |
11341 | ||
11342 | if In_Inlined_Body | |
480156b2 AC |
11343 | and then (Opnd_Type = Any_Character or else |
11344 | Opnd_Type = Any_Integer or else | |
11345 | Opnd_Type = Any_Real) | |
36428cc4 AC |
11346 | then |
11347 | Set_Etype (Operand, Typ); | |
11348 | end if; | |
11349 | ||
dec6faf1 | 11350 | Analyze_Dimension (N); |
996ae0b0 | 11351 | Eval_Unchecked_Conversion (N); |
996ae0b0 RK |
11352 | end Resolve_Unchecked_Type_Conversion; |
11353 | ||
11354 | ------------------------------ | |
11355 | -- Rewrite_Operator_As_Call -- | |
11356 | ------------------------------ | |
11357 | ||
11358 | procedure Rewrite_Operator_As_Call (N : Node_Id; Nam : Entity_Id) is | |
fbf5a39b AC |
11359 | Loc : constant Source_Ptr := Sloc (N); |
11360 | Actuals : constant List_Id := New_List; | |
996ae0b0 RK |
11361 | New_N : Node_Id; |
11362 | ||
11363 | begin | |
21d7ef70 | 11364 | if Nkind (N) in N_Binary_Op then |
996ae0b0 RK |
11365 | Append (Left_Opnd (N), Actuals); |
11366 | end if; | |
11367 | ||
11368 | Append (Right_Opnd (N), Actuals); | |
11369 | ||
11370 | New_N := | |
11371 | Make_Function_Call (Sloc => Loc, | |
11372 | Name => New_Occurrence_Of (Nam, Loc), | |
11373 | Parameter_Associations => Actuals); | |
11374 | ||
11375 | Preserve_Comes_From_Source (New_N, N); | |
11376 | Preserve_Comes_From_Source (Name (New_N), N); | |
11377 | Rewrite (N, New_N); | |
11378 | Set_Etype (N, Etype (Nam)); | |
11379 | end Rewrite_Operator_As_Call; | |
11380 | ||
11381 | ------------------------------ | |
11382 | -- Rewrite_Renamed_Operator -- | |
11383 | ------------------------------ | |
11384 | ||
0ab80019 AC |
11385 | procedure Rewrite_Renamed_Operator |
11386 | (N : Node_Id; | |
11387 | Op : Entity_Id; | |
11388 | Typ : Entity_Id) | |
11389 | is | |
996ae0b0 RK |
11390 | Nam : constant Name_Id := Chars (Op); |
11391 | Is_Binary : constant Boolean := Nkind (N) in N_Binary_Op; | |
11392 | Op_Node : Node_Id; | |
11393 | ||
11394 | begin | |
8d81fb4e AC |
11395 | -- Do not perform this transformation within a pre/postcondition, |
11396 | -- because the expression will be re-analyzed, and the transformation | |
11397 | -- might affect the visibility of the operator, e.g. in an instance. | |
d566e90a HK |
11398 | -- Note that fully analyzed and expanded pre/postconditions appear as |
11399 | -- pragma Check equivalents. | |
8d81fb4e | 11400 | |
d566e90a | 11401 | if In_Pre_Post_Condition (N) then |
8d81fb4e AC |
11402 | return; |
11403 | end if; | |
11404 | ||
d81b4bfe TQ |
11405 | -- Rewrite the operator node using the real operator, not its renaming. |
11406 | -- Exclude user-defined intrinsic operations of the same name, which are | |
11407 | -- treated separately and rewritten as calls. | |
996ae0b0 | 11408 | |
964f13da | 11409 | if Ekind (Op) /= E_Function or else Chars (N) /= Nam then |
996ae0b0 RK |
11410 | Op_Node := New_Node (Operator_Kind (Nam, Is_Binary), Sloc (N)); |
11411 | Set_Chars (Op_Node, Nam); | |
11412 | Set_Etype (Op_Node, Etype (N)); | |
11413 | Set_Entity (Op_Node, Op); | |
11414 | Set_Right_Opnd (Op_Node, Right_Opnd (N)); | |
11415 | ||
b7d1f17f HK |
11416 | -- Indicate that both the original entity and its renaming are |
11417 | -- referenced at this point. | |
fbf5a39b AC |
11418 | |
11419 | Generate_Reference (Entity (N), N); | |
996ae0b0 RK |
11420 | Generate_Reference (Op, N); |
11421 | ||
11422 | if Is_Binary then | |
d566e90a | 11423 | Set_Left_Opnd (Op_Node, Left_Opnd (N)); |
996ae0b0 RK |
11424 | end if; |
11425 | ||
11426 | Rewrite (N, Op_Node); | |
0ab80019 | 11427 | |
1366997b AC |
11428 | -- If the context type is private, add the appropriate conversions so |
11429 | -- that the operator is applied to the full view. This is done in the | |
11430 | -- routines that resolve intrinsic operators. | |
0ab80019 | 11431 | |
d566e90a | 11432 | if Is_Intrinsic_Subprogram (Op) and then Is_Private_Type (Typ) then |
0ab80019 | 11433 | case Nkind (N) is |
d8f43ee6 HK |
11434 | when N_Op_Add |
11435 | | N_Op_Divide | |
11436 | | N_Op_Expon | |
11437 | | N_Op_Mod | |
11438 | | N_Op_Multiply | |
11439 | | N_Op_Rem | |
11440 | | N_Op_Subtract | |
11441 | => | |
0ab80019 AC |
11442 | Resolve_Intrinsic_Operator (N, Typ); |
11443 | ||
d8f43ee6 HK |
11444 | when N_Op_Abs |
11445 | | N_Op_Minus | |
11446 | | N_Op_Plus | |
11447 | => | |
0ab80019 AC |
11448 | Resolve_Intrinsic_Unary_Operator (N, Typ); |
11449 | ||
11450 | when others => | |
11451 | Resolve (N, Typ); | |
11452 | end case; | |
11453 | end if; | |
11454 | ||
964f13da RD |
11455 | elsif Ekind (Op) = E_Function and then Is_Intrinsic_Subprogram (Op) then |
11456 | ||
1366997b AC |
11457 | -- Operator renames a user-defined operator of the same name. Use the |
11458 | -- original operator in the node, which is the one Gigi knows about. | |
0ab80019 AC |
11459 | |
11460 | Set_Entity (N, Op); | |
11461 | Set_Is_Overloaded (N, False); | |
996ae0b0 RK |
11462 | end if; |
11463 | end Rewrite_Renamed_Operator; | |
11464 | ||
11465 | ----------------------- | |
11466 | -- Set_Slice_Subtype -- | |
11467 | ----------------------- | |
11468 | ||
1366997b AC |
11469 | -- Build an implicit subtype declaration to represent the type delivered by |
11470 | -- the slice. This is an abbreviated version of an array subtype. We define | |
11471 | -- an index subtype for the slice, using either the subtype name or the | |
11472 | -- discrete range of the slice. To be consistent with index usage elsewhere | |
11473 | -- we create a list header to hold the single index. This list is not | |
11474 | -- otherwise attached to the syntax tree. | |
996ae0b0 RK |
11475 | |
11476 | procedure Set_Slice_Subtype (N : Node_Id) is | |
11477 | Loc : constant Source_Ptr := Sloc (N); | |
fbf5a39b | 11478 | Index_List : constant List_Id := New_List; |
996ae0b0 | 11479 | Index : Node_Id; |
996ae0b0 RK |
11480 | Index_Subtype : Entity_Id; |
11481 | Index_Type : Entity_Id; | |
11482 | Slice_Subtype : Entity_Id; | |
11483 | Drange : constant Node_Id := Discrete_Range (N); | |
11484 | ||
11485 | begin | |
08cd7c2f AC |
11486 | Index_Type := Base_Type (Etype (Drange)); |
11487 | ||
996ae0b0 RK |
11488 | if Is_Entity_Name (Drange) then |
11489 | Index_Subtype := Entity (Drange); | |
11490 | ||
11491 | else | |
11492 | -- We force the evaluation of a range. This is definitely needed in | |
11493 | -- the renamed case, and seems safer to do unconditionally. Note in | |
11494 | -- any case that since we will create and insert an Itype referring | |
11495 | -- to this range, we must make sure any side effect removal actions | |
11496 | -- are inserted before the Itype definition. | |
11497 | ||
11498 | if Nkind (Drange) = N_Range then | |
11499 | Force_Evaluation (Low_Bound (Drange)); | |
11500 | Force_Evaluation (High_Bound (Drange)); | |
996ae0b0 | 11501 | |
08cd7c2f AC |
11502 | -- If the discrete range is given by a subtype indication, the |
11503 | -- type of the slice is the base of the subtype mark. | |
11504 | ||
11505 | elsif Nkind (Drange) = N_Subtype_Indication then | |
11506 | declare | |
11507 | R : constant Node_Id := Range_Expression (Constraint (Drange)); | |
11508 | begin | |
11509 | Index_Type := Base_Type (Entity (Subtype_Mark (Drange))); | |
11510 | Force_Evaluation (Low_Bound (R)); | |
11511 | Force_Evaluation (High_Bound (R)); | |
11512 | end; | |
11513 | end if; | |
996ae0b0 RK |
11514 | |
11515 | Index_Subtype := Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); | |
11516 | ||
8a95f4e8 | 11517 | -- Take a new copy of Drange (where bounds have been rewritten to |
3c1ecd7e AC |
11518 | -- reference side-effect-free names). Using a separate tree ensures |
11519 | -- that further expansion (e.g. while rewriting a slice assignment | |
8a95f4e8 RD |
11520 | -- into a FOR loop) does not attempt to remove side effects on the |
11521 | -- bounds again (which would cause the bounds in the index subtype | |
11522 | -- definition to refer to temporaries before they are defined) (the | |
11523 | -- reason is that some names are considered side effect free here | |
11524 | -- for the subtype, but not in the context of a loop iteration | |
11525 | -- scheme). | |
11526 | ||
11527 | Set_Scalar_Range (Index_Subtype, New_Copy_Tree (Drange)); | |
4230bdb7 | 11528 | Set_Parent (Scalar_Range (Index_Subtype), Index_Subtype); |
996ae0b0 RK |
11529 | Set_Etype (Index_Subtype, Index_Type); |
11530 | Set_Size_Info (Index_Subtype, Index_Type); | |
11531 | Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); | |
11532 | end if; | |
11533 | ||
11534 | Slice_Subtype := Create_Itype (E_Array_Subtype, N); | |
11535 | ||
11536 | Index := New_Occurrence_Of (Index_Subtype, Loc); | |
11537 | Set_Etype (Index, Index_Subtype); | |
11538 | Append (Index, Index_List); | |
11539 | ||
996ae0b0 RK |
11540 | Set_First_Index (Slice_Subtype, Index); |
11541 | Set_Etype (Slice_Subtype, Base_Type (Etype (N))); | |
11542 | Set_Is_Constrained (Slice_Subtype, True); | |
996ae0b0 | 11543 | |
8a95f4e8 RD |
11544 | Check_Compile_Time_Size (Slice_Subtype); |
11545 | ||
b7d1f17f HK |
11546 | -- The Etype of the existing Slice node is reset to this slice subtype. |
11547 | -- Its bounds are obtained from its first index. | |
996ae0b0 RK |
11548 | |
11549 | Set_Etype (N, Slice_Subtype); | |
11550 | ||
7738270b AC |
11551 | -- For bit-packed slice subtypes, freeze immediately (except in the case |
11552 | -- of being in a "spec expression" where we never freeze when we first | |
11553 | -- see the expression). | |
8a95f4e8 | 11554 | |
7738270b | 11555 | if Is_Bit_Packed_Array (Slice_Subtype) and not In_Spec_Expression then |
8a95f4e8 | 11556 | Freeze_Itype (Slice_Subtype, N); |
996ae0b0 | 11557 | |
cfab0c49 AC |
11558 | -- For all other cases insert an itype reference in the slice's actions |
11559 | -- so that the itype is frozen at the proper place in the tree (i.e. at | |
11560 | -- the point where actions for the slice are analyzed). Note that this | |
11561 | -- is different from freezing the itype immediately, which might be | |
6ff6152d ES |
11562 | -- premature (e.g. if the slice is within a transient scope). This needs |
11563 | -- to be done only if expansion is enabled. | |
cfab0c49 | 11564 | |
4460a9bc | 11565 | elsif Expander_Active then |
8a95f4e8 RD |
11566 | Ensure_Defined (Typ => Slice_Subtype, N => N); |
11567 | end if; | |
996ae0b0 RK |
11568 | end Set_Slice_Subtype; |
11569 | ||
11570 | -------------------------------- | |
11571 | -- Set_String_Literal_Subtype -- | |
11572 | -------------------------------- | |
11573 | ||
11574 | procedure Set_String_Literal_Subtype (N : Node_Id; Typ : Entity_Id) is | |
c8ef728f ES |
11575 | Loc : constant Source_Ptr := Sloc (N); |
11576 | Low_Bound : constant Node_Id := | |
d81b4bfe | 11577 | Type_Low_Bound (Etype (First_Index (Typ))); |
996ae0b0 RK |
11578 | Subtype_Id : Entity_Id; |
11579 | ||
11580 | begin | |
11581 | if Nkind (N) /= N_String_Literal then | |
11582 | return; | |
996ae0b0 RK |
11583 | end if; |
11584 | ||
c8ef728f | 11585 | Subtype_Id := Create_Itype (E_String_Literal_Subtype, N); |
91b1417d AC |
11586 | Set_String_Literal_Length (Subtype_Id, UI_From_Int |
11587 | (String_Length (Strval (N)))); | |
c8ef728f ES |
11588 | Set_Etype (Subtype_Id, Base_Type (Typ)); |
11589 | Set_Is_Constrained (Subtype_Id); | |
11590 | Set_Etype (N, Subtype_Id); | |
11591 | ||
1366997b AC |
11592 | -- The low bound is set from the low bound of the corresponding index |
11593 | -- type. Note that we do not store the high bound in the string literal | |
11594 | -- subtype, but it can be deduced if necessary from the length and the | |
11595 | -- low bound. | |
996ae0b0 | 11596 | |
5f44f0d4 | 11597 | if Is_OK_Static_Expression (Low_Bound) then |
c8ef728f | 11598 | Set_String_Literal_Low_Bound (Subtype_Id, Low_Bound); |
996ae0b0 | 11599 | |
5f44f0d4 AC |
11600 | -- If the lower bound is not static we create a range for the string |
11601 | -- literal, using the index type and the known length of the literal. | |
11602 | -- The index type is not necessarily Positive, so the upper bound is | |
11603 | -- computed as T'Val (T'Pos (Low_Bound) + L - 1). | |
c8ef728f | 11604 | |
5f44f0d4 | 11605 | else |
c8ef728f | 11606 | declare |
5f44f0d4 AC |
11607 | Index_List : constant List_Id := New_List; |
11608 | Index_Type : constant Entity_Id := Etype (First_Index (Typ)); | |
11609 | High_Bound : constant Node_Id := | |
53f29d4f AC |
11610 | Make_Attribute_Reference (Loc, |
11611 | Attribute_Name => Name_Val, | |
11612 | Prefix => | |
11613 | New_Occurrence_Of (Index_Type, Loc), | |
11614 | Expressions => New_List ( | |
11615 | Make_Op_Add (Loc, | |
11616 | Left_Opnd => | |
11617 | Make_Attribute_Reference (Loc, | |
11618 | Attribute_Name => Name_Pos, | |
11619 | Prefix => | |
11620 | New_Occurrence_Of (Index_Type, Loc), | |
11621 | Expressions => | |
11622 | New_List (New_Copy_Tree (Low_Bound))), | |
11623 | Right_Opnd => | |
11624 | Make_Integer_Literal (Loc, | |
11625 | String_Length (Strval (N)) - 1)))); | |
c0b11850 | 11626 | |
c8ef728f | 11627 | Array_Subtype : Entity_Id; |
c8ef728f ES |
11628 | Drange : Node_Id; |
11629 | Index : Node_Id; | |
5f44f0d4 | 11630 | Index_Subtype : Entity_Id; |
c8ef728f ES |
11631 | |
11632 | begin | |
56e94186 AC |
11633 | if Is_Integer_Type (Index_Type) then |
11634 | Set_String_Literal_Low_Bound | |
11635 | (Subtype_Id, Make_Integer_Literal (Loc, 1)); | |
11636 | ||
11637 | else | |
11638 | -- If the index type is an enumeration type, build bounds | |
11639 | -- expression with attributes. | |
11640 | ||
11641 | Set_String_Literal_Low_Bound | |
11642 | (Subtype_Id, | |
11643 | Make_Attribute_Reference (Loc, | |
11644 | Attribute_Name => Name_First, | |
11645 | Prefix => | |
11646 | New_Occurrence_Of (Base_Type (Index_Type), Loc))); | |
11647 | Set_Etype (String_Literal_Low_Bound (Subtype_Id), Index_Type); | |
11648 | end if; | |
11649 | ||
c0b11850 AC |
11650 | Analyze_And_Resolve (String_Literal_Low_Bound (Subtype_Id)); |
11651 | ||
11652 | -- Build bona fide subtype for the string, and wrap it in an | |
11653 | -- unchecked conversion, because the backend expects the | |
11654 | -- String_Literal_Subtype to have a static lower bound. | |
11655 | ||
c8ef728f ES |
11656 | Index_Subtype := |
11657 | Create_Itype (Subtype_Kind (Ekind (Index_Type)), N); | |
0669bebe | 11658 | Drange := Make_Range (Loc, New_Copy_Tree (Low_Bound), High_Bound); |
c8ef728f ES |
11659 | Set_Scalar_Range (Index_Subtype, Drange); |
11660 | Set_Parent (Drange, N); | |
11661 | Analyze_And_Resolve (Drange, Index_Type); | |
11662 | ||
36fcf362 RD |
11663 | -- In the context, the Index_Type may already have a constraint, |
11664 | -- so use common base type on string subtype. The base type may | |
11665 | -- be used when generating attributes of the string, for example | |
11666 | -- in the context of a slice assignment. | |
11667 | ||
4adf3c50 AC |
11668 | Set_Etype (Index_Subtype, Base_Type (Index_Type)); |
11669 | Set_Size_Info (Index_Subtype, Index_Type); | |
11670 | Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); | |
c8ef728f ES |
11671 | |
11672 | Array_Subtype := Create_Itype (E_Array_Subtype, N); | |
11673 | ||
11674 | Index := New_Occurrence_Of (Index_Subtype, Loc); | |
11675 | Set_Etype (Index, Index_Subtype); | |
11676 | Append (Index, Index_List); | |
11677 | ||
11678 | Set_First_Index (Array_Subtype, Index); | |
11679 | Set_Etype (Array_Subtype, Base_Type (Typ)); | |
11680 | Set_Is_Constrained (Array_Subtype, True); | |
c8ef728f ES |
11681 | |
11682 | Rewrite (N, | |
11683 | Make_Unchecked_Type_Conversion (Loc, | |
11684 | Subtype_Mark => New_Occurrence_Of (Array_Subtype, Loc), | |
5f44f0d4 | 11685 | Expression => Relocate_Node (N))); |
c8ef728f ES |
11686 | Set_Etype (N, Array_Subtype); |
11687 | end; | |
11688 | end if; | |
996ae0b0 RK |
11689 | end Set_String_Literal_Subtype; |
11690 | ||
0669bebe GB |
11691 | ------------------------------ |
11692 | -- Simplify_Type_Conversion -- | |
11693 | ------------------------------ | |
11694 | ||
11695 | procedure Simplify_Type_Conversion (N : Node_Id) is | |
11696 | begin | |
11697 | if Nkind (N) = N_Type_Conversion then | |
11698 | declare | |
11699 | Operand : constant Node_Id := Expression (N); | |
11700 | Target_Typ : constant Entity_Id := Etype (N); | |
11701 | Opnd_Typ : constant Entity_Id := Etype (Operand); | |
11702 | ||
11703 | begin | |
24228312 AC |
11704 | -- Special processing if the conversion is the expression of a |
11705 | -- Rounding or Truncation attribute reference. In this case we | |
11706 | -- replace: | |
0669bebe | 11707 | |
24228312 | 11708 | -- ityp (ftyp'Rounding (x)) or ityp (ftyp'Truncation (x)) |
0669bebe GB |
11709 | |
11710 | -- by | |
11711 | ||
11712 | -- ityp (x) | |
11713 | ||
24228312 AC |
11714 | -- with the Float_Truncate flag set to False or True respectively, |
11715 | -- which is more efficient. | |
0669bebe | 11716 | |
24228312 AC |
11717 | if Is_Floating_Point_Type (Opnd_Typ) |
11718 | and then | |
11719 | (Is_Integer_Type (Target_Typ) | |
7a5b62b0 AC |
11720 | or else (Is_Fixed_Point_Type (Target_Typ) |
11721 | and then Conversion_OK (N))) | |
24228312 | 11722 | and then Nkind (Operand) = N_Attribute_Reference |
7a5b62b0 AC |
11723 | and then Nam_In (Attribute_Name (Operand), Name_Rounding, |
11724 | Name_Truncation) | |
0669bebe | 11725 | then |
24228312 AC |
11726 | declare |
11727 | Truncate : constant Boolean := | |
7a5b62b0 | 11728 | Attribute_Name (Operand) = Name_Truncation; |
24228312 AC |
11729 | begin |
11730 | Rewrite (Operand, | |
11731 | Relocate_Node (First (Expressions (Operand)))); | |
11732 | Set_Float_Truncate (N, Truncate); | |
11733 | end; | |
0669bebe GB |
11734 | end if; |
11735 | end; | |
11736 | end if; | |
11737 | end Simplify_Type_Conversion; | |
11738 | ||
996ae0b0 RK |
11739 | ----------------------------- |
11740 | -- Unique_Fixed_Point_Type -- | |
11741 | ----------------------------- | |
11742 | ||
11743 | function Unique_Fixed_Point_Type (N : Node_Id) return Entity_Id is | |
cccb761b | 11744 | procedure Fixed_Point_Error (T1 : Entity_Id; T2 : Entity_Id); |
d81b4bfe TQ |
11745 | -- Give error messages for true ambiguity. Messages are posted on node |
11746 | -- N, and entities T1, T2 are the possible interpretations. | |
a77842bd TQ |
11747 | |
11748 | ----------------------- | |
11749 | -- Fixed_Point_Error -- | |
11750 | ----------------------- | |
996ae0b0 | 11751 | |
cccb761b | 11752 | procedure Fixed_Point_Error (T1 : Entity_Id; T2 : Entity_Id) is |
996ae0b0 | 11753 | begin |
ed2233dc AC |
11754 | Error_Msg_N ("ambiguous universal_fixed_expression", N); |
11755 | Error_Msg_NE ("\\possible interpretation as}", N, T1); | |
11756 | Error_Msg_NE ("\\possible interpretation as}", N, T2); | |
996ae0b0 RK |
11757 | end Fixed_Point_Error; |
11758 | ||
cccb761b AC |
11759 | -- Local variables |
11760 | ||
11761 | ErrN : Node_Id; | |
11762 | Item : Node_Id; | |
11763 | Scop : Entity_Id; | |
11764 | T1 : Entity_Id; | |
11765 | T2 : Entity_Id; | |
11766 | ||
a77842bd TQ |
11767 | -- Start of processing for Unique_Fixed_Point_Type |
11768 | ||
996ae0b0 RK |
11769 | begin |
11770 | -- The operations on Duration are visible, so Duration is always a | |
11771 | -- possible interpretation. | |
11772 | ||
11773 | T1 := Standard_Duration; | |
11774 | ||
bc5f3720 | 11775 | -- Look for fixed-point types in enclosing scopes |
996ae0b0 | 11776 | |
fbf5a39b | 11777 | Scop := Current_Scope; |
996ae0b0 RK |
11778 | while Scop /= Standard_Standard loop |
11779 | T2 := First_Entity (Scop); | |
996ae0b0 RK |
11780 | while Present (T2) loop |
11781 | if Is_Fixed_Point_Type (T2) | |
11782 | and then Current_Entity (T2) = T2 | |
11783 | and then Scope (Base_Type (T2)) = Scop | |
11784 | then | |
11785 | if Present (T1) then | |
cccb761b | 11786 | Fixed_Point_Error (T1, T2); |
996ae0b0 RK |
11787 | return Any_Type; |
11788 | else | |
11789 | T1 := T2; | |
11790 | end if; | |
11791 | end if; | |
11792 | ||
11793 | Next_Entity (T2); | |
11794 | end loop; | |
11795 | ||
11796 | Scop := Scope (Scop); | |
11797 | end loop; | |
11798 | ||
a77842bd | 11799 | -- Look for visible fixed type declarations in the context |
996ae0b0 RK |
11800 | |
11801 | Item := First (Context_Items (Cunit (Current_Sem_Unit))); | |
996ae0b0 | 11802 | while Present (Item) loop |
996ae0b0 RK |
11803 | if Nkind (Item) = N_With_Clause then |
11804 | Scop := Entity (Name (Item)); | |
11805 | T2 := First_Entity (Scop); | |
996ae0b0 RK |
11806 | while Present (T2) loop |
11807 | if Is_Fixed_Point_Type (T2) | |
11808 | and then Scope (Base_Type (T2)) = Scop | |
19fb051c | 11809 | and then (Is_Potentially_Use_Visible (T2) or else In_Use (T2)) |
996ae0b0 RK |
11810 | then |
11811 | if Present (T1) then | |
cccb761b | 11812 | Fixed_Point_Error (T1, T2); |
996ae0b0 RK |
11813 | return Any_Type; |
11814 | else | |
11815 | T1 := T2; | |
11816 | end if; | |
11817 | end if; | |
11818 | ||
11819 | Next_Entity (T2); | |
11820 | end loop; | |
11821 | end if; | |
11822 | ||
11823 | Next (Item); | |
11824 | end loop; | |
11825 | ||
11826 | if Nkind (N) = N_Real_Literal then | |
cccb761b AC |
11827 | Error_Msg_NE ("??real literal interpreted as }!", N, T1); |
11828 | ||
996ae0b0 | 11829 | else |
cccb761b AC |
11830 | -- When the context is a type conversion, issue the warning on the |
11831 | -- expression of the conversion because it is the actual operation. | |
11832 | ||
11833 | if Nkind_In (N, N_Type_Conversion, N_Unchecked_Type_Conversion) then | |
11834 | ErrN := Expression (N); | |
11835 | else | |
11836 | ErrN := N; | |
11837 | end if; | |
11838 | ||
324ac540 | 11839 | Error_Msg_NE |
cccb761b | 11840 | ("??universal_fixed expression interpreted as }!", ErrN, T1); |
996ae0b0 RK |
11841 | end if; |
11842 | ||
11843 | return T1; | |
11844 | end Unique_Fixed_Point_Type; | |
11845 | ||
11846 | ---------------------- | |
11847 | -- Valid_Conversion -- | |
11848 | ---------------------- | |
11849 | ||
11850 | function Valid_Conversion | |
6cce2156 GD |
11851 | (N : Node_Id; |
11852 | Target : Entity_Id; | |
11853 | Operand : Node_Id; | |
11854 | Report_Errs : Boolean := True) return Boolean | |
996ae0b0 | 11855 | is |
e6425869 AC |
11856 | Target_Type : constant Entity_Id := Base_Type (Target); |
11857 | Opnd_Type : Entity_Id := Etype (Operand); | |
11858 | Inc_Ancestor : Entity_Id; | |
996ae0b0 RK |
11859 | |
11860 | function Conversion_Check | |
11861 | (Valid : Boolean; | |
0ab80019 | 11862 | Msg : String) return Boolean; |
996ae0b0 RK |
11863 | -- Little routine to post Msg if Valid is False, returns Valid value |
11864 | ||
1486a00e | 11865 | procedure Conversion_Error_N (Msg : String; N : Node_Or_Entity_Id); |
6cce2156 GD |
11866 | -- If Report_Errs, then calls Errout.Error_Msg_N with its arguments |
11867 | ||
1486a00e | 11868 | procedure Conversion_Error_NE |
6cce2156 GD |
11869 | (Msg : String; |
11870 | N : Node_Or_Entity_Id; | |
11871 | E : Node_Or_Entity_Id); | |
11872 | -- If Report_Errs, then calls Errout.Error_Msg_NE with its arguments | |
11873 | ||
996ae0b0 RK |
11874 | function Valid_Tagged_Conversion |
11875 | (Target_Type : Entity_Id; | |
0ab80019 | 11876 | Opnd_Type : Entity_Id) return Boolean; |
996ae0b0 RK |
11877 | -- Specifically test for validity of tagged conversions |
11878 | ||
aa180613 | 11879 | function Valid_Array_Conversion return Boolean; |
4adf3c50 AC |
11880 | -- Check index and component conformance, and accessibility levels if |
11881 | -- the component types are anonymous access types (Ada 2005). | |
aa180613 | 11882 | |
996ae0b0 RK |
11883 | ---------------------- |
11884 | -- Conversion_Check -- | |
11885 | ---------------------- | |
11886 | ||
11887 | function Conversion_Check | |
11888 | (Valid : Boolean; | |
0ab80019 | 11889 | Msg : String) return Boolean |
996ae0b0 RK |
11890 | is |
11891 | begin | |
0a190dfd AC |
11892 | if not Valid |
11893 | ||
11894 | -- A generic unit has already been analyzed and we have verified | |
11895 | -- that a particular conversion is OK in that context. Since the | |
11896 | -- instance is reanalyzed without relying on the relationships | |
11897 | -- established during the analysis of the generic, it is possible | |
11898 | -- to end up with inconsistent views of private types. Do not emit | |
11899 | -- the error message in such cases. The rest of the machinery in | |
11900 | -- Valid_Conversion still ensures the proper compatibility of | |
11901 | -- target and operand types. | |
11902 | ||
11903 | and then not In_Instance | |
11904 | then | |
1486a00e | 11905 | Conversion_Error_N (Msg, Operand); |
996ae0b0 RK |
11906 | end if; |
11907 | ||
11908 | return Valid; | |
11909 | end Conversion_Check; | |
11910 | ||
1486a00e AC |
11911 | ------------------------ |
11912 | -- Conversion_Error_N -- | |
11913 | ------------------------ | |
6cce2156 | 11914 | |
1486a00e | 11915 | procedure Conversion_Error_N (Msg : String; N : Node_Or_Entity_Id) is |
6cce2156 GD |
11916 | begin |
11917 | if Report_Errs then | |
1486a00e | 11918 | Error_Msg_N (Msg, N); |
6cce2156 | 11919 | end if; |
1486a00e | 11920 | end Conversion_Error_N; |
6cce2156 | 11921 | |
1486a00e AC |
11922 | ------------------------- |
11923 | -- Conversion_Error_NE -- | |
11924 | ------------------------- | |
6cce2156 | 11925 | |
1486a00e | 11926 | procedure Conversion_Error_NE |
6cce2156 GD |
11927 | (Msg : String; |
11928 | N : Node_Or_Entity_Id; | |
11929 | E : Node_Or_Entity_Id) | |
11930 | is | |
11931 | begin | |
11932 | if Report_Errs then | |
1486a00e | 11933 | Error_Msg_NE (Msg, N, E); |
6cce2156 | 11934 | end if; |
1486a00e | 11935 | end Conversion_Error_NE; |
6cce2156 | 11936 | |
aa180613 RD |
11937 | ---------------------------- |
11938 | -- Valid_Array_Conversion -- | |
11939 | ---------------------------- | |
11940 | ||
5f325af2 | 11941 | function Valid_Array_Conversion return Boolean is |
aa180613 RD |
11942 | Opnd_Comp_Type : constant Entity_Id := Component_Type (Opnd_Type); |
11943 | Opnd_Comp_Base : constant Entity_Id := Base_Type (Opnd_Comp_Type); | |
11944 | ||
11945 | Opnd_Index : Node_Id; | |
11946 | Opnd_Index_Type : Entity_Id; | |
11947 | ||
11948 | Target_Comp_Type : constant Entity_Id := | |
11949 | Component_Type (Target_Type); | |
11950 | Target_Comp_Base : constant Entity_Id := | |
11951 | Base_Type (Target_Comp_Type); | |
11952 | ||
11953 | Target_Index : Node_Id; | |
11954 | Target_Index_Type : Entity_Id; | |
11955 | ||
11956 | begin | |
11957 | -- Error if wrong number of dimensions | |
11958 | ||
11959 | if | |
11960 | Number_Dimensions (Target_Type) /= Number_Dimensions (Opnd_Type) | |
11961 | then | |
1486a00e | 11962 | Conversion_Error_N |
aa180613 RD |
11963 | ("incompatible number of dimensions for conversion", Operand); |
11964 | return False; | |
11965 | ||
11966 | -- Number of dimensions matches | |
11967 | ||
11968 | else | |
11969 | -- Loop through indexes of the two arrays | |
11970 | ||
11971 | Target_Index := First_Index (Target_Type); | |
11972 | Opnd_Index := First_Index (Opnd_Type); | |
11973 | while Present (Target_Index) and then Present (Opnd_Index) loop | |
11974 | Target_Index_Type := Etype (Target_Index); | |
11975 | Opnd_Index_Type := Etype (Opnd_Index); | |
11976 | ||
11977 | -- Error if index types are incompatible | |
11978 | ||
11979 | if not (Is_Integer_Type (Target_Index_Type) | |
11980 | and then Is_Integer_Type (Opnd_Index_Type)) | |
11981 | and then (Root_Type (Target_Index_Type) | |
11982 | /= Root_Type (Opnd_Index_Type)) | |
11983 | then | |
1486a00e | 11984 | Conversion_Error_N |
aa180613 RD |
11985 | ("incompatible index types for array conversion", |
11986 | Operand); | |
11987 | return False; | |
11988 | end if; | |
11989 | ||
11990 | Next_Index (Target_Index); | |
11991 | Next_Index (Opnd_Index); | |
11992 | end loop; | |
11993 | ||
11994 | -- If component types have same base type, all set | |
11995 | ||
11996 | if Target_Comp_Base = Opnd_Comp_Base then | |
11997 | null; | |
11998 | ||
11999 | -- Here if base types of components are not the same. The only | |
12000 | -- time this is allowed is if we have anonymous access types. | |
12001 | ||
12002 | -- The conversion of arrays of anonymous access types can lead | |
12003 | -- to dangling pointers. AI-392 formalizes the accessibility | |
12004 | -- checks that must be applied to such conversions to prevent | |
12005 | -- out-of-scope references. | |
12006 | ||
19fb051c AC |
12007 | elsif Ekind_In |
12008 | (Target_Comp_Base, E_Anonymous_Access_Type, | |
12009 | E_Anonymous_Access_Subprogram_Type) | |
aa180613 RD |
12010 | and then Ekind (Opnd_Comp_Base) = Ekind (Target_Comp_Base) |
12011 | and then | |
12012 | Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) | |
12013 | then | |
12014 | if Type_Access_Level (Target_Type) < | |
83e5da69 | 12015 | Deepest_Type_Access_Level (Opnd_Type) |
aa180613 RD |
12016 | then |
12017 | if In_Instance_Body then | |
43417b90 | 12018 | Error_Msg_Warn := SPARK_Mode /= On; |
1486a00e | 12019 | Conversion_Error_N |
4a28b181 AC |
12020 | ("source array type has deeper accessibility " |
12021 | & "level than target<<", Operand); | |
12022 | Conversion_Error_N ("\Program_Error [<<", Operand); | |
aa180613 RD |
12023 | Rewrite (N, |
12024 | Make_Raise_Program_Error (Sloc (N), | |
12025 | Reason => PE_Accessibility_Check_Failed)); | |
12026 | Set_Etype (N, Target_Type); | |
12027 | return False; | |
12028 | ||
12029 | -- Conversion not allowed because of accessibility levels | |
12030 | ||
12031 | else | |
1486a00e AC |
12032 | Conversion_Error_N |
12033 | ("source array type has deeper accessibility " | |
12034 | & "level than target", Operand); | |
aa180613 RD |
12035 | return False; |
12036 | end if; | |
19fb051c | 12037 | |
aa180613 RD |
12038 | else |
12039 | null; | |
12040 | end if; | |
12041 | ||
12042 | -- All other cases where component base types do not match | |
12043 | ||
12044 | else | |
1486a00e | 12045 | Conversion_Error_N |
aa180613 RD |
12046 | ("incompatible component types for array conversion", |
12047 | Operand); | |
12048 | return False; | |
12049 | end if; | |
12050 | ||
45fc7ddb HK |
12051 | -- Check that component subtypes statically match. For numeric |
12052 | -- types this means that both must be either constrained or | |
12053 | -- unconstrained. For enumeration types the bounds must match. | |
12054 | -- All of this is checked in Subtypes_Statically_Match. | |
aa180613 | 12055 | |
45fc7ddb | 12056 | if not Subtypes_Statically_Match |
83e5da69 | 12057 | (Target_Comp_Type, Opnd_Comp_Type) |
aa180613 | 12058 | then |
1486a00e | 12059 | Conversion_Error_N |
aa180613 RD |
12060 | ("component subtypes must statically match", Operand); |
12061 | return False; | |
12062 | end if; | |
12063 | end if; | |
12064 | ||
12065 | return True; | |
12066 | end Valid_Array_Conversion; | |
12067 | ||
996ae0b0 RK |
12068 | ----------------------------- |
12069 | -- Valid_Tagged_Conversion -- | |
12070 | ----------------------------- | |
12071 | ||
12072 | function Valid_Tagged_Conversion | |
12073 | (Target_Type : Entity_Id; | |
0ab80019 | 12074 | Opnd_Type : Entity_Id) return Boolean |
996ae0b0 RK |
12075 | is |
12076 | begin | |
a77842bd | 12077 | -- Upward conversions are allowed (RM 4.6(22)) |
996ae0b0 RK |
12078 | |
12079 | if Covers (Target_Type, Opnd_Type) | |
12080 | or else Is_Ancestor (Target_Type, Opnd_Type) | |
12081 | then | |
12082 | return True; | |
12083 | ||
a77842bd TQ |
12084 | -- Downward conversion are allowed if the operand is class-wide |
12085 | -- (RM 4.6(23)). | |
996ae0b0 RK |
12086 | |
12087 | elsif Is_Class_Wide_Type (Opnd_Type) | |
b7d1f17f | 12088 | and then Covers (Opnd_Type, Target_Type) |
996ae0b0 RK |
12089 | then |
12090 | return True; | |
12091 | ||
12092 | elsif Covers (Opnd_Type, Target_Type) | |
12093 | or else Is_Ancestor (Opnd_Type, Target_Type) | |
12094 | then | |
12095 | return | |
12096 | Conversion_Check (False, | |
12097 | "downward conversion of tagged objects not allowed"); | |
758c442c | 12098 | |
0669bebe | 12099 | -- Ada 2005 (AI-251): The conversion to/from interface types is |
0310af44 | 12100 | -- always valid. The types involved may be class-wide (sub)types. |
758c442c | 12101 | |
0310af44 AC |
12102 | elsif Is_Interface (Etype (Base_Type (Target_Type))) |
12103 | or else Is_Interface (Etype (Base_Type (Opnd_Type))) | |
12104 | then | |
758c442c GD |
12105 | return True; |
12106 | ||
b7d1f17f | 12107 | -- If the operand is a class-wide type obtained through a limited_ |
e4dc3327 | 12108 | -- with clause, and the context includes the nonlimited view, use |
b7d1f17f HK |
12109 | -- it to determine whether the conversion is legal. |
12110 | ||
12111 | elsif Is_Class_Wide_Type (Opnd_Type) | |
7b56a91b | 12112 | and then From_Limited_With (Opnd_Type) |
b7d1f17f HK |
12113 | and then Present (Non_Limited_View (Etype (Opnd_Type))) |
12114 | and then Is_Interface (Non_Limited_View (Etype (Opnd_Type))) | |
12115 | then | |
12116 | return True; | |
12117 | ||
aa180613 RD |
12118 | elsif Is_Access_Type (Opnd_Type) |
12119 | and then Is_Interface (Directly_Designated_Type (Opnd_Type)) | |
12120 | then | |
12121 | return True; | |
12122 | ||
996ae0b0 | 12123 | else |
1486a00e | 12124 | Conversion_Error_NE |
996ae0b0 RK |
12125 | ("invalid tagged conversion, not compatible with}", |
12126 | N, First_Subtype (Opnd_Type)); | |
12127 | return False; | |
12128 | end if; | |
12129 | end Valid_Tagged_Conversion; | |
12130 | ||
12131 | -- Start of processing for Valid_Conversion | |
12132 | ||
12133 | begin | |
12134 | Check_Parameterless_Call (Operand); | |
12135 | ||
12136 | if Is_Overloaded (Operand) then | |
12137 | declare | |
12138 | I : Interp_Index; | |
12139 | I1 : Interp_Index; | |
12140 | It : Interp; | |
12141 | It1 : Interp; | |
12142 | N1 : Entity_Id; | |
f0d10385 | 12143 | T1 : Entity_Id; |
996ae0b0 RK |
12144 | |
12145 | begin | |
d81b4bfe TQ |
12146 | -- Remove procedure calls, which syntactically cannot appear in |
12147 | -- this context, but which cannot be removed by type checking, | |
996ae0b0 RK |
12148 | -- because the context does not impose a type. |
12149 | ||
4adf3c50 AC |
12150 | -- The node may be labelled overloaded, but still contain only one |
12151 | -- interpretation because others were discarded earlier. If this | |
12152 | -- is the case, retain the single interpretation if legal. | |
9ebe3743 | 12153 | |
996ae0b0 | 12154 | Get_First_Interp (Operand, I, It); |
9ebe3743 HK |
12155 | Opnd_Type := It.Typ; |
12156 | Get_Next_Interp (I, It); | |
996ae0b0 | 12157 | |
9ebe3743 HK |
12158 | if Present (It.Typ) |
12159 | and then Opnd_Type /= Standard_Void_Type | |
12160 | then | |
12161 | -- More than one candidate interpretation is available | |
996ae0b0 | 12162 | |
9ebe3743 HK |
12163 | Get_First_Interp (Operand, I, It); |
12164 | while Present (It.Typ) loop | |
12165 | if It.Typ = Standard_Void_Type then | |
12166 | Remove_Interp (I); | |
12167 | end if; | |
1420b484 | 12168 | |
4d49c6e1 AC |
12169 | -- When compiling for a system where Address is of a visible |
12170 | -- integer type, spurious ambiguities can be produced when | |
12171 | -- arithmetic operations have a literal operand and return | |
12172 | -- System.Address or a descendant of it. These ambiguities | |
12173 | -- are usually resolved by the context, but for conversions | |
12174 | -- there is no context type and the removal of the spurious | |
12175 | -- operations must be done explicitly here. | |
12176 | ||
12177 | if not Address_Is_Private | |
d9d25d04 | 12178 | and then Is_Descendant_Of_Address (It.Typ) |
9ebe3743 HK |
12179 | then |
12180 | Remove_Interp (I); | |
12181 | end if; | |
12182 | ||
12183 | Get_Next_Interp (I, It); | |
12184 | end loop; | |
12185 | end if; | |
996ae0b0 RK |
12186 | |
12187 | Get_First_Interp (Operand, I, It); | |
12188 | I1 := I; | |
12189 | It1 := It; | |
12190 | ||
12191 | if No (It.Typ) then | |
1486a00e | 12192 | Conversion_Error_N ("illegal operand in conversion", Operand); |
996ae0b0 RK |
12193 | return False; |
12194 | end if; | |
12195 | ||
12196 | Get_Next_Interp (I, It); | |
12197 | ||
12198 | if Present (It.Typ) then | |
12199 | N1 := It1.Nam; | |
f0d10385 | 12200 | T1 := It1.Typ; |
c8307596 | 12201 | It1 := Disambiguate (Operand, I1, I, Any_Type); |
996ae0b0 RK |
12202 | |
12203 | if It1 = No_Interp then | |
1486a00e AC |
12204 | Conversion_Error_N |
12205 | ("ambiguous operand in conversion", Operand); | |
996ae0b0 | 12206 | |
f0d10385 AC |
12207 | -- If the interpretation involves a standard operator, use |
12208 | -- the location of the type, which may be user-defined. | |
12209 | ||
12210 | if Sloc (It.Nam) = Standard_Location then | |
12211 | Error_Msg_Sloc := Sloc (It.Typ); | |
12212 | else | |
12213 | Error_Msg_Sloc := Sloc (It.Nam); | |
12214 | end if; | |
12215 | ||
1486a00e | 12216 | Conversion_Error_N -- CODEFIX |
4e7a4f6e | 12217 | ("\\possible interpretation#!", Operand); |
996ae0b0 | 12218 | |
f0d10385 AC |
12219 | if Sloc (N1) = Standard_Location then |
12220 | Error_Msg_Sloc := Sloc (T1); | |
12221 | else | |
12222 | Error_Msg_Sloc := Sloc (N1); | |
12223 | end if; | |
12224 | ||
1486a00e | 12225 | Conversion_Error_N -- CODEFIX |
4e7a4f6e | 12226 | ("\\possible interpretation#!", Operand); |
996ae0b0 RK |
12227 | |
12228 | return False; | |
12229 | end if; | |
12230 | end if; | |
12231 | ||
12232 | Set_Etype (Operand, It1.Typ); | |
12233 | Opnd_Type := It1.Typ; | |
12234 | end; | |
12235 | end if; | |
12236 | ||
6fd0a72a AC |
12237 | -- Deal with conversion of integer type to address if the pragma |
12238 | -- Allow_Integer_Address is in effect. We convert the conversion to | |
a90bd866 | 12239 | -- an unchecked conversion in this case and we are all done. |
6fd0a72a | 12240 | |
061828e3 | 12241 | if Address_Integer_Convert_OK (Opnd_Type, Target_Type) then |
6fd0a72a AC |
12242 | Rewrite (N, Unchecked_Convert_To (Target_Type, Expression (N))); |
12243 | Analyze_And_Resolve (N, Target_Type); | |
12244 | return True; | |
12245 | end if; | |
12246 | ||
e6425869 AC |
12247 | -- If we are within a child unit, check whether the type of the |
12248 | -- expression has an ancestor in a parent unit, in which case it | |
12249 | -- belongs to its derivation class even if the ancestor is private. | |
12250 | -- See RM 7.3.1 (5.2/3). | |
12251 | ||
12252 | Inc_Ancestor := Get_Incomplete_View_Of_Ancestor (Opnd_Type); | |
12253 | ||
aa180613 | 12254 | -- Numeric types |
996ae0b0 | 12255 | |
6fd0a72a | 12256 | if Is_Numeric_Type (Target_Type) then |
996ae0b0 | 12257 | |
aa180613 | 12258 | -- A universal fixed expression can be converted to any numeric type |
996ae0b0 | 12259 | |
996ae0b0 RK |
12260 | if Opnd_Type = Universal_Fixed then |
12261 | return True; | |
7324bf49 | 12262 | |
aa180613 RD |
12263 | -- Also no need to check when in an instance or inlined body, because |
12264 | -- the legality has been established when the template was analyzed. | |
12265 | -- Furthermore, numeric conversions may occur where only a private | |
f3d57416 | 12266 | -- view of the operand type is visible at the instantiation point. |
aa180613 RD |
12267 | -- This results in a spurious error if we check that the operand type |
12268 | -- is a numeric type. | |
12269 | ||
12270 | -- Note: in a previous version of this unit, the following tests were | |
12271 | -- applied only for generated code (Comes_From_Source set to False), | |
12272 | -- but in fact the test is required for source code as well, since | |
12273 | -- this situation can arise in source code. | |
12274 | ||
12275 | elsif In_Instance or else In_Inlined_Body then | |
d347f572 | 12276 | return True; |
aa180613 RD |
12277 | |
12278 | -- Otherwise we need the conversion check | |
7324bf49 | 12279 | |
996ae0b0 | 12280 | else |
aa180613 | 12281 | return Conversion_Check |
6fd0a72a AC |
12282 | (Is_Numeric_Type (Opnd_Type) |
12283 | or else | |
12284 | (Present (Inc_Ancestor) | |
12285 | and then Is_Numeric_Type (Inc_Ancestor)), | |
12286 | "illegal operand for numeric conversion"); | |
996ae0b0 RK |
12287 | end if; |
12288 | ||
aa180613 RD |
12289 | -- Array types |
12290 | ||
996ae0b0 RK |
12291 | elsif Is_Array_Type (Target_Type) then |
12292 | if not Is_Array_Type (Opnd_Type) | |
12293 | or else Opnd_Type = Any_Composite | |
12294 | or else Opnd_Type = Any_String | |
12295 | then | |
1486a00e AC |
12296 | Conversion_Error_N |
12297 | ("illegal operand for array conversion", Operand); | |
996ae0b0 | 12298 | return False; |
b2502161 | 12299 | |
996ae0b0 | 12300 | else |
aa180613 | 12301 | return Valid_Array_Conversion; |
996ae0b0 RK |
12302 | end if; |
12303 | ||
4b963531 AC |
12304 | -- Ada 2005 (AI-251): Internally generated conversions of access to |
12305 | -- interface types added to force the displacement of the pointer to | |
12306 | -- reference the corresponding dispatch table. | |
12307 | ||
12308 | elsif not Comes_From_Source (N) | |
12309 | and then Is_Access_Type (Target_Type) | |
12310 | and then Is_Interface (Designated_Type (Target_Type)) | |
12311 | then | |
12312 | return True; | |
12313 | ||
e65f50ec ES |
12314 | -- Ada 2005 (AI-251): Anonymous access types where target references an |
12315 | -- interface type. | |
758c442c | 12316 | |
966fc9c5 AC |
12317 | elsif Is_Access_Type (Opnd_Type) |
12318 | and then Ekind_In (Target_Type, E_General_Access_Type, | |
12319 | E_Anonymous_Access_Type) | |
758c442c GD |
12320 | and then Is_Interface (Directly_Designated_Type (Target_Type)) |
12321 | then | |
12322 | -- Check the static accessibility rule of 4.6(17). Note that the | |
d81b4bfe TQ |
12323 | -- check is not enforced when within an instance body, since the |
12324 | -- RM requires such cases to be caught at run time. | |
758c442c | 12325 | |
4172a8e3 AC |
12326 | -- If the operand is a rewriting of an allocator no check is needed |
12327 | -- because there are no accessibility issues. | |
12328 | ||
12329 | if Nkind (Original_Node (N)) = N_Allocator then | |
12330 | null; | |
12331 | ||
12332 | elsif Ekind (Target_Type) /= E_Anonymous_Access_Type then | |
758c442c | 12333 | if Type_Access_Level (Opnd_Type) > |
996c8821 | 12334 | Deepest_Type_Access_Level (Target_Type) |
758c442c GD |
12335 | then |
12336 | -- In an instance, this is a run-time check, but one we know | |
12337 | -- will fail, so generate an appropriate warning. The raise | |
12338 | -- will be generated by Expand_N_Type_Conversion. | |
12339 | ||
12340 | if In_Instance_Body then | |
43417b90 | 12341 | Error_Msg_Warn := SPARK_Mode /= On; |
1486a00e | 12342 | Conversion_Error_N |
4a28b181 | 12343 | ("cannot convert local pointer to non-local access type<<", |
758c442c | 12344 | Operand); |
4a28b181 | 12345 | Conversion_Error_N ("\Program_Error [<<", Operand); |
996c8821 | 12346 | |
758c442c | 12347 | else |
1486a00e | 12348 | Conversion_Error_N |
758c442c GD |
12349 | ("cannot convert local pointer to non-local access type", |
12350 | Operand); | |
12351 | return False; | |
12352 | end if; | |
12353 | ||
12354 | -- Special accessibility checks are needed in the case of access | |
12355 | -- discriminants declared for a limited type. | |
12356 | ||
12357 | elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type | |
12358 | and then not Is_Local_Anonymous_Access (Opnd_Type) | |
12359 | then | |
12360 | -- When the operand is a selected access discriminant the check | |
12361 | -- needs to be made against the level of the object denoted by | |
d81b4bfe TQ |
12362 | -- the prefix of the selected name (Object_Access_Level handles |
12363 | -- checking the prefix of the operand for this case). | |
758c442c GD |
12364 | |
12365 | if Nkind (Operand) = N_Selected_Component | |
c8ef728f | 12366 | and then Object_Access_Level (Operand) > |
d15f9422 | 12367 | Deepest_Type_Access_Level (Target_Type) |
758c442c | 12368 | then |
d81b4bfe TQ |
12369 | -- In an instance, this is a run-time check, but one we know |
12370 | -- will fail, so generate an appropriate warning. The raise | |
12371 | -- will be generated by Expand_N_Type_Conversion. | |
758c442c GD |
12372 | |
12373 | if In_Instance_Body then | |
43417b90 | 12374 | Error_Msg_Warn := SPARK_Mode /= On; |
1486a00e | 12375 | Conversion_Error_N |
4a28b181 AC |
12376 | ("cannot convert access discriminant to non-local " |
12377 | & "access type<<", Operand); | |
12378 | Conversion_Error_N ("\Program_Error [<<", Operand); | |
12379 | ||
12380 | -- Real error if not in instance body | |
12381 | ||
758c442c | 12382 | else |
1486a00e AC |
12383 | Conversion_Error_N |
12384 | ("cannot convert access discriminant to non-local " | |
12385 | & "access type", Operand); | |
758c442c GD |
12386 | return False; |
12387 | end if; | |
12388 | end if; | |
12389 | ||
12390 | -- The case of a reference to an access discriminant from | |
12391 | -- within a limited type declaration (which will appear as | |
12392 | -- a discriminal) is always illegal because the level of the | |
f3d57416 | 12393 | -- discriminant is considered to be deeper than any (nameable) |
758c442c GD |
12394 | -- access type. |
12395 | ||
12396 | if Is_Entity_Name (Operand) | |
12397 | and then not Is_Local_Anonymous_Access (Opnd_Type) | |
964f13da RD |
12398 | and then |
12399 | Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) | |
758c442c GD |
12400 | and then Present (Discriminal_Link (Entity (Operand))) |
12401 | then | |
1486a00e | 12402 | Conversion_Error_N |
758c442c GD |
12403 | ("discriminant has deeper accessibility level than target", |
12404 | Operand); | |
12405 | return False; | |
12406 | end if; | |
12407 | end if; | |
12408 | end if; | |
12409 | ||
12410 | return True; | |
12411 | ||
aa180613 RD |
12412 | -- General and anonymous access types |
12413 | ||
964f13da RD |
12414 | elsif Ekind_In (Target_Type, E_General_Access_Type, |
12415 | E_Anonymous_Access_Type) | |
996ae0b0 RK |
12416 | and then |
12417 | Conversion_Check | |
12418 | (Is_Access_Type (Opnd_Type) | |
964f13da RD |
12419 | and then not |
12420 | Ekind_In (Opnd_Type, E_Access_Subprogram_Type, | |
12421 | E_Access_Protected_Subprogram_Type), | |
996ae0b0 RK |
12422 | "must be an access-to-object type") |
12423 | then | |
12424 | if Is_Access_Constant (Opnd_Type) | |
12425 | and then not Is_Access_Constant (Target_Type) | |
12426 | then | |
1486a00e | 12427 | Conversion_Error_N |
996ae0b0 RK |
12428 | ("access-to-constant operand type not allowed", Operand); |
12429 | return False; | |
12430 | end if; | |
12431 | ||
758c442c GD |
12432 | -- Check the static accessibility rule of 4.6(17). Note that the |
12433 | -- check is not enforced when within an instance body, since the RM | |
12434 | -- requires such cases to be caught at run time. | |
996ae0b0 | 12435 | |
758c442c GD |
12436 | if Ekind (Target_Type) /= E_Anonymous_Access_Type |
12437 | or else Is_Local_Anonymous_Access (Target_Type) | |
d15f9422 | 12438 | or else Nkind (Associated_Node_For_Itype (Target_Type)) = |
996c8821 | 12439 | N_Object_Declaration |
758c442c | 12440 | then |
6cce2156 GD |
12441 | -- Ada 2012 (AI05-0149): Perform legality checking on implicit |
12442 | -- conversions from an anonymous access type to a named general | |
12443 | -- access type. Such conversions are not allowed in the case of | |
12444 | -- access parameters and stand-alone objects of an anonymous | |
c199ccf7 AC |
12445 | -- access type. The implicit conversion case is recognized by |
12446 | -- testing that Comes_From_Source is False and that it's been | |
12447 | -- rewritten. The Comes_From_Source test isn't sufficient because | |
12448 | -- nodes in inlined calls to predefined library routines can have | |
12449 | -- Comes_From_Source set to False. (Is there a better way to test | |
12450 | -- for implicit conversions???) | |
6cce2156 GD |
12451 | |
12452 | if Ada_Version >= Ada_2012 | |
12453 | and then not Comes_From_Source (N) | |
c199ccf7 | 12454 | and then N /= Original_Node (N) |
6cce2156 GD |
12455 | and then Ekind (Target_Type) = E_General_Access_Type |
12456 | and then Ekind (Opnd_Type) = E_Anonymous_Access_Type | |
996ae0b0 | 12457 | then |
6cce2156 GD |
12458 | if Is_Itype (Opnd_Type) then |
12459 | ||
12460 | -- Implicit conversions aren't allowed for objects of an | |
12461 | -- anonymous access type, since such objects have nonstatic | |
12462 | -- levels in Ada 2012. | |
12463 | ||
12464 | if Nkind (Associated_Node_For_Itype (Opnd_Type)) = | |
12465 | N_Object_Declaration | |
12466 | then | |
1486a00e AC |
12467 | Conversion_Error_N |
12468 | ("implicit conversion of stand-alone anonymous " | |
12469 | & "access object not allowed", Operand); | |
6cce2156 GD |
12470 | return False; |
12471 | ||
12472 | -- Implicit conversions aren't allowed for anonymous access | |
12473 | -- parameters. The "not Is_Local_Anonymous_Access_Type" test | |
12474 | -- is done to exclude anonymous access results. | |
12475 | ||
12476 | elsif not Is_Local_Anonymous_Access (Opnd_Type) | |
12477 | and then Nkind_In (Associated_Node_For_Itype (Opnd_Type), | |
12478 | N_Function_Specification, | |
12479 | N_Procedure_Specification) | |
12480 | then | |
1486a00e AC |
12481 | Conversion_Error_N |
12482 | ("implicit conversion of anonymous access formal " | |
12483 | & "not allowed", Operand); | |
6cce2156 GD |
12484 | return False; |
12485 | ||
12486 | -- This is a case where there's an enclosing object whose | |
12487 | -- to which the "statically deeper than" relationship does | |
12488 | -- not apply (such as an access discriminant selected from | |
12489 | -- a dereference of an access parameter). | |
12490 | ||
12491 | elsif Object_Access_Level (Operand) | |
12492 | = Scope_Depth (Standard_Standard) | |
12493 | then | |
1486a00e AC |
12494 | Conversion_Error_N |
12495 | ("implicit conversion of anonymous access value " | |
12496 | & "not allowed", Operand); | |
6cce2156 GD |
12497 | return False; |
12498 | ||
12499 | -- In other cases, the level of the operand's type must be | |
12500 | -- statically less deep than that of the target type, else | |
12501 | -- implicit conversion is disallowed (by RM12-8.6(27.1/3)). | |
12502 | ||
d15f9422 | 12503 | elsif Type_Access_Level (Opnd_Type) > |
996c8821 | 12504 | Deepest_Type_Access_Level (Target_Type) |
6cce2156 | 12505 | then |
1486a00e AC |
12506 | Conversion_Error_N |
12507 | ("implicit conversion of anonymous access value " | |
12508 | & "violates accessibility", Operand); | |
6cce2156 GD |
12509 | return False; |
12510 | end if; | |
12511 | end if; | |
12512 | ||
d15f9422 | 12513 | elsif Type_Access_Level (Opnd_Type) > |
996c8821 | 12514 | Deepest_Type_Access_Level (Target_Type) |
6cce2156 | 12515 | then |
d81b4bfe TQ |
12516 | -- In an instance, this is a run-time check, but one we know |
12517 | -- will fail, so generate an appropriate warning. The raise | |
12518 | -- will be generated by Expand_N_Type_Conversion. | |
996ae0b0 RK |
12519 | |
12520 | if In_Instance_Body then | |
43417b90 | 12521 | Error_Msg_Warn := SPARK_Mode /= On; |
1486a00e | 12522 | Conversion_Error_N |
4a28b181 | 12523 | ("cannot convert local pointer to non-local access type<<", |
996ae0b0 | 12524 | Operand); |
4a28b181 AC |
12525 | Conversion_Error_N ("\Program_Error [<<", Operand); |
12526 | ||
12527 | -- If not in an instance body, this is a real error | |
996ae0b0 RK |
12528 | |
12529 | else | |
b90cfacd HK |
12530 | -- Avoid generation of spurious error message |
12531 | ||
12532 | if not Error_Posted (N) then | |
1486a00e | 12533 | Conversion_Error_N |
b90cfacd HK |
12534 | ("cannot convert local pointer to non-local access type", |
12535 | Operand); | |
12536 | end if; | |
12537 | ||
996ae0b0 RK |
12538 | return False; |
12539 | end if; | |
12540 | ||
758c442c GD |
12541 | -- Special accessibility checks are needed in the case of access |
12542 | -- discriminants declared for a limited type. | |
12543 | ||
12544 | elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type | |
12545 | and then not Is_Local_Anonymous_Access (Opnd_Type) | |
12546 | then | |
758c442c GD |
12547 | -- When the operand is a selected access discriminant the check |
12548 | -- needs to be made against the level of the object denoted by | |
d81b4bfe TQ |
12549 | -- the prefix of the selected name (Object_Access_Level handles |
12550 | -- checking the prefix of the operand for this case). | |
996ae0b0 RK |
12551 | |
12552 | if Nkind (Operand) = N_Selected_Component | |
45fc7ddb | 12553 | and then Object_Access_Level (Operand) > |
996c8821 | 12554 | Deepest_Type_Access_Level (Target_Type) |
996ae0b0 | 12555 | then |
d81b4bfe TQ |
12556 | -- In an instance, this is a run-time check, but one we know |
12557 | -- will fail, so generate an appropriate warning. The raise | |
12558 | -- will be generated by Expand_N_Type_Conversion. | |
996ae0b0 RK |
12559 | |
12560 | if In_Instance_Body then | |
43417b90 | 12561 | Error_Msg_Warn := SPARK_Mode /= On; |
1486a00e | 12562 | Conversion_Error_N |
4a28b181 AC |
12563 | ("cannot convert access discriminant to non-local " |
12564 | & "access type<<", Operand); | |
12565 | Conversion_Error_N ("\Program_Error [<<", Operand); | |
12566 | ||
12567 | -- If not in an instance body, this is a real error | |
996ae0b0 RK |
12568 | |
12569 | else | |
1486a00e AC |
12570 | Conversion_Error_N |
12571 | ("cannot convert access discriminant to non-local " | |
12572 | & "access type", Operand); | |
996ae0b0 RK |
12573 | return False; |
12574 | end if; | |
12575 | end if; | |
12576 | ||
758c442c GD |
12577 | -- The case of a reference to an access discriminant from |
12578 | -- within a limited type declaration (which will appear as | |
12579 | -- a discriminal) is always illegal because the level of the | |
f3d57416 | 12580 | -- discriminant is considered to be deeper than any (nameable) |
758c442c | 12581 | -- access type. |
996ae0b0 RK |
12582 | |
12583 | if Is_Entity_Name (Operand) | |
964f13da RD |
12584 | and then |
12585 | Ekind_In (Entity (Operand), E_In_Parameter, E_Constant) | |
996ae0b0 RK |
12586 | and then Present (Discriminal_Link (Entity (Operand))) |
12587 | then | |
1486a00e | 12588 | Conversion_Error_N |
996ae0b0 RK |
12589 | ("discriminant has deeper accessibility level than target", |
12590 | Operand); | |
12591 | return False; | |
12592 | end if; | |
12593 | end if; | |
12594 | end if; | |
12595 | ||
e4dc3327 | 12596 | -- In the presence of limited_with clauses we have to use nonlimited |
14e33999 | 12597 | -- views, if available. |
d81b4bfe | 12598 | |
14e33999 | 12599 | Check_Limited : declare |
0669bebe GB |
12600 | function Full_Designated_Type (T : Entity_Id) return Entity_Id; |
12601 | -- Helper function to handle limited views | |
12602 | ||
12603 | -------------------------- | |
12604 | -- Full_Designated_Type -- | |
12605 | -------------------------- | |
12606 | ||
12607 | function Full_Designated_Type (T : Entity_Id) return Entity_Id is | |
950d217a | 12608 | Desig : constant Entity_Id := Designated_Type (T); |
c0985d4e | 12609 | |
0669bebe | 12610 | begin |
950d217a AC |
12611 | -- Handle the limited view of a type |
12612 | ||
47346923 AC |
12613 | if From_Limited_With (Desig) |
12614 | and then Has_Non_Limited_View (Desig) | |
0669bebe | 12615 | then |
950d217a AC |
12616 | return Available_View (Desig); |
12617 | else | |
12618 | return Desig; | |
0669bebe GB |
12619 | end if; |
12620 | end Full_Designated_Type; | |
12621 | ||
d81b4bfe TQ |
12622 | -- Local Declarations |
12623 | ||
0669bebe GB |
12624 | Target : constant Entity_Id := Full_Designated_Type (Target_Type); |
12625 | Opnd : constant Entity_Id := Full_Designated_Type (Opnd_Type); | |
12626 | ||
12627 | Same_Base : constant Boolean := | |
12628 | Base_Type (Target) = Base_Type (Opnd); | |
996ae0b0 | 12629 | |
14e33999 | 12630 | -- Start of processing for Check_Limited |
d81b4bfe | 12631 | |
996ae0b0 RK |
12632 | begin |
12633 | if Is_Tagged_Type (Target) then | |
12634 | return Valid_Tagged_Conversion (Target, Opnd); | |
12635 | ||
12636 | else | |
0669bebe | 12637 | if not Same_Base then |
1486a00e | 12638 | Conversion_Error_NE |
996ae0b0 RK |
12639 | ("target designated type not compatible with }", |
12640 | N, Base_Type (Opnd)); | |
12641 | return False; | |
12642 | ||
da709d08 AC |
12643 | -- Ada 2005 AI-384: legality rule is symmetric in both |
12644 | -- designated types. The conversion is legal (with possible | |
12645 | -- constraint check) if either designated type is | |
12646 | -- unconstrained. | |
12647 | ||
12648 | elsif Subtypes_Statically_Match (Target, Opnd) | |
12649 | or else | |
12650 | (Has_Discriminants (Target) | |
12651 | and then | |
12652 | (not Is_Constrained (Opnd) | |
12653 | or else not Is_Constrained (Target))) | |
996ae0b0 | 12654 | then |
9fa33291 RD |
12655 | -- Special case, if Value_Size has been used to make the |
12656 | -- sizes different, the conversion is not allowed even | |
12657 | -- though the subtypes statically match. | |
12658 | ||
12659 | if Known_Static_RM_Size (Target) | |
12660 | and then Known_Static_RM_Size (Opnd) | |
12661 | and then RM_Size (Target) /= RM_Size (Opnd) | |
12662 | then | |
1486a00e | 12663 | Conversion_Error_NE |
9fa33291 RD |
12664 | ("target designated subtype not compatible with }", |
12665 | N, Opnd); | |
1486a00e | 12666 | Conversion_Error_NE |
9fa33291 RD |
12667 | ("\because sizes of the two designated subtypes differ", |
12668 | N, Opnd); | |
12669 | return False; | |
12670 | ||
12671 | -- Normal case where conversion is allowed | |
12672 | ||
12673 | else | |
12674 | return True; | |
12675 | end if; | |
da709d08 AC |
12676 | |
12677 | else | |
996ae0b0 RK |
12678 | Error_Msg_NE |
12679 | ("target designated subtype not compatible with }", | |
12680 | N, Opnd); | |
12681 | return False; | |
996ae0b0 RK |
12682 | end if; |
12683 | end if; | |
14e33999 | 12684 | end Check_Limited; |
996ae0b0 | 12685 | |
cdbf04c0 | 12686 | -- Access to subprogram types. If the operand is an access parameter, |
4adf3c50 AC |
12687 | -- the type has a deeper accessibility that any master, and cannot be |
12688 | -- assigned. We must make an exception if the conversion is part of an | |
12689 | -- assignment and the target is the return object of an extended return | |
12690 | -- statement, because in that case the accessibility check takes place | |
12691 | -- after the return. | |
aa180613 | 12692 | |
dce86910 | 12693 | elsif Is_Access_Subprogram_Type (Target_Type) |
b07b7ace | 12694 | |
3f1bc2cf AC |
12695 | -- Note: this test of Opnd_Type is there to prevent entering this |
12696 | -- branch in the case of a remote access to subprogram type, which | |
12697 | -- is internally represented as an E_Record_Type. | |
b07b7ace | 12698 | |
3f1bc2cf | 12699 | and then Is_Access_Type (Opnd_Type) |
996ae0b0 | 12700 | then |
cdbf04c0 AC |
12701 | if Ekind (Base_Type (Opnd_Type)) = E_Anonymous_Access_Subprogram_Type |
12702 | and then Is_Entity_Name (Operand) | |
12703 | and then Ekind (Entity (Operand)) = E_In_Parameter | |
53cf4600 ES |
12704 | and then |
12705 | (Nkind (Parent (N)) /= N_Assignment_Statement | |
12706 | or else not Is_Entity_Name (Name (Parent (N))) | |
12707 | or else not Is_Return_Object (Entity (Name (Parent (N))))) | |
0669bebe | 12708 | then |
1486a00e | 12709 | Conversion_Error_N |
0669bebe GB |
12710 | ("illegal attempt to store anonymous access to subprogram", |
12711 | Operand); | |
1486a00e AC |
12712 | Conversion_Error_N |
12713 | ("\value has deeper accessibility than any master " | |
12714 | & "(RM 3.10.2 (13))", | |
0669bebe GB |
12715 | Operand); |
12716 | ||
c147ac26 ES |
12717 | Error_Msg_NE |
12718 | ("\use named access type for& instead of access parameter", | |
12719 | Operand, Entity (Operand)); | |
0669bebe GB |
12720 | end if; |
12721 | ||
996ae0b0 RK |
12722 | -- Check that the designated types are subtype conformant |
12723 | ||
bc5f3720 RD |
12724 | Check_Subtype_Conformant (New_Id => Designated_Type (Target_Type), |
12725 | Old_Id => Designated_Type (Opnd_Type), | |
12726 | Err_Loc => N); | |
996ae0b0 RK |
12727 | |
12728 | -- Check the static accessibility rule of 4.6(20) | |
12729 | ||
12730 | if Type_Access_Level (Opnd_Type) > | |
996c8821 | 12731 | Deepest_Type_Access_Level (Target_Type) |
996ae0b0 | 12732 | then |
1486a00e | 12733 | Conversion_Error_N |
996ae0b0 RK |
12734 | ("operand type has deeper accessibility level than target", |
12735 | Operand); | |
12736 | ||
12737 | -- Check that if the operand type is declared in a generic body, | |
12738 | -- then the target type must be declared within that same body | |
12739 | -- (enforces last sentence of 4.6(20)). | |
12740 | ||
12741 | elsif Present (Enclosing_Generic_Body (Opnd_Type)) then | |
12742 | declare | |
12743 | O_Gen : constant Node_Id := | |
12744 | Enclosing_Generic_Body (Opnd_Type); | |
12745 | ||
1420b484 | 12746 | T_Gen : Node_Id; |
996ae0b0 RK |
12747 | |
12748 | begin | |
1420b484 | 12749 | T_Gen := Enclosing_Generic_Body (Target_Type); |
996ae0b0 RK |
12750 | while Present (T_Gen) and then T_Gen /= O_Gen loop |
12751 | T_Gen := Enclosing_Generic_Body (T_Gen); | |
12752 | end loop; | |
12753 | ||
12754 | if T_Gen /= O_Gen then | |
1486a00e AC |
12755 | Conversion_Error_N |
12756 | ("target type must be declared in same generic body " | |
12757 | & "as operand type", N); | |
996ae0b0 RK |
12758 | end if; |
12759 | end; | |
12760 | end if; | |
12761 | ||
12762 | return True; | |
12763 | ||
b07b7ace | 12764 | -- Remote access to subprogram types |
aa180613 | 12765 | |
996ae0b0 RK |
12766 | elsif Is_Remote_Access_To_Subprogram_Type (Target_Type) |
12767 | and then Is_Remote_Access_To_Subprogram_Type (Opnd_Type) | |
12768 | then | |
12769 | -- It is valid to convert from one RAS type to another provided | |
12770 | -- that their specification statically match. | |
12771 | ||
b07b7ace AC |
12772 | -- Note: at this point, remote access to subprogram types have been |
12773 | -- expanded to their E_Record_Type representation, and we need to | |
12774 | -- go back to the original access type definition using the | |
12775 | -- Corresponding_Remote_Type attribute in order to check that the | |
12776 | -- designated profiles match. | |
12777 | ||
12778 | pragma Assert (Ekind (Target_Type) = E_Record_Type); | |
12779 | pragma Assert (Ekind (Opnd_Type) = E_Record_Type); | |
12780 | ||
996ae0b0 RK |
12781 | Check_Subtype_Conformant |
12782 | (New_Id => | |
12783 | Designated_Type (Corresponding_Remote_Type (Target_Type)), | |
12784 | Old_Id => | |
12785 | Designated_Type (Corresponding_Remote_Type (Opnd_Type)), | |
12786 | Err_Loc => | |
12787 | N); | |
12788 | return True; | |
aa180613 | 12789 | |
be482a8c AC |
12790 | -- If it was legal in the generic, it's legal in the instance |
12791 | ||
12792 | elsif In_Instance_Body then | |
12793 | return True; | |
12794 | ||
e65f50ec | 12795 | -- If both are tagged types, check legality of view conversions |
996ae0b0 | 12796 | |
e65f50ec | 12797 | elsif Is_Tagged_Type (Target_Type) |
4adf3c50 AC |
12798 | and then |
12799 | Is_Tagged_Type (Opnd_Type) | |
e65f50ec | 12800 | then |
996ae0b0 RK |
12801 | return Valid_Tagged_Conversion (Target_Type, Opnd_Type); |
12802 | ||
a77842bd | 12803 | -- Types derived from the same root type are convertible |
996ae0b0 RK |
12804 | |
12805 | elsif Root_Type (Target_Type) = Root_Type (Opnd_Type) then | |
12806 | return True; | |
12807 | ||
4adf3c50 AC |
12808 | -- In an instance or an inlined body, there may be inconsistent views of |
12809 | -- the same type, or of types derived from a common root. | |
996ae0b0 | 12810 | |
aa5147f0 ES |
12811 | elsif (In_Instance or In_Inlined_Body) |
12812 | and then | |
d81b4bfe TQ |
12813 | Root_Type (Underlying_Type (Target_Type)) = |
12814 | Root_Type (Underlying_Type (Opnd_Type)) | |
996ae0b0 RK |
12815 | then |
12816 | return True; | |
12817 | ||
12818 | -- Special check for common access type error case | |
12819 | ||
12820 | elsif Ekind (Target_Type) = E_Access_Type | |
12821 | and then Is_Access_Type (Opnd_Type) | |
12822 | then | |
1486a00e AC |
12823 | Conversion_Error_N ("target type must be general access type!", N); |
12824 | Conversion_Error_NE -- CODEFIX | |
305caf42 | 12825 | ("add ALL to }!", N, Target_Type); |
996ae0b0 RK |
12826 | return False; |
12827 | ||
818b578d AC |
12828 | -- Here we have a real conversion error |
12829 | ||
996ae0b0 | 12830 | else |
1486a00e AC |
12831 | Conversion_Error_NE |
12832 | ("invalid conversion, not compatible with }", N, Opnd_Type); | |
996ae0b0 RK |
12833 | return False; |
12834 | end if; | |
12835 | end Valid_Conversion; | |
12836 | ||
12837 | end Sem_Res; |