|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S E M _ C A T --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
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- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
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 --
|
|
|
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. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
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;
|
|
|
31 with Lib; use Lib;
|
|
|
32 with Namet; use Namet;
|
|
|
33 with Nlists; use Nlists;
|
|
|
34 with Opt; use Opt;
|
|
|
35 with Sem; use Sem;
|
|
|
36 with Sem_Attr; use Sem_Attr;
|
|
|
37 with Sem_Aux; use Sem_Aux;
|
|
|
38 with Sem_Dist; use Sem_Dist;
|
|
|
39 with Sem_Eval; use Sem_Eval;
|
|
|
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
|
|
|
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.
|
|
|
82
|
|
|
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.
|
|
|
86
|
|
|
87 function In_RCI_Declaration return Boolean;
|
|
|
88 function In_RT_Declaration return Boolean;
|
|
|
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
|
|
|
94
|
|
|
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);
|
|
|
104 -- Check validity of declaration if RCI or RT unit. It should not contain
|
|
|
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)
|
|
|
109
|
|
|
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
|
|
|
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
|
|
|
126 N : constant Node_Id := Info_Node;
|
|
|
127 Err : Boolean;
|
|
|
128
|
|
|
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
|
|
|
133 type Categorization is
|
|
|
134 (Pure,
|
|
|
135 Shared_Passive,
|
|
|
136 Remote_Types,
|
|
|
137 Remote_Call_Interface,
|
|
|
138 Normal);
|
|
|
139
|
|
|
140 function Get_Categorization (E : Entity_Id) return Categorization;
|
|
|
141 -- Check categorization flags from entity, and return in the form
|
|
|
142 -- of the lowest value of the Categorization type that applies to E.
|
|
|
143
|
|
|
144 ------------------------
|
|
|
145 -- Get_Categorization --
|
|
|
146 ------------------------
|
|
|
147
|
|
|
148 function Get_Categorization (E : Entity_Id) return Categorization is
|
|
|
149 begin
|
|
|
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
|
|
|
155 -- return the lowest applicable value.
|
|
|
156
|
|
|
157 -- Ignore Pure specification if set by pragma Pure_Function
|
|
|
158
|
|
|
159 if Is_Pure (E)
|
|
|
160 and then not
|
|
|
161 (Has_Pragma_Pure_Function (E) and not Has_Pragma_Pure (E))
|
|
|
162 then
|
|
|
163 return Pure;
|
|
|
164
|
|
|
165 elsif Is_Shared_Passive (E) then
|
|
|
166 return Shared_Passive;
|
|
|
167
|
|
|
168 elsif Is_Remote_Types (E) then
|
|
|
169 return Remote_Types;
|
|
|
170
|
|
|
171 elsif Is_Remote_Call_Interface (E) then
|
|
|
172 return Remote_Call_Interface;
|
|
|
173
|
|
|
174 else
|
|
|
175 return Normal;
|
|
|
176 end if;
|
|
|
177 end Get_Categorization;
|
|
|
178
|
|
|
179 Unit_Category : Categorization;
|
|
|
180 With_Category : Categorization;
|
|
|
181
|
|
|
182 -- Start of processing for Check_Categorization_Dependencies
|
|
|
183
|
|
|
184 begin
|
|
|
185 -- Intrinsic subprograms are preelaborated, so do not impose any
|
|
|
186 -- categorization dependencies. Also, ignore categorization
|
|
|
187 -- dependencies when compilation switch -gnatdu is used.
|
|
|
188
|
|
|
189 if Is_Intrinsic_Subprogram (Depended_Entity) or else Debug_Flag_U then
|
|
|
190 return;
|
|
|
191 end if;
|
|
|
192
|
|
|
193 -- First check 10.2.1 (11/1) rules on preelaborate packages
|
|
|
194
|
|
|
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;
|
|
|
203
|
|
|
204 -- Check categorization rules of RM E.2(5)
|
|
|
205
|
|
|
206 Unit_Category := Get_Categorization (Unit_Entity);
|
|
|
207 With_Category := Get_Categorization (Depended_Entity);
|
|
|
208
|
|
|
209 if With_Category > Unit_Category then
|
|
|
210
|
|
|
211 -- Special case: Remote_Types and Remote_Call_Interface are allowed
|
|
|
212 -- to WITH anything in the package body, per (RM E.2(5)).
|
|
|
213
|
|
|
214 if (Unit_Category = Remote_Types
|
|
|
215 or else Unit_Category = Remote_Call_Interface)
|
|
|
216 and then In_Package_Body (Unit_Entity)
|
|
|
217 then
|
|
|
218 null;
|
|
|
219
|
|
|
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
|
|
|
225 or else
|
|
|
226 Unit_Category = Remote_Call_Interface)
|
|
|
227 and then Nkind (N) = N_With_Clause
|
|
|
228 and then Private_Present (N)
|
|
|
229 and then Is_Preelaborated (Depended_Entity)
|
|
|
230 then
|
|
|
231 null;
|
|
|
232
|
|
|
233 -- All other cases, we do have an error
|
|
|
234
|
|
|
235 else
|
|
|
236 Err := True;
|
|
|
237 end if;
|
|
|
238 end if;
|
|
|
239
|
|
|
240 -- Here if we have an error
|
|
|
241
|
|
|
242 if Err then
|
|
|
243
|
|
|
244 -- These messages are warnings in GNAT mode or if the -gnateP switch
|
|
|
245 -- was set. Otherwise these are real errors for real illegalities.
|
|
|
246
|
|
|
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;
|
|
|
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
|
|
|
264 if Is_Internal_Unit (Current_Sem_Unit)
|
|
|
265 and then not Is_Internal_Unit (Main_Unit)
|
|
|
266 then
|
|
|
267 return;
|
|
|
268
|
|
|
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
|
|
|
273 or else
|
|
|
274 Unit_Category = Remote_Call_Interface)
|
|
|
275 and then Is_Preelaborated (Depended_Entity)
|
|
|
276 then
|
|
|
277 Error_Msg_NE
|
|
|
278 ("<<must use private with clause for preelaborated unit& ",
|
|
|
279 N, Depended_Entity);
|
|
|
280
|
|
|
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
|
|
|
289
|
|
|
290 else
|
|
|
291 Error_Msg_NE
|
|
|
292 ("<<cannot depend on& " &
|
|
|
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
|
|
|
300 ("\<<pure unit cannot depend on non-pure unit",
|
|
|
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
|
|
|
308 ("\<<preelaborated unit cannot depend on "
|
|
|
309 & "non-preelaborated unit",
|
|
|
310 N, Depended_Entity);
|
|
|
311 end if;
|
|
|
312 end if;
|
|
|
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
|
|
|
356 and then not Is_OK_Static_Expression (Expression (Component_Decl))
|
|
|
357 then
|
|
|
358 Error_Msg_Sloc := Sloc (Component_Decl);
|
|
|
359 Error_Msg_F
|
|
|
360 ("object in preelaborated unit has non-static default#",
|
|
|
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
|
|
|
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);
|
|
|
384
|
|
|
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
|
|
|
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);
|
|
|
431 end Has_Read_Write_Attributes;
|
|
|
432
|
|
|
433 -------------------------------------
|
|
|
434 -- Has_Stream_Attribute_Definition --
|
|
|
435 -------------------------------------
|
|
|
436
|
|
|
437 function Has_Stream_Attribute_Definition
|
|
|
438 (Typ : Entity_Id;
|
|
|
439 Nam : TSS_Name_Type;
|
|
|
440 At_Any_Place : Boolean := False) return Boolean
|
|
|
441 is
|
|
|
442 Rep_Item : Node_Id;
|
|
|
443
|
|
|
444 Real_Rep : Node_Id;
|
|
|
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.
|
|
|
451
|
|
|
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
|
|
|
457 -- inserted by the expander at the point where the clause occurs),
|
|
|
458 -- unless At_Any_Place is true.
|
|
|
459
|
|
|
460 Rep_Item := First_Rep_Item (Typ);
|
|
|
461 while Present (Rep_Item) loop
|
|
|
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
|
|
|
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;
|
|
|
487 end case;
|
|
|
488 end if;
|
|
|
489
|
|
|
490 Next_Rep_Item (Rep_Item);
|
|
|
491 end loop;
|
|
|
492
|
|
|
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.
|
|
|
509
|
|
|
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;
|
|
|
516 end Has_Stream_Attribute_Definition;
|
|
|
517
|
|
|
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
|
|
|
535 ---------------------------
|
|
|
536 -- In_Preelaborated_Unit --
|
|
|
537 ---------------------------
|
|
|
538
|
|
|
539 function In_Preelaborated_Unit return Boolean is
|
|
|
540 Unit_Entity : Entity_Id := Current_Scope;
|
|
|
541 Unit_Kind : constant Node_Kind :=
|
|
|
542 Nkind (Unit (Cunit (Current_Sem_Unit)));
|
|
|
543
|
|
|
544 begin
|
|
|
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
|
|
|
556 -- There are no constraints on the body of Remote_Call_Interface or
|
|
|
557 -- Remote_Types packages.
|
|
|
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)
|
|
|
565 or else Is_Remote_Call_Interface (Unit_Entity))
|
|
|
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
|
|
|
581 ------------------------
|
|
|
582 -- In_RCI_Declaration --
|
|
|
583 ------------------------
|
|
|
584
|
|
|
585 function In_RCI_Declaration return Boolean is
|
|
|
586 begin
|
|
|
587 return Is_Remote_Call_Interface (Current_Scope)
|
|
|
588 and then In_Package_Declaration;
|
|
|
589 end In_RCI_Declaration;
|
|
|
590
|
|
|
591 -----------------------
|
|
|
592 -- In_RT_Declaration --
|
|
|
593 -----------------------
|
|
|
594
|
|
|
595 function In_RT_Declaration return Boolean is
|
|
|
596 begin
|
|
|
597 return Is_Remote_Types (Current_Scope) and then In_Package_Declaration;
|
|
|
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;
|
|
|
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
|
|
|
627 if Is_Subprogram_Or_Generic_Subprogram (E)
|
|
|
628 or else
|
|
|
629 Is_Concurrent_Type (E)
|
|
|
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;
|
|
|
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
|
|
|
646 U_E : constant Entity_Id := Underlying_Type (Base_Type (E));
|
|
|
647 -- Use full view of base type to handle subtypes properly.
|
|
|
648
|
|
|
649 begin
|
|
|
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);
|
|
|
661 end Is_Non_Remote_Access_Type;
|
|
|
662
|
|
|
663 ---------------------------
|
|
|
664 -- No_External_Streaming --
|
|
|
665 ---------------------------
|
|
|
666
|
|
|
667 function No_External_Streaming (E : Entity_Id) return Boolean is
|
|
|
668 U_E : constant Entity_Id := Underlying_Type (E);
|
|
|
669
|
|
|
670 begin
|
|
|
671 if No (U_E) then
|
|
|
672 return False;
|
|
|
673
|
|
|
674 elsif Has_Read_Write_Attributes (E) then
|
|
|
675
|
|
|
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
|
|
|
680 return False;
|
|
|
681
|
|
|
682 elsif Has_Non_Remote_Access (U_E) then
|
|
|
683 return True;
|
|
|
684 end if;
|
|
|
685
|
|
|
686 return Is_Limited_Type (E);
|
|
|
687 end No_External_Streaming;
|
|
|
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
|
|
|
703 -----------------
|
|
|
704 -- Set_Parents --
|
|
|
705 -----------------
|
|
|
706
|
|
|
707 procedure Set_Parents (Visibility : Boolean) is
|
|
|
708 Par : Entity_Id;
|
|
|
709 begin
|
|
|
710 Par := Scope (S);
|
|
|
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
|
|
|
717 -- Start of processing for Set_Categorization_From_Pragmas
|
|
|
718
|
|
|
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
|
|
|
724 -- the unit.
|
|
|
725
|
|
|
726 if Nkind (P) /= N_Compilation_Unit then
|
|
|
727 return;
|
|
|
728 end if;
|
|
|
729
|
|
|
730 declare
|
|
|
731 PN : Node_Id;
|
|
|
732
|
|
|
733 begin
|
|
|
734 if Is_Child_Unit (S) and then Is_Generic_Instance (S) then
|
|
|
735 Set_Parents (True);
|
|
|
736 end if;
|
|
|
737
|
|
|
738 PN := First (Pragmas_After (Aux_Decls_Node (P)));
|
|
|
739 while Present (PN) loop
|
|
|
740
|
|
|
741 -- Skip implicit types that may have been introduced by
|
|
|
742 -- previous analysis.
|
|
|
743
|
|
|
744 if Nkind (PN) = N_Pragma then
|
|
|
745 case Get_Pragma_Id (PN) is
|
|
|
746 when Pragma_All_Calls_Remote
|
|
|
747 | Pragma_Preelaborate
|
|
|
748 | Pragma_Pure
|
|
|
749 | Pragma_Remote_Call_Interface
|
|
|
750 | Pragma_Remote_Types
|
|
|
751 | Pragma_Shared_Passive
|
|
|
752 =>
|
|
|
753 Analyze (PN);
|
|
|
754
|
|
|
755 when others =>
|
|
|
756 null;
|
|
|
757 end case;
|
|
|
758 end if;
|
|
|
759
|
|
|
760 Next (PN);
|
|
|
761 end loop;
|
|
|
762
|
|
|
763 if Is_Child_Unit (S) and then Is_Generic_Instance (S) then
|
|
|
764 Set_Parents (False);
|
|
|
765 end if;
|
|
|
766 end;
|
|
|
767 end Set_Categorization_From_Pragmas;
|
|
|
768
|
|
|
769 -----------------------------------
|
|
|
770 -- Set_Categorization_From_Scope --
|
|
|
771 -----------------------------------
|
|
|
772
|
|
|
773 procedure Set_Categorization_From_Scope (E : Entity_Id; Scop : Entity_Id) is
|
|
|
774 Declaration : Node_Id := Empty;
|
|
|
775 Specification : Node_Id := Empty;
|
|
|
776
|
|
|
777 begin
|
|
|
778 -- Do not modify the purity of an internally generated entity if it has
|
|
|
779 -- been explicitly marked as pure for optimization purposes.
|
|
|
780
|
|
|
781 if not Has_Pragma_Pure_Function (E) then
|
|
|
782 Set_Is_Pure
|
|
|
783 (E, Is_Pure (Scop) and then Is_Library_Level_Entity (E));
|
|
|
784 end if;
|
|
|
785
|
|
|
786 if not Is_Remote_Call_Interface (E) then
|
|
|
787 if Ekind (E) in Subprogram_Kind then
|
|
|
788 Declaration := Unit_Declaration_Node (E);
|
|
|
789
|
|
|
790 if Nkind_In (Declaration, N_Subprogram_Body,
|
|
|
791 N_Subprogram_Renaming_Declaration)
|
|
|
792 then
|
|
|
793 Specification := Corresponding_Spec (Declaration);
|
|
|
794 end if;
|
|
|
795 end if;
|
|
|
796
|
|
|
797 -- A subprogram body or renaming-as-body is a remote call interface
|
|
|
798 -- if it serves as the completion of a subprogram declaration that
|
|
|
799 -- is a remote call interface.
|
|
|
800
|
|
|
801 if Nkind (Specification) in N_Entity then
|
|
|
802 Set_Is_Remote_Call_Interface
|
|
|
803 (E, Is_Remote_Call_Interface (Specification));
|
|
|
804
|
|
|
805 -- A subprogram declaration is a remote call interface when it is
|
|
|
806 -- declared within the visible part of, or declared by, a library
|
|
|
807 -- unit declaration that is a remote call interface.
|
|
|
808
|
|
|
809 else
|
|
|
810 Set_Is_Remote_Call_Interface
|
|
|
811 (E, Is_Remote_Call_Interface (Scop)
|
|
|
812 and then not (In_Private_Part (Scop)
|
|
|
813 or else In_Package_Body (Scop)));
|
|
|
814 end if;
|
|
|
815 end if;
|
|
|
816
|
|
|
817 Set_Is_Remote_Types
|
|
|
818 (E, Is_Remote_Types (Scop)
|
|
|
819 and then not (In_Private_Part (Scop)
|
|
|
820 or else In_Package_Body (Scop)));
|
|
|
821 end Set_Categorization_From_Scope;
|
|
|
822
|
|
|
823 ------------------------------
|
|
|
824 -- Static_Discriminant_Expr --
|
|
|
825 ------------------------------
|
|
|
826
|
|
|
827 -- We need to accommodate a Why_Not_Static call somehow here ???
|
|
|
828
|
|
|
829 function Static_Discriminant_Expr (L : List_Id) return Boolean is
|
|
|
830 Discriminant_Spec : Node_Id;
|
|
|
831
|
|
|
832 begin
|
|
|
833 Discriminant_Spec := First (L);
|
|
|
834 while Present (Discriminant_Spec) loop
|
|
|
835 if Present (Expression (Discriminant_Spec))
|
|
|
836 and then
|
|
|
837 not Is_OK_Static_Expression (Expression (Discriminant_Spec))
|
|
|
838 then
|
|
|
839 return False;
|
|
|
840 end if;
|
|
|
841
|
|
|
842 Next (Discriminant_Spec);
|
|
|
843 end loop;
|
|
|
844
|
|
|
845 return True;
|
|
|
846 end Static_Discriminant_Expr;
|
|
|
847
|
|
|
848 --------------------------------------
|
|
|
849 -- Validate_Access_Type_Declaration --
|
|
|
850 --------------------------------------
|
|
|
851
|
|
|
852 procedure Validate_Access_Type_Declaration (T : Entity_Id; N : Node_Id) is
|
|
|
853 Def : constant Node_Id := Type_Definition (N);
|
|
|
854
|
|
|
855 begin
|
|
|
856 case Nkind (Def) is
|
|
|
857
|
|
|
858 -- Access to subprogram case
|
|
|
859
|
|
|
860 when N_Access_To_Subprogram_Definition =>
|
|
|
861
|
|
|
862 -- A pure library_item must not contain the declaration of a
|
|
|
863 -- named access type, except within a subprogram, generic
|
|
|
864 -- subprogram, task unit, or protected unit (RM 10.2.1(16)).
|
|
|
865
|
|
|
866 -- This test is skipped in Ada 2005 (see AI-366)
|
|
|
867
|
|
|
868 if Ada_Version < Ada_2005
|
|
|
869 and then Comes_From_Source (T)
|
|
|
870 and then In_Pure_Unit
|
|
|
871 and then not In_Subprogram_Task_Protected_Unit
|
|
|
872 then
|
|
|
873 Error_Msg_N ("named access type not allowed in pure unit", T);
|
|
|
874 end if;
|
|
|
875
|
|
|
876 -- Access to object case
|
|
|
877
|
|
|
878 when N_Access_To_Object_Definition =>
|
|
|
879 if Comes_From_Source (T)
|
|
|
880 and then In_Pure_Unit
|
|
|
881 and then not In_Subprogram_Task_Protected_Unit
|
|
|
882 then
|
|
|
883 -- We can't give the message yet, since the type is not frozen
|
|
|
884 -- and in Ada 2005 mode, access types are allowed in pure units
|
|
|
885 -- if the type has no storage pool (see AI-366). So we set a
|
|
|
886 -- flag which will be checked at freeze time.
|
|
|
887
|
|
|
888 Set_Is_Pure_Unit_Access_Type (T);
|
|
|
889 end if;
|
|
|
890
|
|
|
891 -- Check for RCI or RT unit type declaration: declaration of an
|
|
|
892 -- access-to-object type is illegal unless it is a general access
|
|
|
893 -- type that designates a class-wide limited private type.
|
|
|
894 -- Note that constraints on the primitive subprograms of the
|
|
|
895 -- designated tagged type are not enforced here but in
|
|
|
896 -- Validate_RACW_Primitives, which is done separately because the
|
|
|
897 -- designated type might not be frozen (and therefore its
|
|
|
898 -- primitive operations might not be completely known) at the
|
|
|
899 -- point of the RACW declaration.
|
|
|
900
|
|
|
901 Validate_Remote_Access_Object_Type_Declaration (T);
|
|
|
902
|
|
|
903 -- Check for shared passive unit type declaration. It should
|
|
|
904 -- not contain the declaration of access to class wide type,
|
|
|
905 -- access to task type and access to protected type with entry.
|
|
|
906
|
|
|
907 Validate_SP_Access_Object_Type_Decl (T);
|
|
|
908
|
|
|
909 when others =>
|
|
|
910 null;
|
|
|
911 end case;
|
|
|
912
|
|
|
913 -- Set categorization flag from package on entity as well, to allow
|
|
|
914 -- easy checks later on for required validations of RCI or RT units.
|
|
|
915 -- This is only done for entities that are in the original source.
|
|
|
916
|
|
|
917 if Comes_From_Source (T)
|
|
|
918 and then not (In_Package_Body (Scope (T))
|
|
|
919 or else In_Private_Part (Scope (T)))
|
|
|
920 then
|
|
|
921 Set_Is_Remote_Call_Interface
|
|
|
922 (T, Is_Remote_Call_Interface (Scope (T)));
|
|
|
923 Set_Is_Remote_Types
|
|
|
924 (T, Is_Remote_Types (Scope (T)));
|
|
|
925 end if;
|
|
|
926 end Validate_Access_Type_Declaration;
|
|
|
927
|
|
|
928 ----------------------------
|
|
|
929 -- Validate_Ancestor_Part --
|
|
|
930 ----------------------------
|
|
|
931
|
|
|
932 procedure Validate_Ancestor_Part (N : Node_Id) is
|
|
|
933 A : constant Node_Id := Ancestor_Part (N);
|
|
|
934 T : constant Entity_Id := Entity (A);
|
|
|
935
|
|
|
936 begin
|
|
|
937 if In_Preelaborated_Unit
|
|
|
938 and then not In_Subprogram_Or_Concurrent_Unit
|
|
|
939 and then (not Inside_A_Generic
|
|
|
940 or else Present (Enclosing_Generic_Body (N)))
|
|
|
941 then
|
|
|
942 -- If the type is private, it must have the Ada 2005 pragma
|
|
|
943 -- Has_Preelaborable_Initialization.
|
|
|
944
|
|
|
945 -- The check is omitted within predefined units. This is probably
|
|
|
946 -- obsolete code to fix the Ada 95 weakness in this area ???
|
|
|
947
|
|
|
948 if Is_Private_Type (T)
|
|
|
949 and then not Has_Pragma_Preelab_Init (T)
|
|
|
950 and then not In_Internal_Unit (N)
|
|
|
951 then
|
|
|
952 Error_Msg_N
|
|
|
953 ("private ancestor type not allowed in preelaborated unit", A);
|
|
|
954
|
|
|
955 elsif Is_Record_Type (T) then
|
|
|
956 if Nkind (Parent (T)) = N_Full_Type_Declaration then
|
|
|
957 Check_Non_Static_Default_Expr
|
|
|
958 (Type_Definition (Parent (T)), A);
|
|
|
959 end if;
|
|
|
960 end if;
|
|
|
961 end if;
|
|
|
962 end Validate_Ancestor_Part;
|
|
|
963
|
|
|
964 ----------------------------------------
|
|
|
965 -- Validate_Categorization_Dependency --
|
|
|
966 ----------------------------------------
|
|
|
967
|
|
|
968 procedure Validate_Categorization_Dependency
|
|
|
969 (N : Node_Id;
|
|
|
970 E : Entity_Id)
|
|
|
971 is
|
|
|
972 K : constant Node_Kind := Nkind (N);
|
|
|
973 P : Node_Id := Parent (N);
|
|
|
974 U : Entity_Id := E;
|
|
|
975 Is_Subunit : constant Boolean := Nkind (P) = N_Subunit;
|
|
|
976
|
|
|
977 begin
|
|
|
978 -- Only validate library units and subunits. For subunits, checks
|
|
|
979 -- concerning withed units apply to the parent compilation unit.
|
|
|
980
|
|
|
981 if Is_Subunit then
|
|
|
982 P := Parent (P);
|
|
|
983 U := Scope (E);
|
|
|
984
|
|
|
985 while Present (U)
|
|
|
986 and then not Is_Compilation_Unit (U)
|
|
|
987 and then not Is_Child_Unit (U)
|
|
|
988 loop
|
|
|
989 U := Scope (U);
|
|
|
990 end loop;
|
|
|
991 end if;
|
|
|
992
|
|
|
993 if Nkind (P) /= N_Compilation_Unit then
|
|
|
994 return;
|
|
|
995 end if;
|
|
|
996
|
|
|
997 -- Body of RCI unit does not need validation
|
|
|
998
|
|
|
999 if Is_Remote_Call_Interface (E)
|
|
|
1000 and then Nkind_In (N, N_Package_Body, N_Subprogram_Body)
|
|
|
1001 then
|
|
|
1002 return;
|
|
|
1003 end if;
|
|
|
1004
|
|
|
1005 -- Ada 2005 (AI-50217): Process explicit non-limited with_clauses
|
|
|
1006
|
|
|
1007 declare
|
|
|
1008 Item : Node_Id;
|
|
|
1009 Entity_Of_Withed : Entity_Id;
|
|
|
1010
|
|
|
1011 begin
|
|
|
1012 Item := First (Context_Items (P));
|
|
|
1013 while Present (Item) loop
|
|
|
1014 if Nkind (Item) = N_With_Clause
|
|
|
1015 and then
|
|
|
1016 not (Implicit_With (Item)
|
|
|
1017 or else Limited_Present (Item)
|
|
|
1018
|
|
|
1019 -- Skip if error already posted on the WITH clause (in
|
|
|
1020 -- which case the Name attribute may be invalid). In
|
|
|
1021 -- particular, this fixes the problem of hanging in the
|
|
|
1022 -- presence of a WITH clause on a child that is an
|
|
|
1023 -- illegal generic instantiation.
|
|
|
1024
|
|
|
1025 or else Error_Posted (Item))
|
|
|
1026 and then
|
|
|
1027 not (Try_Semantics
|
|
|
1028
|
|
|
1029 -- Skip processing malformed trees
|
|
|
1030
|
|
|
1031 and then Nkind (Name (Item)) not in N_Has_Entity)
|
|
|
1032 then
|
|
|
1033 Entity_Of_Withed := Entity (Name (Item));
|
|
|
1034 Check_Categorization_Dependencies
|
|
|
1035 (U, Entity_Of_Withed, Item, Is_Subunit);
|
|
|
1036 end if;
|
|
|
1037
|
|
|
1038 Next (Item);
|
|
|
1039 end loop;
|
|
|
1040 end;
|
|
|
1041
|
|
|
1042 -- Child depends on parent; therefore parent should also be categorized
|
|
|
1043 -- and satisfy the dependency hierarchy.
|
|
|
1044
|
|
|
1045 -- Check if N is a child spec
|
|
|
1046
|
|
|
1047 if (K in N_Generic_Declaration or else
|
|
|
1048 K in N_Generic_Instantiation or else
|
|
|
1049 K in N_Generic_Renaming_Declaration or else
|
|
|
1050 K = N_Package_Declaration or else
|
|
|
1051 K = N_Package_Renaming_Declaration or else
|
|
|
1052 K = N_Subprogram_Declaration or else
|
|
|
1053 K = N_Subprogram_Renaming_Declaration)
|
|
|
1054 and then Present (Parent_Spec (N))
|
|
|
1055 then
|
|
|
1056 Check_Categorization_Dependencies (E, Scope (E), N, False);
|
|
|
1057
|
|
|
1058 -- Verify that public child of an RCI library unit must also be an
|
|
|
1059 -- RCI library unit (RM E.2.3(15)).
|
|
|
1060
|
|
|
1061 if Is_Remote_Call_Interface (Scope (E))
|
|
|
1062 and then not Private_Present (P)
|
|
|
1063 and then not Is_Remote_Call_Interface (E)
|
|
|
1064 then
|
|
|
1065 Error_Msg_N ("public child of rci unit must also be rci unit", N);
|
|
|
1066 end if;
|
|
|
1067 end if;
|
|
|
1068 end Validate_Categorization_Dependency;
|
|
|
1069
|
|
|
1070 --------------------------------
|
|
|
1071 -- Validate_Controlled_Object --
|
|
|
1072 --------------------------------
|
|
|
1073
|
|
|
1074 procedure Validate_Controlled_Object (E : Entity_Id) is
|
|
|
1075 begin
|
|
|
1076 -- Don't need this check in Ada 2005 mode, where this is all taken
|
|
|
1077 -- care of by the mechanism for Preelaborable Initialization.
|
|
|
1078
|
|
|
1079 if Ada_Version >= Ada_2005 then
|
|
|
1080 return;
|
|
|
1081 end if;
|
|
|
1082
|
|
|
1083 -- For now, never apply this check for internal GNAT units, since we
|
|
|
1084 -- have a number of cases in the library where we are stuck with objects
|
|
|
1085 -- of this type, and the RM requires Preelaborate.
|
|
|
1086
|
|
|
1087 -- For similar reasons, we only do this check for source entities, since
|
|
|
1088 -- we generate entities of this type in some situations.
|
|
|
1089
|
|
|
1090 -- Note that the 10.2.1(9) restrictions are not relevant to us anyway.
|
|
|
1091 -- We have to enforce them for RM compatibility, but we have no trouble
|
|
|
1092 -- accepting these objects and doing the right thing. Note that there is
|
|
|
1093 -- no requirement that Preelaborate not actually generate any code.
|
|
|
1094
|
|
|
1095 if In_Preelaborated_Unit
|
|
|
1096 and then not Debug_Flag_PP
|
|
|
1097 and then Comes_From_Source (E)
|
|
|
1098 and then not In_Internal_Unit (E)
|
|
|
1099 and then (not Inside_A_Generic
|
|
|
1100 or else Present (Enclosing_Generic_Body (E)))
|
|
|
1101 and then not Is_Protected_Type (Etype (E))
|
|
|
1102 then
|
|
|
1103 Error_Msg_N
|
|
|
1104 ("library level controlled object not allowed in " &
|
|
|
1105 "preelaborated unit", E);
|
|
|
1106 end if;
|
|
|
1107 end Validate_Controlled_Object;
|
|
|
1108
|
|
|
1109 --------------------------------------
|
|
|
1110 -- Validate_Null_Statement_Sequence --
|
|
|
1111 --------------------------------------
|
|
|
1112
|
|
|
1113 procedure Validate_Null_Statement_Sequence (N : Node_Id) is
|
|
|
1114 Item : Node_Id;
|
|
|
1115
|
|
|
1116 begin
|
|
|
1117 if In_Preelaborated_Unit then
|
|
|
1118 Item := First (Statements (Handled_Statement_Sequence (N)));
|
|
|
1119 while Present (Item) loop
|
|
|
1120 if Nkind (Item) /= N_Label
|
|
|
1121 and then Nkind (Item) /= N_Null_Statement
|
|
|
1122 then
|
|
|
1123 -- In GNAT mode, this is a warning, allowing the run-time
|
|
|
1124 -- to judiciously bypass this error condition.
|
|
|
1125
|
|
|
1126 Error_Msg_Warn := GNAT_Mode;
|
|
|
1127 Error_Msg_N
|
|
|
1128 ("<<statements not allowed in preelaborated unit", Item);
|
|
|
1129
|
|
|
1130 exit;
|
|
|
1131 end if;
|
|
|
1132
|
|
|
1133 Next (Item);
|
|
|
1134 end loop;
|
|
|
1135 end if;
|
|
|
1136 end Validate_Null_Statement_Sequence;
|
|
|
1137
|
|
|
1138 ---------------------------------
|
|
|
1139 -- Validate_Object_Declaration --
|
|
|
1140 ---------------------------------
|
|
|
1141
|
|
|
1142 procedure Validate_Object_Declaration (N : Node_Id) is
|
|
|
1143 Id : constant Entity_Id := Defining_Identifier (N);
|
|
|
1144 E : constant Node_Id := Expression (N);
|
|
|
1145 Odf : constant Node_Id := Object_Definition (N);
|
|
|
1146 T : constant Entity_Id := Etype (Id);
|
|
|
1147
|
|
|
1148 begin
|
|
|
1149 -- Verify that any access to subprogram object does not have in its
|
|
|
1150 -- subprogram profile access type parameters or limited parameters
|
|
|
1151 -- without Read and Write attributes (E.2.3(13)).
|
|
|
1152
|
|
|
1153 Validate_RCI_Subprogram_Declaration (N);
|
|
|
1154
|
|
|
1155 -- Check that if we are in preelaborated elaboration code, then we
|
|
|
1156 -- do not have an instance of a default initialized private, task or
|
|
|
1157 -- protected object declaration which would violate (RM 10.2.1(9)).
|
|
|
1158 -- Note that constants are never default initialized (and the test
|
|
|
1159 -- below also filters out deferred constants). A variable is default
|
|
|
1160 -- initialized if it does *not* have an initialization expression.
|
|
|
1161
|
|
|
1162 -- Filter out cases that are not declaration of a variable from source
|
|
|
1163
|
|
|
1164 if Nkind (N) /= N_Object_Declaration
|
|
|
1165 or else Constant_Present (N)
|
|
|
1166 or else not Comes_From_Source (Id)
|
|
|
1167 then
|
|
|
1168 return;
|
|
|
1169 end if;
|
|
|
1170
|
|
|
1171 -- Exclude generic specs from the checks (this will get rechecked
|
|
|
1172 -- on instantiations).
|
|
|
1173
|
|
|
1174 if Inside_A_Generic and then No (Enclosing_Generic_Body (Id)) then
|
|
|
1175 return;
|
|
|
1176 end if;
|
|
|
1177
|
|
|
1178 -- Required checks for declaration that is in a preelaborated package
|
|
|
1179 -- and is not within some subprogram.
|
|
|
1180
|
|
|
1181 if In_Preelaborated_Unit
|
|
|
1182 and then not In_Subprogram_Or_Concurrent_Unit
|
|
|
1183 then
|
|
|
1184 -- Check for default initialized variable case. Note that in
|
|
|
1185 -- accordance with (RM B.1(24)) imported objects are not subject to
|
|
|
1186 -- default initialization.
|
|
|
1187 -- If the initialization does not come from source and is an
|
|
|
1188 -- aggregate, it is a static initialization that replaces an
|
|
|
1189 -- implicit call, and must be treated as such.
|
|
|
1190
|
|
|
1191 if Present (E)
|
|
|
1192 and then (Comes_From_Source (E) or else Nkind (E) /= N_Aggregate)
|
|
|
1193 then
|
|
|
1194 null;
|
|
|
1195
|
|
|
1196 elsif Is_Imported (Id) then
|
|
|
1197 null;
|
|
|
1198
|
|
|
1199 else
|
|
|
1200 declare
|
|
|
1201 Ent : Entity_Id := T;
|
|
|
1202
|
|
|
1203 begin
|
|
|
1204 -- An array whose component type is a record with nonstatic
|
|
|
1205 -- default expressions is a violation, so we get the array's
|
|
|
1206 -- component type.
|
|
|
1207
|
|
|
1208 if Is_Array_Type (Ent) then
|
|
|
1209 declare
|
|
|
1210 Comp_Type : Entity_Id;
|
|
|
1211
|
|
|
1212 begin
|
|
|
1213 Comp_Type := Component_Type (Ent);
|
|
|
1214 while Is_Array_Type (Comp_Type) loop
|
|
|
1215 Comp_Type := Component_Type (Comp_Type);
|
|
|
1216 end loop;
|
|
|
1217
|
|
|
1218 Ent := Comp_Type;
|
|
|
1219 end;
|
|
|
1220 end if;
|
|
|
1221
|
|
|
1222 -- Object decl. that is of record type and has no default expr.
|
|
|
1223 -- should check if there is any non-static default expression
|
|
|
1224 -- in component decl. of the record type decl.
|
|
|
1225
|
|
|
1226 if Is_Record_Type (Ent) then
|
|
|
1227 if Nkind (Parent (Ent)) = N_Full_Type_Declaration then
|
|
|
1228 Check_Non_Static_Default_Expr
|
|
|
1229 (Type_Definition (Parent (Ent)), N);
|
|
|
1230
|
|
|
1231 elsif Nkind (Odf) = N_Subtype_Indication
|
|
|
1232 and then not Is_Array_Type (T)
|
|
|
1233 and then not Is_Private_Type (T)
|
|
|
1234 then
|
|
|
1235 Check_Non_Static_Default_Expr (Type_Definition
|
|
|
1236 (Parent (Entity (Subtype_Mark (Odf)))), N);
|
|
|
1237 end if;
|
|
|
1238 end if;
|
|
|
1239
|
|
|
1240 -- Check for invalid use of private object. Note that Ada 2005
|
|
|
1241 -- AI-161 modifies the rules for Ada 2005, including the use of
|
|
|
1242 -- the new pragma Preelaborable_Initialization.
|
|
|
1243
|
|
|
1244 if Is_Private_Type (Ent)
|
|
|
1245 or else Depends_On_Private (Ent)
|
|
|
1246 then
|
|
|
1247 -- Case where type has preelaborable initialization which
|
|
|
1248 -- means that a pragma Preelaborable_Initialization was
|
|
|
1249 -- given for the private type.
|
|
|
1250
|
|
|
1251 if Relaxed_RM_Semantics then
|
|
|
1252
|
|
|
1253 -- In relaxed mode, do not issue these messages, this
|
|
|
1254 -- is basically similar to the GNAT_Mode test below.
|
|
|
1255
|
|
|
1256 null;
|
|
|
1257
|
|
|
1258 elsif Has_Preelaborable_Initialization (Ent) then
|
|
|
1259
|
|
|
1260 -- But for the predefined units, we will ignore this
|
|
|
1261 -- status unless we are in Ada 2005 mode since we want
|
|
|
1262 -- Ada 95 compatible behavior, in which the entities
|
|
|
1263 -- marked with this pragma in the predefined library are
|
|
|
1264 -- not treated specially.
|
|
|
1265
|
|
|
1266 if Ada_Version < Ada_2005 then
|
|
|
1267 Error_Msg_N
|
|
|
1268 ("private object not allowed in preelaborated unit",
|
|
|
1269 N);
|
|
|
1270 Error_Msg_N ("\(would be legal in Ada 2005 mode)", N);
|
|
|
1271 end if;
|
|
|
1272
|
|
|
1273 -- Type does not have preelaborable initialization
|
|
|
1274
|
|
|
1275 else
|
|
|
1276 -- We allow this when compiling in GNAT mode to make life
|
|
|
1277 -- easier for some cases where it would otherwise be hard
|
|
|
1278 -- to be exactly valid Ada.
|
|
|
1279
|
|
|
1280 if not GNAT_Mode then
|
|
|
1281 Error_Msg_N
|
|
|
1282 ("private object not allowed in preelaborated unit",
|
|
|
1283 N);
|
|
|
1284
|
|
|
1285 -- Add a message if it would help to provide a pragma
|
|
|
1286 -- Preelaborable_Initialization on the type of the
|
|
|
1287 -- object (which would make it legal in Ada 2005).
|
|
|
1288
|
|
|
1289 -- If the type has no full view (generic type, or
|
|
|
1290 -- previous error), the warning does not apply.
|
|
|
1291
|
|
|
1292 if Is_Private_Type (Ent)
|
|
|
1293 and then Present (Full_View (Ent))
|
|
|
1294 and then
|
|
|
1295 Has_Preelaborable_Initialization (Full_View (Ent))
|
|
|
1296 then
|
|
|
1297 Error_Msg_Sloc := Sloc (Ent);
|
|
|
1298
|
|
|
1299 if Ada_Version >= Ada_2005 then
|
|
|
1300 Error_Msg_NE
|
|
|
1301 ("\would be legal if pragma Preelaborable_" &
|
|
|
1302 "Initialization given for & #", N, Ent);
|
|
|
1303 else
|
|
|
1304 Error_Msg_NE
|
|
|
1305 ("\would be legal in Ada 2005 if pragma " &
|
|
|
1306 "Preelaborable_Initialization given for & #",
|
|
|
1307 N, Ent);
|
|
|
1308 end if;
|
|
|
1309 end if;
|
|
|
1310 end if;
|
|
|
1311 end if;
|
|
|
1312
|
|
|
1313 -- Access to Task or Protected type
|
|
|
1314
|
|
|
1315 elsif Is_Entity_Name (Odf)
|
|
|
1316 and then Present (Etype (Odf))
|
|
|
1317 and then Is_Access_Type (Etype (Odf))
|
|
|
1318 then
|
|
|
1319 Ent := Designated_Type (Etype (Odf));
|
|
|
1320
|
|
|
1321 elsif Is_Entity_Name (Odf) then
|
|
|
1322 Ent := Entity (Odf);
|
|
|
1323
|
|
|
1324 elsif Nkind (Odf) = N_Subtype_Indication then
|
|
|
1325 Ent := Etype (Subtype_Mark (Odf));
|
|
|
1326
|
|
|
1327 elsif Nkind (Odf) = N_Constrained_Array_Definition then
|
|
|
1328 Ent := Component_Type (T);
|
|
|
1329 end if;
|
|
|
1330
|
|
|
1331 if Is_Task_Type (Ent)
|
|
|
1332 or else (Is_Protected_Type (Ent) and then Has_Entries (Ent))
|
|
|
1333 then
|
|
|
1334 Error_Msg_N
|
|
|
1335 ("concurrent object not allowed in preelaborated unit",
|
|
|
1336 N);
|
|
|
1337 return;
|
|
|
1338 end if;
|
|
|
1339 end;
|
|
|
1340 end if;
|
|
|
1341
|
|
|
1342 -- Non-static discriminants not allowed in preelaborated unit.
|
|
|
1343 -- Objects of a controlled type with a user-defined Initialize
|
|
|
1344 -- are forbidden as well.
|
|
|
1345
|
|
|
1346 if Is_Record_Type (Etype (Id)) then
|
|
|
1347 declare
|
|
|
1348 ET : constant Entity_Id := Etype (Id);
|
|
|
1349 EE : constant Entity_Id := Etype (Etype (Id));
|
|
|
1350 PEE : Node_Id;
|
|
|
1351
|
|
|
1352 begin
|
|
|
1353 if Has_Discriminants (ET) and then Present (EE) then
|
|
|
1354 PEE := Parent (EE);
|
|
|
1355
|
|
|
1356 if Nkind (PEE) = N_Full_Type_Declaration
|
|
|
1357 and then not Static_Discriminant_Expr
|
|
|
1358 (Discriminant_Specifications (PEE))
|
|
|
1359 then
|
|
|
1360 Error_Msg_N
|
|
|
1361 ("non-static discriminant in preelaborated unit",
|
|
|
1362 PEE);
|
|
|
1363 end if;
|
|
|
1364 end if;
|
|
|
1365
|
|
|
1366 -- For controlled type or type with controlled component, check
|
|
|
1367 -- preelaboration flag, as there may be a non-null Initialize
|
|
|
1368 -- primitive. For language versions earlier than Ada 2005,
|
|
|
1369 -- there is no notion of preelaborable initialization, and
|
|
|
1370 -- Validate_Controlled_Object is used to enforce rules for
|
|
|
1371 -- controlled objects.
|
|
|
1372
|
|
|
1373 if (Is_Controlled (ET) or else Has_Controlled_Component (ET))
|
|
|
1374 and then Ada_Version >= Ada_2005
|
|
|
1375 and then not Has_Preelaborable_Initialization (ET)
|
|
|
1376 then
|
|
|
1377 Error_Msg_NE
|
|
|
1378 ("controlled type& does not have"
|
|
|
1379 & " preelaborable initialization", N, ET);
|
|
|
1380 end if;
|
|
|
1381 end;
|
|
|
1382
|
|
|
1383 end if;
|
|
|
1384 end if;
|
|
|
1385
|
|
|
1386 -- A pure library_item must not contain the declaration of any variable
|
|
|
1387 -- except within a subprogram, generic subprogram, task unit, or
|
|
|
1388 -- protected unit (RM 10.2.1(16)).
|
|
|
1389
|
|
|
1390 if In_Pure_Unit and then not In_Subprogram_Task_Protected_Unit then
|
|
|
1391 Error_Msg_N ("declaration of variable not allowed in pure unit", N);
|
|
|
1392
|
|
|
1393 elsif not In_Private_Part (Id) then
|
|
|
1394
|
|
|
1395 -- The visible part of an RCI library unit must not contain the
|
|
|
1396 -- declaration of a variable (RM E.1.3(9)).
|
|
|
1397
|
|
|
1398 if In_RCI_Declaration then
|
|
|
1399 Error_Msg_N ("visible variable not allowed in 'R'C'I unit", N);
|
|
|
1400
|
|
|
1401 -- The visible part of a Shared Passive library unit must not contain
|
|
|
1402 -- the declaration of a variable (RM E.2.2(7)).
|
|
|
1403
|
|
|
1404 elsif In_RT_Declaration then
|
|
|
1405 Error_Msg_N
|
|
|
1406 ("visible variable not allowed in remote types unit", N);
|
|
|
1407 end if;
|
|
|
1408 end if;
|
|
|
1409 end Validate_Object_Declaration;
|
|
|
1410
|
|
|
1411 -----------------------------
|
|
|
1412 -- Validate_RACW_Primitive --
|
|
|
1413 -----------------------------
|
|
|
1414
|
|
|
1415 procedure Validate_RACW_Primitive
|
|
|
1416 (Subp : Entity_Id;
|
|
|
1417 RACW : Entity_Id)
|
|
|
1418 is
|
|
|
1419 procedure Illegal_Remote_Subp (Msg : String; N : Node_Id);
|
|
|
1420 -- Diagnose illegality on N. If RACW is present, report the error on it
|
|
|
1421 -- rather than on N.
|
|
|
1422
|
|
|
1423 -------------------------
|
|
|
1424 -- Illegal_Remote_Subp --
|
|
|
1425 -------------------------
|
|
|
1426
|
|
|
1427 procedure Illegal_Remote_Subp (Msg : String; N : Node_Id) is
|
|
|
1428 begin
|
|
|
1429 if Present (RACW) then
|
|
|
1430 if not Error_Posted (RACW) then
|
|
|
1431 Error_Msg_N
|
|
|
1432 ("illegal remote access to class-wide type&", RACW);
|
|
|
1433 end if;
|
|
|
1434
|
|
|
1435 Error_Msg_Sloc := Sloc (N);
|
|
|
1436 Error_Msg_NE ("\\" & Msg & " in primitive& #", RACW, Subp);
|
|
|
1437
|
|
|
1438 else
|
|
|
1439 Error_Msg_NE (Msg & " in remote subprogram&", N, Subp);
|
|
|
1440 end if;
|
|
|
1441 end Illegal_Remote_Subp;
|
|
|
1442
|
|
|
1443 Rtyp : Entity_Id;
|
|
|
1444 Param : Node_Id;
|
|
|
1445 Param_Spec : Node_Id;
|
|
|
1446 Param_Type : Entity_Id;
|
|
|
1447
|
|
|
1448 -- Start of processing for Validate_RACW_Primitive
|
|
|
1449
|
|
|
1450 begin
|
|
|
1451 -- Check return type
|
|
|
1452
|
|
|
1453 if Ekind (Subp) = E_Function then
|
|
|
1454 Rtyp := Etype (Subp);
|
|
|
1455
|
|
|
1456 -- AI05-0101 (Binding Interpretation): The result type of a remote
|
|
|
1457 -- function must either support external streaming or be a
|
|
|
1458 -- controlling access result type.
|
|
|
1459
|
|
|
1460 if Has_Controlling_Result (Subp) then
|
|
|
1461 null;
|
|
|
1462
|
|
|
1463 elsif Ekind (Rtyp) = E_Anonymous_Access_Type then
|
|
|
1464 Illegal_Remote_Subp ("anonymous access result", Rtyp);
|
|
|
1465
|
|
|
1466 elsif Is_Limited_Type (Rtyp) then
|
|
|
1467 if No (TSS (Rtyp, TSS_Stream_Read))
|
|
|
1468 or else
|
|
|
1469 No (TSS (Rtyp, TSS_Stream_Write))
|
|
|
1470 then
|
|
|
1471 Illegal_Remote_Subp
|
|
|
1472 ("limited return type must have Read and Write attributes",
|
|
|
1473 Parent (Subp));
|
|
|
1474 Explain_Limited_Type (Rtyp, Parent (Subp));
|
|
|
1475 end if;
|
|
|
1476
|
|
|
1477 -- Check that the return type supports external streaming
|
|
|
1478
|
|
|
1479 elsif No_External_Streaming (Rtyp)
|
|
|
1480 and then not Error_Posted (Rtyp)
|
|
|
1481 then
|
|
|
1482 Illegal_Remote_Subp ("return type containing non-remote access "
|
|
|
1483 & "must have Read and Write attributes",
|
|
|
1484 Parent (Subp));
|
|
|
1485 end if;
|
|
|
1486 end if;
|
|
|
1487
|
|
|
1488 Param := First_Formal (Subp);
|
|
|
1489 while Present (Param) loop
|
|
|
1490
|
|
|
1491 -- Now find out if this parameter is a controlling parameter
|
|
|
1492
|
|
|
1493 Param_Spec := Parent (Param);
|
|
|
1494 Param_Type := Etype (Param);
|
|
|
1495
|
|
|
1496 if Is_Controlling_Formal (Param) then
|
|
|
1497
|
|
|
1498 -- It is a controlling parameter, so specific checks below do not
|
|
|
1499 -- apply.
|
|
|
1500
|
|
|
1501 null;
|
|
|
1502
|
|
|
1503 elsif Ekind_In (Param_Type, E_Anonymous_Access_Type,
|
|
|
1504 E_Anonymous_Access_Subprogram_Type)
|
|
|
1505 then
|
|
|
1506 -- From RM E.2.2(14), no anonymous access parameter other than
|
|
|
1507 -- controlling ones may be used (because an anonymous access
|
|
|
1508 -- type never supports external streaming).
|
|
|
1509
|
|
|
1510 Illegal_Remote_Subp
|
|
|
1511 ("non-controlling access parameter", Param_Spec);
|
|
|
1512
|
|
|
1513 elsif No_External_Streaming (Param_Type)
|
|
|
1514 and then not Error_Posted (Param_Type)
|
|
|
1515 then
|
|
|
1516 Illegal_Remote_Subp ("formal parameter in remote subprogram must "
|
|
|
1517 & "support external streaming", Param_Spec);
|
|
|
1518 end if;
|
|
|
1519
|
|
|
1520 -- Check next parameter in this subprogram
|
|
|
1521
|
|
|
1522 Next_Formal (Param);
|
|
|
1523 end loop;
|
|
|
1524 end Validate_RACW_Primitive;
|
|
|
1525
|
|
|
1526 ------------------------------
|
|
|
1527 -- Validate_RACW_Primitives --
|
|
|
1528 ------------------------------
|
|
|
1529
|
|
|
1530 procedure Validate_RACW_Primitives (T : Entity_Id) is
|
|
|
1531 Desig_Type : Entity_Id;
|
|
|
1532 Primitive_Subprograms : Elist_Id;
|
|
|
1533 Subprogram_Elmt : Elmt_Id;
|
|
|
1534 Subprogram : Entity_Id;
|
|
|
1535
|
|
|
1536 begin
|
|
|
1537 Desig_Type := Etype (Designated_Type (T));
|
|
|
1538
|
|
|
1539 -- No action needed for concurrent types
|
|
|
1540
|
|
|
1541 if Is_Concurrent_Type (Desig_Type) then
|
|
|
1542 return;
|
|
|
1543 end if;
|
|
|
1544
|
|
|
1545 Primitive_Subprograms := Primitive_Operations (Desig_Type);
|
|
|
1546
|
|
|
1547 Subprogram_Elmt := First_Elmt (Primitive_Subprograms);
|
|
|
1548 while Subprogram_Elmt /= No_Elmt loop
|
|
|
1549 Subprogram := Node (Subprogram_Elmt);
|
|
|
1550
|
|
|
1551 if Is_Predefined_Dispatching_Operation (Subprogram)
|
|
|
1552 or else Is_Hidden (Subprogram)
|
|
|
1553 then
|
|
|
1554 goto Next_Subprogram;
|
|
|
1555 end if;
|
|
|
1556
|
|
|
1557 Validate_RACW_Primitive (Subp => Subprogram, RACW => T);
|
|
|
1558
|
|
|
1559 <<Next_Subprogram>>
|
|
|
1560 Next_Elmt (Subprogram_Elmt);
|
|
|
1561 end loop;
|
|
|
1562 end Validate_RACW_Primitives;
|
|
|
1563
|
|
|
1564 -------------------------------
|
|
|
1565 -- Validate_RCI_Declarations --
|
|
|
1566 -------------------------------
|
|
|
1567
|
|
|
1568 procedure Validate_RCI_Declarations (P : Entity_Id) is
|
|
|
1569 E : Entity_Id;
|
|
|
1570
|
|
|
1571 begin
|
|
|
1572 E := First_Entity (P);
|
|
|
1573 while Present (E) loop
|
|
|
1574 if Comes_From_Source (E) then
|
|
|
1575 if Is_Limited_Type (E) then
|
|
|
1576 Error_Msg_N
|
|
|
1577 ("limited type not allowed in rci unit", Parent (E));
|
|
|
1578 Explain_Limited_Type (E, Parent (E));
|
|
|
1579
|
|
|
1580 elsif Ekind_In (E, E_Generic_Function,
|
|
|
1581 E_Generic_Package,
|
|
|
1582 E_Generic_Procedure)
|
|
|
1583 then
|
|
|
1584 Error_Msg_N ("generic declaration not allowed in rci unit",
|
|
|
1585 Parent (E));
|
|
|
1586
|
|
|
1587 elsif (Ekind (E) = E_Function or else Ekind (E) = E_Procedure)
|
|
|
1588 and then Has_Pragma_Inline (E)
|
|
|
1589 then
|
|
|
1590 Error_Msg_N
|
|
|
1591 ("inlined subprogram not allowed in rci unit", Parent (E));
|
|
|
1592
|
|
|
1593 -- Inner packages that are renamings need not be checked. Generic
|
|
|
1594 -- RCI packages are subject to the checks, but entities that come
|
|
|
1595 -- from formal packages are not part of the visible declarations
|
|
|
1596 -- of the package and are not checked.
|
|
|
1597
|
|
|
1598 elsif Ekind (E) = E_Package then
|
|
|
1599 if Present (Renamed_Entity (E)) then
|
|
|
1600 null;
|
|
|
1601
|
|
|
1602 elsif Ekind (P) /= E_Generic_Package
|
|
|
1603 or else List_Containing (Unit_Declaration_Node (E)) /=
|
|
|
1604 Generic_Formal_Declarations
|
|
|
1605 (Unit_Declaration_Node (P))
|
|
|
1606 then
|
|
|
1607 Validate_RCI_Declarations (E);
|
|
|
1608 end if;
|
|
|
1609 end if;
|
|
|
1610 end if;
|
|
|
1611
|
|
|
1612 Next_Entity (E);
|
|
|
1613 end loop;
|
|
|
1614 end Validate_RCI_Declarations;
|
|
|
1615
|
|
|
1616 -----------------------------------------
|
|
|
1617 -- Validate_RCI_Subprogram_Declaration --
|
|
|
1618 -----------------------------------------
|
|
|
1619
|
|
|
1620 procedure Validate_RCI_Subprogram_Declaration (N : Node_Id) is
|
|
|
1621 K : constant Node_Kind := Nkind (N);
|
|
|
1622 Profile : List_Id;
|
|
|
1623 Id : constant Entity_Id := Defining_Entity (N);
|
|
|
1624 Param_Spec : Node_Id;
|
|
|
1625 Param_Type : Entity_Id;
|
|
|
1626 Error_Node : Node_Id := N;
|
|
|
1627
|
|
|
1628 begin
|
|
|
1629 -- This procedure enforces rules on subprogram and access to subprogram
|
|
|
1630 -- declarations in RCI units. These rules do not apply to expander
|
|
|
1631 -- generated routines, which are not remote subprograms. It is called:
|
|
|
1632
|
|
|
1633 -- 1. from Analyze_Subprogram_Declaration.
|
|
|
1634 -- 2. from Validate_Object_Declaration (access to subprogram).
|
|
|
1635
|
|
|
1636 if not (Comes_From_Source (N)
|
|
|
1637 and then In_RCI_Declaration
|
|
|
1638 and then not In_Private_Part (Scope (Id)))
|
|
|
1639 then
|
|
|
1640 return;
|
|
|
1641 end if;
|
|
|
1642
|
|
|
1643 if K = N_Subprogram_Declaration then
|
|
|
1644 Profile := Parameter_Specifications (Specification (N));
|
|
|
1645
|
|
|
1646 else
|
|
|
1647 pragma Assert (K = N_Object_Declaration);
|
|
|
1648
|
|
|
1649 -- The above assertion is dubious, the visible declarations of an
|
|
|
1650 -- RCI unit never contain an object declaration, this should be an
|
|
|
1651 -- ACCESS-to-object declaration???
|
|
|
1652
|
|
|
1653 if Nkind (Id) = N_Defining_Identifier
|
|
|
1654 and then Nkind (Parent (Etype (Id))) = N_Full_Type_Declaration
|
|
|
1655 and then Ekind (Etype (Id)) = E_Access_Subprogram_Type
|
|
|
1656 then
|
|
|
1657 Profile :=
|
|
|
1658 Parameter_Specifications (Type_Definition (Parent (Etype (Id))));
|
|
|
1659 else
|
|
|
1660 return;
|
|
|
1661 end if;
|
|
|
1662 end if;
|
|
|
1663
|
|
|
1664 -- Iterate through the parameter specification list, checking that
|
|
|
1665 -- no access parameter and no limited type parameter in the list.
|
|
|
1666 -- RM E.2.3(14).
|
|
|
1667
|
|
|
1668 if Present (Profile) then
|
|
|
1669 Param_Spec := First (Profile);
|
|
|
1670 while Present (Param_Spec) loop
|
|
|
1671 Param_Type := Etype (Defining_Identifier (Param_Spec));
|
|
|
1672
|
|
|
1673 if Ekind (Param_Type) = E_Anonymous_Access_Type then
|
|
|
1674 if K = N_Subprogram_Declaration then
|
|
|
1675 Error_Node := Param_Spec;
|
|
|
1676 end if;
|
|
|
1677
|
|
|
1678 -- Report error only if declaration is in source program
|
|
|
1679
|
|
|
1680 if Comes_From_Source (Id) then
|
|
|
1681 Error_Msg_N
|
|
|
1682 ("subprogram in 'R'C'I unit cannot have access parameter",
|
|
|
1683 Error_Node);
|
|
|
1684 end if;
|
|
|
1685
|
|
|
1686 -- For a limited private type parameter, we check only the private
|
|
|
1687 -- declaration and ignore full type declaration, unless this is
|
|
|
1688 -- the only declaration for the type, e.g., as a limited record.
|
|
|
1689
|
|
|
1690 elsif No_External_Streaming (Param_Type) then
|
|
|
1691 if K = N_Subprogram_Declaration then
|
|
|
1692 Error_Node := Param_Spec;
|
|
|
1693 end if;
|
|
|
1694
|
|
|
1695 Error_Msg_NE
|
|
|
1696 ("formal of remote subprogram& "
|
|
|
1697 & "must support external streaming",
|
|
|
1698 Error_Node, Id);
|
|
|
1699 if Is_Limited_Type (Param_Type) then
|
|
|
1700 Explain_Limited_Type (Param_Type, Error_Node);
|
|
|
1701 end if;
|
|
|
1702 end if;
|
|
|
1703
|
|
|
1704 Next (Param_Spec);
|
|
|
1705 end loop;
|
|
|
1706 end if;
|
|
|
1707
|
|
|
1708 if Ekind (Id) = E_Function
|
|
|
1709 and then Ekind (Etype (Id)) = E_Anonymous_Access_Type
|
|
|
1710 and then Comes_From_Source (Id)
|
|
|
1711 then
|
|
|
1712 Error_Msg_N
|
|
|
1713 ("function in 'R'C'I unit cannot have access result",
|
|
|
1714 Error_Node);
|
|
|
1715 end if;
|
|
|
1716 end Validate_RCI_Subprogram_Declaration;
|
|
|
1717
|
|
|
1718 ----------------------------------------------------
|
|
|
1719 -- Validate_Remote_Access_Object_Type_Declaration --
|
|
|
1720 ----------------------------------------------------
|
|
|
1721
|
|
|
1722 procedure Validate_Remote_Access_Object_Type_Declaration (T : Entity_Id) is
|
|
|
1723 Direct_Designated_Type : Entity_Id;
|
|
|
1724 Desig_Type : Entity_Id;
|
|
|
1725
|
|
|
1726 begin
|
|
|
1727 -- We are called from Analyze_Full_Type_Declaration, and the Nkind of
|
|
|
1728 -- the given node is N_Access_To_Object_Definition.
|
|
|
1729
|
|
|
1730 if not Comes_From_Source (T)
|
|
|
1731 or else (not In_RCI_Declaration and then not In_RT_Declaration)
|
|
|
1732 then
|
|
|
1733 return;
|
|
|
1734 end if;
|
|
|
1735
|
|
|
1736 -- An access definition in the private part of a package is not a
|
|
|
1737 -- remote access type. Restrictions related to external streaming
|
|
|
1738 -- support for non-remote access types are enforced elsewhere. Note
|
|
|
1739 -- that In_Private_Part is never set on type entities: check flag
|
|
|
1740 -- on enclosing scope.
|
|
|
1741
|
|
|
1742 if In_Private_Part (Scope (T)) then
|
|
|
1743 return;
|
|
|
1744 end if;
|
|
|
1745
|
|
|
1746 -- Check RCI or RT unit type declaration. It may not contain the
|
|
|
1747 -- declaration of an access-to-object type unless it is a general access
|
|
|
1748 -- type that designates a class-wide limited private type or subtype.
|
|
|
1749 -- There are also constraints on the primitive subprograms of the
|
|
|
1750 -- class-wide type (RM E.2.2(14), see Validate_RACW_Primitives).
|
|
|
1751
|
|
|
1752 if Ekind (T) /= E_General_Access_Type
|
|
|
1753 or else not Is_Class_Wide_Type (Designated_Type (T))
|
|
|
1754 then
|
|
|
1755 if In_RCI_Declaration then
|
|
|
1756 Error_Msg_N
|
|
|
1757 ("error in access type in Remote_Call_Interface unit", T);
|
|
|
1758 else
|
|
|
1759 Error_Msg_N
|
|
|
1760 ("error in access type in Remote_Types unit", T);
|
|
|
1761 end if;
|
|
|
1762
|
|
|
1763 Error_Msg_N ("\must be general access to class-wide type", T);
|
|
|
1764 return;
|
|
|
1765 end if;
|
|
|
1766
|
|
|
1767 Direct_Designated_Type := Designated_Type (T);
|
|
|
1768 Desig_Type := Etype (Direct_Designated_Type);
|
|
|
1769
|
|
|
1770 -- Why is this check not in Validate_Remote_Access_To_Class_Wide_Type???
|
|
|
1771
|
|
|
1772 if not Is_Valid_Remote_Object_Type (Desig_Type) then
|
|
|
1773 Error_Msg_N
|
|
|
1774 ("error in designated type of remote access to class-wide type", T);
|
|
|
1775 Error_Msg_N
|
|
|
1776 ("\must be tagged limited private or private extension", T);
|
|
|
1777 return;
|
|
|
1778 end if;
|
|
|
1779 end Validate_Remote_Access_Object_Type_Declaration;
|
|
|
1780
|
|
|
1781 -----------------------------------------------
|
|
|
1782 -- Validate_Remote_Access_To_Class_Wide_Type --
|
|
|
1783 -----------------------------------------------
|
|
|
1784
|
|
|
1785 procedure Validate_Remote_Access_To_Class_Wide_Type (N : Node_Id) is
|
|
|
1786 K : constant Node_Kind := Nkind (N);
|
|
|
1787 PK : constant Node_Kind := Nkind (Parent (N));
|
|
|
1788 E : Entity_Id;
|
|
|
1789
|
|
|
1790 begin
|
|
|
1791 -- This subprogram enforces the checks in (RM E.2.2(8)) for certain uses
|
|
|
1792 -- of class-wide limited private types.
|
|
|
1793
|
|
|
1794 -- Storage_Pool and Storage_Size are not defined for such types
|
|
|
1795 --
|
|
|
1796 -- The expected type of allocator must not be such a type.
|
|
|
1797
|
|
|
1798 -- The actual parameter of generic instantiation must not be such a
|
|
|
1799 -- type if the formal parameter is of an access type.
|
|
|
1800
|
|
|
1801 -- On entry, there are several cases:
|
|
|
1802
|
|
|
1803 -- 1. called from sem_attr Analyze_Attribute where attribute name is
|
|
|
1804 -- either Storage_Pool or Storage_Size.
|
|
|
1805
|
|
|
1806 -- 2. called from exp_ch4 Expand_N_Allocator
|
|
|
1807
|
|
|
1808 -- 3. called from sem_ch4 Analyze_Explicit_Dereference
|
|
|
1809
|
|
|
1810 -- 4. called from sem_res Resolve_Actuals
|
|
|
1811
|
|
|
1812 if K = N_Attribute_Reference then
|
|
|
1813 E := Etype (Prefix (N));
|
|
|
1814
|
|
|
1815 if Is_Remote_Access_To_Class_Wide_Type (E) then
|
|
|
1816 Error_Msg_N ("incorrect attribute of remote operand", N);
|
|
|
1817 return;
|
|
|
1818 end if;
|
|
|
1819
|
|
|
1820 elsif K = N_Allocator then
|
|
|
1821 E := Etype (N);
|
|
|
1822
|
|
|
1823 if Is_Remote_Access_To_Class_Wide_Type (E) then
|
|
|
1824 Error_Msg_N ("incorrect expected remote type of allocator", N);
|
|
|
1825 return;
|
|
|
1826 end if;
|
|
|
1827
|
|
|
1828 -- This subprogram also enforces the checks in E.2.2(13). A value of
|
|
|
1829 -- such type must not be dereferenced unless as controlling operand of
|
|
|
1830 -- a dispatching call. Explicit dereferences not coming from source are
|
|
|
1831 -- exempted from this checking because the expander produces them in
|
|
|
1832 -- some cases (such as for tag checks on dispatching calls with multiple
|
|
|
1833 -- controlling operands). However we do check in the case of an implicit
|
|
|
1834 -- dereference that is expanded to an explicit dereference (hence the
|
|
|
1835 -- test of whether Original_Node (N) comes from source).
|
|
|
1836
|
|
|
1837 elsif K = N_Explicit_Dereference
|
|
|
1838 and then Comes_From_Source (Original_Node (N))
|
|
|
1839 then
|
|
|
1840 E := Etype (Prefix (N));
|
|
|
1841
|
|
|
1842 -- If the class-wide type is not a remote one, the restrictions
|
|
|
1843 -- do not apply.
|
|
|
1844
|
|
|
1845 if not Is_Remote_Access_To_Class_Wide_Type (E) then
|
|
|
1846 return;
|
|
|
1847 end if;
|
|
|
1848
|
|
|
1849 -- If we have a true dereference that comes from source and that
|
|
|
1850 -- is a controlling argument for a dispatching call, accept it.
|
|
|
1851
|
|
|
1852 if Is_Actual_Parameter (N) and then Is_Controlling_Actual (N) then
|
|
|
1853 return;
|
|
|
1854 end if;
|
|
|
1855
|
|
|
1856 -- If we are just within a procedure or function call and the
|
|
|
1857 -- dereference has not been analyzed, return because this procedure
|
|
|
1858 -- will be called again from sem_res Resolve_Actuals. The same can
|
|
|
1859 -- apply in the case of dereference that is the prefix of a selected
|
|
|
1860 -- component, which can be a call given in prefixed form.
|
|
|
1861
|
|
|
1862 if (Is_Actual_Parameter (N) or else PK = N_Selected_Component)
|
|
|
1863 and then not Analyzed (N)
|
|
|
1864 then
|
|
|
1865 return;
|
|
|
1866 end if;
|
|
|
1867
|
|
|
1868 -- We must allow expanded code to generate a reference to the tag of
|
|
|
1869 -- the designated object (may be either the actual tag, or the stub
|
|
|
1870 -- tag in the case of a remote object).
|
|
|
1871
|
|
|
1872 if PK = N_Selected_Component
|
|
|
1873 and then Is_Tag (Entity (Selector_Name (Parent (N))))
|
|
|
1874 then
|
|
|
1875 return;
|
|
|
1876 end if;
|
|
|
1877
|
|
|
1878 Error_Msg_N
|
|
|
1879 ("invalid dereference of a remote access-to-class-wide value", N);
|
|
|
1880 end if;
|
|
|
1881 end Validate_Remote_Access_To_Class_Wide_Type;
|
|
|
1882
|
|
|
1883 ------------------------------------------
|
|
|
1884 -- Validate_Remote_Type_Type_Conversion --
|
|
|
1885 ------------------------------------------
|
|
|
1886
|
|
|
1887 procedure Validate_Remote_Type_Type_Conversion (N : Node_Id) is
|
|
|
1888 S : constant Entity_Id := Etype (N);
|
|
|
1889 E : constant Entity_Id := Etype (Expression (N));
|
|
|
1890
|
|
|
1891 begin
|
|
|
1892 -- This test is required in the case where a conversion appears inside a
|
|
|
1893 -- normal package, it does not necessarily have to be inside an RCI,
|
|
|
1894 -- Remote_Types unit (RM E.2.2(9,12)).
|
|
|
1895
|
|
|
1896 if Is_Remote_Access_To_Subprogram_Type (E)
|
|
|
1897 and then not Is_Remote_Access_To_Subprogram_Type (S)
|
|
|
1898 then
|
|
|
1899 Error_Msg_N
|
|
|
1900 ("incorrect conversion of remote operand to local type", N);
|
|
|
1901 return;
|
|
|
1902
|
|
|
1903 elsif not Is_Remote_Access_To_Subprogram_Type (E)
|
|
|
1904 and then Is_Remote_Access_To_Subprogram_Type (S)
|
|
|
1905 then
|
|
|
1906 Error_Msg_N
|
|
|
1907 ("incorrect conversion of local operand to remote type", N);
|
|
|
1908 return;
|
|
|
1909
|
|
|
1910 elsif Is_Remote_Access_To_Class_Wide_Type (E)
|
|
|
1911 and then not Is_Remote_Access_To_Class_Wide_Type (S)
|
|
|
1912 then
|
|
|
1913 Error_Msg_N
|
|
|
1914 ("incorrect conversion of remote operand to local type", N);
|
|
|
1915 return;
|
|
|
1916 end if;
|
|
|
1917
|
|
|
1918 -- If a local access type is converted into a RACW type, then the
|
|
|
1919 -- current unit has a pointer that may now be exported to another
|
|
|
1920 -- partition.
|
|
|
1921
|
|
|
1922 if Is_Remote_Access_To_Class_Wide_Type (S)
|
|
|
1923 and then not Is_Remote_Access_To_Class_Wide_Type (E)
|
|
|
1924 then
|
|
|
1925 Set_Has_RACW (Current_Sem_Unit);
|
|
|
1926 end if;
|
|
|
1927 end Validate_Remote_Type_Type_Conversion;
|
|
|
1928
|
|
|
1929 -------------------------------
|
|
|
1930 -- Validate_RT_RAT_Component --
|
|
|
1931 -------------------------------
|
|
|
1932
|
|
|
1933 procedure Validate_RT_RAT_Component (N : Node_Id) is
|
|
|
1934 Spec : constant Node_Id := Specification (N);
|
|
|
1935 Name_U : constant Entity_Id := Defining_Entity (Spec);
|
|
|
1936 Typ : Entity_Id;
|
|
|
1937 U_Typ : Entity_Id;
|
|
|
1938 First_Priv_Ent : constant Entity_Id := First_Private_Entity (Name_U);
|
|
|
1939
|
|
|
1940 function Stream_Attributes_Available (Typ : Entity_Id) return Boolean;
|
|
|
1941 -- True if any stream attribute is available for Typ
|
|
|
1942
|
|
|
1943 ---------------------------------
|
|
|
1944 -- Stream_Attributes_Available --
|
|
|
1945 ---------------------------------
|
|
|
1946
|
|
|
1947 function Stream_Attributes_Available (Typ : Entity_Id) return Boolean
|
|
|
1948 is
|
|
|
1949 begin
|
|
|
1950 return Stream_Attribute_Available (Typ, TSS_Stream_Read)
|
|
|
1951 or else
|
|
|
1952 Stream_Attribute_Available (Typ, TSS_Stream_Write)
|
|
|
1953 or else
|
|
|
1954 Stream_Attribute_Available (Typ, TSS_Stream_Input)
|
|
|
1955 or else
|
|
|
1956 Stream_Attribute_Available (Typ, TSS_Stream_Output);
|
|
|
1957 end Stream_Attributes_Available;
|
|
|
1958
|
|
|
1959 -- Start of processing for Validate_RT_RAT_Component
|
|
|
1960
|
|
|
1961 begin
|
|
|
1962 if not Is_Remote_Types (Name_U) then
|
|
|
1963 return;
|
|
|
1964 end if;
|
|
|
1965
|
|
|
1966 Typ := First_Entity (Name_U);
|
|
|
1967 while Present (Typ) and then Typ /= First_Priv_Ent loop
|
|
|
1968 U_Typ := Underlying_Type (Base_Type (Typ));
|
|
|
1969
|
|
|
1970 if No (U_Typ) then
|
|
|
1971 U_Typ := Typ;
|
|
|
1972 end if;
|
|
|
1973
|
|
|
1974 if Comes_From_Source (Typ) and then Is_Type (Typ)
|
|
|
1975 and then Ekind (Typ) /= E_Incomplete_Type
|
|
|
1976 then
|
|
|
1977 -- Check that the type can be meaningfully transmitted to another
|
|
|
1978 -- partition (E.2.2(8)).
|
|
|
1979
|
|
|
1980 if (Ada_Version < Ada_2005 and then Has_Non_Remote_Access (U_Typ))
|
|
|
1981 or else (Stream_Attributes_Available (Typ)
|
|
|
1982 and then No_External_Streaming (U_Typ))
|
|
|
1983 then
|
|
|
1984 if Is_Non_Remote_Access_Type (Typ) then
|
|
|
1985 Error_Msg_N ("error in non-remote access type", U_Typ);
|
|
|
1986 else
|
|
|
1987 Error_Msg_N
|
|
|
1988 ("error in record type containing a component of a " &
|
|
|
1989 "non-remote access type", U_Typ);
|
|
|
1990 end if;
|
|
|
1991
|
|
|
1992 if Ada_Version >= Ada_2005 then
|
|
|
1993 Error_Msg_N
|
|
|
1994 ("\must have visible Read and Write attribute " &
|
|
|
1995 "definition clauses (RM E.2.2(8))", U_Typ);
|
|
|
1996 else
|
|
|
1997 Error_Msg_N
|
|
|
1998 ("\must have Read and Write attribute " &
|
|
|
1999 "definition clauses (RM E.2.2(8))", U_Typ);
|
|
|
2000 end if;
|
|
|
2001 end if;
|
|
|
2002 end if;
|
|
|
2003
|
|
|
2004 Next_Entity (Typ);
|
|
|
2005 end loop;
|
|
|
2006 end Validate_RT_RAT_Component;
|
|
|
2007
|
|
|
2008 -----------------------------------------
|
|
|
2009 -- Validate_SP_Access_Object_Type_Decl --
|
|
|
2010 -----------------------------------------
|
|
|
2011
|
|
|
2012 procedure Validate_SP_Access_Object_Type_Decl (T : Entity_Id) is
|
|
|
2013 Direct_Designated_Type : Entity_Id;
|
|
|
2014
|
|
|
2015 function Has_Entry_Declarations (E : Entity_Id) return Boolean;
|
|
|
2016 -- Return true if the protected type designated by T has entry
|
|
|
2017 -- declarations.
|
|
|
2018
|
|
|
2019 ----------------------------
|
|
|
2020 -- Has_Entry_Declarations --
|
|
|
2021 ----------------------------
|
|
|
2022
|
|
|
2023 function Has_Entry_Declarations (E : Entity_Id) return Boolean is
|
|
|
2024 Ety : Entity_Id;
|
|
|
2025
|
|
|
2026 begin
|
|
|
2027 if Nkind (Parent (E)) = N_Protected_Type_Declaration then
|
|
|
2028 Ety := First_Entity (E);
|
|
|
2029 while Present (Ety) loop
|
|
|
2030 if Ekind (Ety) = E_Entry then
|
|
|
2031 return True;
|
|
|
2032 end if;
|
|
|
2033
|
|
|
2034 Next_Entity (Ety);
|
|
|
2035 end loop;
|
|
|
2036 end if;
|
|
|
2037
|
|
|
2038 return False;
|
|
|
2039 end Has_Entry_Declarations;
|
|
|
2040
|
|
|
2041 -- Start of processing for Validate_SP_Access_Object_Type_Decl
|
|
|
2042
|
|
|
2043 begin
|
|
|
2044 -- We are called from Sem_Ch3.Analyze_Full_Type_Declaration, and the
|
|
|
2045 -- Nkind of the given entity is N_Access_To_Object_Definition.
|
|
|
2046
|
|
|
2047 if not Comes_From_Source (T)
|
|
|
2048 or else not In_Shared_Passive_Unit
|
|
|
2049 or else In_Subprogram_Task_Protected_Unit
|
|
|
2050 then
|
|
|
2051 return;
|
|
|
2052 end if;
|
|
|
2053
|
|
|
2054 -- Check Shared Passive unit. It should not contain the declaration
|
|
|
2055 -- of an access-to-object type whose designated type is a class-wide
|
|
|
2056 -- type, task type or protected type with entry (RM E.2.1(7)).
|
|
|
2057
|
|
|
2058 Direct_Designated_Type := Designated_Type (T);
|
|
|
2059
|
|
|
2060 if Ekind (Direct_Designated_Type) = E_Class_Wide_Type then
|
|
|
2061 Error_Msg_N
|
|
|
2062 ("invalid access-to-class-wide type in shared passive unit", T);
|
|
|
2063 return;
|
|
|
2064
|
|
|
2065 elsif Ekind (Direct_Designated_Type) in Task_Kind then
|
|
|
2066 Error_Msg_N
|
|
|
2067 ("invalid access-to-task type in shared passive unit", T);
|
|
|
2068 return;
|
|
|
2069
|
|
|
2070 elsif Ekind (Direct_Designated_Type) in Protected_Kind
|
|
|
2071 and then Has_Entry_Declarations (Direct_Designated_Type)
|
|
|
2072 then
|
|
|
2073 Error_Msg_N
|
|
|
2074 ("invalid access-to-protected type in shared passive unit", T);
|
|
|
2075 return;
|
|
|
2076 end if;
|
|
|
2077 end Validate_SP_Access_Object_Type_Decl;
|
|
|
2078
|
|
|
2079 ---------------------------------
|
|
|
2080 -- Validate_Static_Object_Name --
|
|
|
2081 ---------------------------------
|
|
|
2082
|
|
|
2083 procedure Validate_Static_Object_Name (N : Node_Id) is
|
|
|
2084 E : Entity_Id;
|
|
|
2085 Val : Node_Id;
|
|
|
2086
|
|
|
2087 function Is_Primary (N : Node_Id) return Boolean;
|
|
|
2088 -- Determine whether node is syntactically a primary in an expression
|
|
|
2089 -- This function should probably be somewhere else ???
|
|
|
2090 --
|
|
|
2091 -- Also it does not do what it says, e.g if N is a binary operator
|
|
|
2092 -- whose parent is a binary operator, Is_Primary returns True ???
|
|
|
2093
|
|
|
2094 ----------------
|
|
|
2095 -- Is_Primary --
|
|
|
2096 ----------------
|
|
|
2097
|
|
|
2098 function Is_Primary (N : Node_Id) return Boolean is
|
|
|
2099 K : constant Node_Kind := Nkind (Parent (N));
|
|
|
2100
|
|
|
2101 begin
|
|
|
2102 case K is
|
|
|
2103 when N_Aggregate
|
|
|
2104 | N_Component_Association
|
|
|
2105 | N_Index_Or_Discriminant_Constraint
|
|
|
2106 | N_Membership_Test
|
|
|
2107 | N_Op
|
|
|
2108 =>
|
|
|
2109 return True;
|
|
|
2110
|
|
|
2111 when N_Attribute_Reference =>
|
|
|
2112 declare
|
|
|
2113 Attr : constant Name_Id := Attribute_Name (Parent (N));
|
|
|
2114
|
|
|
2115 begin
|
|
|
2116 return Attr /= Name_Address
|
|
|
2117 and then Attr /= Name_Access
|
|
|
2118 and then Attr /= Name_Unchecked_Access
|
|
|
2119 and then Attr /= Name_Unrestricted_Access;
|
|
|
2120 end;
|
|
|
2121
|
|
|
2122 when N_Indexed_Component =>
|
|
|
2123 return N /= Prefix (Parent (N)) or else Is_Primary (Parent (N));
|
|
|
2124
|
|
|
2125 when N_Qualified_Expression
|
|
|
2126 | N_Type_Conversion
|
|
|
2127 =>
|
|
|
2128 return Is_Primary (Parent (N));
|
|
|
2129
|
|
|
2130 when N_Assignment_Statement
|
|
|
2131 | N_Object_Declaration
|
|
|
2132 =>
|
|
|
2133 return N = Expression (Parent (N));
|
|
|
2134
|
|
|
2135 when N_Selected_Component =>
|
|
|
2136 return Is_Primary (Parent (N));
|
|
|
2137
|
|
|
2138 when others =>
|
|
|
2139 return False;
|
|
|
2140 end case;
|
|
|
2141 end Is_Primary;
|
|
|
2142
|
|
|
2143 -- Start of processing for Validate_Static_Object_Name
|
|
|
2144
|
|
|
2145 begin
|
|
|
2146 if not In_Preelaborated_Unit
|
|
|
2147 or else not Comes_From_Source (N)
|
|
|
2148 or else In_Subprogram_Or_Concurrent_Unit
|
|
|
2149 or else Ekind (Current_Scope) = E_Block
|
|
|
2150 then
|
|
|
2151 return;
|
|
|
2152
|
|
|
2153 -- Filter out cases where primary is default in a component declaration,
|
|
|
2154 -- discriminant specification, or actual in a record type initialization
|
|
|
2155 -- call.
|
|
|
2156
|
|
|
2157 -- Initialization call of internal types
|
|
|
2158
|
|
|
2159 elsif Nkind (Parent (N)) = N_Procedure_Call_Statement then
|
|
|
2160
|
|
|
2161 if Present (Parent (Parent (N)))
|
|
|
2162 and then Nkind (Parent (Parent (N))) = N_Freeze_Entity
|
|
|
2163 then
|
|
|
2164 return;
|
|
|
2165 end if;
|
|
|
2166
|
|
|
2167 if Nkind (Name (Parent (N))) = N_Identifier
|
|
|
2168 and then not Comes_From_Source (Entity (Name (Parent (N))))
|
|
|
2169 then
|
|
|
2170 return;
|
|
|
2171 end if;
|
|
|
2172 end if;
|
|
|
2173
|
|
|
2174 -- Error if the name is a primary in an expression. The parent must not
|
|
|
2175 -- be an operator, or a selected component or an indexed component that
|
|
|
2176 -- is itself a primary. Entities that are actuals do not need to be
|
|
|
2177 -- checked, because the call itself will be diagnosed. Entities in a
|
|
|
2178 -- generic unit or within a preanalyzed expression are not checked:
|
|
|
2179 -- only their use in executable code matters.
|
|
|
2180
|
|
|
2181 if Is_Primary (N)
|
|
|
2182 and then (not Inside_A_Generic
|
|
|
2183 or else Present (Enclosing_Generic_Body (N)))
|
|
|
2184 and then not In_Spec_Expression
|
|
|
2185 then
|
|
|
2186 if Ekind (Entity (N)) = E_Variable
|
|
|
2187 or else Ekind (Entity (N)) in Formal_Object_Kind
|
|
|
2188 then
|
|
|
2189 Flag_Non_Static_Expr
|
|
|
2190 ("non-static object name in preelaborated unit", N);
|
|
|
2191
|
|
|
2192 -- Give an error for a reference to a nonstatic constant, unless the
|
|
|
2193 -- constant is in another GNAT library unit that is preelaborable.
|
|
|
2194
|
|
|
2195 elsif Ekind (Entity (N)) = E_Constant
|
|
|
2196 and then not Is_Static_Expression (N)
|
|
|
2197 then
|
|
|
2198 E := Entity (N);
|
|
|
2199 Val := Constant_Value (E);
|
|
|
2200
|
|
|
2201 if In_Internal_Unit (N)
|
|
|
2202 and then
|
|
|
2203 Enclosing_Comp_Unit_Node (N) /= Enclosing_Comp_Unit_Node (E)
|
|
|
2204 and then (Is_Preelaborated (Scope (E))
|
|
|
2205 or else Is_Pure (Scope (E))
|
|
|
2206 or else (Present (Renamed_Object (E))
|
|
|
2207 and then Is_Entity_Name (Renamed_Object (E))
|
|
|
2208 and then
|
|
|
2209 (Is_Preelaborated
|
|
|
2210 (Scope (Renamed_Object (E)))
|
|
|
2211 or else
|
|
|
2212 Is_Pure
|
|
|
2213 (Scope (Renamed_Object (E))))))
|
|
|
2214 then
|
|
|
2215 null;
|
|
|
2216
|
|
|
2217 -- If the value of the constant is a local variable that renames
|
|
|
2218 -- an aggregate, this is in itself legal. The aggregate may be
|
|
|
2219 -- expanded into a loop, but this does not affect preelaborability
|
|
|
2220 -- in itself. If some aggregate components are non-static, that is
|
|
|
2221 -- to say if they involve non static primaries, they will be
|
|
|
2222 -- flagged when analyzed.
|
|
|
2223
|
|
|
2224 elsif Present (Val)
|
|
|
2225 and then Is_Entity_Name (Val)
|
|
|
2226 and then Is_Array_Type (Etype (Val))
|
|
|
2227 and then not Comes_From_Source (Val)
|
|
|
2228 and then Nkind (Original_Node (Val)) = N_Aggregate
|
|
|
2229 then
|
|
|
2230 null;
|
|
|
2231
|
|
|
2232 -- This is the error case
|
|
|
2233
|
|
|
2234 else
|
|
|
2235 -- In GNAT mode or Relaxed RM Semantic mode, this is just a
|
|
|
2236 -- warning, to allow it to be judiciously turned off.
|
|
|
2237 -- Otherwise it is a real error.
|
|
|
2238
|
|
|
2239 if GNAT_Mode or Relaxed_RM_Semantics then
|
|
|
2240 Error_Msg_N
|
|
|
2241 ("??non-static constant in preelaborated unit", N);
|
|
|
2242 else
|
|
|
2243 Flag_Non_Static_Expr
|
|
|
2244 ("non-static constant in preelaborated unit", N);
|
|
|
2245 end if;
|
|
|
2246 end if;
|
|
|
2247 end if;
|
|
|
2248 end if;
|
|
|
2249 end Validate_Static_Object_Name;
|
|
|
2250
|
|
|
2251 end Sem_Cat;
|
