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