]>
Commit | Line | Data |
---|---|---|
996ae0b0 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- S E M _ C A T -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
8d0d46f4 | 9 | -- Copyright (C) 1992-2021, 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 Debug; use Debug; | |
76f9c7f4 BD |
28 | with Einfo; use Einfo; |
29 | with Einfo.Entities; use Einfo.Entities; | |
30 | with Einfo.Utils; use Einfo.Utils; | |
996ae0b0 RK |
31 | with Elists; use Elists; |
32 | with Errout; use Errout; | |
996ae0b0 | 33 | with Lib; use Lib; |
2fa9443e | 34 | with Namet; use Namet; |
996ae0b0 | 35 | with Nlists; use Nlists; |
6d158291 | 36 | with Opt; use Opt; |
996ae0b0 | 37 | with Sem; use Sem; |
b5ea9143 | 38 | with Sem_Attr; use Sem_Attr; |
a4100e55 | 39 | with Sem_Aux; use Sem_Aux; |
25081892 | 40 | with Sem_Dist; use Sem_Dist; |
fbf5a39b | 41 | with Sem_Eval; use Sem_Eval; |
996ae0b0 | 42 | with Sem_Util; use Sem_Util; |
76f9c7f4 BD |
43 | with Sinfo; use Sinfo; |
44 | with Sinfo.Nodes; use Sinfo.Nodes; | |
45 | with Sinfo.Utils; use Sinfo.Utils; | |
996ae0b0 RK |
46 | with Snames; use Snames; |
47 | with Stand; use Stand; | |
48 | ||
49 | package body Sem_Cat is | |
50 | ||
51 | ----------------------- | |
52 | -- Local Subprograms -- | |
53 | ----------------------- | |
54 | ||
55 | procedure Check_Categorization_Dependencies | |
56 | (Unit_Entity : Entity_Id; | |
57 | Depended_Entity : Entity_Id; | |
58 | Info_Node : Node_Id; | |
59 | Is_Subunit : Boolean); | |
60 | -- This procedure checks that the categorization of a lib unit and that | |
61 | -- of the depended unit satisfy dependency restrictions. | |
62 | -- The depended_entity can be the entity in a with_clause item, in which | |
63 | -- case Info_Node denotes that item. The depended_entity can also be the | |
64 | -- parent unit of a child unit, in which case Info_Node is the declaration | |
65 | -- of the child unit. The error message is posted on Info_Node, and is | |
66 | -- specialized if Is_Subunit is true. | |
67 | ||
68 | procedure Check_Non_Static_Default_Expr | |
69 | (Type_Def : Node_Id; | |
70 | Obj_Decl : Node_Id); | |
71 | -- Iterate through the component list of a record definition, check | |
72 | -- that no component is declared with a nonstatic default value. | |
73 | -- If a nonstatic default exists, report an error on Obj_Decl. | |
74 | ||
b5ea9143 AC |
75 | function Has_Read_Write_Attributes (E : Entity_Id) return Boolean; |
76 | -- Return True if entity has attribute definition clauses for Read and | |
77 | -- Write attributes that are visible at some place. | |
78 | ||
79 | function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean; | |
80 | -- Returns true if the entity is a type whose full view is a non-remote | |
81 | -- access type, for the purpose of enforcing E.2.2(8) rules. | |
82 | ||
83 | function Has_Non_Remote_Access (Typ : Entity_Id) return Boolean; | |
84 | -- Return true if Typ or the type of any of its subcomponents is a non | |
85 | -- remote access type and doesn't have user-defined stream attributes. | |
996ae0b0 | 86 | |
b5ea9143 AC |
87 | function No_External_Streaming (E : Entity_Id) return Boolean; |
88 | -- Return True if the entity or one of its subcomponents does not support | |
89 | -- external streaming. | |
996ae0b0 | 90 | |
375cbc2b | 91 | function In_RCI_Declaration return Boolean; |
996ae0b0 | 92 | function In_RT_Declaration return Boolean; |
375cbc2b TQ |
93 | -- Determine if current scope is within the declaration of a Remote Call |
94 | -- Interface or Remote Types unit, for semantic checking purposes. | |
95 | ||
96 | function In_Package_Declaration return Boolean; | |
97 | -- Shared supporting routine for In_RCI_Declaration and In_RT_Declaration | |
996ae0b0 | 98 | |
996ae0b0 RK |
99 | function In_Shared_Passive_Unit return Boolean; |
100 | -- Determines if current scope is within a Shared Passive compilation unit | |
101 | ||
102 | function Static_Discriminant_Expr (L : List_Id) return Boolean; | |
103 | -- Iterate through the list of discriminants to check if any of them | |
104 | -- contains non-static default expression, which is a violation in | |
105 | -- a preelaborated library unit. | |
106 | ||
107 | procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id); | |
fbf5a39b | 108 | -- Check validity of declaration if RCI or RT unit. It should not contain |
de5cd98e TQ |
109 | -- the declaration of an access-to-object type unless it is a general |
110 | -- access type that designates a class-wide limited private type. There are | |
111 | -- also constraints about the primitive subprograms of the class-wide type. | |
112 | -- RM E.2 (9, 13, 14) | |
996ae0b0 | 113 | |
b5ea9143 AC |
114 | procedure Validate_RACW_Primitive |
115 | (Subp : Entity_Id; | |
116 | RACW : Entity_Id); | |
117 | -- Check legality of the declaration of primitive Subp of the designated | |
118 | -- type of the given RACW type. | |
119 | ||
996ae0b0 RK |
120 | --------------------------------------- |
121 | -- Check_Categorization_Dependencies -- | |
122 | --------------------------------------- | |
123 | ||
124 | procedure Check_Categorization_Dependencies | |
125 | (Unit_Entity : Entity_Id; | |
126 | Depended_Entity : Entity_Id; | |
127 | Info_Node : Node_Id; | |
128 | Is_Subunit : Boolean) | |
129 | is | |
ff69f95a RD |
130 | N : constant Node_Id := Info_Node; |
131 | Err : Boolean; | |
996ae0b0 | 132 | |
2fa9443e ES |
133 | -- Here we define an enumeration type to represent categorization types, |
134 | -- ordered so that a unit with a given categorization can only WITH | |
135 | -- units with lower or equal categorization type. | |
136 | ||
996ae0b0 | 137 | type Categorization is |
0835f1d7 RD |
138 | (Pure, |
139 | Shared_Passive, | |
140 | Remote_Types, | |
141 | Remote_Call_Interface, | |
0835f1d7 | 142 | Normal); |
996ae0b0 | 143 | |
996ae0b0 RK |
144 | function Get_Categorization (E : Entity_Id) return Categorization; |
145 | -- Check categorization flags from entity, and return in the form | |
2fa9443e | 146 | -- of the lowest value of the Categorization type that applies to E. |
996ae0b0 | 147 | |
fbf5a39b AC |
148 | ------------------------ |
149 | -- Get_Categorization -- | |
150 | ------------------------ | |
151 | ||
996ae0b0 RK |
152 | function Get_Categorization (E : Entity_Id) return Categorization is |
153 | begin | |
2fa9443e ES |
154 | -- Get the lowest categorization that corresponds to E. Note that |
155 | -- nothing prevents several (different) categorization pragmas | |
156 | -- to apply to the same library unit, in which case the unit has | |
157 | -- all associated categories, so we need to be careful here to | |
158 | -- check pragmas in proper Categorization order in order to | |
12a13f01 | 159 | -- return the lowest applicable value. |
ba673907 | 160 | |
2fa9443e | 161 | -- Ignore Pure specification if set by pragma Pure_Function |
ba673907 | 162 | |
2fa9443e | 163 | if Is_Pure (E) |
ba673907 | 164 | and then not |
22243c12 | 165 | (Has_Pragma_Pure_Function (E) and not Has_Pragma_Pure (E)) |
ba673907 | 166 | then |
996ae0b0 | 167 | return Pure; |
ba673907 | 168 | |
996ae0b0 RK |
169 | elsif Is_Shared_Passive (E) then |
170 | return Shared_Passive; | |
ba673907 | 171 | |
996ae0b0 RK |
172 | elsif Is_Remote_Types (E) then |
173 | return Remote_Types; | |
ba673907 | 174 | |
996ae0b0 RK |
175 | elsif Is_Remote_Call_Interface (E) then |
176 | return Remote_Call_Interface; | |
ba673907 | 177 | |
996ae0b0 RK |
178 | else |
179 | return Normal; | |
180 | end if; | |
181 | end Get_Categorization; | |
182 | ||
2fa9443e ES |
183 | Unit_Category : Categorization; |
184 | With_Category : Categorization; | |
185 | ||
996ae0b0 RK |
186 | -- Start of processing for Check_Categorization_Dependencies |
187 | ||
188 | begin | |
189 | -- Intrinsic subprograms are preelaborated, so do not impose any | |
46ee0270 AC |
190 | -- categorization dependencies. Also, ignore categorization |
191 | -- dependencies when compilation switch -gnatdu is used. | |
996ae0b0 | 192 | |
46ee0270 | 193 | if Is_Intrinsic_Subprogram (Depended_Entity) or else Debug_Flag_U then |
996ae0b0 RK |
194 | return; |
195 | end if; | |
196 | ||
ff69f95a | 197 | -- First check 10.2.1 (11/1) rules on preelaborate packages |
996ae0b0 | 198 | |
ff69f95a RD |
199 | if Is_Preelaborated (Unit_Entity) |
200 | and then not Is_Preelaborated (Depended_Entity) | |
201 | and then not Is_Pure (Depended_Entity) | |
202 | then | |
203 | Err := True; | |
204 | else | |
205 | Err := False; | |
206 | end if; | |
0835f1d7 | 207 | |
ff69f95a | 208 | -- Check categorization rules of RM E.2(5) |
0835f1d7 | 209 | |
ff69f95a RD |
210 | Unit_Category := Get_Categorization (Unit_Entity); |
211 | With_Category := Get_Categorization (Depended_Entity); | |
0835f1d7 | 212 | |
996ae0b0 | 213 | if With_Category > Unit_Category then |
0835f1d7 RD |
214 | |
215 | -- Special case: Remote_Types and Remote_Call_Interface are allowed | |
ff69f95a | 216 | -- to WITH anything in the package body, per (RM E.2(5)). |
0835f1d7 | 217 | |
996ae0b0 | 218 | if (Unit_Category = Remote_Types |
22243c12 | 219 | or else Unit_Category = Remote_Call_Interface) |
996ae0b0 RK |
220 | and then In_Package_Body (Unit_Entity) |
221 | then | |
222 | null; | |
6f123e48 | 223 | |
b7f7dab2 AC |
224 | -- Special case: Remote_Types and Remote_Call_Interface declarations |
225 | -- can depend on a preelaborated unit via a private with_clause, per | |
226 | -- AI05-0206. | |
227 | ||
228 | elsif (Unit_Category = Remote_Types | |
a2c1791d AC |
229 | or else |
230 | Unit_Category = Remote_Call_Interface) | |
231 | and then Nkind (N) = N_With_Clause | |
232 | and then Private_Present (N) | |
6f123e48 RD |
233 | and then Is_Preelaborated (Depended_Entity) |
234 | then | |
235 | null; | |
236 | ||
237 | -- All other cases, we do have an error | |
238 | ||
ff69f95a RD |
239 | else |
240 | Err := True; | |
241 | end if; | |
242 | end if; | |
243 | ||
244 | -- Here if we have an error | |
245 | ||
246 | if Err then | |
996ae0b0 | 247 | |
880dabb5 | 248 | -- These messages are warnings in GNAT mode or if the -gnateP switch |
ce09f8b3 | 249 | -- was set. Otherwise these are real errors for real illegalities. |
ff69f95a | 250 | |
880dabb5 AC |
251 | -- The reason we suppress these errors in GNAT mode is that the run- |
252 | -- time has several instances of violations of the categorization | |
253 | -- errors (e.g. Pure units withing Preelaborate units. All these | |
254 | -- violations are harmless in the cases where we intend them, and | |
255 | -- we suppress the warnings with Warnings (Off). In cases where we | |
256 | -- do not intend the violation, warnings are errors in GNAT mode | |
257 | -- anyway, so we will still get an error. | |
258 | ||
259 | Error_Msg_Warn := | |
260 | Treat_Categorization_Errors_As_Warnings or GNAT_Mode; | |
ff69f95a RD |
261 | |
262 | -- Don't give error if main unit is not an internal unit, and the | |
263 | -- unit generating the message is an internal unit. This is the | |
264 | -- situation in which such messages would be ignored in any case, | |
265 | -- so it is convenient not to generate them (since it causes | |
266 | -- annoying interference with debugging). | |
267 | ||
8ab31c0c AC |
268 | if Is_Internal_Unit (Current_Sem_Unit) |
269 | and then not Is_Internal_Unit (Main_Unit) | |
ff69f95a RD |
270 | then |
271 | return; | |
272 | ||
b7f7dab2 AC |
273 | -- Dependence of Remote_Types or Remote_Call_Interface declaration |
274 | -- on a preelaborated unit with a normal with_clause. | |
275 | ||
276 | elsif (Unit_Category = Remote_Types | |
a2c1791d AC |
277 | or else |
278 | Unit_Category = Remote_Call_Interface) | |
b7f7dab2 AC |
279 | and then Is_Preelaborated (Depended_Entity) |
280 | then | |
281 | Error_Msg_NE | |
0bfa2f3c | 282 | ("<<must use private with clause for preelaborated unit&", |
b7f7dab2 AC |
283 | N, Depended_Entity); |
284 | ||
ff69f95a RD |
285 | -- Subunit case |
286 | ||
287 | elsif Is_Subunit then | |
288 | Error_Msg_NE | |
289 | ("<subunit cannot depend on& " & | |
290 | "(parent has wrong categorization)", N, Depended_Entity); | |
291 | ||
292 | -- Normal unit, not subunit | |
6d158291 | 293 | |
0835f1d7 | 294 | else |
ff69f95a | 295 | Error_Msg_NE |
b785e0b8 | 296 | ("<<cannot depend on& " & |
ff69f95a RD |
297 | "(wrong categorization)", N, Depended_Entity); |
298 | end if; | |
299 | ||
300 | -- Add further explanation for Pure/Preelaborate common cases | |
301 | ||
302 | if Unit_Category = Pure then | |
4d3106a1 PT |
303 | Error_Msg_N |
304 | ("\<<pure unit cannot depend on non-pure unit", N); | |
ff69f95a RD |
305 | |
306 | elsif Is_Preelaborated (Unit_Entity) | |
307 | and then not Is_Preelaborated (Depended_Entity) | |
308 | and then not Is_Pure (Depended_Entity) | |
309 | then | |
4d3106a1 | 310 | Error_Msg_N |
b785e0b8 | 311 | ("\<<preelaborated unit cannot depend on " |
4d3106a1 | 312 | & "non-preelaborated unit", N); |
996ae0b0 RK |
313 | end if; |
314 | end if; | |
996ae0b0 RK |
315 | end Check_Categorization_Dependencies; |
316 | ||
317 | ----------------------------------- | |
318 | -- Check_Non_Static_Default_Expr -- | |
319 | ----------------------------------- | |
320 | ||
321 | procedure Check_Non_Static_Default_Expr | |
322 | (Type_Def : Node_Id; | |
323 | Obj_Decl : Node_Id) | |
324 | is | |
325 | Recdef : Node_Id; | |
326 | Component_Decl : Node_Id; | |
327 | ||
328 | begin | |
329 | if Nkind (Type_Def) = N_Derived_Type_Definition then | |
330 | Recdef := Record_Extension_Part (Type_Def); | |
331 | ||
332 | if No (Recdef) then | |
333 | return; | |
334 | end if; | |
335 | ||
336 | else | |
337 | Recdef := Type_Def; | |
338 | end if; | |
339 | ||
340 | -- Check that component declarations do not involve: | |
341 | ||
342 | -- a. a non-static default expression, where the object is | |
343 | -- declared to be default initialized. | |
344 | ||
345 | -- b. a dynamic Itype (discriminants and constraints) | |
346 | ||
347 | if Null_Present (Recdef) then | |
348 | return; | |
349 | else | |
350 | Component_Decl := First (Component_Items (Component_List (Recdef))); | |
351 | end if; | |
352 | ||
353 | while Present (Component_Decl) | |
354 | and then Nkind (Component_Decl) = N_Component_Declaration | |
355 | loop | |
356 | if Present (Expression (Component_Decl)) | |
357 | and then Nkind (Expression (Component_Decl)) /= N_Null | |
edab6088 | 358 | and then not Is_OK_Static_Expression (Expression (Component_Decl)) |
996ae0b0 RK |
359 | then |
360 | Error_Msg_Sloc := Sloc (Component_Decl); | |
fbf5a39b AC |
361 | Error_Msg_F |
362 | ("object in preelaborated unit has non-static default#", | |
996ae0b0 RK |
363 | Obj_Decl); |
364 | ||
365 | -- Fix this later ??? | |
366 | ||
367 | -- elsif Has_Dynamic_Itype (Component_Decl) then | |
368 | -- Error_Msg_N | |
369 | -- ("dynamic type discriminant," & | |
370 | -- " constraint in preelaborated unit", | |
371 | -- Component_Decl); | |
372 | end if; | |
373 | ||
374 | Next (Component_Decl); | |
375 | end loop; | |
376 | end Check_Non_Static_Default_Expr; | |
377 | ||
b5ea9143 AC |
378 | --------------------------- |
379 | -- Has_Non_Remote_Access -- | |
380 | --------------------------- | |
381 | ||
382 | function Has_Non_Remote_Access (Typ : Entity_Id) return Boolean is | |
383 | Component : Entity_Id; | |
384 | Comp_Type : Entity_Id; | |
385 | U_Typ : constant Entity_Id := Underlying_Type (Typ); | |
9fde638d | 386 | |
b5ea9143 AC |
387 | begin |
388 | if No (U_Typ) then | |
389 | return False; | |
390 | ||
391 | elsif Has_Read_Write_Attributes (Typ) | |
392 | or else Has_Read_Write_Attributes (U_Typ) | |
393 | then | |
394 | return False; | |
395 | ||
396 | elsif Is_Non_Remote_Access_Type (U_Typ) then | |
397 | return True; | |
398 | end if; | |
399 | ||
400 | if Is_Record_Type (U_Typ) then | |
401 | Component := First_Entity (U_Typ); | |
402 | while Present (Component) loop | |
403 | if not Is_Tag (Component) then | |
404 | Comp_Type := Etype (Component); | |
405 | ||
406 | if Has_Non_Remote_Access (Comp_Type) then | |
407 | return True; | |
408 | end if; | |
409 | end if; | |
410 | ||
411 | Next_Entity (Component); | |
412 | end loop; | |
413 | ||
414 | elsif Is_Array_Type (U_Typ) then | |
415 | return Has_Non_Remote_Access (Component_Type (U_Typ)); | |
416 | ||
417 | end if; | |
418 | ||
419 | return False; | |
420 | end Has_Non_Remote_Access; | |
421 | ||
422 | ------------------------------- | |
423 | -- Has_Read_Write_Attributes -- | |
424 | ------------------------------- | |
425 | ||
426 | function Has_Read_Write_Attributes (E : Entity_Id) return Boolean is | |
427 | begin | |
428 | return True | |
22243c12 RD |
429 | and then Has_Stream_Attribute_Definition |
430 | (E, TSS_Stream_Read, At_Any_Place => True) | |
431 | and then Has_Stream_Attribute_Definition | |
432 | (E, TSS_Stream_Write, At_Any_Place => True); | |
b5ea9143 AC |
433 | end Has_Read_Write_Attributes; |
434 | ||
468c6c8a ES |
435 | ------------------------------------- |
436 | -- Has_Stream_Attribute_Definition -- | |
437 | ------------------------------------- | |
438 | ||
439 | function Has_Stream_Attribute_Definition | |
fe685905 TQ |
440 | (Typ : Entity_Id; |
441 | Nam : TSS_Name_Type; | |
442 | At_Any_Place : Boolean := False) return Boolean | |
468c6c8a | 443 | is |
2945460b AC |
444 | Rep_Item : Node_Id; |
445 | ||
446 | Real_Rep : Node_Id; | |
551e1935 AC |
447 | -- The stream operation may be specified by an attribute definition |
448 | -- clause in the source, or by an aspect that generates such an | |
449 | -- attribute definition. For an aspect, the generated attribute | |
450 | -- definition may be placed at the freeze point of the full view of | |
451 | -- the type, but the aspect specification makes the operation visible | |
452 | -- to a client wherever the partial view is visible. | |
b4592168 | 453 | |
468c6c8a ES |
454 | begin |
455 | -- We start from the declaration node and then loop until the end of | |
456 | -- the list until we find the requested attribute definition clause. | |
457 | -- In Ada 2005 mode, clauses are ignored if they are not currently | |
458 | -- visible (this is tested using the corresponding Entity, which is | |
fe685905 TQ |
459 | -- inserted by the expander at the point where the clause occurs), |
460 | -- unless At_Any_Place is true. | |
468c6c8a | 461 | |
551e1935 | 462 | Rep_Item := First_Rep_Item (Typ); |
468c6c8a | 463 | while Present (Rep_Item) loop |
551e1935 AC |
464 | Real_Rep := Rep_Item; |
465 | ||
466 | -- If the representation item is an aspect specification, retrieve | |
467 | -- the corresponding pragma or attribute definition. | |
468 | ||
469 | if Nkind (Rep_Item) = N_Aspect_Specification then | |
470 | Real_Rep := Aspect_Rep_Item (Rep_Item); | |
471 | end if; | |
472 | ||
473 | if Nkind (Real_Rep) = N_Attribute_Definition_Clause then | |
474 | case Chars (Real_Rep) is | |
468c6c8a ES |
475 | when Name_Read => |
476 | exit when Nam = TSS_Stream_Read; | |
477 | ||
478 | when Name_Write => | |
479 | exit when Nam = TSS_Stream_Write; | |
480 | ||
481 | when Name_Input => | |
482 | exit when Nam = TSS_Stream_Input; | |
483 | ||
484 | when Name_Output => | |
485 | exit when Nam = TSS_Stream_Output; | |
486 | ||
487 | when others => | |
488 | null; | |
468c6c8a ES |
489 | end case; |
490 | end if; | |
491 | ||
492 | Next_Rep_Item (Rep_Item); | |
493 | end loop; | |
494 | ||
551e1935 AC |
495 | -- If not found, and the type is derived from a private view, check |
496 | -- for a stream attribute inherited from parent. Any specified stream | |
497 | -- attributes will be attached to the derived type's underlying type | |
498 | -- rather the derived type entity itself (which is itself private). | |
499 | ||
500 | if No (Rep_Item) | |
501 | and then Is_Private_Type (Typ) | |
502 | and then Is_Derived_Type (Typ) | |
503 | and then Present (Full_View (Typ)) | |
504 | then | |
505 | return Has_Stream_Attribute_Definition | |
506 | (Underlying_Type (Typ), Nam, At_Any_Place); | |
507 | ||
508 | -- Otherwise, if At_Any_Place is true, return True if the attribute is | |
509 | -- available at any place; if it is false, return True only if the | |
510 | -- attribute is currently visible. | |
fe685905 | 511 | |
551e1935 AC |
512 | else |
513 | return Present (Rep_Item) | |
514 | and then (Ada_Version < Ada_2005 | |
515 | or else At_Any_Place | |
516 | or else not Is_Hidden (Entity (Rep_Item))); | |
517 | end if; | |
468c6c8a ES |
518 | end Has_Stream_Attribute_Definition; |
519 | ||
375cbc2b TQ |
520 | ---------------------------- |
521 | -- In_Package_Declaration -- | |
522 | ---------------------------- | |
523 | ||
524 | function In_Package_Declaration return Boolean is | |
525 | Unit_Kind : constant Node_Kind := | |
526 | Nkind (Unit (Cunit (Current_Sem_Unit))); | |
527 | ||
528 | begin | |
529 | -- There are no restrictions on the body of an RCI or RT unit | |
530 | ||
531 | return Is_Package_Or_Generic_Package (Current_Scope) | |
532 | and then Unit_Kind /= N_Package_Body | |
533 | and then not In_Package_Body (Current_Scope) | |
534 | and then not In_Instance; | |
535 | end In_Package_Declaration; | |
536 | ||
996ae0b0 RK |
537 | --------------------------- |
538 | -- In_Preelaborated_Unit -- | |
539 | --------------------------- | |
540 | ||
541 | function In_Preelaborated_Unit return Boolean is | |
a8551b5f | 542 | Unit_Entity : Entity_Id := Current_Scope; |
996ae0b0 RK |
543 | Unit_Kind : constant Node_Kind := |
544 | Nkind (Unit (Cunit (Current_Sem_Unit))); | |
545 | ||
546 | begin | |
a8551b5f AC |
547 | -- If evaluating actuals for a child unit instantiation, then ignore |
548 | -- the preelaboration status of the parent; use the child instead. | |
549 | ||
550 | if Is_Compilation_Unit (Unit_Entity) | |
551 | and then Unit_Kind in N_Generic_Instantiation | |
552 | and then not In_Same_Source_Unit (Unit_Entity, | |
553 | Cunit (Current_Sem_Unit)) | |
554 | then | |
555 | Unit_Entity := Cunit_Entity (Current_Sem_Unit); | |
556 | end if; | |
557 | ||
7873037f TQ |
558 | -- There are no constraints on the body of Remote_Call_Interface or |
559 | -- Remote_Types packages. | |
996ae0b0 RK |
560 | |
561 | return (Unit_Entity /= Standard_Standard) | |
562 | and then (Is_Preelaborated (Unit_Entity) | |
563 | or else Is_Pure (Unit_Entity) | |
564 | or else Is_Shared_Passive (Unit_Entity) | |
565 | or else | |
566 | ((Is_Remote_Types (Unit_Entity) | |
22243c12 | 567 | or else Is_Remote_Call_Interface (Unit_Entity)) |
996ae0b0 RK |
568 | and then Ekind (Unit_Entity) = E_Package |
569 | and then Unit_Kind /= N_Package_Body | |
570 | and then not In_Package_Body (Unit_Entity) | |
571 | and then not In_Instance)); | |
572 | end In_Preelaborated_Unit; | |
573 | ||
574 | ------------------ | |
575 | -- In_Pure_Unit -- | |
576 | ------------------ | |
577 | ||
578 | function In_Pure_Unit return Boolean is | |
579 | begin | |
580 | return Is_Pure (Current_Scope); | |
581 | end In_Pure_Unit; | |
582 | ||
375cbc2b TQ |
583 | ------------------------ |
584 | -- In_RCI_Declaration -- | |
585 | ------------------------ | |
996ae0b0 | 586 | |
375cbc2b | 587 | function In_RCI_Declaration return Boolean is |
996ae0b0 | 588 | begin |
375cbc2b TQ |
589 | return Is_Remote_Call_Interface (Current_Scope) |
590 | and then In_Package_Declaration; | |
591 | end In_RCI_Declaration; | |
996ae0b0 RK |
592 | |
593 | ----------------------- | |
594 | -- In_RT_Declaration -- | |
595 | ----------------------- | |
596 | ||
597 | function In_RT_Declaration return Boolean is | |
996ae0b0 | 598 | begin |
375cbc2b | 599 | return Is_Remote_Types (Current_Scope) and then In_Package_Declaration; |
996ae0b0 RK |
600 | end In_RT_Declaration; |
601 | ||
602 | ---------------------------- | |
603 | -- In_Shared_Passive_Unit -- | |
604 | ---------------------------- | |
605 | ||
606 | function In_Shared_Passive_Unit return Boolean is | |
607 | Unit_Entity : constant Entity_Id := Current_Scope; | |
608 | ||
609 | begin | |
610 | return Is_Shared_Passive (Unit_Entity); | |
611 | end In_Shared_Passive_Unit; | |
612 | ||
613 | --------------------------------------- | |
614 | -- In_Subprogram_Task_Protected_Unit -- | |
615 | --------------------------------------- | |
616 | ||
617 | function In_Subprogram_Task_Protected_Unit return Boolean is | |
618 | E : Entity_Id; | |
996ae0b0 RK |
619 | |
620 | begin | |
621 | -- The following is to verify that a declaration is inside | |
622 | -- subprogram, generic subprogram, task unit, protected unit. | |
623 | -- Used to validate if a lib. unit is Pure. RM 10.2.1(16). | |
624 | ||
625 | -- Use scope chain to check successively outer scopes | |
626 | ||
627 | E := Current_Scope; | |
628 | loop | |
b9696ffb | 629 | if Is_Subprogram_Or_Generic_Subprogram (E) |
fbf5a39b AC |
630 | or else |
631 | Is_Concurrent_Type (E) | |
996ae0b0 RK |
632 | then |
633 | return True; | |
634 | ||
635 | elsif E = Standard_Standard then | |
636 | return False; | |
637 | end if; | |
638 | ||
639 | E := Scope (E); | |
640 | end loop; | |
996ae0b0 RK |
641 | end In_Subprogram_Task_Protected_Unit; |
642 | ||
643 | ------------------------------- | |
644 | -- Is_Non_Remote_Access_Type -- | |
645 | ------------------------------- | |
646 | ||
647 | function Is_Non_Remote_Access_Type (E : Entity_Id) return Boolean is | |
715e529d AC |
648 | U_E : constant Entity_Id := Underlying_Type (Base_Type (E)); |
649 | -- Use full view of base type to handle subtypes properly. | |
650 | ||
996ae0b0 | 651 | begin |
468c6c8a ES |
652 | if No (U_E) then |
653 | ||
654 | -- This case arises for the case of a generic formal type, in which | |
655 | -- case E.2.2(8) rules will be enforced at instantiation time. | |
656 | ||
657 | return False; | |
658 | end if; | |
659 | ||
660 | return Is_Access_Type (U_E) | |
661 | and then not Is_Remote_Access_To_Class_Wide_Type (U_E) | |
662 | and then not Is_Remote_Access_To_Subprogram_Type (U_E); | |
996ae0b0 RK |
663 | end Is_Non_Remote_Access_Type; |
664 | ||
b5ea9143 AC |
665 | --------------------------- |
666 | -- No_External_Streaming -- | |
667 | --------------------------- | |
996ae0b0 | 668 | |
b5ea9143 AC |
669 | function No_External_Streaming (E : Entity_Id) return Boolean is |
670 | U_E : constant Entity_Id := Underlying_Type (E); | |
9fde638d | 671 | |
996ae0b0 | 672 | begin |
468c6c8a ES |
673 | if No (U_E) then |
674 | return False; | |
675 | ||
b5ea9143 | 676 | elsif Has_Read_Write_Attributes (E) then |
9fde638d | 677 | |
b5ea9143 AC |
678 | -- Note: availability of stream attributes is tested on E, not U_E. |
679 | -- There may be stream attributes defined on U_E that are not visible | |
680 | -- at the place where support of external streaming is tested. | |
681 | ||
996ae0b0 | 682 | return False; |
468c6c8a | 683 | |
b5ea9143 | 684 | elsif Has_Non_Remote_Access (U_E) then |
996ae0b0 RK |
685 | return True; |
686 | end if; | |
687 | ||
b5ea9143 AC |
688 | return Is_Limited_Type (E); |
689 | end No_External_Streaming; | |
996ae0b0 RK |
690 | |
691 | ------------------------------------- | |
692 | -- Set_Categorization_From_Pragmas -- | |
693 | ------------------------------------- | |
694 | ||
695 | procedure Set_Categorization_From_Pragmas (N : Node_Id) is | |
02ba0989 | 696 | P : constant Node_Id := Parent (N); |
996ae0b0 | 697 | |
02ba0989 PT |
698 | procedure Make_Parents_Visible_And_Process_Pragmas (Par : Entity_Id); |
699 | -- Parents might not be immediately visible during analysis. Make | |
700 | -- them momentarily visible so that the argument of the pragma can | |
701 | -- be resolved properly, process pragmas and restore the previous | |
702 | -- visibility. | |
996ae0b0 | 703 | |
02ba0989 PT |
704 | procedure Process_Categorization_Pragmas; |
705 | -- Process categorization pragmas, if any | |
996ae0b0 | 706 | |
02ba0989 PT |
707 | ------------------------------------ |
708 | -- Process_Categorization_Pragmas -- | |
709 | ------------------------------------ | |
996ae0b0 | 710 | |
02ba0989 | 711 | procedure Process_Categorization_Pragmas is |
468c6c8a | 712 | PN : Node_Id; |
996ae0b0 RK |
713 | |
714 | begin | |
468c6c8a | 715 | PN := First (Pragmas_After (Aux_Decls_Node (P))); |
996ae0b0 RK |
716 | while Present (PN) loop |
717 | ||
718 | -- Skip implicit types that may have been introduced by | |
719 | -- previous analysis. | |
720 | ||
721 | if Nkind (PN) = N_Pragma then | |
2b2b6798 | 722 | case Get_Pragma_Id (PN) is |
d8f43ee6 HK |
723 | when Pragma_All_Calls_Remote |
724 | | Pragma_Preelaborate | |
725 | | Pragma_Pure | |
726 | | Pragma_Remote_Call_Interface | |
727 | | Pragma_Remote_Types | |
728 | | Pragma_Shared_Passive | |
729 | => | |
730 | Analyze (PN); | |
731 | ||
732 | when others => | |
733 | null; | |
996ae0b0 RK |
734 | end case; |
735 | end if; | |
736 | ||
737 | Next (PN); | |
738 | end loop; | |
02ba0989 | 739 | end Process_Categorization_Pragmas; |
468c6c8a | 740 | |
02ba0989 PT |
741 | ---------------------------------------------- |
742 | -- Make_Parents_Visible_And_Process_Pragmas -- | |
743 | ---------------------------------------------- | |
744 | ||
745 | procedure Make_Parents_Visible_And_Process_Pragmas (Par : Entity_Id) is | |
746 | begin | |
747 | -- When we reached the Standard scope, then just process pragmas | |
748 | ||
749 | if Par = Standard_Standard then | |
750 | Process_Categorization_Pragmas; | |
751 | ||
752 | -- Otherwise make the current scope momentarily visible, recurse | |
753 | -- into its enclosing scope, and restore the visibility. This is | |
754 | -- required for child units that are instances of generic parents. | |
755 | ||
756 | else | |
757 | declare | |
758 | Save_Is_Immediately_Visible : constant Boolean := | |
759 | Is_Immediately_Visible (Par); | |
760 | begin | |
761 | Set_Is_Immediately_Visible (Par); | |
762 | Make_Parents_Visible_And_Process_Pragmas (Scope (Par)); | |
763 | Set_Is_Immediately_Visible (Par, Save_Is_Immediately_Visible); | |
764 | end; | |
996ae0b0 | 765 | end if; |
02ba0989 PT |
766 | end Make_Parents_Visible_And_Process_Pragmas; |
767 | ||
768 | -- Start of processing for Set_Categorization_From_Pragmas | |
769 | ||
770 | begin | |
771 | -- Deal with categorization pragmas in Pragmas of Compilation_Unit. | |
772 | -- The purpose is to set categorization flags before analyzing the | |
773 | -- unit itself, so as to diagnose violations of categorization as | |
774 | -- we process each declaration, even though the pragma appears after | |
775 | -- the unit. | |
776 | ||
777 | if Nkind (P) /= N_Compilation_Unit then | |
778 | return; | |
779 | end if; | |
780 | ||
781 | Make_Parents_Visible_And_Process_Pragmas (Scope (Current_Scope)); | |
996ae0b0 RK |
782 | end Set_Categorization_From_Pragmas; |
783 | ||
fbf5a39b AC |
784 | ----------------------------------- |
785 | -- Set_Categorization_From_Scope -- | |
786 | ----------------------------------- | |
787 | ||
788 | procedure Set_Categorization_From_Scope (E : Entity_Id; Scop : Entity_Id) is | |
789 | Declaration : Node_Id := Empty; | |
790 | Specification : Node_Id := Empty; | |
791 | ||
792 | begin | |
138fc6f1 HK |
793 | -- Do not modify the purity of an internally generated entity if it has |
794 | -- been explicitly marked as pure for optimization purposes. | |
795 | ||
796 | if not Has_Pragma_Pure_Function (E) then | |
797 | Set_Is_Pure | |
798 | (E, Is_Pure (Scop) and then Is_Library_Level_Entity (E)); | |
799 | end if; | |
fbf5a39b AC |
800 | |
801 | if not Is_Remote_Call_Interface (E) then | |
802 | if Ekind (E) in Subprogram_Kind then | |
803 | Declaration := Unit_Declaration_Node (E); | |
804 | ||
4a08c95c AC |
805 | if Nkind (Declaration) in |
806 | N_Subprogram_Body | N_Subprogram_Renaming_Declaration | |
fbf5a39b AC |
807 | then |
808 | Specification := Corresponding_Spec (Declaration); | |
809 | end if; | |
810 | end if; | |
811 | ||
22243c12 RD |
812 | -- A subprogram body or renaming-as-body is a remote call interface |
813 | -- if it serves as the completion of a subprogram declaration that | |
814 | -- is a remote call interface. | |
fbf5a39b AC |
815 | |
816 | if Nkind (Specification) in N_Entity then | |
817 | Set_Is_Remote_Call_Interface | |
818 | (E, Is_Remote_Call_Interface (Specification)); | |
819 | ||
820 | -- A subprogram declaration is a remote call interface when it is | |
821 | -- declared within the visible part of, or declared by, a library | |
822 | -- unit declaration that is a remote call interface. | |
823 | ||
824 | else | |
825 | Set_Is_Remote_Call_Interface | |
826 | (E, Is_Remote_Call_Interface (Scop) | |
827 | and then not (In_Private_Part (Scop) | |
22243c12 | 828 | or else In_Package_Body (Scop))); |
fbf5a39b AC |
829 | end if; |
830 | end if; | |
831 | ||
de5cd98e TQ |
832 | Set_Is_Remote_Types |
833 | (E, Is_Remote_Types (Scop) | |
834 | and then not (In_Private_Part (Scop) | |
22243c12 | 835 | or else In_Package_Body (Scop))); |
fbf5a39b AC |
836 | end Set_Categorization_From_Scope; |
837 | ||
996ae0b0 RK |
838 | ------------------------------ |
839 | -- Static_Discriminant_Expr -- | |
840 | ------------------------------ | |
841 | ||
12a13f01 | 842 | -- We need to accommodate a Why_Not_Static call somehow here ??? |
fbf5a39b | 843 | |
996ae0b0 RK |
844 | function Static_Discriminant_Expr (L : List_Id) return Boolean is |
845 | Discriminant_Spec : Node_Id; | |
846 | ||
847 | begin | |
848 | Discriminant_Spec := First (L); | |
849 | while Present (Discriminant_Spec) loop | |
850 | if Present (Expression (Discriminant_Spec)) | |
edab6088 RD |
851 | and then |
852 | not Is_OK_Static_Expression (Expression (Discriminant_Spec)) | |
996ae0b0 RK |
853 | then |
854 | return False; | |
855 | end if; | |
856 | ||
857 | Next (Discriminant_Spec); | |
858 | end loop; | |
859 | ||
860 | return True; | |
861 | end Static_Discriminant_Expr; | |
862 | ||
863 | -------------------------------------- | |
864 | -- Validate_Access_Type_Declaration -- | |
865 | -------------------------------------- | |
866 | ||
867 | procedure Validate_Access_Type_Declaration (T : Entity_Id; N : Node_Id) is | |
868 | Def : constant Node_Id := Type_Definition (N); | |
869 | ||
870 | begin | |
871 | case Nkind (Def) is | |
6d158291 RD |
872 | |
873 | -- Access to subprogram case | |
874 | ||
996ae0b0 RK |
875 | when N_Access_To_Subprogram_Definition => |
876 | ||
877 | -- A pure library_item must not contain the declaration of a | |
878 | -- named access type, except within a subprogram, generic | |
879 | -- subprogram, task unit, or protected unit (RM 10.2.1(16)). | |
880 | ||
6d158291 RD |
881 | -- This test is skipped in Ada 2005 (see AI-366) |
882 | ||
0791fbe9 | 883 | if Ada_Version < Ada_2005 |
6d158291 RD |
884 | and then Comes_From_Source (T) |
885 | and then In_Pure_Unit | |
886 | and then not In_Subprogram_Task_Protected_Unit | |
996ae0b0 RK |
887 | then |
888 | Error_Msg_N ("named access type not allowed in pure unit", T); | |
889 | end if; | |
890 | ||
6d158291 | 891 | -- Access to object case |
996ae0b0 | 892 | |
6d158291 | 893 | when N_Access_To_Object_Definition => |
996ae0b0 RK |
894 | if Comes_From_Source (T) |
895 | and then In_Pure_Unit | |
896 | and then not In_Subprogram_Task_Protected_Unit | |
897 | then | |
6d158291 RD |
898 | -- We can't give the message yet, since the type is not frozen |
899 | -- and in Ada 2005 mode, access types are allowed in pure units | |
900 | -- if the type has no storage pool (see AI-366). So we set a | |
901 | -- flag which will be checked at freeze time. | |
902 | ||
903 | Set_Is_Pure_Unit_Access_Type (T); | |
996ae0b0 RK |
904 | end if; |
905 | ||
468c6c8a ES |
906 | -- Check for RCI or RT unit type declaration: declaration of an |
907 | -- access-to-object type is illegal unless it is a general access | |
908 | -- type that designates a class-wide limited private type. | |
909 | -- Note that constraints on the primitive subprograms of the | |
910 | -- designated tagged type are not enforced here but in | |
911 | -- Validate_RACW_Primitives, which is done separately because the | |
912 | -- designated type might not be frozen (and therefore its | |
913 | -- primitive operations might not be completely known) at the | |
914 | -- point of the RACW declaration. | |
996ae0b0 RK |
915 | |
916 | Validate_Remote_Access_Object_Type_Declaration (T); | |
917 | ||
918 | -- Check for shared passive unit type declaration. It should | |
919 | -- not contain the declaration of access to class wide type, | |
920 | -- access to task type and access to protected type with entry. | |
921 | ||
922 | Validate_SP_Access_Object_Type_Decl (T); | |
923 | ||
6d158291 RD |
924 | when others => |
925 | null; | |
996ae0b0 RK |
926 | end case; |
927 | ||
fbf5a39b AC |
928 | -- Set categorization flag from package on entity as well, to allow |
929 | -- easy checks later on for required validations of RCI or RT units. | |
930 | -- This is only done for entities that are in the original source. | |
996ae0b0 | 931 | |
fbf5a39b AC |
932 | if Comes_From_Source (T) |
933 | and then not (In_Package_Body (Scope (T)) | |
22243c12 | 934 | or else In_Private_Part (Scope (T))) |
fbf5a39b AC |
935 | then |
936 | Set_Is_Remote_Call_Interface | |
937 | (T, Is_Remote_Call_Interface (Scope (T))); | |
938 | Set_Is_Remote_Types | |
939 | (T, Is_Remote_Types (Scope (T))); | |
996ae0b0 RK |
940 | end if; |
941 | end Validate_Access_Type_Declaration; | |
942 | ||
943 | ---------------------------- | |
944 | -- Validate_Ancestor_Part -- | |
945 | ---------------------------- | |
946 | ||
947 | procedure Validate_Ancestor_Part (N : Node_Id) is | |
fbf5a39b AC |
948 | A : constant Node_Id := Ancestor_Part (N); |
949 | T : constant Entity_Id := Entity (A); | |
996ae0b0 RK |
950 | |
951 | begin | |
952 | if In_Preelaborated_Unit | |
953 | and then not In_Subprogram_Or_Concurrent_Unit | |
954 | and then (not Inside_A_Generic | |
955 | or else Present (Enclosing_Generic_Body (N))) | |
956 | then | |
fe685905 TQ |
957 | -- If the type is private, it must have the Ada 2005 pragma |
958 | -- Has_Preelaborable_Initialization. | |
324ac540 | 959 | |
fe685905 | 960 | -- The check is omitted within predefined units. This is probably |
885c4871 | 961 | -- obsolete code to fix the Ada 95 weakness in this area ??? |
996ae0b0 RK |
962 | |
963 | if Is_Private_Type (T) | |
fe685905 | 964 | and then not Has_Pragma_Preelab_Init (T) |
8ab31c0c | 965 | and then not In_Internal_Unit (N) |
996ae0b0 RK |
966 | then |
967 | Error_Msg_N | |
968 | ("private ancestor type not allowed in preelaborated unit", A); | |
969 | ||
970 | elsif Is_Record_Type (T) then | |
971 | if Nkind (Parent (T)) = N_Full_Type_Declaration then | |
972 | Check_Non_Static_Default_Expr | |
973 | (Type_Definition (Parent (T)), A); | |
974 | end if; | |
975 | end if; | |
976 | end if; | |
977 | end Validate_Ancestor_Part; | |
978 | ||
979 | ---------------------------------------- | |
980 | -- Validate_Categorization_Dependency -- | |
981 | ---------------------------------------- | |
982 | ||
983 | procedure Validate_Categorization_Dependency | |
984 | (N : Node_Id; | |
985 | E : Entity_Id) | |
986 | is | |
987 | K : constant Node_Kind := Nkind (N); | |
988 | P : Node_Id := Parent (N); | |
989 | U : Entity_Id := E; | |
990 | Is_Subunit : constant Boolean := Nkind (P) = N_Subunit; | |
991 | ||
992 | begin | |
993 | -- Only validate library units and subunits. For subunits, checks | |
994 | -- concerning withed units apply to the parent compilation unit. | |
995 | ||
996 | if Is_Subunit then | |
997 | P := Parent (P); | |
998 | U := Scope (E); | |
999 | ||
1000 | while Present (U) | |
1001 | and then not Is_Compilation_Unit (U) | |
1002 | and then not Is_Child_Unit (U) | |
1003 | loop | |
1004 | U := Scope (U); | |
1005 | end loop; | |
996ae0b0 RK |
1006 | end if; |
1007 | ||
1008 | if Nkind (P) /= N_Compilation_Unit then | |
1009 | return; | |
1010 | end if; | |
1011 | ||
0835f1d7 | 1012 | -- Body of RCI unit does not need validation |
996ae0b0 RK |
1013 | |
1014 | if Is_Remote_Call_Interface (E) | |
4a08c95c | 1015 | and then Nkind (N) in N_Package_Body | N_Subprogram_Body |
996ae0b0 RK |
1016 | then |
1017 | return; | |
1018 | end if; | |
1019 | ||
0ab80019 | 1020 | -- Ada 2005 (AI-50217): Process explicit non-limited with_clauses |
996ae0b0 RK |
1021 | |
1022 | declare | |
1023 | Item : Node_Id; | |
1024 | Entity_Of_Withed : Entity_Id; | |
1025 | ||
1026 | begin | |
1027 | Item := First (Context_Items (P)); | |
996ae0b0 RK |
1028 | while Present (Item) loop |
1029 | if Nkind (Item) = N_With_Clause | |
7124d1a5 HK |
1030 | and then |
1031 | not (Implicit_With (Item) | |
1032 | or else Limited_Present (Item) | |
1033 | ||
1034 | -- Skip if error already posted on the WITH clause (in | |
1035 | -- which case the Name attribute may be invalid). In | |
1036 | -- particular, this fixes the problem of hanging in the | |
1037 | -- presence of a WITH clause on a child that is an | |
1038 | -- illegal generic instantiation. | |
1039 | ||
1040 | or else Error_Posted (Item)) | |
1041 | and then | |
1042 | not (Try_Semantics | |
1043 | ||
1044 | -- Skip processing malformed trees | |
1045 | ||
1046 | and then Nkind (Name (Item)) not in N_Has_Entity) | |
996ae0b0 RK |
1047 | then |
1048 | Entity_Of_Withed := Entity (Name (Item)); | |
1049 | Check_Categorization_Dependencies | |
fe685905 | 1050 | (U, Entity_Of_Withed, Item, Is_Subunit); |
996ae0b0 RK |
1051 | end if; |
1052 | ||
1053 | Next (Item); | |
1054 | end loop; | |
1055 | end; | |
1056 | ||
0835f1d7 | 1057 | -- Child depends on parent; therefore parent should also be categorized |
12a13f01 | 1058 | -- and satisfy the dependency hierarchy. |
996ae0b0 | 1059 | |
0835f1d7 | 1060 | -- Check if N is a child spec |
996ae0b0 RK |
1061 | |
1062 | if (K in N_Generic_Declaration or else | |
1063 | K in N_Generic_Instantiation or else | |
1064 | K in N_Generic_Renaming_Declaration or else | |
1065 | K = N_Package_Declaration or else | |
1066 | K = N_Package_Renaming_Declaration or else | |
1067 | K = N_Subprogram_Declaration or else | |
1068 | K = N_Subprogram_Renaming_Declaration) | |
1069 | and then Present (Parent_Spec (N)) | |
1070 | then | |
523456db | 1071 | Check_Categorization_Dependencies (E, Scope (E), N, False); |
996ae0b0 | 1072 | |
0835f1d7 RD |
1073 | -- Verify that public child of an RCI library unit must also be an |
1074 | -- RCI library unit (RM E.2.3(15)). | |
996ae0b0 | 1075 | |
523456db AC |
1076 | if Is_Remote_Call_Interface (Scope (E)) |
1077 | and then not Private_Present (P) | |
1078 | and then not Is_Remote_Call_Interface (E) | |
1079 | then | |
9ed2b86d YM |
1080 | Error_Msg_N |
1081 | ("public child of 'R'C'I unit must also be 'R'C'I unit", N); | |
523456db | 1082 | end if; |
996ae0b0 | 1083 | end if; |
996ae0b0 RK |
1084 | end Validate_Categorization_Dependency; |
1085 | ||
1086 | -------------------------------- | |
1087 | -- Validate_Controlled_Object -- | |
1088 | -------------------------------- | |
1089 | ||
1090 | procedure Validate_Controlled_Object (E : Entity_Id) is | |
1091 | begin | |
468c6c8a ES |
1092 | -- Don't need this check in Ada 2005 mode, where this is all taken |
1093 | -- care of by the mechanism for Preelaborable Initialization. | |
1094 | ||
0791fbe9 | 1095 | if Ada_Version >= Ada_2005 then |
468c6c8a ES |
1096 | return; |
1097 | end if; | |
1098 | ||
996ae0b0 RK |
1099 | -- For now, never apply this check for internal GNAT units, since we |
1100 | -- have a number of cases in the library where we are stuck with objects | |
1101 | -- of this type, and the RM requires Preelaborate. | |
1102 | ||
1103 | -- For similar reasons, we only do this check for source entities, since | |
1104 | -- we generate entities of this type in some situations. | |
1105 | ||
1106 | -- Note that the 10.2.1(9) restrictions are not relevant to us anyway. | |
1107 | -- We have to enforce them for RM compatibility, but we have no trouble | |
1108 | -- accepting these objects and doing the right thing. Note that there is | |
a90bd866 | 1109 | -- no requirement that Preelaborate not actually generate any code. |
996ae0b0 RK |
1110 | |
1111 | if In_Preelaborated_Unit | |
1112 | and then not Debug_Flag_PP | |
1113 | and then Comes_From_Source (E) | |
8ab31c0c | 1114 | and then not In_Internal_Unit (E) |
996ae0b0 RK |
1115 | and then (not Inside_A_Generic |
1116 | or else Present (Enclosing_Generic_Body (E))) | |
1117 | and then not Is_Protected_Type (Etype (E)) | |
1118 | then | |
1119 | Error_Msg_N | |
1120 | ("library level controlled object not allowed in " & | |
1121 | "preelaborated unit", E); | |
1122 | end if; | |
1123 | end Validate_Controlled_Object; | |
1124 | ||
1125 | -------------------------------------- | |
1126 | -- Validate_Null_Statement_Sequence -- | |
1127 | -------------------------------------- | |
1128 | ||
1129 | procedure Validate_Null_Statement_Sequence (N : Node_Id) is | |
1130 | Item : Node_Id; | |
1131 | ||
1132 | begin | |
1133 | if In_Preelaborated_Unit then | |
1134 | Item := First (Statements (Handled_Statement_Sequence (N))); | |
996ae0b0 RK |
1135 | while Present (Item) loop |
1136 | if Nkind (Item) /= N_Label | |
1137 | and then Nkind (Item) /= N_Null_Statement | |
1138 | then | |
6d158291 RD |
1139 | -- In GNAT mode, this is a warning, allowing the run-time |
1140 | -- to judiciously bypass this error condition. | |
1141 | ||
0835f1d7 RD |
1142 | Error_Msg_Warn := GNAT_Mode; |
1143 | Error_Msg_N | |
b785e0b8 | 1144 | ("<<statements not allowed in preelaborated unit", Item); |
6d158291 | 1145 | |
996ae0b0 RK |
1146 | exit; |
1147 | end if; | |
1148 | ||
1149 | Next (Item); | |
1150 | end loop; | |
1151 | end if; | |
1152 | end Validate_Null_Statement_Sequence; | |
1153 | ||
1154 | --------------------------------- | |
1155 | -- Validate_Object_Declaration -- | |
1156 | --------------------------------- | |
1157 | ||
1158 | procedure Validate_Object_Declaration (N : Node_Id) is | |
1159 | Id : constant Entity_Id := Defining_Identifier (N); | |
1160 | E : constant Node_Id := Expression (N); | |
1161 | Odf : constant Node_Id := Object_Definition (N); | |
1162 | T : constant Entity_Id := Etype (Id); | |
1163 | ||
1164 | begin | |
1165 | -- Verify that any access to subprogram object does not have in its | |
1166 | -- subprogram profile access type parameters or limited parameters | |
1167 | -- without Read and Write attributes (E.2.3(13)). | |
1168 | ||
1169 | Validate_RCI_Subprogram_Declaration (N); | |
1170 | ||
1171 | -- Check that if we are in preelaborated elaboration code, then we | |
1172 | -- do not have an instance of a default initialized private, task or | |
1173 | -- protected object declaration which would violate (RM 10.2.1(9)). | |
1174 | -- Note that constants are never default initialized (and the test | |
1175 | -- below also filters out deferred constants). A variable is default | |
1176 | -- initialized if it does *not* have an initialization expression. | |
1177 | ||
1178 | -- Filter out cases that are not declaration of a variable from source | |
1179 | ||
1180 | if Nkind (N) /= N_Object_Declaration | |
1181 | or else Constant_Present (N) | |
1182 | or else not Comes_From_Source (Id) | |
1183 | then | |
1184 | return; | |
1185 | end if; | |
1186 | ||
1187 | -- Exclude generic specs from the checks (this will get rechecked | |
1188 | -- on instantiations). | |
1189 | ||
709121b5 | 1190 | if Inside_A_Generic and then No (Enclosing_Generic_Body (Id)) then |
996ae0b0 RK |
1191 | return; |
1192 | end if; | |
1193 | ||
709121b5 TQ |
1194 | -- Required checks for declaration that is in a preelaborated package |
1195 | -- and is not within some subprogram. | |
996ae0b0 RK |
1196 | |
1197 | if In_Preelaborated_Unit | |
1198 | and then not In_Subprogram_Or_Concurrent_Unit | |
1199 | then | |
1200 | -- Check for default initialized variable case. Note that in | |
709121b5 TQ |
1201 | -- accordance with (RM B.1(24)) imported objects are not subject to |
1202 | -- default initialization. | |
2fa9443e ES |
1203 | -- If the initialization does not come from source and is an |
1204 | -- aggregate, it is a static initialization that replaces an | |
1205 | -- implicit call, and must be treated as such. | |
1206 | ||
1207 | if Present (E) | |
1cf3727f | 1208 | and then (Comes_From_Source (E) or else Nkind (E) /= N_Aggregate) |
2fa9443e ES |
1209 | then |
1210 | null; | |
996ae0b0 | 1211 | |
2fa9443e ES |
1212 | elsif Is_Imported (Id) then |
1213 | null; | |
1214 | ||
1215 | else | |
996ae0b0 RK |
1216 | declare |
1217 | Ent : Entity_Id := T; | |
1218 | ||
1219 | begin | |
1220 | -- An array whose component type is a record with nonstatic | |
1221 | -- default expressions is a violation, so we get the array's | |
1222 | -- component type. | |
1223 | ||
1224 | if Is_Array_Type (Ent) then | |
1225 | declare | |
468c6c8a | 1226 | Comp_Type : Entity_Id; |
996ae0b0 RK |
1227 | |
1228 | begin | |
468c6c8a | 1229 | Comp_Type := Component_Type (Ent); |
996ae0b0 RK |
1230 | while Is_Array_Type (Comp_Type) loop |
1231 | Comp_Type := Component_Type (Comp_Type); | |
1232 | end loop; | |
1233 | ||
1234 | Ent := Comp_Type; | |
1235 | end; | |
1236 | end if; | |
1237 | ||
1238 | -- Object decl. that is of record type and has no default expr. | |
1239 | -- should check if there is any non-static default expression | |
1240 | -- in component decl. of the record type decl. | |
1241 | ||
1242 | if Is_Record_Type (Ent) then | |
1243 | if Nkind (Parent (Ent)) = N_Full_Type_Declaration then | |
1244 | Check_Non_Static_Default_Expr | |
1245 | (Type_Definition (Parent (Ent)), N); | |
1246 | ||
1247 | elsif Nkind (Odf) = N_Subtype_Indication | |
1248 | and then not Is_Array_Type (T) | |
1249 | and then not Is_Private_Type (T) | |
1250 | then | |
1251 | Check_Non_Static_Default_Expr (Type_Definition | |
1252 | (Parent (Entity (Subtype_Mark (Odf)))), N); | |
1253 | end if; | |
1254 | end if; | |
1255 | ||
468c6c8a ES |
1256 | -- Check for invalid use of private object. Note that Ada 2005 |
1257 | -- AI-161 modifies the rules for Ada 2005, including the use of | |
1258 | -- the new pragma Preelaborable_Initialization. | |
1259 | ||
1260 | if Is_Private_Type (Ent) | |
1261 | or else Depends_On_Private (Ent) | |
996ae0b0 | 1262 | then |
468c6c8a ES |
1263 | -- Case where type has preelaborable initialization which |
1264 | -- means that a pragma Preelaborable_Initialization was | |
1265 | -- given for the private type. | |
1266 | ||
90b51aaf | 1267 | if Relaxed_RM_Semantics then |
c2e54001 | 1268 | |
90b51aaf AC |
1269 | -- In relaxed mode, do not issue these messages, this |
1270 | -- is basically similar to the GNAT_Mode test below. | |
1271 | ||
1272 | null; | |
1273 | ||
1274 | elsif Has_Preelaborable_Initialization (Ent) then | |
468c6c8a ES |
1275 | |
1276 | -- But for the predefined units, we will ignore this | |
1277 | -- status unless we are in Ada 2005 mode since we want | |
1278 | -- Ada 95 compatible behavior, in which the entities | |
1279 | -- marked with this pragma in the predefined library are | |
1280 | -- not treated specially. | |
1281 | ||
0791fbe9 | 1282 | if Ada_Version < Ada_2005 then |
468c6c8a ES |
1283 | Error_Msg_N |
1284 | ("private object not allowed in preelaborated unit", | |
1285 | N); | |
1286 | Error_Msg_N ("\(would be legal in Ada 2005 mode)", N); | |
1287 | end if; | |
1288 | ||
1289 | -- Type does not have preelaborable initialization | |
1290 | ||
1291 | else | |
1292 | -- We allow this when compiling in GNAT mode to make life | |
1293 | -- easier for some cases where it would otherwise be hard | |
1294 | -- to be exactly valid Ada. | |
1295 | ||
1296 | if not GNAT_Mode then | |
1297 | Error_Msg_N | |
1298 | ("private object not allowed in preelaborated unit", | |
1299 | N); | |
1300 | ||
2fa9443e | 1301 | -- Add a message if it would help to provide a pragma |
468c6c8a | 1302 | -- Preelaborable_Initialization on the type of the |
2fa9443e | 1303 | -- object (which would make it legal in Ada 2005). |
468c6c8a ES |
1304 | |
1305 | -- If the type has no full view (generic type, or | |
1306 | -- previous error), the warning does not apply. | |
1307 | ||
2fa9443e | 1308 | if Is_Private_Type (Ent) |
468c6c8a ES |
1309 | and then Present (Full_View (Ent)) |
1310 | and then | |
1311 | Has_Preelaborable_Initialization (Full_View (Ent)) | |
1312 | then | |
1313 | Error_Msg_Sloc := Sloc (Ent); | |
2fa9443e | 1314 | |
0791fbe9 | 1315 | if Ada_Version >= Ada_2005 then |
2fa9443e ES |
1316 | Error_Msg_NE |
1317 | ("\would be legal if pragma Preelaborable_" & | |
1318 | "Initialization given for & #", N, Ent); | |
1319 | else | |
1320 | Error_Msg_NE | |
1321 | ("\would be legal in Ada 2005 if pragma " & | |
1322 | "Preelaborable_Initialization given for & #", | |
1323 | N, Ent); | |
1324 | end if; | |
468c6c8a ES |
1325 | end if; |
1326 | end if; | |
1327 | end if; | |
996ae0b0 RK |
1328 | |
1329 | -- Access to Task or Protected type | |
1330 | ||
1331 | elsif Is_Entity_Name (Odf) | |
1332 | and then Present (Etype (Odf)) | |
1333 | and then Is_Access_Type (Etype (Odf)) | |
1334 | then | |
1335 | Ent := Designated_Type (Etype (Odf)); | |
1336 | ||
1337 | elsif Is_Entity_Name (Odf) then | |
1338 | Ent := Entity (Odf); | |
1339 | ||
1340 | elsif Nkind (Odf) = N_Subtype_Indication then | |
1341 | Ent := Etype (Subtype_Mark (Odf)); | |
1342 | ||
709121b5 | 1343 | elsif Nkind (Odf) = N_Constrained_Array_Definition then |
996ae0b0 | 1344 | Ent := Component_Type (T); |
996ae0b0 RK |
1345 | end if; |
1346 | ||
1347 | if Is_Task_Type (Ent) | |
1348 | or else (Is_Protected_Type (Ent) and then Has_Entries (Ent)) | |
1349 | then | |
1350 | Error_Msg_N | |
1351 | ("concurrent object not allowed in preelaborated unit", | |
1352 | N); | |
1353 | return; | |
1354 | end if; | |
1355 | end; | |
1356 | end if; | |
1357 | ||
709121b5 TQ |
1358 | -- Non-static discriminants not allowed in preelaborated unit. |
1359 | -- Objects of a controlled type with a user-defined Initialize | |
1360 | -- are forbidden as well. | |
996ae0b0 RK |
1361 | |
1362 | if Is_Record_Type (Etype (Id)) then | |
1363 | declare | |
1364 | ET : constant Entity_Id := Etype (Id); | |
1365 | EE : constant Entity_Id := Etype (Etype (Id)); | |
1366 | PEE : Node_Id; | |
1367 | ||
1368 | begin | |
22243c12 | 1369 | if Has_Discriminants (ET) and then Present (EE) then |
996ae0b0 RK |
1370 | PEE := Parent (EE); |
1371 | ||
1372 | if Nkind (PEE) = N_Full_Type_Declaration | |
1cf3727f RD |
1373 | and then not Static_Discriminant_Expr |
1374 | (Discriminant_Specifications (PEE)) | |
996ae0b0 RK |
1375 | then |
1376 | Error_Msg_N | |
1377 | ("non-static discriminant in preelaborated unit", | |
1378 | PEE); | |
1379 | end if; | |
1380 | end if; | |
b4592168 | 1381 | |
c228a069 AC |
1382 | -- For controlled type or type with controlled component, check |
1383 | -- preelaboration flag, as there may be a non-null Initialize | |
1384 | -- primitive. For language versions earlier than Ada 2005, | |
e7d897b8 AC |
1385 | -- there is no notion of preelaborable initialization, and |
1386 | -- Validate_Controlled_Object is used to enforce rules for | |
1387 | -- controlled objects. | |
c228a069 AC |
1388 | |
1389 | if (Is_Controlled (ET) or else Has_Controlled_Component (ET)) | |
1390 | and then Ada_Version >= Ada_2005 | |
1391 | and then not Has_Preelaborable_Initialization (ET) | |
1392 | then | |
b4592168 GD |
1393 | Error_Msg_NE |
1394 | ("controlled type& does not have" | |
1395 | & " preelaborable initialization", N, ET); | |
1396 | end if; | |
996ae0b0 | 1397 | end; |
b4592168 | 1398 | |
996ae0b0 RK |
1399 | end if; |
1400 | end if; | |
1401 | ||
468c6c8a ES |
1402 | -- A pure library_item must not contain the declaration of any variable |
1403 | -- except within a subprogram, generic subprogram, task unit, or | |
1404 | -- protected unit (RM 10.2.1(16)). | |
996ae0b0 | 1405 | |
709121b5 | 1406 | if In_Pure_Unit and then not In_Subprogram_Task_Protected_Unit then |
996ae0b0 RK |
1407 | Error_Msg_N ("declaration of variable not allowed in pure unit", N); |
1408 | ||
375cbc2b | 1409 | elsif not In_Private_Part (Id) then |
996ae0b0 | 1410 | |
375cbc2b TQ |
1411 | -- The visible part of an RCI library unit must not contain the |
1412 | -- declaration of a variable (RM E.1.3(9)). | |
996ae0b0 | 1413 | |
375cbc2b TQ |
1414 | if In_RCI_Declaration then |
1415 | Error_Msg_N ("visible variable not allowed in 'R'C'I unit", N); | |
996ae0b0 | 1416 | |
375cbc2b TQ |
1417 | -- The visible part of a Shared Passive library unit must not contain |
1418 | -- the declaration of a variable (RM E.2.2(7)). | |
996ae0b0 | 1419 | |
375cbc2b TQ |
1420 | elsif In_RT_Declaration then |
1421 | Error_Msg_N | |
1422 | ("visible variable not allowed in remote types unit", N); | |
1423 | end if; | |
1424 | end if; | |
996ae0b0 RK |
1425 | end Validate_Object_Declaration; |
1426 | ||
b5ea9143 AC |
1427 | ----------------------------- |
1428 | -- Validate_RACW_Primitive -- | |
1429 | ----------------------------- | |
468c6c8a | 1430 | |
b5ea9143 AC |
1431 | procedure Validate_RACW_Primitive |
1432 | (Subp : Entity_Id; | |
1433 | RACW : Entity_Id) | |
1434 | is | |
1435 | procedure Illegal_Remote_Subp (Msg : String; N : Node_Id); | |
1436 | -- Diagnose illegality on N. If RACW is present, report the error on it | |
1437 | -- rather than on N. | |
468c6c8a | 1438 | |
b5ea9143 AC |
1439 | ------------------------- |
1440 | -- Illegal_Remote_Subp -- | |
1441 | ------------------------- | |
2b2b6798 | 1442 | |
b5ea9143 AC |
1443 | procedure Illegal_Remote_Subp (Msg : String; N : Node_Id) is |
1444 | begin | |
1445 | if Present (RACW) then | |
1446 | if not Error_Posted (RACW) then | |
1447 | Error_Msg_N | |
1448 | ("illegal remote access to class-wide type&", RACW); | |
1449 | end if; | |
2b2b6798 | 1450 | |
b5ea9143 AC |
1451 | Error_Msg_Sloc := Sloc (N); |
1452 | Error_Msg_NE ("\\" & Msg & " in primitive& #", RACW, Subp); | |
2b2b6798 | 1453 | |
b5ea9143 AC |
1454 | else |
1455 | Error_Msg_NE (Msg & " in remote subprogram&", N, Subp); | |
2b2b6798 | 1456 | end if; |
b5ea9143 | 1457 | end Illegal_Remote_Subp; |
2b2b6798 | 1458 | |
b5ea9143 AC |
1459 | Rtyp : Entity_Id; |
1460 | Param : Node_Id; | |
1461 | Param_Spec : Node_Id; | |
1462 | Param_Type : Entity_Id; | |
2b2b6798 | 1463 | |
b5ea9143 | 1464 | -- Start of processing for Validate_RACW_Primitive |
2b2b6798 | 1465 | |
468c6c8a | 1466 | begin |
b5ea9143 | 1467 | -- Check return type |
468c6c8a | 1468 | |
b5ea9143 AC |
1469 | if Ekind (Subp) = E_Function then |
1470 | Rtyp := Etype (Subp); | |
ef2a63ba | 1471 | |
ee2e3f6b AC |
1472 | -- AI05-0101 (Binding Interpretation): The result type of a remote |
1473 | -- function must either support external streaming or be a | |
1474 | -- controlling access result type. | |
1475 | ||
b5ea9143 AC |
1476 | if Has_Controlling_Result (Subp) then |
1477 | null; | |
ef2a63ba | 1478 | |
b5ea9143 AC |
1479 | elsif Ekind (Rtyp) = E_Anonymous_Access_Type then |
1480 | Illegal_Remote_Subp ("anonymous access result", Rtyp); | |
468c6c8a | 1481 | |
b5ea9143 AC |
1482 | elsif Is_Limited_Type (Rtyp) then |
1483 | if No (TSS (Rtyp, TSS_Stream_Read)) | |
1484 | or else | |
1485 | No (TSS (Rtyp, TSS_Stream_Write)) | |
1486 | then | |
1487 | Illegal_Remote_Subp | |
1488 | ("limited return type must have Read and Write attributes", | |
1489 | Parent (Subp)); | |
1490 | Explain_Limited_Type (Rtyp, Parent (Subp)); | |
ee2e3f6b | 1491 | end if; |
b5ea9143 | 1492 | |
ee2e3f6b | 1493 | -- Check that the return type supports external streaming |
b5ea9143 | 1494 | |
ee2e3f6b | 1495 | elsif No_External_Streaming (Rtyp) |
22243c12 | 1496 | and then not Error_Posted (Rtyp) |
ee2e3f6b AC |
1497 | then |
1498 | Illegal_Remote_Subp ("return type containing non-remote access " | |
1499 | & "must have Read and Write attributes", | |
1500 | Parent (Subp)); | |
468c6c8a | 1501 | end if; |
b5ea9143 | 1502 | end if; |
468c6c8a | 1503 | |
b5ea9143 AC |
1504 | Param := First_Formal (Subp); |
1505 | while Present (Param) loop | |
468c6c8a | 1506 | |
b5ea9143 | 1507 | -- Now find out if this parameter is a controlling parameter |
468c6c8a | 1508 | |
b5ea9143 AC |
1509 | Param_Spec := Parent (Param); |
1510 | Param_Type := Etype (Param); | |
468c6c8a | 1511 | |
b5ea9143 | 1512 | if Is_Controlling_Formal (Param) then |
468c6c8a | 1513 | |
b5ea9143 AC |
1514 | -- It is a controlling parameter, so specific checks below do not |
1515 | -- apply. | |
468c6c8a | 1516 | |
b5ea9143 | 1517 | null; |
468c6c8a | 1518 | |
4a08c95c AC |
1519 | elsif Ekind (Param_Type) in E_Anonymous_Access_Type |
1520 | | E_Anonymous_Access_Subprogram_Type | |
b5ea9143 AC |
1521 | then |
1522 | -- From RM E.2.2(14), no anonymous access parameter other than | |
1523 | -- controlling ones may be used (because an anonymous access | |
1524 | -- type never supports external streaming). | |
468c6c8a | 1525 | |
b5ea9143 AC |
1526 | Illegal_Remote_Subp |
1527 | ("non-controlling access parameter", Param_Spec); | |
468c6c8a | 1528 | |
b5ea9143 AC |
1529 | elsif No_External_Streaming (Param_Type) |
1530 | and then not Error_Posted (Param_Type) | |
1531 | then | |
1532 | Illegal_Remote_Subp ("formal parameter in remote subprogram must " | |
1533 | & "support external streaming", Param_Spec); | |
1534 | end if; | |
468c6c8a | 1535 | |
b5ea9143 | 1536 | -- Check next parameter in this subprogram |
468c6c8a | 1537 | |
b5ea9143 AC |
1538 | Next_Formal (Param); |
1539 | end loop; | |
1540 | end Validate_RACW_Primitive; | |
468c6c8a | 1541 | |
b5ea9143 AC |
1542 | ------------------------------ |
1543 | -- Validate_RACW_Primitives -- | |
1544 | ------------------------------ | |
468c6c8a | 1545 | |
b5ea9143 AC |
1546 | procedure Validate_RACW_Primitives (T : Entity_Id) is |
1547 | Desig_Type : Entity_Id; | |
1548 | Primitive_Subprograms : Elist_Id; | |
1549 | Subprogram_Elmt : Elmt_Id; | |
1550 | Subprogram : Entity_Id; | |
468c6c8a | 1551 | |
b5ea9143 AC |
1552 | begin |
1553 | Desig_Type := Etype (Designated_Type (T)); | |
468c6c8a | 1554 | |
b5ea9143 | 1555 | -- No action needed for concurrent types |
468c6c8a | 1556 | |
b5ea9143 AC |
1557 | if Is_Concurrent_Type (Desig_Type) then |
1558 | return; | |
1559 | end if; | |
468c6c8a | 1560 | |
b5ea9143 | 1561 | Primitive_Subprograms := Primitive_Operations (Desig_Type); |
de5cd98e | 1562 | |
b5ea9143 AC |
1563 | Subprogram_Elmt := First_Elmt (Primitive_Subprograms); |
1564 | while Subprogram_Elmt /= No_Elmt loop | |
1565 | Subprogram := Node (Subprogram_Elmt); | |
468c6c8a | 1566 | |
b5ea9143 AC |
1567 | if Is_Predefined_Dispatching_Operation (Subprogram) |
1568 | or else Is_Hidden (Subprogram) | |
1569 | then | |
1570 | goto Next_Subprogram; | |
1571 | end if; | |
468c6c8a | 1572 | |
b5ea9143 | 1573 | Validate_RACW_Primitive (Subp => Subprogram, RACW => T); |
468c6c8a | 1574 | |
b5ea9143 AC |
1575 | <<Next_Subprogram>> |
1576 | Next_Elmt (Subprogram_Elmt); | |
468c6c8a ES |
1577 | end loop; |
1578 | end Validate_RACW_Primitives; | |
1579 | ||
15ce9ca2 AC |
1580 | ------------------------------- |
1581 | -- Validate_RCI_Declarations -- | |
1582 | ------------------------------- | |
996ae0b0 RK |
1583 | |
1584 | procedure Validate_RCI_Declarations (P : Entity_Id) is | |
1585 | E : Entity_Id; | |
1586 | ||
1587 | begin | |
1588 | E := First_Entity (P); | |
996ae0b0 RK |
1589 | while Present (E) loop |
1590 | if Comes_From_Source (E) then | |
996ae0b0 RK |
1591 | if Is_Limited_Type (E) then |
1592 | Error_Msg_N | |
9ed2b86d | 1593 | ("limited type not allowed in 'R'C'I unit", Parent (E)); |
fbf5a39b | 1594 | Explain_Limited_Type (E, Parent (E)); |
996ae0b0 | 1595 | |
4a08c95c AC |
1596 | elsif Ekind (E) in E_Generic_Function |
1597 | | E_Generic_Package | |
1598 | | E_Generic_Procedure | |
996ae0b0 | 1599 | then |
9ed2b86d | 1600 | Error_Msg_N ("generic declaration not allowed in 'R'C'I unit", |
996ae0b0 RK |
1601 | Parent (E)); |
1602 | ||
b5ea9143 | 1603 | elsif (Ekind (E) = E_Function or else Ekind (E) = E_Procedure) |
996ae0b0 RK |
1604 | and then Has_Pragma_Inline (E) |
1605 | then | |
1606 | Error_Msg_N | |
9ed2b86d | 1607 | ("inlined subprogram not allowed in 'R'C'I unit", Parent (E)); |
996ae0b0 | 1608 | |
468c6c8a ES |
1609 | -- Inner packages that are renamings need not be checked. Generic |
1610 | -- RCI packages are subject to the checks, but entities that come | |
1611 | -- from formal packages are not part of the visible declarations | |
1612 | -- of the package and are not checked. | |
996ae0b0 RK |
1613 | |
1614 | elsif Ekind (E) = E_Package then | |
1615 | if Present (Renamed_Entity (E)) then | |
1616 | null; | |
1617 | ||
1618 | elsif Ekind (P) /= E_Generic_Package | |
1619 | or else List_Containing (Unit_Declaration_Node (E)) /= | |
1620 | Generic_Formal_Declarations | |
1621 | (Unit_Declaration_Node (P)) | |
1622 | then | |
1623 | Validate_RCI_Declarations (E); | |
1624 | end if; | |
1625 | end if; | |
1626 | end if; | |
1627 | ||
1628 | Next_Entity (E); | |
1629 | end loop; | |
1630 | end Validate_RCI_Declarations; | |
1631 | ||
1632 | ----------------------------------------- | |
1633 | -- Validate_RCI_Subprogram_Declaration -- | |
1634 | ----------------------------------------- | |
1635 | ||
1636 | procedure Validate_RCI_Subprogram_Declaration (N : Node_Id) is | |
fbf5a39b | 1637 | K : constant Node_Kind := Nkind (N); |
996ae0b0 | 1638 | Profile : List_Id; |
375cbc2b | 1639 | Id : constant Entity_Id := Defining_Entity (N); |
996ae0b0 RK |
1640 | Param_Spec : Node_Id; |
1641 | Param_Type : Entity_Id; | |
996ae0b0 RK |
1642 | Error_Node : Node_Id := N; |
1643 | ||
1644 | begin | |
de5cd98e TQ |
1645 | -- This procedure enforces rules on subprogram and access to subprogram |
1646 | -- declarations in RCI units. These rules do not apply to expander | |
1647 | -- generated routines, which are not remote subprograms. It is called: | |
996ae0b0 | 1648 | |
de5cd98e TQ |
1649 | -- 1. from Analyze_Subprogram_Declaration. |
1650 | -- 2. from Validate_Object_Declaration (access to subprogram). | |
996ae0b0 | 1651 | |
375cbc2b TQ |
1652 | if not (Comes_From_Source (N) |
1653 | and then In_RCI_Declaration | |
1654 | and then not In_Private_Part (Scope (Id))) | |
1655 | then | |
996ae0b0 RK |
1656 | return; |
1657 | end if; | |
1658 | ||
1659 | if K = N_Subprogram_Declaration then | |
1660 | Profile := Parameter_Specifications (Specification (N)); | |
1661 | ||
375cbc2b TQ |
1662 | else |
1663 | pragma Assert (K = N_Object_Declaration); | |
24b66768 | 1664 | |
de5cd98e TQ |
1665 | -- The above assertion is dubious, the visible declarations of an |
1666 | -- RCI unit never contain an object declaration, this should be an | |
1667 | -- ACCESS-to-object declaration??? | |
1668 | ||
996ae0b0 RK |
1669 | if Nkind (Id) = N_Defining_Identifier |
1670 | and then Nkind (Parent (Etype (Id))) = N_Full_Type_Declaration | |
1671 | and then Ekind (Etype (Id)) = E_Access_Subprogram_Type | |
1672 | then | |
1673 | Profile := | |
1674 | Parameter_Specifications (Type_Definition (Parent (Etype (Id)))); | |
1675 | else | |
1676 | return; | |
1677 | end if; | |
1678 | end if; | |
1679 | ||
1680 | -- Iterate through the parameter specification list, checking that | |
1681 | -- no access parameter and no limited type parameter in the list. | |
de5cd98e | 1682 | -- RM E.2.3(14). |
996ae0b0 RK |
1683 | |
1684 | if Present (Profile) then | |
1685 | Param_Spec := First (Profile); | |
996ae0b0 RK |
1686 | while Present (Param_Spec) loop |
1687 | Param_Type := Etype (Defining_Identifier (Param_Spec)); | |
996ae0b0 RK |
1688 | |
1689 | if Ekind (Param_Type) = E_Anonymous_Access_Type then | |
996ae0b0 RK |
1690 | if K = N_Subprogram_Declaration then |
1691 | Error_Node := Param_Spec; | |
1692 | end if; | |
1693 | ||
0835f1d7 | 1694 | -- Report error only if declaration is in source program |
996ae0b0 | 1695 | |
72eaa365 | 1696 | if Comes_From_Source (Id) then |
996ae0b0 | 1697 | Error_Msg_N |
de5cd98e | 1698 | ("subprogram in 'R'C'I unit cannot have access parameter", |
72eaa365 | 1699 | Error_Node); |
996ae0b0 RK |
1700 | end if; |
1701 | ||
b4592168 | 1702 | -- For a limited private type parameter, we check only the private |
468c6c8a | 1703 | -- declaration and ignore full type declaration, unless this is |
b4592168 | 1704 | -- the only declaration for the type, e.g., as a limited record. |
996ae0b0 | 1705 | |
b5ea9143 | 1706 | elsif No_External_Streaming (Param_Type) then |
de5cd98e TQ |
1707 | if K = N_Subprogram_Declaration then |
1708 | Error_Node := Param_Spec; | |
1709 | end if; | |
1710 | ||
b5ea9143 AC |
1711 | Error_Msg_NE |
1712 | ("formal of remote subprogram& " | |
1713 | & "must support external streaming", | |
1714 | Error_Node, Id); | |
1715 | if Is_Limited_Type (Param_Type) then | |
1716 | Explain_Limited_Type (Param_Type, Error_Node); | |
de5cd98e TQ |
1717 | end if; |
1718 | end if; | |
b5ea9143 | 1719 | |
996ae0b0 RK |
1720 | Next (Param_Spec); |
1721 | end loop; | |
72eaa365 | 1722 | end if; |
de5cd98e | 1723 | |
72eaa365 AC |
1724 | if Ekind (Id) = E_Function |
1725 | and then Ekind (Etype (Id)) = E_Anonymous_Access_Type | |
1726 | and then Comes_From_Source (Id) | |
1727 | then | |
1728 | Error_Msg_N | |
1729 | ("function in 'R'C'I unit cannot have access result", | |
1730 | Error_Node); | |
996ae0b0 RK |
1731 | end if; |
1732 | end Validate_RCI_Subprogram_Declaration; | |
1733 | ||
1734 | ---------------------------------------------------- | |
1735 | -- Validate_Remote_Access_Object_Type_Declaration -- | |
1736 | ---------------------------------------------------- | |
1737 | ||
1738 | procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id) is | |
1739 | Direct_Designated_Type : Entity_Id; | |
1740 | Desig_Type : Entity_Id; | |
996ae0b0 RK |
1741 | |
1742 | begin | |
0f1a6a0b AC |
1743 | -- We are called from Analyze_Full_Type_Declaration, and the Nkind of |
1744 | -- the given node is N_Access_To_Object_Definition. | |
996ae0b0 RK |
1745 | |
1746 | if not Comes_From_Source (T) | |
375cbc2b | 1747 | or else (not In_RCI_Declaration and then not In_RT_Declaration) |
996ae0b0 RK |
1748 | then |
1749 | return; | |
1750 | end if; | |
1751 | ||
375cbc2b TQ |
1752 | -- An access definition in the private part of a package is not a |
1753 | -- remote access type. Restrictions related to external streaming | |
1754 | -- support for non-remote access types are enforced elsewhere. Note | |
1755 | -- that In_Private_Part is never set on type entities: check flag | |
1756 | -- on enclosing scope. | |
996ae0b0 | 1757 | |
375cbc2b | 1758 | if In_Private_Part (Scope (T)) then |
996ae0b0 RK |
1759 | return; |
1760 | end if; | |
1761 | ||
468c6c8a ES |
1762 | -- Check RCI or RT unit type declaration. It may not contain the |
1763 | -- declaration of an access-to-object type unless it is a general access | |
a73734f5 AC |
1764 | -- type that designates a class-wide limited private type or subtype. |
1765 | -- There are also constraints on the primitive subprograms of the | |
1766 | -- class-wide type (RM E.2.2(14), see Validate_RACW_Primitives). | |
996ae0b0 RK |
1767 | |
1768 | if Ekind (T) /= E_General_Access_Type | |
a73734f5 | 1769 | or else not Is_Class_Wide_Type (Designated_Type (T)) |
996ae0b0 | 1770 | then |
375cbc2b | 1771 | if In_RCI_Declaration then |
996ae0b0 | 1772 | Error_Msg_N |
468c6c8a | 1773 | ("error in access type in Remote_Call_Interface unit", T); |
996ae0b0 | 1774 | else |
468c6c8a ES |
1775 | Error_Msg_N |
1776 | ("error in access type in Remote_Types unit", T); | |
996ae0b0 | 1777 | end if; |
468c6c8a ES |
1778 | |
1779 | Error_Msg_N ("\must be general access to class-wide type", T); | |
996ae0b0 RK |
1780 | return; |
1781 | end if; | |
1782 | ||
1783 | Direct_Designated_Type := Designated_Type (T); | |
996ae0b0 RK |
1784 | Desig_Type := Etype (Direct_Designated_Type); |
1785 | ||
324ac540 | 1786 | -- Why is this check not in Validate_Remote_Access_To_Class_Wide_Type??? |
de5cd98e TQ |
1787 | |
1788 | if not Is_Valid_Remote_Object_Type (Desig_Type) then | |
996ae0b0 RK |
1789 | Error_Msg_N |
1790 | ("error in designated type of remote access to class-wide type", T); | |
1791 | Error_Msg_N | |
2b2b6798 | 1792 | ("\must be tagged limited private or private extension", T); |
996ae0b0 RK |
1793 | return; |
1794 | end if; | |
996ae0b0 RK |
1795 | end Validate_Remote_Access_Object_Type_Declaration; |
1796 | ||
1797 | ----------------------------------------------- | |
1798 | -- Validate_Remote_Access_To_Class_Wide_Type -- | |
1799 | ----------------------------------------------- | |
1800 | ||
1801 | procedure Validate_Remote_Access_To_Class_Wide_Type (N : Node_Id) is | |
1802 | K : constant Node_Kind := Nkind (N); | |
1803 | PK : constant Node_Kind := Nkind (Parent (N)); | |
1804 | E : Entity_Id; | |
1805 | ||
1806 | begin | |
6d158291 RD |
1807 | -- This subprogram enforces the checks in (RM E.2.2(8)) for certain uses |
1808 | -- of class-wide limited private types. | |
996ae0b0 RK |
1809 | |
1810 | -- Storage_Pool and Storage_Size are not defined for such types | |
1811 | -- | |
de5cd98e | 1812 | -- The expected type of allocator must not be such a type. |
996ae0b0 | 1813 | |
6d158291 RD |
1814 | -- The actual parameter of generic instantiation must not be such a |
1815 | -- type if the formal parameter is of an access type. | |
996ae0b0 | 1816 | |
25081892 | 1817 | -- On entry, there are several cases: |
996ae0b0 | 1818 | |
6d158291 RD |
1819 | -- 1. called from sem_attr Analyze_Attribute where attribute name is |
1820 | -- either Storage_Pool or Storage_Size. | |
996ae0b0 RK |
1821 | |
1822 | -- 2. called from exp_ch4 Expand_N_Allocator | |
1823 | ||
25081892 | 1824 | -- 3. called from sem_ch4 Analyze_Explicit_Dereference |
996ae0b0 | 1825 | |
25081892 | 1826 | -- 4. called from sem_res Resolve_Actuals |
996ae0b0 | 1827 | |
072c5071 AC |
1828 | if K = N_Attribute_Definition_Clause then |
1829 | E := Etype (Entity (N)); | |
1830 | ||
1831 | if Is_Remote_Access_To_Class_Wide_Type (E) then | |
1832 | Error_Msg_Name_1 := Chars (N); | |
1833 | Error_Msg_N | |
1834 | ("cannot specify% aspect for a remote operand", N); | |
1835 | return; | |
1836 | end if; | |
1837 | ||
1838 | elsif K = N_Attribute_Reference then | |
996ae0b0 RK |
1839 | E := Etype (Prefix (N)); |
1840 | ||
1841 | if Is_Remote_Access_To_Class_Wide_Type (E) then | |
1842 | Error_Msg_N ("incorrect attribute of remote operand", N); | |
1843 | return; | |
1844 | end if; | |
1845 | ||
1846 | elsif K = N_Allocator then | |
1847 | E := Etype (N); | |
1848 | ||
1849 | if Is_Remote_Access_To_Class_Wide_Type (E) then | |
1850 | Error_Msg_N ("incorrect expected remote type of allocator", N); | |
1851 | return; | |
996ae0b0 RK |
1852 | end if; |
1853 | ||
6d158291 | 1854 | -- This subprogram also enforces the checks in E.2.2(13). A value of |
468c6c8a | 1855 | -- such type must not be dereferenced unless as controlling operand of |
b4592168 GD |
1856 | -- a dispatching call. Explicit dereferences not coming from source are |
1857 | -- exempted from this checking because the expander produces them in | |
1858 | -- some cases (such as for tag checks on dispatching calls with multiple | |
1859 | -- controlling operands). However we do check in the case of an implicit | |
1860 | -- dereference that is expanded to an explicit dereference (hence the | |
1861 | -- test of whether Original_Node (N) comes from source). | |
996ae0b0 RK |
1862 | |
1863 | elsif K = N_Explicit_Dereference | |
b4592168 | 1864 | and then Comes_From_Source (Original_Node (N)) |
996ae0b0 RK |
1865 | then |
1866 | E := Etype (Prefix (N)); | |
1867 | ||
1868 | -- If the class-wide type is not a remote one, the restrictions | |
1869 | -- do not apply. | |
1870 | ||
1871 | if not Is_Remote_Access_To_Class_Wide_Type (E) then | |
1872 | return; | |
1873 | end if; | |
1874 | ||
1875 | -- If we have a true dereference that comes from source and that | |
1876 | -- is a controlling argument for a dispatching call, accept it. | |
1877 | ||
22243c12 | 1878 | if Is_Actual_Parameter (N) and then Is_Controlling_Actual (N) then |
996ae0b0 RK |
1879 | return; |
1880 | end if; | |
1881 | ||
1882 | -- If we are just within a procedure or function call and the | |
6d158291 | 1883 | -- dereference has not been analyzed, return because this procedure |
b4592168 GD |
1884 | -- will be called again from sem_res Resolve_Actuals. The same can |
1885 | -- apply in the case of dereference that is the prefix of a selected | |
1886 | -- component, which can be a call given in prefixed form. | |
996ae0b0 | 1887 | |
22243c12 | 1888 | if (Is_Actual_Parameter (N) or else PK = N_Selected_Component) |
996ae0b0 RK |
1889 | and then not Analyzed (N) |
1890 | then | |
1891 | return; | |
1892 | end if; | |
1893 | ||
468c6c8a ES |
1894 | -- We must allow expanded code to generate a reference to the tag of |
1895 | -- the designated object (may be either the actual tag, or the stub | |
1896 | -- tag in the case of a remote object). | |
1897 | ||
1898 | if PK = N_Selected_Component | |
1899 | and then Is_Tag (Entity (Selector_Name (Parent (N)))) | |
996ae0b0 RK |
1900 | then |
1901 | return; | |
1902 | end if; | |
1903 | ||
b4592168 GD |
1904 | Error_Msg_N |
1905 | ("invalid dereference of a remote access-to-class-wide value", N); | |
996ae0b0 RK |
1906 | end if; |
1907 | end Validate_Remote_Access_To_Class_Wide_Type; | |
1908 | ||
996ae0b0 RK |
1909 | ------------------------------------------ |
1910 | -- Validate_Remote_Type_Type_Conversion -- | |
1911 | ------------------------------------------ | |
1912 | ||
1913 | procedure Validate_Remote_Type_Type_Conversion (N : Node_Id) is | |
1914 | S : constant Entity_Id := Etype (N); | |
1915 | E : constant Entity_Id := Etype (Expression (N)); | |
1916 | ||
1917 | begin | |
6d158291 RD |
1918 | -- This test is required in the case where a conversion appears inside a |
1919 | -- normal package, it does not necessarily have to be inside an RCI, | |
1920 | -- Remote_Types unit (RM E.2.2(9,12)). | |
996ae0b0 RK |
1921 | |
1922 | if Is_Remote_Access_To_Subprogram_Type (E) | |
1923 | and then not Is_Remote_Access_To_Subprogram_Type (S) | |
1924 | then | |
6332d842 TQ |
1925 | Error_Msg_N |
1926 | ("incorrect conversion of remote operand to local type", N); | |
1927 | return; | |
1928 | ||
1929 | elsif not Is_Remote_Access_To_Subprogram_Type (E) | |
1930 | and then Is_Remote_Access_To_Subprogram_Type (S) | |
1931 | then | |
1932 | Error_Msg_N | |
1933 | ("incorrect conversion of local operand to remote type", N); | |
996ae0b0 RK |
1934 | return; |
1935 | ||
1936 | elsif Is_Remote_Access_To_Class_Wide_Type (E) | |
1937 | and then not Is_Remote_Access_To_Class_Wide_Type (S) | |
1938 | then | |
6332d842 TQ |
1939 | Error_Msg_N |
1940 | ("incorrect conversion of remote operand to local type", N); | |
996ae0b0 RK |
1941 | return; |
1942 | end if; | |
1943 | ||
1944 | -- If a local access type is converted into a RACW type, then the | |
1945 | -- current unit has a pointer that may now be exported to another | |
1946 | -- partition. | |
1947 | ||
1948 | if Is_Remote_Access_To_Class_Wide_Type (S) | |
1949 | and then not Is_Remote_Access_To_Class_Wide_Type (E) | |
1950 | then | |
1951 | Set_Has_RACW (Current_Sem_Unit); | |
1952 | end if; | |
1953 | end Validate_Remote_Type_Type_Conversion; | |
1954 | ||
1955 | ------------------------------- | |
1956 | -- Validate_RT_RAT_Component -- | |
1957 | ------------------------------- | |
1958 | ||
1959 | procedure Validate_RT_RAT_Component (N : Node_Id) is | |
468c6c8a ES |
1960 | Spec : constant Node_Id := Specification (N); |
1961 | Name_U : constant Entity_Id := Defining_Entity (Spec); | |
1962 | Typ : Entity_Id; | |
1963 | U_Typ : Entity_Id; | |
1964 | First_Priv_Ent : constant Entity_Id := First_Private_Entity (Name_U); | |
996ae0b0 | 1965 | |
b5ea9143 AC |
1966 | function Stream_Attributes_Available (Typ : Entity_Id) return Boolean; |
1967 | -- True if any stream attribute is available for Typ | |
1968 | ||
1969 | --------------------------------- | |
1970 | -- Stream_Attributes_Available -- | |
1971 | --------------------------------- | |
1972 | ||
1973 | function Stream_Attributes_Available (Typ : Entity_Id) return Boolean | |
1974 | is | |
1975 | begin | |
1976 | return Stream_Attribute_Available (Typ, TSS_Stream_Read) | |
1977 | or else | |
1978 | Stream_Attribute_Available (Typ, TSS_Stream_Write) | |
1979 | or else | |
1980 | Stream_Attribute_Available (Typ, TSS_Stream_Input) | |
1981 | or else | |
1982 | Stream_Attribute_Available (Typ, TSS_Stream_Output); | |
1983 | end Stream_Attributes_Available; | |
1984 | ||
1985 | -- Start of processing for Validate_RT_RAT_Component | |
1986 | ||
996ae0b0 RK |
1987 | begin |
1988 | if not Is_Remote_Types (Name_U) then | |
1989 | return; | |
1990 | end if; | |
1991 | ||
1992 | Typ := First_Entity (Name_U); | |
468c6c8a | 1993 | while Present (Typ) and then Typ /= First_Priv_Ent loop |
715e529d | 1994 | U_Typ := Underlying_Type (Base_Type (Typ)); |
468c6c8a ES |
1995 | |
1996 | if No (U_Typ) then | |
1997 | U_Typ := Typ; | |
996ae0b0 RK |
1998 | end if; |
1999 | ||
57f6e00c AC |
2000 | if Comes_From_Source (Typ) and then Is_Type (Typ) |
2001 | and then Ekind (Typ) /= E_Incomplete_Type | |
2002 | then | |
b5ea9143 AC |
2003 | -- Check that the type can be meaningfully transmitted to another |
2004 | -- partition (E.2.2(8)). | |
2005 | ||
2006 | if (Ada_Version < Ada_2005 and then Has_Non_Remote_Access (U_Typ)) | |
22243c12 RD |
2007 | or else (Stream_Attributes_Available (Typ) |
2008 | and then No_External_Streaming (U_Typ)) | |
b5ea9143 | 2009 | then |
996ae0b0 | 2010 | if Is_Non_Remote_Access_Type (Typ) then |
468c6c8a | 2011 | Error_Msg_N ("error in non-remote access type", U_Typ); |
996ae0b0 RK |
2012 | else |
2013 | Error_Msg_N | |
468c6c8a ES |
2014 | ("error in record type containing a component of a " & |
2015 | "non-remote access type", U_Typ); | |
2016 | end if; | |
2017 | ||
0791fbe9 | 2018 | if Ada_Version >= Ada_2005 then |
468c6c8a ES |
2019 | Error_Msg_N |
2020 | ("\must have visible Read and Write attribute " & | |
fe685905 | 2021 | "definition clauses (RM E.2.2(8))", U_Typ); |
468c6c8a | 2022 | else |
996ae0b0 | 2023 | Error_Msg_N |
468c6c8a | 2024 | ("\must have Read and Write attribute " & |
fe685905 | 2025 | "definition clauses (RM E.2.2(8))", U_Typ); |
996ae0b0 RK |
2026 | end if; |
2027 | end if; | |
2028 | end if; | |
2029 | ||
2030 | Next_Entity (Typ); | |
2031 | end loop; | |
2032 | end Validate_RT_RAT_Component; | |
2033 | ||
2034 | ----------------------------------------- | |
2035 | -- Validate_SP_Access_Object_Type_Decl -- | |
2036 | ----------------------------------------- | |
2037 | ||
2038 | procedure Validate_SP_Access_Object_Type_Decl (T : Entity_Id) is | |
2039 | Direct_Designated_Type : Entity_Id; | |
2040 | ||
2041 | function Has_Entry_Declarations (E : Entity_Id) return Boolean; | |
22243c12 RD |
2042 | -- Return true if the protected type designated by T has entry |
2043 | -- declarations. | |
996ae0b0 | 2044 | |
6d158291 RD |
2045 | ---------------------------- |
2046 | -- Has_Entry_Declarations -- | |
2047 | ---------------------------- | |
2048 | ||
996ae0b0 RK |
2049 | function Has_Entry_Declarations (E : Entity_Id) return Boolean is |
2050 | Ety : Entity_Id; | |
2051 | ||
2052 | begin | |
2053 | if Nkind (Parent (E)) = N_Protected_Type_Declaration then | |
2054 | Ety := First_Entity (E); | |
2055 | while Present (Ety) loop | |
2056 | if Ekind (Ety) = E_Entry then | |
2057 | return True; | |
2058 | end if; | |
2059 | ||
2060 | Next_Entity (Ety); | |
2061 | end loop; | |
2062 | end if; | |
2063 | ||
2064 | return False; | |
2065 | end Has_Entry_Declarations; | |
2066 | ||
2067 | -- Start of processing for Validate_SP_Access_Object_Type_Decl | |
2068 | ||
2069 | begin | |
0f1a6a0b | 2070 | -- We are called from Sem_Ch3.Analyze_Full_Type_Declaration, and the |
996ae0b0 RK |
2071 | -- Nkind of the given entity is N_Access_To_Object_Definition. |
2072 | ||
2073 | if not Comes_From_Source (T) | |
2074 | or else not In_Shared_Passive_Unit | |
2075 | or else In_Subprogram_Task_Protected_Unit | |
2076 | then | |
2077 | return; | |
2078 | end if; | |
2079 | ||
2080 | -- Check Shared Passive unit. It should not contain the declaration | |
2081 | -- of an access-to-object type whose designated type is a class-wide | |
2082 | -- type, task type or protected type with entry (RM E.2.1(7)). | |
2083 | ||
2084 | Direct_Designated_Type := Designated_Type (T); | |
2085 | ||
2086 | if Ekind (Direct_Designated_Type) = E_Class_Wide_Type then | |
2087 | Error_Msg_N | |
2088 | ("invalid access-to-class-wide type in shared passive unit", T); | |
2089 | return; | |
2090 | ||
2091 | elsif Ekind (Direct_Designated_Type) in Task_Kind then | |
2092 | Error_Msg_N | |
2093 | ("invalid access-to-task type in shared passive unit", T); | |
2094 | return; | |
2095 | ||
2096 | elsif Ekind (Direct_Designated_Type) in Protected_Kind | |
2097 | and then Has_Entry_Declarations (Direct_Designated_Type) | |
2098 | then | |
2099 | Error_Msg_N | |
2100 | ("invalid access-to-protected type in shared passive unit", T); | |
2101 | return; | |
2102 | end if; | |
2103 | end Validate_SP_Access_Object_Type_Decl; | |
2104 | ||
2105 | --------------------------------- | |
2106 | -- Validate_Static_Object_Name -- | |
2107 | --------------------------------- | |
2108 | ||
2109 | procedure Validate_Static_Object_Name (N : Node_Id) is | |
aa611332 AC |
2110 | E : Entity_Id; |
2111 | Val : Node_Id; | |
996ae0b0 RK |
2112 | |
2113 | function Is_Primary (N : Node_Id) return Boolean; | |
0835f1d7 | 2114 | -- Determine whether node is syntactically a primary in an expression |
468c6c8a | 2115 | -- This function should probably be somewhere else ??? |
324ac540 | 2116 | -- |
468c6c8a ES |
2117 | -- Also it does not do what it says, e.g if N is a binary operator |
2118 | -- whose parent is a binary operator, Is_Primary returns True ??? | |
996ae0b0 | 2119 | |
6d158291 RD |
2120 | ---------------- |
2121 | -- Is_Primary -- | |
2122 | ---------------- | |
2123 | ||
996ae0b0 RK |
2124 | function Is_Primary (N : Node_Id) return Boolean is |
2125 | K : constant Node_Kind := Nkind (Parent (N)); | |
2126 | ||
2127 | begin | |
2128 | case K is | |
996ae0b0 RK |
2129 | when N_Aggregate |
2130 | | N_Component_Association | |
d8f43ee6 HK |
2131 | | N_Index_Or_Discriminant_Constraint |
2132 | | N_Membership_Test | |
2133 | | N_Op | |
4b97cbee | 2134 | | N_Range |
d8f43ee6 | 2135 | => |
996ae0b0 RK |
2136 | return True; |
2137 | ||
2138 | when N_Attribute_Reference => | |
d8f43ee6 HK |
2139 | declare |
2140 | Attr : constant Name_Id := Attribute_Name (Parent (N)); | |
2141 | ||
2142 | begin | |
2143 | return Attr /= Name_Address | |
2144 | and then Attr /= Name_Access | |
2145 | and then Attr /= Name_Unchecked_Access | |
2146 | and then Attr /= Name_Unrestricted_Access; | |
2147 | end; | |
996ae0b0 RK |
2148 | |
2149 | when N_Indexed_Component => | |
d8f43ee6 | 2150 | return N /= Prefix (Parent (N)) or else Is_Primary (Parent (N)); |
996ae0b0 | 2151 | |
d8f43ee6 HK |
2152 | when N_Qualified_Expression |
2153 | | N_Type_Conversion | |
2154 | => | |
996ae0b0 RK |
2155 | return Is_Primary (Parent (N)); |
2156 | ||
d8f43ee6 HK |
2157 | when N_Assignment_Statement |
2158 | | N_Object_Declaration | |
2159 | => | |
2160 | return N = Expression (Parent (N)); | |
996ae0b0 RK |
2161 | |
2162 | when N_Selected_Component => | |
2163 | return Is_Primary (Parent (N)); | |
2164 | ||
2165 | when others => | |
2166 | return False; | |
2167 | end case; | |
2168 | end Is_Primary; | |
2169 | ||
2170 | -- Start of processing for Validate_Static_Object_Name | |
2171 | ||
2172 | begin | |
2173 | if not In_Preelaborated_Unit | |
2174 | or else not Comes_From_Source (N) | |
2175 | or else In_Subprogram_Or_Concurrent_Unit | |
2176 | or else Ekind (Current_Scope) = E_Block | |
2177 | then | |
2178 | return; | |
2179 | ||
6d158291 RD |
2180 | -- Filter out cases where primary is default in a component declaration, |
2181 | -- discriminant specification, or actual in a record type initialization | |
2182 | -- call. | |
996ae0b0 | 2183 | |
0835f1d7 | 2184 | -- Initialization call of internal types |
996ae0b0 RK |
2185 | |
2186 | elsif Nkind (Parent (N)) = N_Procedure_Call_Statement then | |
2187 | ||
2188 | if Present (Parent (Parent (N))) | |
2189 | and then Nkind (Parent (Parent (N))) = N_Freeze_Entity | |
2190 | then | |
2191 | return; | |
2192 | end if; | |
2193 | ||
2194 | if Nkind (Name (Parent (N))) = N_Identifier | |
2195 | and then not Comes_From_Source (Entity (Name (Parent (N)))) | |
2196 | then | |
2197 | return; | |
2198 | end if; | |
2199 | end if; | |
2200 | ||
2201 | -- Error if the name is a primary in an expression. The parent must not | |
2202 | -- be an operator, or a selected component or an indexed component that | |
2203 | -- is itself a primary. Entities that are actuals do not need to be | |
ce06d641 AC |
2204 | -- checked, because the call itself will be diagnosed. Entities in a |
2205 | -- generic unit or within a preanalyzed expression are not checked: | |
2206 | -- only their use in executable code matters. | |
996ae0b0 RK |
2207 | |
2208 | if Is_Primary (N) | |
2209 | and then (not Inside_A_Generic | |
2210 | or else Present (Enclosing_Generic_Body (N))) | |
ce06d641 | 2211 | and then not In_Spec_Expression |
996ae0b0 | 2212 | then |
468c6c8a ES |
2213 | if Ekind (Entity (N)) = E_Variable |
2214 | or else Ekind (Entity (N)) in Formal_Object_Kind | |
2215 | then | |
fbf5a39b AC |
2216 | Flag_Non_Static_Expr |
2217 | ("non-static object name in preelaborated unit", N); | |
996ae0b0 | 2218 | |
241bea26 AC |
2219 | -- Give an error for a reference to a nonstatic constant, unless the |
2220 | -- constant is in another GNAT library unit that is preelaborable. | |
996ae0b0 RK |
2221 | |
2222 | elsif Ekind (Entity (N)) = E_Constant | |
2223 | and then not Is_Static_Expression (N) | |
2224 | then | |
aa611332 AC |
2225 | E := Entity (N); |
2226 | Val := Constant_Value (E); | |
996ae0b0 | 2227 | |
8ab31c0c | 2228 | if In_Internal_Unit (N) |
996ae0b0 | 2229 | and then |
799d0e05 | 2230 | Enclosing_Comp_Unit_Node (N) /= Enclosing_Comp_Unit_Node (E) |
996ae0b0 | 2231 | and then (Is_Preelaborated (Scope (E)) |
22243c12 RD |
2232 | or else Is_Pure (Scope (E)) |
2233 | or else (Present (Renamed_Object (E)) | |
2234 | and then Is_Entity_Name (Renamed_Object (E)) | |
2235 | and then | |
2236 | (Is_Preelaborated | |
e3a325f2 AC |
2237 | (Scope (Renamed_Object (E))) |
2238 | or else | |
2239 | Is_Pure | |
2240 | (Scope (Renamed_Object (E)))))) | |
996ae0b0 RK |
2241 | then |
2242 | null; | |
6d158291 | 2243 | |
aa611332 AC |
2244 | -- If the value of the constant is a local variable that renames |
2245 | -- an aggregate, this is in itself legal. The aggregate may be | |
2246 | -- expanded into a loop, but this does not affect preelaborability | |
2247 | -- in itself. If some aggregate components are non-static, that is | |
2248 | -- to say if they involve non static primaries, they will be | |
2249 | -- flagged when analyzed. | |
2250 | ||
2251 | elsif Present (Val) | |
2252 | and then Is_Entity_Name (Val) | |
2253 | and then Is_Array_Type (Etype (Val)) | |
2254 | and then not Comes_From_Source (Val) | |
e3a325f2 | 2255 | and then Nkind (Original_Node (Val)) = N_Aggregate |
aa611332 AC |
2256 | then |
2257 | null; | |
2258 | ||
6d158291 RD |
2259 | -- This is the error case |
2260 | ||
996ae0b0 | 2261 | else |
a6152428 AC |
2262 | -- In GNAT mode or Relaxed RM Semantic mode, this is just a |
2263 | -- warning, to allow it to be judiciously turned off. | |
2264 | -- Otherwise it is a real error. | |
6d158291 | 2265 | |
a6152428 | 2266 | if GNAT_Mode or Relaxed_RM_Semantics then |
6d158291 | 2267 | Error_Msg_N |
324ac540 | 2268 | ("??non-static constant in preelaborated unit", N); |
6d158291 RD |
2269 | else |
2270 | Flag_Non_Static_Expr | |
2271 | ("non-static constant in preelaborated unit", N); | |
2272 | end if; | |
996ae0b0 RK |
2273 | end if; |
2274 | end if; | |
2275 | end if; | |
2276 | end Validate_Static_Object_Name; | |
2277 | ||
2278 | end Sem_Cat; |