1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- A C C E S S I B I L I T Y --
9 -- Copyright (C) 2022-2023, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Einfo
.Entities
; use Einfo
.Entities
;
31 with Elists
; use Elists
;
32 with Errout
; use Errout
;
33 with Einfo
.Utils
; use Einfo
.Utils
;
34 with Exp_Atag
; use Exp_Atag
;
35 with Exp_Ch3
; use Exp_Ch3
;
36 with Exp_Ch7
; use Exp_Ch7
;
37 with Exp_Tss
; use Exp_Tss
;
38 with Exp_Util
; use Exp_Util
;
39 with Namet
; use Namet
;
40 with Nlists
; use Nlists
;
41 with Nmake
; use Nmake
;
43 with Restrict
; use Restrict
;
44 with Rtsfind
; use Rtsfind
;
46 with Sem_Aux
; use Sem_Aux
;
47 with Sem_Ch8
; use Sem_Ch8
;
48 with Sem_Res
; use Sem_Res
;
49 with Sem_Util
; use Sem_Util
;
50 with Sinfo
; use Sinfo
;
51 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
52 with Sinfo
.Utils
; use Sinfo
.Utils
;
53 with Snames
; use Snames
;
54 with Stand
; use Stand
;
55 with Tbuild
; use Tbuild
;
57 package body Accessibility
is
59 ---------------------------
60 -- Accessibility_Message --
61 ---------------------------
63 procedure Accessibility_Message
(N
: Node_Id
; Typ
: Entity_Id
) is
64 Loc
: constant Source_Ptr
:= Sloc
(N
);
65 P
: constant Node_Id
:= Prefix
(N
);
66 Indic
: Node_Id
:= Parent
(Parent
(N
));
69 -- In an instance, this is a runtime check, but one we know will fail,
70 -- so generate an appropriate warning.
72 if In_Instance_Body
then
73 Error_Msg_Warn
:= SPARK_Mode
/= On
;
75 ("non-local pointer cannot point to local object<<", P
);
76 Error_Msg_F
("\Program_Error [<<", P
);
78 Make_Raise_Program_Error
(Loc
,
79 Reason
=> PE_Accessibility_Check_Failed
));
84 Error_Msg_F
("non-local pointer cannot point to local object", P
);
86 -- Check for case where we have a missing access definition
88 if Is_Record_Type
(Current_Scope
)
90 Nkind
(Parent
(N
)) in N_Discriminant_Association
91 | N_Index_Or_Discriminant_Constraint
93 Indic
:= Parent
(Parent
(N
));
95 and then Nkind
(Indic
) /= N_Subtype_Indication
97 Indic
:= Parent
(Indic
);
100 if Present
(Indic
) then
102 ("\use an access definition for" &
103 " the access discriminant of&",
104 N
, Entity
(Subtype_Mark
(Indic
)));
108 end Accessibility_Message
;
110 -------------------------
111 -- Accessibility_Level --
112 -------------------------
114 function Accessibility_Level
116 Level
: Accessibility_Level_Kind
;
117 In_Return_Context
: Boolean := False;
118 Allow_Alt_Model
: Boolean := True) return Node_Id
120 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
122 function Accessibility_Level
(Expr
: Node_Id
) return Node_Id
123 is (Accessibility_Level
(Expr
, Level
, In_Return_Context
));
124 -- Renaming of the enclosing function to facilitate recursive calls
126 function Make_Level_Literal
(Level
: Uint
) return Node_Id
;
127 -- Construct an integer literal representing an accessibility level with
128 -- its type set to Natural.
130 function Innermost_Master_Scope_Depth
(N
: Node_Id
) return Uint
;
131 -- Returns the scope depth of the given node's innermost enclosing scope
132 -- (effectively the accessibility level of the innermost enclosing
135 function Function_Call_Or_Allocator_Level
(N
: Node_Id
) return Node_Id
;
136 -- Centralized processing of subprogram calls which may appear in prefix
139 function Typ_Access_Level
(Typ
: Entity_Id
) return Uint
140 is (Type_Access_Level
(Typ
, Allow_Alt_Model
));
141 -- Renaming of Type_Access_Level with Allow_Alt_Model specified to avoid
142 -- passing the parameter specifically in every call.
144 ----------------------------------
145 -- Innermost_Master_Scope_Depth --
146 ----------------------------------
148 function Innermost_Master_Scope_Depth
(N
: Node_Id
) return Uint
is
149 Encl_Scop
: Entity_Id
;
151 Node_Par
: Node_Id
:= Parent
(N
);
152 Master_Lvl_Modifier
: Int
:= 0;
155 -- Locate the nearest enclosing node (by traversing Parents)
156 -- that Defining_Entity can be applied to, and return the
157 -- depth of that entity's nearest enclosing scope.
159 -- The RM 7.6.1(3) definition of "master" includes statements
160 -- and conditions for loops among other things. Are these cases
161 -- detected properly ???
163 while Present
(Node_Par
) loop
164 Ent
:= Defining_Entity_Or_Empty
(Node_Par
);
166 if Present
(Ent
) then
167 Encl_Scop
:= Find_Enclosing_Scope
(Ent
);
169 -- Ignore transient scopes made during expansion while also
170 -- taking into account certain expansions - like iterators
171 -- which get expanded into renamings and thus not marked
172 -- as coming from source.
174 if Comes_From_Source
(Node_Par
)
175 or else (Nkind
(Node_Par
) = N_Object_Renaming_Declaration
176 and then Comes_From_Iterator
(Node_Par
))
178 -- Note that in some rare cases the scope depth may not be
179 -- set, for example, when we are in the middle of analyzing
180 -- a type and the enclosing scope is said type. So, instead,
181 -- continue to move up the parent chain since the scope
182 -- depth of the type's parent is the same as that of the
185 if not Scope_Depth_Set
(Encl_Scop
) then
186 pragma Assert
(Nkind
(Parent
(Encl_Scop
))
187 = N_Full_Type_Declaration
);
190 Scope_Depth
(Encl_Scop
) + Master_Lvl_Modifier
;
194 -- For a return statement within a function, return
195 -- the depth of the function itself. This is not just
196 -- a small optimization, but matters when analyzing
197 -- the expression in an expression function before
198 -- the body is created.
200 elsif Nkind
(Node_Par
) in N_Extended_Return_Statement
201 | N_Simple_Return_Statement
203 return Scope_Depth
(Enclosing_Subprogram
(Node_Par
));
205 -- Statements are counted as masters
207 elsif Is_Master
(Node_Par
) then
208 Master_Lvl_Modifier
:= Master_Lvl_Modifier
+ 1;
212 Node_Par
:= Parent
(Node_Par
);
215 -- Should never reach the following return
217 pragma Assert
(False);
219 return Scope_Depth
(Current_Scope
) + 1;
220 end Innermost_Master_Scope_Depth
;
222 ------------------------
223 -- Make_Level_Literal --
224 ------------------------
226 function Make_Level_Literal
(Level
: Uint
) return Node_Id
is
227 Result
: constant Node_Id
:= Make_Integer_Literal
(Loc
, Level
);
230 Set_Etype
(Result
, Standard_Natural
);
232 end Make_Level_Literal
;
234 --------------------------------------
235 -- Function_Call_Or_Allocator_Level --
236 --------------------------------------
238 function Function_Call_Or_Allocator_Level
(N
: Node_Id
) return Node_Id
is
242 -- Results of functions are objects, so we either get the
243 -- accessibility of the function or, in case of a call which is
244 -- indirect, the level of the access-to-subprogram type.
246 -- This code looks wrong ???
248 if Nkind
(N
) = N_Function_Call
249 and then Ada_Version
< Ada_2005
251 if Is_Entity_Name
(Name
(N
)) then
252 return Make_Level_Literal
253 (Subprogram_Access_Level
(Entity
(Name
(N
))));
255 return Make_Level_Literal
256 (Typ_Access_Level
(Etype
(Prefix
(Name
(N
)))));
259 -- We ignore coextensions as they cannot be implemented under the
260 -- "small-integer" model.
262 elsif Nkind
(N
) = N_Allocator
263 and then (Is_Static_Coextension
(N
)
264 or else Is_Dynamic_Coextension
(N
))
266 return Make_Level_Literal
(Scope_Depth
(Standard_Standard
));
269 -- Named access types have a designated level
271 if Is_Named_Access_Type
(Etype
(N
)) then
272 return Make_Level_Literal
(Typ_Access_Level
(Etype
(N
)));
274 -- Otherwise, the level is dictated by RM 3.10.2 (10.7/3)
277 -- Check No_Dynamic_Accessibility_Checks restriction override for
278 -- alternative accessibility model.
281 and then No_Dynamic_Accessibility_Checks_Enabled
(N
)
282 and then Is_Anonymous_Access_Type
(Etype
(N
))
284 -- In the alternative model the level is that of the
287 if Debug_Flag_Underscore_B
then
288 return Make_Level_Literal
(Typ_Access_Level
(Etype
(N
)));
290 -- For function calls the level is that of the innermost
291 -- master, otherwise (for allocators etc.) we get the level
292 -- of the corresponding anonymous access type, which is
293 -- calculated through the normal path of execution.
295 elsif Nkind
(N
) = N_Function_Call
then
296 return Make_Level_Literal
297 (Innermost_Master_Scope_Depth
(Expr
));
301 if Nkind
(N
) = N_Function_Call
then
302 -- Dynamic checks are generated when we are within a return
303 -- value or we are in a function call within an anonymous
304 -- access discriminant constraint of a return object (signified
305 -- by In_Return_Context) on the side of the callee.
307 -- So, in this case, return accessibility level of the
308 -- enclosing subprogram.
310 if In_Return_Value
(N
)
311 or else In_Return_Context
313 return Make_Level_Literal
314 (Subprogram_Access_Level
(Current_Subprogram
));
318 -- When the call is being dereferenced the level is that of the
319 -- enclosing master of the dereferenced call.
321 if Nkind
(Parent
(N
)) in N_Explicit_Dereference
322 | N_Indexed_Component
323 | N_Selected_Component
325 return Make_Level_Literal
326 (Innermost_Master_Scope_Depth
(Expr
));
329 -- Find any relevant enclosing parent nodes that designate an
330 -- object being initialized.
332 -- Note: The above is only relevant if the result is used "in its
333 -- entirety" as RM 3.10.2 (10.2/3) states. However, this is
334 -- accounted for in the case statement in the main body of
335 -- Accessibility_Level for N_Selected_Component.
337 Par
:= Parent
(Expr
);
339 while Present
(Par
) loop
340 -- Detect an expanded implicit conversion, typically this
341 -- occurs on implicitly converted actuals in calls.
343 -- Does this catch all implicit conversions ???
345 if Nkind
(Par
) = N_Type_Conversion
346 and then Is_Named_Access_Type
(Etype
(Par
))
348 return Make_Level_Literal
349 (Typ_Access_Level
(Etype
(Par
)));
352 -- Jump out when we hit an object declaration or the right-hand
353 -- side of an assignment, or a construct such as an aggregate
354 -- subtype indication which would be the result is not used
355 -- "in its entirety."
357 exit when Nkind
(Par
) in N_Object_Declaration
358 or else (Nkind
(Par
) = N_Assignment_Statement
359 and then Name
(Par
) /= Prev_Par
);
365 -- Assignment statements are handled in a similar way in
366 -- accordance to the left-hand part. However, strictly speaking,
367 -- this is illegal according to the RM, but this change is needed
368 -- to pass an ACATS C-test and is useful in general ???
371 when N_Object_Declaration
=>
372 return Make_Level_Literal
374 (Scope
(Defining_Identifier
(Par
))));
376 when N_Assignment_Statement
=>
377 -- Return the accessibility level of the left-hand part
379 return Accessibility_Level
381 Level
=> Object_Decl_Level
,
382 In_Return_Context
=> In_Return_Context
);
385 return Make_Level_Literal
386 (Innermost_Master_Scope_Depth
(Expr
));
389 end Function_Call_Or_Allocator_Level
;
393 E
: Node_Id
:= Original_Node
(Expr
);
396 -- Start of processing for Accessibility_Level
399 -- We could be looking at a reference to a formal due to the expansion
400 -- of entries and other cases, so obtain the renaming if necessary.
402 if Present
(Param_Entity
(Expr
)) then
403 E
:= Param_Entity
(Expr
);
406 -- Extract the entity
408 if Nkind
(E
) in N_Has_Entity
and then Present
(Entity
(E
)) then
411 -- Deal with a possible renaming of a private protected component
413 if Ekind
(E
) in E_Constant | E_Variable
and then Is_Prival
(E
) then
414 E
:= Prival_Link
(E
);
418 -- Perform the processing on the expression
421 -- The level of an aggregate is that of the innermost master that
422 -- evaluates it as defined in RM 3.10.2 (10/4).
425 return Make_Level_Literal
(Innermost_Master_Scope_Depth
(Expr
));
427 -- The accessibility level is that of the access type, except for an
428 -- anonymous allocators which have special rules defined in RM 3.10.2
432 return Function_Call_Or_Allocator_Level
(E
);
434 -- We could reach this point for two reasons. Either the expression
435 -- applies to a special attribute ('Loop_Entry, 'Result, or 'Old), or
436 -- we are looking at the access attributes directly ('Access,
437 -- 'Address, or 'Unchecked_Access).
439 when N_Attribute_Reference
=>
440 Pre
:= Original_Node
(Prefix
(E
));
442 -- Regular 'Access attribute presence means we have to look at the
445 if Attribute_Name
(E
) = Name_Access
then
446 return Accessibility_Level
(Prefix
(E
));
448 -- Unchecked or unrestricted attributes have unlimited depth
450 elsif Attribute_Name
(E
) in Name_Address
451 | Name_Unchecked_Access
452 | Name_Unrestricted_Access
454 return Make_Level_Literal
(Scope_Depth
(Standard_Standard
));
456 -- 'Access can be taken further against other special attributes,
457 -- so handle these cases explicitly.
459 elsif Attribute_Name
(E
)
460 in Name_Old | Name_Loop_Entry | Name_Result
462 -- Named access types
464 if Is_Named_Access_Type
(Etype
(Pre
)) then
465 return Make_Level_Literal
466 (Typ_Access_Level
(Etype
(Pre
)));
468 -- Anonymous access types
470 elsif Nkind
(Pre
) in N_Has_Entity
471 and then Ekind
(Entity
(Pre
)) not in Subprogram_Kind
472 and then Present
(Get_Dynamic_Accessibility
(Entity
(Pre
)))
473 and then Level
= Dynamic_Level
475 return New_Occurrence_Of
476 (Get_Dynamic_Accessibility
(Entity
(Pre
)), Loc
);
478 -- Otherwise the level is treated in a similar way as
479 -- aggregates according to RM 6.1.1 (35.1/4) which concerns
480 -- an implicit constant declaration - in turn defining the
481 -- accessibility level to be that of the implicit constant
485 return Make_Level_Literal
486 (Innermost_Master_Scope_Depth
(Expr
));
493 -- This is the "base case" for accessibility level calculations which
494 -- means we are near the end of our recursive traversal.
496 when N_Defining_Identifier
=>
497 -- A dynamic check is performed on the side of the callee when we
498 -- are within a return statement, so return a library-level
499 -- accessibility level to null out checks on the side of the
502 if Is_Explicitly_Aliased
(E
)
503 and then (In_Return_Context
504 or else (Level
/= Dynamic_Level
505 and then In_Return_Value
(Expr
)))
507 return Make_Level_Literal
(Scope_Depth
(Standard_Standard
));
509 -- Something went wrong and an extra accessibility formal has not
510 -- been generated when one should have ???
513 and then No
(Get_Dynamic_Accessibility
(E
))
514 and then Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
516 return Make_Level_Literal
(Scope_Depth
(Standard_Standard
));
518 -- Stand-alone object of an anonymous access type "SAOAAT"
521 or else Ekind
(E
) in E_Variable
523 and then Present
(Get_Dynamic_Accessibility
(E
))
524 and then (Level
= Dynamic_Level
525 or else Level
= Zero_On_Dynamic_Level
)
527 if Level
= Zero_On_Dynamic_Level
then
528 return Make_Level_Literal
529 (Scope_Depth
(Standard_Standard
));
532 -- No_Dynamic_Accessibility_Checks restriction override for
533 -- alternative accessibility model.
536 and then No_Dynamic_Accessibility_Checks_Enabled
(E
)
538 -- In the alternative model the level is that of the
539 -- designated type entity's context.
541 if Debug_Flag_Underscore_B
then
542 return Make_Level_Literal
(Typ_Access_Level
(Etype
(E
)));
544 -- Otherwise the level depends on the entity's context
546 elsif Is_Formal
(E
) then
547 return Make_Level_Literal
548 (Subprogram_Access_Level
549 (Enclosing_Subprogram
(E
)));
551 return Make_Level_Literal
552 (Scope_Depth
(Enclosing_Dynamic_Scope
(E
)));
556 -- Return the dynamic level in the normal case
558 return New_Occurrence_Of
559 (Get_Dynamic_Accessibility
(E
), Loc
);
561 -- Initialization procedures have a special extra accessibility
562 -- parameter associated with the level at which the object
563 -- being initialized exists
565 elsif Ekind
(E
) = E_Record_Type
566 and then Is_Limited_Record
(E
)
567 and then Current_Scope
= Init_Proc
(E
)
568 and then Present
(Init_Proc_Level_Formal
(Current_Scope
))
570 return New_Occurrence_Of
571 (Init_Proc_Level_Formal
(Current_Scope
), Loc
);
573 -- Current instance of the type is deeper than that of the type
574 -- according to RM 3.10.2 (21).
576 elsif Is_Type
(E
) then
577 -- When restriction No_Dynamic_Accessibility_Checks is active
578 -- along with -gnatd_b.
581 and then No_Dynamic_Accessibility_Checks_Enabled
(E
)
582 and then Debug_Flag_Underscore_B
584 return Make_Level_Literal
(Typ_Access_Level
(E
));
589 return Make_Level_Literal
(Typ_Access_Level
(E
) + 1);
591 -- Move up the renamed entity or object if it came from source
592 -- since expansion may have created a dummy renaming under
593 -- certain circumstances.
595 -- Note: We check if the original node of the renaming comes
596 -- from source because the node may have been rewritten.
598 elsif Present
(Renamed_Entity_Or_Object
(E
))
599 and then Comes_From_Source
600 (Original_Node
(Renamed_Entity_Or_Object
(E
)))
602 return Accessibility_Level
(Renamed_Entity_Or_Object
(E
));
604 -- Named access types get their level from their associated type
606 elsif Is_Named_Access_Type
(Etype
(E
)) then
607 return Make_Level_Literal
608 (Typ_Access_Level
(Etype
(E
)));
610 -- Check if E is an expansion-generated renaming of an iterator
611 -- by examining Related_Expression. If so, determine the
612 -- accessibility level based on the original expression.
614 elsif Ekind
(E
) in E_Constant | E_Variable
615 and then Present
(Related_Expression
(E
))
617 return Accessibility_Level
(Related_Expression
(E
));
619 elsif Level
= Dynamic_Level
620 and then Ekind
(E
) in E_In_Parameter | E_In_Out_Parameter
621 and then Present
(Init_Proc_Level_Formal
(Scope
(E
)))
623 return New_Occurrence_Of
624 (Init_Proc_Level_Formal
(Scope
(E
)), Loc
);
626 -- Normal object - get the level of the enclosing scope
629 return Make_Level_Literal
630 (Scope_Depth
(Enclosing_Dynamic_Scope
(E
)));
633 -- Handle indexed and selected components including the special cases
634 -- whereby there is an implicit dereference, a component of a
635 -- composite type, or a function call in prefix notation.
637 -- We don't handle function calls in prefix notation correctly ???
639 when N_Indexed_Component | N_Selected_Component | N_Slice
=>
642 -- Fetch the original node when the prefix comes from the result
643 -- of expanding a function call since we want to find the level
644 -- of the original source call.
646 if not Comes_From_Source
(Pre
)
647 and then Nkind
(Original_Node
(Pre
)) = N_Function_Call
649 Pre
:= Original_Node
(Pre
);
652 -- When E is an indexed component or selected component and
653 -- the current Expr is a function call, we know that we are
654 -- looking at an expanded call in prefix notation.
656 if Nkind
(Expr
) = N_Function_Call
then
657 return Function_Call_Or_Allocator_Level
(Expr
);
659 -- If the prefix is a named access type, then we are dealing
660 -- with an implicit deferences. In that case the level is that
661 -- of the named access type in the prefix.
663 elsif Is_Named_Access_Type
(Etype
(Pre
)) then
664 return Make_Level_Literal
665 (Typ_Access_Level
(Etype
(Pre
)));
667 -- The current expression is a named access type, so there is no
668 -- reason to look at the prefix. Instead obtain the level of E's
669 -- named access type.
671 elsif Is_Named_Access_Type
(Etype
(E
)) then
672 return Make_Level_Literal
673 (Typ_Access_Level
(Etype
(E
)));
675 -- A nondiscriminant selected component where the component
676 -- is an anonymous access type means that its associated
677 -- level is that of the containing type - see RM 3.10.2 (16).
679 -- Note that when restriction No_Dynamic_Accessibility_Checks is
680 -- in effect we treat discriminant components as regular
684 (Nkind
(E
) = N_Selected_Component
685 and then Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
686 and then Ekind
(Etype
(Pre
)) /= E_Anonymous_Access_Type
687 and then (not (Nkind
(Selector_Name
(E
)) in N_Has_Entity
688 and then Ekind
(Entity
(Selector_Name
(E
)))
691 -- The alternative accessibility models both treat
692 -- discriminants as regular components.
694 or else (No_Dynamic_Accessibility_Checks_Enabled
(E
)
695 and then Allow_Alt_Model
)))
697 -- Arrays featuring components of anonymous access components
698 -- get their corresponding level from their containing type's
702 (Nkind
(E
) = N_Indexed_Component
703 and then Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
704 and then Ekind
(Etype
(Pre
)) in Array_Kind
705 and then Ekind
(Component_Type
(Base_Type
(Etype
(Pre
))))
706 = E_Anonymous_Access_Type
)
708 -- When restriction No_Dynamic_Accessibility_Checks is active
709 -- and -gnatd_b set, the level is that of the designated type.
712 and then No_Dynamic_Accessibility_Checks_Enabled
(E
)
713 and then Debug_Flag_Underscore_B
715 return Make_Level_Literal
716 (Typ_Access_Level
(Etype
(E
)));
719 -- Otherwise proceed normally
721 return Make_Level_Literal
722 (Typ_Access_Level
(Etype
(Prefix
(E
))));
724 -- The accessibility calculation routine that handles function
725 -- calls (Function_Call_Level) assumes, in the case the
726 -- result is of an anonymous access type, that the result will be
727 -- used "in its entirety" when the call is present within an
728 -- assignment or object declaration.
730 -- To properly handle cases where the result is not used in its
731 -- entirety, we test if the prefix of the component in question is
732 -- a function call, which tells us that one of its components has
733 -- been identified and is being accessed. Therefore we can
734 -- conclude that the result is not used "in its entirety"
735 -- according to RM 3.10.2 (10.2/3).
737 elsif Nkind
(Pre
) = N_Function_Call
738 and then not Is_Named_Access_Type
(Etype
(Pre
))
740 -- Dynamic checks are generated when we are within a return
741 -- value or we are in a function call within an anonymous
742 -- access discriminant constraint of a return object (signified
743 -- by In_Return_Context) on the side of the callee.
745 -- So, in this case, return a library accessibility level to
746 -- null out the check on the side of the caller.
748 if (In_Return_Value
(E
)
749 or else In_Return_Context
)
750 and then Level
/= Dynamic_Level
752 return Make_Level_Literal
753 (Scope_Depth
(Standard_Standard
));
756 return Make_Level_Literal
757 (Innermost_Master_Scope_Depth
(Expr
));
759 -- Otherwise, continue recursing over the expression prefixes
762 return Accessibility_Level
(Prefix
(E
));
765 -- Qualified expressions
767 when N_Qualified_Expression
=>
768 if Is_Named_Access_Type
(Etype
(E
)) then
769 return Make_Level_Literal
770 (Typ_Access_Level
(Etype
(E
)));
772 return Accessibility_Level
(Expression
(E
));
775 -- Handle function calls
777 when N_Function_Call
=>
778 return Function_Call_Or_Allocator_Level
(E
);
780 -- Explicit dereference accessibility level calculation
782 when N_Explicit_Dereference
=>
783 Pre
:= Original_Node
(Prefix
(E
));
785 -- The prefix is a named access type so the level is taken from
788 if Is_Named_Access_Type
(Etype
(Pre
)) then
789 return Make_Level_Literal
(Typ_Access_Level
(Etype
(Pre
)));
791 -- Otherwise, recurse deeper
794 return Accessibility_Level
(Prefix
(E
));
799 when N_Type_Conversion | N_Unchecked_Type_Conversion
=>
800 -- View conversions are special in that they require use to
801 -- inspect the expression of the type conversion.
803 -- Allocators of anonymous access types are internally generated,
804 -- so recurse deeper in that case as well.
806 if Is_View_Conversion
(E
)
807 or else Ekind
(Etype
(E
)) = E_Anonymous_Access_Type
809 return Accessibility_Level
(Expression
(E
));
811 -- We don't care about the master if we are looking at a named
814 elsif Is_Named_Access_Type
(Etype
(E
)) then
815 return Make_Level_Literal
816 (Typ_Access_Level
(Etype
(E
)));
818 -- In section RM 3.10.2 (10/4) the accessibility rules for
819 -- aggregates and value conversions are outlined. Are these
820 -- followed in the case of initialization of an object ???
822 -- Should use Innermost_Master_Scope_Depth ???
825 return Accessibility_Level
(Current_Scope
);
828 -- Default to the type accessibility level for the type of the
829 -- expression's entity.
832 return Make_Level_Literal
(Typ_Access_Level
(Etype
(E
)));
834 end Accessibility_Level
;
836 -------------------------------
837 -- Apply_Accessibility_Check --
838 -------------------------------
840 procedure Apply_Accessibility_Check
843 Insert_Node
: Node_Id
)
845 Loc
: constant Source_Ptr
:= Sloc
(N
);
847 Check_Cond
: Node_Id
;
848 Param_Ent
: Entity_Id
:= Param_Entity
(N
);
849 Param_Level
: Node_Id
;
850 Type_Level
: Node_Id
;
853 -- Verify we haven't tried to add a dynamic accessibility check when we
856 pragma Assert
(not No_Dynamic_Accessibility_Checks_Enabled
(N
));
858 if Ada_Version
>= Ada_2012
859 and then No
(Param_Ent
)
860 and then Is_Entity_Name
(N
)
861 and then Ekind
(Entity
(N
)) in E_Constant | E_Variable
862 and then Present
(Effective_Extra_Accessibility
(Entity
(N
)))
864 Param_Ent
:= Entity
(N
);
865 while Present
(Renamed_Object
(Param_Ent
)) loop
866 -- Renamed_Object must return an Entity_Name here
867 -- because of preceding "Present (E_E_A (...))" test.
869 Param_Ent
:= Entity
(Renamed_Object
(Param_Ent
));
873 if Inside_A_Generic
then
876 -- Only apply the run-time check if the access parameter has an
877 -- associated extra access level parameter and when accessibility checks
880 elsif Present
(Param_Ent
)
881 and then Present
(Get_Dynamic_Accessibility
(Param_Ent
))
882 and then not Accessibility_Checks_Suppressed
(Param_Ent
)
883 and then not Accessibility_Checks_Suppressed
(Typ
)
885 -- Obtain the parameter's accessibility level
888 New_Occurrence_Of
(Get_Dynamic_Accessibility
(Param_Ent
), Loc
);
890 -- Use the dynamic accessibility parameter for the function's result
891 -- when one has been created instead of statically referring to the
892 -- deepest type level so as to appropriatly handle the rules for
893 -- RM 3.10.2 (10.1/3).
895 if Ekind
(Scope
(Param_Ent
)) = E_Function
896 and then In_Return_Value
(N
)
897 and then Ekind
(Typ
) = E_Anonymous_Access_Type
899 -- Associate the level of the result type to the extra result
900 -- accessibility parameter belonging to the current function.
902 if Present
(Extra_Accessibility_Of_Result
(Scope
(Param_Ent
))) then
905 (Extra_Accessibility_Of_Result
(Scope
(Param_Ent
)), Loc
);
907 -- In Ada 2005 and earlier modes, a result extra accessibility
908 -- parameter is not generated and no dynamic check is performed.
914 -- Otherwise get the type's accessibility level normally
918 Make_Integer_Literal
(Loc
, Deepest_Type_Access_Level
(Typ
));
921 -- Raise Program_Error if the accessibility level of the access
922 -- parameter is deeper than the level of the target access type.
926 Left_Opnd
=> Param_Level
,
927 Right_Opnd
=> Type_Level
);
929 Insert_Action
(Insert_Node
,
930 Make_Raise_Program_Error
(Loc
,
931 Condition
=> Check_Cond
,
932 Reason
=> PE_Accessibility_Check_Failed
));
934 Analyze_And_Resolve
(N
);
936 -- If constant folding has happened on the condition for the
937 -- generated error, then warn about it being unconditional.
939 if Nkind
(Check_Cond
) = N_Identifier
940 and then Entity
(Check_Cond
) = Standard_True
942 Error_Msg_Warn
:= SPARK_Mode
/= On
;
943 Error_Msg_N
("accessibility check fails<<", N
);
944 Error_Msg_N
("\Program_Error [<<", N
);
947 end Apply_Accessibility_Check
;
949 ---------------------------------------------
950 -- Apply_Accessibility_Check_For_Allocator --
951 ---------------------------------------------
953 procedure Apply_Accessibility_Check_For_Allocator
957 Built_In_Place
: Boolean := False)
959 Loc
: constant Source_Ptr
:= Sloc
(N
);
960 PtrT
: constant Entity_Id
:= Etype
(N
);
961 DesigT
: constant Entity_Id
:= Designated_Type
(PtrT
);
962 Pool_Id
: constant Entity_Id
:= Associated_Storage_Pool
(PtrT
);
970 if Ada_Version
>= Ada_2005
971 and then Is_Class_Wide_Type
(DesigT
)
972 and then Tagged_Type_Expansion
973 and then not Scope_Suppress
.Suppress
(Accessibility_Check
)
974 and then not No_Dynamic_Accessibility_Checks_Enabled
(Ref
)
976 (Type_Access_Level
(Etype
(Exp
)) > Type_Access_Level
(PtrT
)
978 (Is_Class_Wide_Type
(Etype
(Exp
))
979 and then Scope
(PtrT
) /= Current_Scope
))
981 -- If the allocator was built in place, Ref is already a reference
982 -- to the access object initialized to the result of the allocator
983 -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
984 -- Remove_Side_Effects for cases where the build-in-place call may
985 -- still be the prefix of the reference (to avoid generating
986 -- duplicate calls). Otherwise, it is the entity associated with
987 -- the object containing the address of the allocated object.
989 if Built_In_Place
then
990 Remove_Side_Effects
(Ref
);
991 Obj_Ref
:= New_Copy_Tree
(Ref
);
993 Obj_Ref
:= New_Occurrence_Of
(Ref
, Loc
);
996 -- For access to interface types we must generate code to displace
997 -- the pointer to the base of the object since the subsequent code
998 -- references components located in the TSD of the object (which
999 -- is associated with the primary dispatch table --see a-tags.ads)
1000 -- and also generates code invoking Free, which requires also a
1001 -- reference to the base of the unallocated object.
1003 if Is_Interface
(DesigT
) and then Tagged_Type_Expansion
then
1005 Unchecked_Convert_To
(Etype
(Obj_Ref
),
1006 Make_Function_Call
(Loc
,
1008 New_Occurrence_Of
(RTE
(RE_Base_Address
), Loc
),
1009 Parameter_Associations
=> New_List
(
1010 Unchecked_Convert_To
(RTE
(RE_Address
),
1011 New_Copy_Tree
(Obj_Ref
)))));
1014 -- Step 1: Create the object clean up code
1018 -- Deallocate the object if the accessibility check fails. This is
1019 -- done only on targets or profiles that support deallocation.
1023 if RTE_Available
(RE_Free
) then
1024 Free_Stmt
:= Make_Free_Statement
(Loc
, New_Copy_Tree
(Obj_Ref
));
1025 Set_Storage_Pool
(Free_Stmt
, Pool_Id
);
1027 Append_To
(Stmts
, Free_Stmt
);
1029 -- The target or profile cannot deallocate objects
1035 -- Finalize the object if applicable. Generate:
1037 -- [Deep_]Finalize (Obj_Ref.all);
1039 if Needs_Finalization
(DesigT
)
1040 and then not No_Heap_Finalization
(PtrT
)
1045 Make_Explicit_Dereference
(Loc
, New_Copy
(Obj_Ref
)),
1048 -- Guard against a missing [Deep_]Finalize when the designated
1049 -- type was not properly frozen.
1051 if No
(Fin_Call
) then
1052 Fin_Call
:= Make_Null_Statement
(Loc
);
1055 -- When the target or profile supports deallocation, wrap the
1056 -- finalization call in a block to ensure proper deallocation even
1057 -- if finalization fails. Generate:
1067 if Present
(Free_Stmt
) then
1069 Make_Block_Statement
(Loc
,
1070 Handled_Statement_Sequence
=>
1071 Make_Handled_Sequence_Of_Statements
(Loc
,
1072 Statements
=> New_List
(Fin_Call
),
1074 Exception_Handlers
=> New_List
(
1075 Make_Exception_Handler
(Loc
,
1076 Exception_Choices
=> New_List
(
1077 Make_Others_Choice
(Loc
)),
1078 Statements
=> New_List
(
1079 New_Copy_Tree
(Free_Stmt
),
1080 Make_Raise_Statement
(Loc
))))));
1083 Prepend_To
(Stmts
, Fin_Call
);
1086 -- Signal the accessibility failure through a Program_Error
1089 Make_Raise_Program_Error
(Loc
,
1090 Reason
=> PE_Accessibility_Check_Failed
));
1092 -- Step 2: Create the accessibility comparison
1098 Make_Attribute_Reference
(Loc
,
1100 Attribute_Name
=> Name_Tag
);
1102 -- For tagged types, determine the accessibility level by looking at
1103 -- the type specific data of the dispatch table. Generate:
1105 -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
1107 if Tagged_Type_Expansion
then
1108 Cond
:= Build_Get_Access_Level
(Loc
, Obj_Ref
);
1110 -- Use a runtime call to determine the accessibility level when
1111 -- compiling on virtual machine targets. Generate:
1113 -- Get_Access_Level (Ref'Tag)
1117 Make_Function_Call
(Loc
,
1119 New_Occurrence_Of
(RTE
(RE_Get_Access_Level
), Loc
),
1120 Parameter_Associations
=> New_List
(Obj_Ref
));
1126 Right_Opnd
=> Accessibility_Level
(N
, Dynamic_Level
));
1128 -- Due to the complexity and side effects of the check, utilize an if
1129 -- statement instead of the regular Program_Error circuitry.
1132 Make_Implicit_If_Statement
(N
,
1134 Then_Statements
=> Stmts
));
1136 end Apply_Accessibility_Check_For_Allocator
;
1138 ------------------------------------------
1139 -- Check_Return_Construct_Accessibility --
1140 ------------------------------------------
1142 procedure Check_Return_Construct_Accessibility
1143 (Return_Stmt
: Node_Id
;
1144 Stm_Entity
: Entity_Id
)
1146 Loc
: constant Source_Ptr
:= Sloc
(Return_Stmt
);
1147 Scope_Id
: constant Entity_Id
:= Return_Applies_To
(Stm_Entity
);
1149 R_Type
: constant Entity_Id
:= Etype
(Scope_Id
);
1150 -- Function result subtype
1152 function First_Selector
(Assoc
: Node_Id
) return Node_Id
;
1153 -- Obtain the first selector or choice from a given association
1155 function Is_Formal_Of_Current_Function
1156 (Assoc_Expr
: Entity_Id
) return Boolean;
1157 -- Predicate to test if a given expression associated with a
1158 -- discriminant is a formal parameter to the function in which the
1159 -- return construct we checking applies to.
1161 --------------------
1162 -- First_Selector --
1163 --------------------
1165 function First_Selector
(Assoc
: Node_Id
) return Node_Id
is
1167 if Nkind
(Assoc
) = N_Component_Association
then
1168 return First
(Choices
(Assoc
));
1170 elsif Nkind
(Assoc
) = N_Discriminant_Association
then
1171 return (First
(Selector_Names
(Assoc
)));
1174 raise Program_Error
;
1178 -----------------------------------
1179 -- Is_Formal_Of_Current_Function --
1180 -----------------------------------
1182 function Is_Formal_Of_Current_Function
1183 (Assoc_Expr
: Entity_Id
) return Boolean is
1185 return Is_Entity_Name
(Assoc_Expr
)
1186 and then Enclosing_Subprogram
1187 (Entity
(Assoc_Expr
)) = Scope_Id
1188 and then Is_Formal
(Entity
(Assoc_Expr
));
1189 end Is_Formal_Of_Current_Function
;
1191 -- Local declarations
1193 Assoc
: Node_Id
:= Empty
;
1194 -- Assoc should perhaps be renamed and declared as a
1195 -- Node_Or_Entity_Id since it encompasses not only component and
1196 -- discriminant associations, but also discriminant components within
1197 -- a type declaration or subtype indication ???
1199 Assoc_Expr
: Node_Id
;
1200 Assoc_Present
: Boolean := False;
1202 Check_Cond
: Node_Id
;
1203 Unseen_Disc_Count
: Nat
:= 0;
1204 Seen_Discs
: Elist_Id
;
1206 First_Disc
: Entity_Id
;
1209 Return_Con
: Node_Id
;
1212 -- Start of processing for Check_Return_Construct_Accessibility
1215 -- Only perform checks on record types with access discriminants and
1216 -- non-internally generated functions.
1218 if not Is_Record_Type
(R_Type
)
1219 or else not Has_Anonymous_Access_Discriminant
(R_Type
)
1220 or else not Comes_From_Source
(Return_Stmt
)
1225 -- We are only interested in return statements
1227 if Nkind
(Return_Stmt
) not in
1228 N_Extended_Return_Statement | N_Simple_Return_Statement
1233 -- Fetch the object from the return statement, in the case of a
1234 -- simple return statement the expression is part of the node.
1236 if Nkind
(Return_Stmt
) = N_Extended_Return_Statement
then
1237 -- Obtain the object definition from the expanded extended return
1239 Return_Con
:= First
(Return_Object_Declarations
(Return_Stmt
));
1240 while Present
(Return_Con
) loop
1241 -- Inspect the original node to avoid object declarations
1242 -- expanded into renamings.
1244 if Nkind
(Original_Node
(Return_Con
)) = N_Object_Declaration
1245 and then Comes_From_Source
(Original_Node
(Return_Con
))
1250 Nlists
.Next
(Return_Con
);
1253 pragma Assert
(Present
(Return_Con
));
1255 -- Could be dealing with a renaming
1257 Return_Con
:= Original_Node
(Return_Con
);
1259 Return_Con
:= Expression
(Return_Stmt
);
1262 -- Obtain the accessibility levels of the expressions associated
1263 -- with all anonymous access discriminants, then generate a
1264 -- dynamic check or static error when relevant.
1266 -- Note the repeated use of Original_Node to avoid checking
1269 Unqual
:= Original_Node
(Unqualify
(Original_Node
(Return_Con
)));
1271 -- Get the corresponding declaration based on the return object's
1274 if Nkind
(Unqual
) = N_Identifier
1275 and then Nkind
(Parent
(Entity
(Unqual
)))
1276 in N_Object_Declaration
1277 | N_Object_Renaming_Declaration
1279 Obj_Decl
:= Original_Node
(Parent
(Entity
(Unqual
)));
1281 -- We were passed the object declaration directly, so use it
1283 elsif Nkind
(Unqual
) in N_Object_Declaration
1284 | N_Object_Renaming_Declaration
1288 -- Otherwise, we are looking at something else
1295 -- Hop up object renamings when present
1297 if Present
(Obj_Decl
)
1298 and then Nkind
(Obj_Decl
) = N_Object_Renaming_Declaration
1300 while Nkind
(Obj_Decl
) = N_Object_Renaming_Declaration
loop
1302 if Nkind
(Name
(Obj_Decl
)) not in N_Entity
then
1303 -- We may be looking at the expansion of iterators or
1304 -- some other internally generated construct, so it is safe
1305 -- to ignore checks ???
1307 if not Comes_From_Source
(Obj_Decl
) then
1311 Obj_Decl
:= Original_Node
1313 (Ultimate_Prefix
(Name
(Obj_Decl
))));
1315 -- Move up to the next declaration based on the object's name
1318 Obj_Decl
:= Original_Node
1319 (Declaration_Node
(Name
(Obj_Decl
)));
1324 -- Obtain the discriminant values from the return aggregate
1326 -- Do we cover extension aggregates correctly ???
1328 if Nkind
(Unqual
) = N_Aggregate
then
1329 if Present
(Expressions
(Unqual
)) then
1330 Assoc
:= First
(Expressions
(Unqual
));
1332 Assoc
:= First
(Component_Associations
(Unqual
));
1335 -- There is an object declaration for the return object
1337 elsif Present
(Obj_Decl
) then
1338 -- When a subtype indication is present in an object declaration
1339 -- it must contain the object's discriminants.
1341 if Nkind
(Object_Definition
(Obj_Decl
)) = N_Subtype_Indication
then
1345 (Object_Definition
(Obj_Decl
))));
1347 -- The object declaration contains an aggregate
1349 elsif Present
(Expression
(Obj_Decl
)) then
1351 if Nkind
(Unqualify
(Expression
(Obj_Decl
))) = N_Aggregate
then
1352 -- Grab the first associated discriminant expresion
1355 (Expressions
(Unqualify
(Expression
(Obj_Decl
))))
1359 (Unqualify
(Expression
(Obj_Decl
))));
1362 (Component_Associations
1363 (Unqualify
(Expression
(Obj_Decl
))));
1366 -- Otherwise, this is something else
1372 -- There are no supplied discriminants in the object declaration,
1373 -- so get them from the type definition since they must be default
1376 -- Do we handle constrained subtypes correctly ???
1378 elsif Nkind
(Unqual
) = N_Object_Declaration
then
1379 Assoc
:= First_Discriminant
1380 (Etype
(Object_Definition
(Obj_Decl
)));
1383 Assoc
:= First_Discriminant
(Etype
(Unqual
));
1386 -- When we are not looking at an aggregate or an identifier, return
1387 -- since any other construct (like a function call) is not
1388 -- applicable since checks will be performed on the side of the
1395 -- Obtain the discriminants so we know the actual type in case the
1396 -- value of their associated expression gets implicitly converted.
1398 if No
(Obj_Decl
) then
1399 pragma Assert
(Nkind
(Unqual
) = N_Aggregate
);
1401 Disc
:= First_Discriminant
(Etype
(Unqual
));
1404 Disc
:= First_Discriminant
1405 (Etype
(Defining_Identifier
(Obj_Decl
)));
1408 -- Preserve the first discriminant for checking named associations
1412 -- Count the number of discriminants for processing an aggregate
1413 -- which includes an others.
1416 while Present
(Disc
) loop
1417 Unseen_Disc_Count
:= Unseen_Disc_Count
+ 1;
1419 Next_Discriminant
(Disc
);
1422 Seen_Discs
:= New_Elmt_List
;
1424 -- Loop through each of the discriminants and check each expression
1425 -- associated with an anonymous access discriminant.
1427 -- When named associations occur in the return aggregate then
1428 -- discriminants can be in any order, so we need to ensure we do
1429 -- not continue to loop when all discriminants have been seen.
1432 while Present
(Assoc
)
1433 and then (Present
(Disc
) or else Assoc_Present
)
1434 and then Unseen_Disc_Count
> 0
1436 -- Handle named associations by searching through the names of
1437 -- the relevant discriminant components.
1440 in N_Component_Association | N_Discriminant_Association
1442 Assoc_Expr
:= Expression
(Assoc
);
1443 Assoc_Present
:= True;
1445 -- We currently don't handle box initialized discriminants,
1446 -- however, since default initialized anonymous access
1447 -- discriminants are a corner case, this is ok for now ???
1449 if Nkind
(Assoc
) = N_Component_Association
1450 and then Box_Present
(Assoc
)
1452 if Nkind
(First_Selector
(Assoc
)) = N_Others_Choice
then
1453 Unseen_Disc_Count
:= 0;
1456 -- When others is present we must identify a discriminant we
1457 -- haven't already seen so as to get the appropriate type for
1458 -- the static accessibility check.
1460 -- This works because all components within an others clause
1461 -- must have the same type.
1463 elsif Nkind
(First_Selector
(Assoc
)) = N_Others_Choice
then
1466 Outer
: while Present
(Disc
) loop
1468 Current_Seen_Disc
: Elmt_Id
;
1470 -- Move through the list of identified discriminants
1472 Current_Seen_Disc
:= First_Elmt
(Seen_Discs
);
1473 while Present
(Current_Seen_Disc
) loop
1474 -- Exit the loop when we found a match
1477 Chars
(Node
(Current_Seen_Disc
)) = Chars
(Disc
);
1479 Next_Elmt
(Current_Seen_Disc
);
1482 -- When we have exited the above loop without finding
1483 -- a match then we know that Disc has not been seen.
1485 exit Outer
when No
(Current_Seen_Disc
);
1488 Next_Discriminant
(Disc
);
1491 -- If we got to an others clause with a non-zero
1492 -- discriminant count there must be a discriminant left to
1495 pragma Assert
(Present
(Disc
));
1497 -- Set the unseen discriminant count to zero because we know
1498 -- an others clause sets all remaining components of an
1501 Unseen_Disc_Count
:= 0;
1503 -- Move through each of the selectors in the named association
1504 -- and obtain a discriminant for accessibility checking if one
1505 -- is referenced in the list. Also track which discriminants
1506 -- are referenced for the purpose of handling an others clause.
1510 Assoc_Choice
: Node_Id
;
1511 Curr_Disc
: Node_Id
;
1515 Curr_Disc
:= First_Disc
;
1516 while Present
(Curr_Disc
) loop
1517 -- Check each of the choices in the associations for a
1518 -- match to the name of the current discriminant.
1520 Assoc_Choice
:= First_Selector
(Assoc
);
1521 while Present
(Assoc_Choice
) loop
1522 -- When the name matches we track that we have seen
1523 -- the discriminant, but instead of exiting the
1524 -- loop we continue iterating to make sure all the
1525 -- discriminants within the named association get
1528 if Chars
(Assoc_Choice
) = Chars
(Curr_Disc
) then
1529 Append_Elmt
(Curr_Disc
, Seen_Discs
);
1532 Unseen_Disc_Count
:= Unseen_Disc_Count
- 1;
1535 Next
(Assoc_Choice
);
1538 Next_Discriminant
(Curr_Disc
);
1543 -- Unwrap the associated expression if we are looking at a default
1544 -- initialized type declaration. In this case Assoc is not really
1545 -- an association, but a component declaration. Should Assoc be
1546 -- renamed in some way to be more clear ???
1548 -- This occurs when the return object does not initialize
1549 -- discriminant and instead relies on the type declaration for
1550 -- their supplied values.
1552 elsif Nkind
(Assoc
) in N_Entity
1553 and then Ekind
(Assoc
) = E_Discriminant
1555 Append_Elmt
(Disc
, Seen_Discs
);
1557 Assoc_Expr
:= Discriminant_Default_Value
(Assoc
);
1558 Unseen_Disc_Count
:= Unseen_Disc_Count
- 1;
1560 -- Otherwise, there is nothing to do because Assoc is an
1561 -- expression within the return aggregate itself.
1564 Append_Elmt
(Disc
, Seen_Discs
);
1566 Assoc_Expr
:= Assoc
;
1567 Unseen_Disc_Count
:= Unseen_Disc_Count
- 1;
1570 -- Check the accessibility level of the expression when the
1571 -- discriminant is of an anonymous access type.
1573 if Present
(Assoc_Expr
)
1574 and then Present
(Disc
)
1575 and then Ekind
(Etype
(Disc
)) = E_Anonymous_Access_Type
1577 -- We disable the check when we have a tagged return type and
1578 -- the associated expression for the discriminant is a formal
1579 -- parameter since the check would require us to compare the
1580 -- accessibility level of Assoc_Expr to the level of the
1581 -- Extra_Accessibility_Of_Result of the function - which is
1582 -- currently disabled for functions with tagged return types.
1583 -- This may change in the future ???
1585 -- See Needs_Result_Accessibility_Level for details.
1588 (No
(Extra_Accessibility_Of_Result
(Scope_Id
))
1589 and then Is_Formal_Of_Current_Function
(Assoc_Expr
)
1590 and then Is_Tagged_Type
(Etype
(Scope_Id
)))
1592 -- Generate a dynamic check based on the extra accessibility of
1593 -- the result or the scope of the current function.
1597 Left_Opnd
=> Accessibility_Level
1598 (Expr
=> Assoc_Expr
,
1599 Level
=> Dynamic_Level
,
1600 In_Return_Context
=> True),
1602 (if Present
(Extra_Accessibility_Of_Result
(Scope_Id
))
1604 -- When Assoc_Expr is a formal we have to look at the
1605 -- extra accessibility-level formal associated with
1608 and then Is_Formal_Of_Current_Function
(Assoc_Expr
)
1611 (Extra_Accessibility_Of_Result
(Scope_Id
), Loc
)
1613 -- Otherwise, we compare the level of Assoc_Expr to the
1614 -- scope of the current function.
1617 Make_Integer_Literal
1618 (Loc
, Scope_Depth
(Scope
(Scope_Id
)))));
1620 Insert_Before_And_Analyze
(Return_Stmt
,
1621 Make_Raise_Program_Error
(Loc
,
1622 Condition
=> Check_Cond
,
1623 Reason
=> PE_Accessibility_Check_Failed
));
1625 -- If constant folding has happened on the condition for the
1626 -- generated error, then warn about it being unconditional when
1627 -- we know an error will be raised.
1629 if Nkind
(Check_Cond
) = N_Identifier
1630 and then Entity
(Check_Cond
) = Standard_True
1633 ("access discriminant in return object would be a dangling"
1634 & " reference", Return_Stmt
);
1638 -- Iterate over the discriminants, except when we have encountered
1639 -- a named association since the discriminant order becomes
1640 -- irrelevant in that case.
1642 if not Assoc_Present
then
1643 Next_Discriminant
(Disc
);
1646 -- Iterate over associations
1648 if not Is_List_Member
(Assoc
) then
1651 Nlists
.Next
(Assoc
);
1654 end Check_Return_Construct_Accessibility
;
1656 -------------------------------
1657 -- Deepest_Type_Access_Level --
1658 -------------------------------
1660 function Deepest_Type_Access_Level
1662 Allow_Alt_Model
: Boolean := True) return Uint
1665 if Ekind
(Typ
) = E_Anonymous_Access_Type
1666 and then not Is_Local_Anonymous_Access
(Typ
)
1667 and then Nkind
(Associated_Node_For_Itype
(Typ
)) = N_Object_Declaration
1669 -- No_Dynamic_Accessibility_Checks override for alternative
1670 -- accessibility model.
1673 and then No_Dynamic_Accessibility_Checks_Enabled
(Typ
)
1675 return Type_Access_Level
(Typ
, Allow_Alt_Model
);
1678 -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
1682 Scope_Depth
(Enclosing_Dynamic_Scope
1683 (Defining_Identifier
1684 (Associated_Node_For_Itype
(Typ
))));
1686 -- For generic formal type, return Int'Last (infinite).
1687 -- See comment preceding Is_Generic_Type call in Type_Access_Level.
1689 elsif Is_Generic_Type
(Root_Type
(Typ
)) then
1690 return UI_From_Int
(Int
'Last);
1693 return Type_Access_Level
(Typ
, Allow_Alt_Model
);
1695 end Deepest_Type_Access_Level
;
1697 -----------------------------------
1698 -- Effective_Extra_Accessibility --
1699 -----------------------------------
1701 function Effective_Extra_Accessibility
(Id
: Entity_Id
) return Entity_Id
is
1703 if Present
(Renamed_Object
(Id
))
1704 and then Is_Entity_Name
(Renamed_Object
(Id
))
1706 return Effective_Extra_Accessibility
(Entity
(Renamed_Object
(Id
)));
1708 return Extra_Accessibility
(Id
);
1710 end Effective_Extra_Accessibility
;
1712 -------------------------------
1713 -- Get_Dynamic_Accessibility --
1714 -------------------------------
1716 function Get_Dynamic_Accessibility
(E
: Entity_Id
) return Entity_Id
is
1718 -- When minimum accessibility is set for E then we utilize it - except
1719 -- in a few edge cases like the expansion of select statements where
1720 -- generated subprogram may attempt to unnecessarily use a minimum
1721 -- accessibility object declared outside of scope.
1723 -- To avoid these situations where expansion may get complex we verify
1724 -- that the minimum accessibility object is within scope.
1727 and then Present
(Minimum_Accessibility
(E
))
1728 and then In_Open_Scopes
(Scope
(Minimum_Accessibility
(E
)))
1730 return Minimum_Accessibility
(E
);
1733 return Extra_Accessibility
(E
);
1734 end Get_Dynamic_Accessibility
;
1736 -----------------------
1737 -- Has_Access_Values --
1738 -----------------------
1740 function Has_Access_Values
(T
: Entity_Id
) return Boolean
1742 Typ
: constant Entity_Id
:= Underlying_Type
(T
);
1745 -- Case of a private type which is not completed yet. This can only
1746 -- happen in the case of a generic formal type appearing directly, or
1747 -- as a component of the type to which this function is being applied
1748 -- at the top level. Return False in this case, since we certainly do
1749 -- not know that the type contains access types.
1754 elsif Is_Access_Type
(Typ
) then
1757 elsif Is_Array_Type
(Typ
) then
1758 return Has_Access_Values
(Component_Type
(Typ
));
1760 elsif Is_Record_Type
(Typ
) then
1765 -- Loop to check components
1767 Comp
:= First_Component_Or_Discriminant
(Typ
);
1768 while Present
(Comp
) loop
1770 -- Check for access component, tag field does not count, even
1771 -- though it is implemented internally using an access type.
1773 if Has_Access_Values
(Etype
(Comp
))
1774 and then Chars
(Comp
) /= Name_uTag
1779 Next_Component_Or_Discriminant
(Comp
);
1788 end Has_Access_Values
;
1790 ---------------------------------------
1791 -- Has_Anonymous_Access_Discriminant --
1792 ---------------------------------------
1794 function Has_Anonymous_Access_Discriminant
(Typ
: Entity_Id
) return Boolean
1799 if not Has_Discriminants
(Typ
) then
1803 Disc
:= First_Discriminant
(Typ
);
1804 while Present
(Disc
) loop
1805 if Ekind
(Etype
(Disc
)) = E_Anonymous_Access_Type
then
1809 Next_Discriminant
(Disc
);
1813 end Has_Anonymous_Access_Discriminant
;
1815 --------------------------------------------
1816 -- Has_Unconstrained_Access_Discriminants --
1817 --------------------------------------------
1819 function Has_Unconstrained_Access_Discriminants
1820 (Subtyp
: Entity_Id
) return Boolean
1825 if Has_Discriminants
(Subtyp
)
1826 and then not Is_Constrained
(Subtyp
)
1828 Discr
:= First_Discriminant
(Subtyp
);
1829 while Present
(Discr
) loop
1830 if Ekind
(Etype
(Discr
)) = E_Anonymous_Access_Type
then
1834 Next_Discriminant
(Discr
);
1839 end Has_Unconstrained_Access_Discriminants
;
1841 --------------------------------
1842 -- Is_Anonymous_Access_Actual --
1843 --------------------------------
1845 function Is_Anonymous_Access_Actual
(N
: Node_Id
) return Boolean is
1848 if Ekind
(Etype
(N
)) /= E_Anonymous_Access_Type
then
1854 and then Nkind
(Par
) in N_Case_Expression
1856 | N_Parameter_Association
1858 Par
:= Parent
(Par
);
1860 return Nkind
(Par
) in N_Subprogram_Call
;
1861 end Is_Anonymous_Access_Actual
;
1863 --------------------------------------
1864 -- Is_Special_Aliased_Formal_Access --
1865 --------------------------------------
1867 function Is_Special_Aliased_Formal_Access
1869 In_Return_Context
: Boolean := False) return Boolean
1871 Scop
: constant Entity_Id
:= Current_Subprogram
;
1873 -- Verify the expression is an access reference to 'Access within a
1874 -- return statement as this is the only time an explicitly aliased
1875 -- formal has different semantics.
1877 if Nkind
(Exp
) /= N_Attribute_Reference
1878 or else Get_Attribute_Id
(Attribute_Name
(Exp
)) /= Attribute_Access
1879 or else not (In_Return_Value
(Exp
)
1880 or else In_Return_Context
)
1881 or else not Needs_Result_Accessibility_Level
(Scop
)
1886 -- Check if the prefix of the reference is indeed an explicitly aliased
1887 -- formal parameter for the function Scop. Additionally, we must check
1888 -- that Scop returns an anonymous access type, otherwise the special
1889 -- rules dictating a need for a dynamic check are not in effect.
1891 return Is_Entity_Name
(Prefix
(Exp
))
1892 and then Is_Explicitly_Aliased
(Entity
(Prefix
(Exp
)));
1893 end Is_Special_Aliased_Formal_Access
;
1895 --------------------------------------
1896 -- Needs_Result_Accessibility_Level --
1897 --------------------------------------
1899 function Needs_Result_Accessibility_Level
1900 (Func_Id
: Entity_Id
) return Boolean
1902 Func_Typ
: constant Entity_Id
:= Underlying_Type
(Etype
(Func_Id
));
1904 function Has_Unconstrained_Access_Discriminant_Component
1905 (Comp_Typ
: Entity_Id
) return Boolean;
1906 -- Returns True if any component of the type has an unconstrained access
1909 -----------------------------------------------------
1910 -- Has_Unconstrained_Access_Discriminant_Component --
1911 -----------------------------------------------------
1913 function Has_Unconstrained_Access_Discriminant_Component
1914 (Comp_Typ
: Entity_Id
) return Boolean
1917 if not Is_Limited_Type
(Comp_Typ
) then
1920 -- Only limited types can have access discriminants with
1923 elsif Has_Unconstrained_Access_Discriminants
(Comp_Typ
) then
1926 elsif Is_Array_Type
(Comp_Typ
) then
1927 return Has_Unconstrained_Access_Discriminant_Component
1928 (Underlying_Type
(Component_Type
(Comp_Typ
)));
1930 elsif Is_Record_Type
(Comp_Typ
) then
1935 Comp
:= First_Component
(Comp_Typ
);
1936 while Present
(Comp
) loop
1937 if Has_Unconstrained_Access_Discriminant_Component
1938 (Underlying_Type
(Etype
(Comp
)))
1943 Next_Component
(Comp
);
1949 end Has_Unconstrained_Access_Discriminant_Component
;
1951 Disable_Tagged_Cases
: constant Boolean := True;
1952 -- Flag used to temporarily disable a "True" result for tagged types.
1953 -- See comments further below for details.
1955 -- Start of processing for Needs_Result_Accessibility_Level
1958 -- False if completion unavailable, which can happen when we are
1959 -- analyzing an abstract subprogram or if the subprogram has
1960 -- delayed freezing.
1962 if No
(Func_Typ
) then
1965 -- False if not a function, also handle enum-lit renames case
1967 elsif Func_Typ
= Standard_Void_Type
1968 or else Is_Scalar_Type
(Func_Typ
)
1972 -- Handle a corner case, a cross-dialect subp renaming. For example,
1973 -- an Ada 2012 renaming of an Ada 2005 subprogram. This can occur when
1974 -- an Ada 2005 (or earlier) unit references predefined run-time units.
1976 elsif Present
(Alias
(Func_Id
)) then
1978 -- Unimplemented: a cross-dialect subp renaming which does not set
1979 -- the Alias attribute (e.g., a rename of a dereference of an access
1980 -- to subprogram value). ???
1982 return Present
(Extra_Accessibility_Of_Result
(Alias
(Func_Id
)));
1984 -- Remaining cases require Ada 2012 mode, unless they are dispatching
1985 -- operations, since they may be overridden by Ada_2012 primitives.
1987 elsif Ada_Version
< Ada_2012
1988 and then not Is_Dispatching_Operation
(Func_Id
)
1992 -- Handle the situation where a result is an anonymous access type
1993 -- RM 3.10.2 (10.3/3).
1995 elsif Ekind
(Func_Typ
) = E_Anonymous_Access_Type
then
1998 -- In the case of, say, a null tagged record result type, the need for
1999 -- this extra parameter might not be obvious so this function returns
2000 -- True for all tagged types for compatibility reasons.
2002 -- A function with, say, a tagged null controlling result type might
2003 -- be overridden by a primitive of an extension having an access
2004 -- discriminant and the overrider and overridden must have compatible
2005 -- calling conventions (including implicitly declared parameters).
2007 -- Similarly, values of one access-to-subprogram type might designate
2008 -- both a primitive subprogram of a given type and a function which is,
2009 -- for example, not a primitive subprogram of any type. Again, this
2010 -- requires calling convention compatibility. It might be possible to
2011 -- solve these issues by introducing wrappers, but that is not the
2012 -- approach that was chosen.
2014 -- Note: Despite the reasoning noted above, the extra accessibility
2015 -- parameter for tagged types is disabled for performance reasons.
2017 elsif Is_Tagged_Type
(Func_Typ
) then
2018 return not Disable_Tagged_Cases
;
2020 elsif Has_Unconstrained_Access_Discriminants
(Func_Typ
) then
2023 elsif Has_Unconstrained_Access_Discriminant_Component
(Func_Typ
) then
2026 -- False for all other cases
2031 end Needs_Result_Accessibility_Level
;
2033 ------------------------------------------
2034 -- Prefix_With_Safe_Accessibility_Level --
2035 ------------------------------------------
2037 function Prefix_With_Safe_Accessibility_Level
2039 Typ
: Entity_Id
) return Boolean
2041 P
: constant Node_Id
:= Prefix
(N
);
2042 Aname
: constant Name_Id
:= Attribute_Name
(N
);
2043 Attr_Id
: constant Attribute_Id
:= Get_Attribute_Id
(Aname
);
2044 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
2046 function Safe_Value_Conversions
return Boolean;
2047 -- Return False if the prefix has a value conversion of an array type
2049 ----------------------------
2050 -- Safe_Value_Conversions --
2051 ----------------------------
2053 function Safe_Value_Conversions
return Boolean is
2058 if Nkind
(PP
) in N_Selected_Component | N_Indexed_Component
then
2061 elsif Comes_From_Source
(PP
)
2062 and then Nkind
(PP
) in N_Type_Conversion
2063 | N_Unchecked_Type_Conversion
2064 and then Is_Array_Type
(Etype
(PP
))
2068 elsif Comes_From_Source
(PP
)
2069 and then Nkind
(PP
) = N_Qualified_Expression
2070 and then Is_Array_Type
(Etype
(PP
))
2071 and then Nkind
(Original_Node
(Expression
(PP
))) in
2072 N_Aggregate | N_Extension_Aggregate
2082 end Safe_Value_Conversions
;
2084 -- Start of processing for Prefix_With_Safe_Accessibility_Level
2087 -- No check required for unchecked and unrestricted access
2089 if Attr_Id
= Attribute_Unchecked_Access
2090 or else Attr_Id
= Attribute_Unrestricted_Access
2094 -- Check value conversions
2096 elsif Ekind
(Btyp
) = E_General_Access_Type
2097 and then not Safe_Value_Conversions
2103 end Prefix_With_Safe_Accessibility_Level
;
2105 -----------------------------
2106 -- Subprogram_Access_Level --
2107 -----------------------------
2109 function Subprogram_Access_Level
(Subp
: Entity_Id
) return Uint
is
2111 if Present
(Alias
(Subp
)) then
2112 return Subprogram_Access_Level
(Alias
(Subp
));
2114 return Scope_Depth
(Enclosing_Dynamic_Scope
(Subp
));
2116 end Subprogram_Access_Level
;
2118 --------------------------------
2119 -- Static_Accessibility_Level --
2120 --------------------------------
2122 function Static_Accessibility_Level
2124 Level
: Static_Accessibility_Level_Kind
;
2125 In_Return_Context
: Boolean := False) return Uint
2129 (Accessibility_Level
(Expr
, Level
, In_Return_Context
));
2130 end Static_Accessibility_Level
;
2132 -----------------------
2133 -- Type_Access_Level --
2134 -----------------------
2136 function Type_Access_Level
2138 Allow_Alt_Model
: Boolean := True;
2139 Assoc_Ent
: Entity_Id
:= Empty
) return Uint
2141 Btyp
: Entity_Id
:= Base_Type
(Typ
);
2142 Def_Ent
: Entity_Id
;
2145 -- Ada 2005 (AI-230): For most cases of anonymous access types, we
2146 -- simply use the level where the type is declared. This is true for
2147 -- stand-alone object declarations, and for anonymous access types
2148 -- associated with components the level is the same as that of the
2149 -- enclosing composite type. However, special treatment is needed for
2150 -- the cases of access parameters, return objects of an anonymous access
2151 -- type, and, in Ada 95, access discriminants of limited types.
2153 if Is_Access_Type
(Btyp
) then
2154 if Ekind
(Btyp
) = E_Anonymous_Access_Type
then
2155 -- No_Dynamic_Accessibility_Checks restriction override for
2156 -- alternative accessibility model.
2159 and then No_Dynamic_Accessibility_Checks_Enabled
(Btyp
)
2161 -- In the -gnatd_b model, the level of an anonymous access
2162 -- type is always that of the designated type.
2164 if Debug_Flag_Underscore_B
then
2165 return Type_Access_Level
2166 (Designated_Type
(Btyp
), Allow_Alt_Model
);
2169 -- When an anonymous access type's Assoc_Ent is specified,
2170 -- calculate the result based on the general accessibility
2173 -- We would like to use Associated_Node_For_Itype here instead,
2174 -- but in some cases it is not fine grained enough ???
2176 if Present
(Assoc_Ent
) then
2177 return Static_Accessibility_Level
2178 (Assoc_Ent
, Object_Decl_Level
);
2181 -- Otherwise take the context of the anonymous access type into
2184 -- Obtain the defining entity for the internally generated
2185 -- anonymous access type.
2187 Def_Ent
:= Defining_Entity_Or_Empty
2188 (Associated_Node_For_Itype
(Typ
));
2190 if Present
(Def_Ent
) then
2191 -- When the defining entity is a subprogram then we know the
2192 -- anonymous access type Typ has been generated to either
2193 -- describe an anonymous access type formal or an anonymous
2194 -- access result type.
2196 -- Since we are only interested in the formal case, avoid
2197 -- the anonymous access result type.
2199 if Is_Subprogram
(Def_Ent
)
2200 and then not (Ekind
(Def_Ent
) = E_Function
2201 and then Etype
(Def_Ent
) = Typ
)
2203 -- When the type comes from an anonymous access
2204 -- parameter, the level is that of the subprogram
2207 return Scope_Depth
(Def_Ent
);
2209 -- When the type is an access discriminant, the level is
2210 -- that of the type.
2212 elsif Ekind
(Def_Ent
) = E_Discriminant
then
2213 return Scope_Depth
(Scope
(Def_Ent
));
2217 -- If the type is a nonlocal anonymous access type (such as for
2218 -- an access parameter) we treat it as being declared at the
2219 -- library level to ensure that names such as X.all'access don't
2220 -- fail static accessibility checks.
2222 elsif not Is_Local_Anonymous_Access
(Typ
) then
2223 return Scope_Depth
(Standard_Standard
);
2225 -- If this is a return object, the accessibility level is that of
2226 -- the result subtype of the enclosing function. The test here is
2227 -- little complicated, because we have to account for extended
2228 -- return statements that have been rewritten as blocks, in which
2229 -- case we have to find and the Is_Return_Object attribute of the
2230 -- itype's associated object. It would be nice to find a way to
2231 -- simplify this test, but it doesn't seem worthwhile to add a new
2232 -- flag just for purposes of this test. ???
2234 elsif Ekind
(Scope
(Btyp
)) = E_Return_Statement
2237 and then Nkind
(Associated_Node_For_Itype
(Btyp
)) =
2238 N_Object_Declaration
2239 and then Is_Return_Object
2240 (Defining_Identifier
2241 (Associated_Node_For_Itype
(Btyp
))))
2247 Scop
:= Scope
(Scope
(Btyp
));
2248 while Present
(Scop
) loop
2249 exit when Ekind
(Scop
) = E_Function
;
2250 Scop
:= Scope
(Scop
);
2253 -- Treat the return object's type as having the level of the
2254 -- function's result subtype (as per RM05-6.5(5.3/2)).
2256 return Type_Access_Level
(Etype
(Scop
), Allow_Alt_Model
);
2261 Btyp
:= Root_Type
(Btyp
);
2263 -- The accessibility level of anonymous access types associated with
2264 -- discriminants is that of the current instance of the type, and
2265 -- that's deeper than the type itself (AARM 3.10.2 (12.3.21)).
2267 -- AI-402: access discriminants have accessibility based on the
2268 -- object rather than the type in Ada 2005, so the above paragraph
2271 -- ??? Needs completion with rules from AI-416
2273 if Ada_Version
<= Ada_95
2274 and then Ekind
(Typ
) = E_Anonymous_Access_Type
2275 and then Present
(Associated_Node_For_Itype
(Typ
))
2276 and then Nkind
(Associated_Node_For_Itype
(Typ
)) =
2277 N_Discriminant_Specification
2279 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
)) + 1;
2283 -- Return library level for a generic formal type. This is done because
2284 -- RM(10.3.2) says that "The statically deeper relationship does not
2285 -- apply to ... a descendant of a generic formal type". Rather than
2286 -- checking at each point where a static accessibility check is
2287 -- performed to see if we are dealing with a formal type, this rule is
2288 -- implemented by having Type_Access_Level and Deepest_Type_Access_Level
2289 -- return extreme values for a formal type; Deepest_Type_Access_Level
2290 -- returns Int'Last. By calling the appropriate function from among the
2291 -- two, we ensure that the static accessibility check will pass if we
2292 -- happen to run into a formal type. More specifically, we should call
2293 -- Deepest_Type_Access_Level instead of Type_Access_Level whenever the
2294 -- call occurs as part of a static accessibility check and the error
2295 -- case is the case where the type's level is too shallow (as opposed
2298 if Is_Generic_Type
(Root_Type
(Btyp
)) then
2299 return Scope_Depth
(Standard_Standard
);
2302 return Scope_Depth
(Enclosing_Dynamic_Scope
(Btyp
));
2303 end Type_Access_Level
;