mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-06 02:10:29 +08:00
Code Issues Packages Projects Releases Wiki Activity

ada: Accessibility code reorganization and bug fixes

Browse Source 
This patch performs a large reorganization of accessibility related sources,
and also corrects some latent issues with accessibility checks - namely the
calculation of accessibility levels for expanded iterators and type
conversions.

gcc/ada/
	* accessibility.adb, accessibility.ads
	(Accessibility_Message): Moved from sem_attr.
	(Apply_Accessibility_Check): Moved from checks.
	(Apply_Accessibility_Check_For_Allocator): Moved from exp_ch4 and
	renamed
	(Check_Return_Construct_Accessibility): Moved from sem_ch6.
	(Innermost_Master_Scope_Depth): Moved from sem_util. Add condition
	to detect expanded iterators.
	(Prefix_With_Safe_Accessibility_Level): Moved from sem_attr.
	(Static_Accessibility_Level): Moved from sem_util.
	(Has_Unconstrained_Access_Discriminants): Likewise.
	(Has_Anonymous_Access_Discriminant): Likewise.
	(Is_Anonymous_Access_Actual): Likewise.
	(Is_Special_Aliased_Formal_Access): Likewise.
	(Needs_Result_Accessibility_Level): Likewise.
	(Subprogram_Access_Level): Likewise.
	(Type_Access_Level): Likewise.
	(Deepest_Type_Access_Level): Likewise.
	(Effective_Extra_Accessibility): Likewise.
	(Get_Dynamic_Accessibility): Likewise.
	(Has_Access_Values): Likewise.
	(Accessibility_Level): Likewise.
	* exp_attr.adb (Access_Cases): Obtain the proper enclosing object
	which applies to a given 'Access by looking through type
	conversions.
	* exp_ch4.adb (Apply_Accessibility_Check): Moved to accessibility.
	* exp_ch5.adb: Likewise.
	* exp_ch6.adb: Likewise.
	* exp_ch9.adb: Likewise.
	* exp_disp.adb: Likewise.
	* gen_il-fields.ads: Add new flag Comes_From_Iterator.
	* gen_il-gen-gen_nodes.adb: Add new flag Comes_From_Iterator for
	N_Object_Renaming_Declaration.
	* sem_ch5.adb (Analyze_Iterator_Specification): Mark object
	renamings resulting from iterator expansion with the new flag
	Comes_From_Iterator.
	* sem_aggr.adb (Resolve_Container_Aggregate): Refine test.
	* sem_ch13.adb: Add dependence on the accessibility package.
	* sem_ch3.adb: Likewise.
	* sem_ch4.adb: Likewise.
	* sem_ch9.adb: Likewise.
	* sem_res.adb: Likewise.
	* sem_warn.adb: Likewise.
	* exp_ch3.adb: Likewise.
	* sem_attr.adb (Accessibility_Message): Moved to accessibility.
	(Prefix_With_Safe_Accessibility_Level): Likewise.
	* checks.adb, checks.ads (Apply_Accessibility_Check): Likewise.
	* sem_ch6.adb (Check_Return_Construct_Accessibility): Likewise.
	* sem_util.adb, sem_util.ads
	(Accessibility_Level): Likewise.
	(Deepest_Type_Access_Level): Likewise.
	(Effective_Extra_Accessibility): Likewise.
	(Get_Dynamic_Accessibility): Likewise.
	(Has_Access_Values): Likewise.
	(Has_Anonymous_Access_Discriminant): Likewise.
	(Static_Accessibility_Level): Likewise.
	(Has_Unconstrained_Access_Discriminants): Likewise.
	(Is_Anonymous_Access_Actual): Likewise.
	(Is_Special_Aliased_Formal_Access): Likewise.
	(Needs_Result_Accessibility_Level): Likewise.
	(Subprogram_Access_Level): Likewise.
	(Type_Access_Level): Likewise.
	* sinfo.ads: Document new flag Comes_From_Iterator.
	* gcc-interface/Make-lang.in: Add entry for new Accessibility package.
This commit is contained in:
Justin Squirek 2022-11-17 15:34:57 +00:00 committed by Marc Poulhiès
parent c690f116b6
commit f459afaa67
27 changed files with 2577 additions and 2414 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2305
gcc/ada/accessibility.adb Normal file
View File

File diff suppressed because it is too large Load Diff

222
gcc/ada/accessibility.ads Normal file
View File

@ -0,0 +1,222 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- A C C E S S I B I L I T Y --
-- --
-- S p e c --
-- --
-- Copyright (C) 2022-2022, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Accessibility level and check generation routines
with Types; use Types;
with Uintp; use Uintp;
package Accessibility is
procedure Accessibility_Message (N : Node_Id; Typ : Entity_Id);
-- Error, or warning within an instance, if the static accessibility
-- rules of 3.10.2 are violated.
type Accessibility_Level_Kind is
(Dynamic_Level,
Object_Decl_Level,
Zero_On_Dynamic_Level);
-- Accessibility_Level_Kind is an enumerated type which captures the
-- different modes in which an accessibility level could be obtained for
-- a given expression.
-- When in the context of the function Accessibility_Level,
-- Accessibility_Level_Kind signals what type of accessibility level to
-- obtain. For example, when Level is Dynamic_Level, a defining identifier
-- associated with a SAOOAAT may be returned or an N_Integer_Literal node.
-- When the level is Object_Decl_Level, an N_Integer_Literal node is
-- returned containing the level of the declaration of the object if
-- relevant (be it a SAOOAAT or otherwise). Finally, Zero_On_Dynamic_Level
-- returns library level for all cases where the accessibility level is
-- dynamic (used to bypass static accessibility checks in dynamic cases).
function Accessibility_Level
(Expr : Node_Id;
Level : Accessibility_Level_Kind;
In_Return_Context : Boolean := False;
Allow_Alt_Model : Boolean := True) return Node_Id;
-- Centralized accessibility level calculation routine for finding the
-- accessibility level of a given expression Expr.
-- In_Return_Context forces the Accessibility_Level calculations to be
-- carried out "as if" Expr existed in a return value. This is useful for
-- calculating the accessibility levels for discriminant associations
-- and return aggregates.
-- The Allow_Alt_Model parameter allows the alternative level calculation
-- under the restriction No_Dynamic_Accessibility_Checks to be performed.
procedure Apply_Accessibility_Check
(N : Node_Id;
Typ : Entity_Id;
Insert_Node : Node_Id);
-- Given a name N denoting an access parameter, emits a run-time
-- accessibility check (if necessary), checking that the level of
-- the object denoted by the access parameter is not deeper than the
-- level of the type Typ. Program_Error is raised if the check fails.
-- Insert_Node indicates the node where the check should be inserted.
procedure Apply_Accessibility_Check_For_Allocator
(N : Node_Id;
Exp : Node_Id;
Ref : Node_Id;
Built_In_Place : Boolean := False);
-- Ada 2005 (AI-344): For an allocator with a class-wide designated
-- type, generate an accessibility check to verify that the level of the
-- type of the created object is not deeper than the level of the access
-- type. If the type of the qualified expression is class-wide, then
-- always generate the check (except in the case where it is known to be
-- unnecessary, see comment below). Otherwise, only generate the check
-- if the level of the qualified expression type is statically deeper
-- than the access type.
--
-- Although the static accessibility will generally have been performed
-- as a legality check, it won't have been done in cases where the
-- allocator appears in generic body, so a run-time check is needed in
-- general. One special case is when the access type is declared in the
-- same scope as the class-wide allocator, in which case the check can
-- never fail, so it need not be generated.
--
-- As an open issue, there seem to be cases where the static level
-- associated with the class-wide object's underlying type is not
-- sufficient to perform the proper accessibility check, such as for
-- allocators in nested subprograms or accept statements initialized by
-- class-wide formals when the actual originates outside at a deeper
-- static level. The nested subprogram case might require passing
-- accessibility levels along with class-wide parameters, and the task
-- case seems to be an actual gap in the language rules that needs to
-- be fixed by the ARG. ???
procedure Check_Return_Construct_Accessibility
(Return_Stmt : Node_Id;
Stm_Entity : Entity_Id);
-- Apply legality rule of 6.5 (5.9) to the access discriminants of an
-- aggregate in a return statement.
function Deepest_Type_Access_Level
(Typ : Entity_Id;
Allow_Alt_Model : Boolean := True) return Uint;
-- Same as Type_Access_Level, except that if the type is the type of an Ada
-- 2012 stand-alone object of an anonymous access type, then return the
-- static accessibility level of the object. In that case, the dynamic
-- accessibility level of the object may take on values in a range. The low
-- bound of that range is returned by Type_Access_Level; this function
-- yields the high bound of that range. Also differs from Type_Access_Level
-- in the case of a descendant of a generic formal type (returns Int'Last
-- instead of 0).
-- The Allow_Alt_Model parameter allows the alternative level calculation
-- under the restriction No_Dynamic_Accessibility_Checks to be performed.
function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id;
-- Same as Einfo.Extra_Accessibility except thtat object renames
-- are looked through.
function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id;
-- Obtain the accessibility level for a given entity formal taking into
-- account both extra and minimum accessibility.
function Has_Access_Values (T : Entity_Id) return Boolean;
-- Returns true if the underlying type of T is an access type, or has a
-- component (at any recursive level) that is an access type. This is a
-- conservative predicate, if it is not known whether or not T contains
-- access values (happens for generic formals in some cases), then False is
-- returned. Note that tagged types return False. Even though the tag is
-- implemented as an access type internally, this function tests only for
-- access types known to the programmer. See also Has_Tagged_Component.
function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean;
-- Returns True if Typ has one or more anonymous access discriminants
function Prefix_With_Safe_Accessibility_Level
(N : Node_Id;
Typ : Entity_Id) return Boolean;
-- Return True if the prefix does not have a value conversion of an
-- array because a value conversion is like an aggregate with respect
-- to determining accessibility level (RM 3.10.2); even if evaluation
-- of a value conversion is guaranteed to not create a new object,
-- accessibility rules are defined as if it might.
subtype Static_Accessibility_Level_Kind
is Accessibility_Level_Kind range Object_Decl_Level
.. Zero_On_Dynamic_Level;
-- Restrict the reange of Accessibility_Level_Kind to be non-dynamic for
-- use in the static version of Accessibility_Level below.
function Static_Accessibility_Level
(Expr : Node_Id;
Level : Static_Accessibility_Level_Kind;
In_Return_Context : Boolean := False) return Uint;
-- Overloaded version of Accessibility_Level which returns a universal
-- integer for use in compile-time checking. Note: Level is restricted to
-- be non-dynamic.
function Has_Unconstrained_Access_Discriminants
(Subtyp : Entity_Id) return Boolean;
-- Returns True if the given subtype is unconstrained and has one or more
-- access discriminants.
function Is_Anonymous_Access_Actual (N : Node_Id) return Boolean;
-- Determine if N is used as an actual for a call whose corresponding
-- formal is of an anonymous access type.
function Is_Special_Aliased_Formal_Access
(Exp : Node_Id;
In_Return_Context : Boolean := False) return Boolean;
-- Determines whether a dynamic check must be generated for explicitly
-- aliased formals within a function Scop for the expression Exp.
-- In_Return_Context forces Is_Special_Aliased_Formal_Access to assume
-- that Exp is within a return value which is useful for checking
-- expressions within discriminant associations of return objects.
-- More specially, Is_Special_Aliased_Formal_Access checks that Exp is a
-- 'Access attribute reference within a return statement where the ultimate
-- prefix is an aliased formal of Scop and that Scop returns an anonymous
-- access type. See RM 3.10.2 for more details.
function Needs_Result_Accessibility_Level
(Func_Id : Entity_Id) return Boolean;
-- Ada 2012 (AI05-0234): Return True if the function needs an implicit
-- parameter to identify the accessibility level of the function result
-- "determined by the point of call".
function Subprogram_Access_Level (Subp : Entity_Id) return Uint;
-- Return the accessibility level of the view denoted by Subp
function Type_Access_Level
(Typ : Entity_Id;
Allow_Alt_Model : Boolean := True;
Assoc_Ent : Entity_Id := Empty) return Uint;
-- Return the accessibility level of Typ
-- The Allow_Alt_Model parameter allows the alternative level calculation
-- under the restriction No_Dynamic_Accessibility_Checks to be performed.
-- Assoc_Ent allows for the optional specification of the entity associated
-- with Typ. This gets utilized mostly for anonymous access type
-- processing, where context matters in interpreting Typ's level.
end Accessibility;

113
gcc/ada/checks.adb
View File

@ -570,119 +570,6 @@ package body Checks is
Install_Null_Excluding_Check (P);
end Apply_Access_Check;
-------------------------------
-- Apply_Accessibility_Check --
-------------------------------
procedure Apply_Accessibility_Check
(N : Node_Id;
Typ : Entity_Id;
Insert_Node : Node_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Check_Cond : Node_Id;
Param_Ent : Entity_Id := Param_Entity (N);
Param_Level : Node_Id;
Type_Level : Node_Id;
begin
-- Verify we haven't tried to add a dynamic accessibility check when we
-- shouldn't.
pragma Assert (not No_Dynamic_Accessibility_Checks_Enabled (N));
if Ada_Version >= Ada_2012
and then No (Param_Ent)
and then Is_Entity_Name (N)
and then Ekind (Entity (N)) in E_Constant | E_Variable
and then Present (Effective_Extra_Accessibility (Entity (N)))
then
Param_Ent := Entity (N);
while Present (Renamed_Object (Param_Ent)) loop
-- Renamed_Object must return an Entity_Name here
-- because of preceding "Present (E_E_A (...))" test.
Param_Ent := Entity (Renamed_Object (Param_Ent));
end loop;
end if;
if Inside_A_Generic then
return;
-- Only apply the run-time check if the access parameter has an
-- associated extra access level parameter and when accessibility checks
-- are enabled.
elsif Present (Param_Ent)
and then Present (Get_Dynamic_Accessibility (Param_Ent))
and then not Accessibility_Checks_Suppressed (Param_Ent)
and then not Accessibility_Checks_Suppressed (Typ)
then
-- Obtain the parameter's accessibility level
Param_Level :=
New_Occurrence_Of (Get_Dynamic_Accessibility (Param_Ent), Loc);
-- Use the dynamic accessibility parameter for the function's result
-- when one has been created instead of statically referring to the
-- deepest type level so as to appropriatly handle the rules for
-- RM 3.10.2 (10.1/3).
if Ekind (Scope (Param_Ent)) = E_Function
and then In_Return_Value (N)
and then Ekind (Typ) = E_Anonymous_Access_Type
then
-- Associate the level of the result type to the extra result
-- accessibility parameter belonging to the current function.
if Present (Extra_Accessibility_Of_Result (Scope (Param_Ent))) then
Type_Level :=
New_Occurrence_Of
(Extra_Accessibility_Of_Result (Scope (Param_Ent)), Loc);
-- In Ada 2005 and earlier modes, a result extra accessibility
-- parameter is not generated and no dynamic check is performed.
else
return;
end if;
-- Otherwise get the type's accessibility level normally
else
Type_Level :=
Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ));
end if;
-- Raise Program_Error if the accessibility level of the access
-- parameter is deeper than the level of the target access type.
Check_Cond :=
Make_Op_Gt (Loc,
Left_Opnd => Param_Level,
Right_Opnd => Type_Level);
Insert_Action (Insert_Node,
Make_Raise_Program_Error (Loc,
Condition => Check_Cond,
Reason => PE_Accessibility_Check_Failed));
Analyze_And_Resolve (N);
-- If constant folding has happened on the condition for the
-- generated error, then warn about it being unconditional.
if Nkind (Check_Cond) = N_Identifier
and then Entity (Check_Cond) = Standard_True
then
Error_Msg_Warn := SPARK_Mode /= On;
Error_Msg_N ("accessibility check fails<<", N);
Error_Msg_N ("\Program_Error [<<", N);
end if;
end if;
end Apply_Accessibility_Check;
--------------------------------
-- Apply_Address_Clause_Check --
--------------------------------

10
gcc/ada/checks.ads
View File

@ -189,16 +189,6 @@ package Checks is
-- Determines whether an expression node requires a run-time access
-- check and if so inserts the appropriate run-time check.
procedure Apply_Accessibility_Check
(N : Node_Id;
Typ : Entity_Id;
Insert_Node : Node_Id);
-- Given a name N denoting an access parameter, emits a run-time
-- accessibility check (if necessary), checking that the level of
-- the object denoted by the access parameter is not deeper than the
-- level of the type Typ. Program_Error is raised if the check fails.
-- Insert_Node indicates the node where the check should be inserted.
procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id);
-- E is the entity for an object which has an address clause. If checks
-- are enabled, then this procedure generates a check that the specified

15
gcc/ada/exp_attr.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
@ -2215,13 +2216,25 @@ package body Exp_Attr is
-- Local declarations
Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);
Enc_Object : Node_Id := Enclosing_Object (Ref_Object);
-- Start of processing for Access_Cases
begin
Btyp_DDT := Designated_Type (Btyp);
-- When Enc_Object is a view conversion then RM 3.10.2 (9)
-- applies and we obtain the expression being converted.
-- Otherwise we do not dig any deeper since a conversion
-- might generate a copy and we can't assume it will be as
-- long-lived as the original.
while Nkind (Enc_Object) = N_Type_Conversion
and then Is_View_Conversion (Enc_Object)
loop
Enc_Object := Expression (Enc_Object);
end loop;
-- Handle designated types that come from the limited view
if From_Limited_With (Btyp_DDT)

1
gcc/ada/exp_ch3.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;

223
gcc/ada/exp_ch4.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
@ -33,7 +34,6 @@ with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Atag; use Exp_Atag;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
@ -560,219 +560,6 @@ package body Exp_Ch4 is
PtrT : constant Entity_Id := Etype (N);
DesigT : constant Entity_Id := Designated_Type (PtrT);
procedure Apply_Accessibility_Check
(Ref : Node_Id;
Built_In_Place : Boolean := False);
-- Ada 2005 (AI-344): For an allocator with a class-wide designated
-- type, generate an accessibility check to verify that the level of the
-- type of the created object is not deeper than the level of the access
-- type. If the type of the qualified expression is class-wide, then
-- always generate the check (except in the case where it is known to be
-- unnecessary, see comment below). Otherwise, only generate the check
-- if the level of the qualified expression type is statically deeper
-- than the access type.
--
-- Although the static accessibility will generally have been performed
-- as a legality check, it won't have been done in cases where the
-- allocator appears in generic body, so a run-time check is needed in
-- general. One special case is when the access type is declared in the
-- same scope as the class-wide allocator, in which case the check can
-- never fail, so it need not be generated.
--
-- As an open issue, there seem to be cases where the static level
-- associated with the class-wide object's underlying type is not
-- sufficient to perform the proper accessibility check, such as for
-- allocators in nested subprograms or accept statements initialized by
-- class-wide formals when the actual originates outside at a deeper
-- static level. The nested subprogram case might require passing
-- accessibility levels along with class-wide parameters, and the task
-- case seems to be an actual gap in the language rules that needs to
-- be fixed by the ARG. ???
-------------------------------
-- Apply_Accessibility_Check --
-------------------------------
procedure Apply_Accessibility_Check
(Ref : Node_Id;
Built_In_Place : Boolean := False)
is
Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT);
Cond : Node_Id;
Fin_Call : Node_Id;
Free_Stmt : Node_Id;
Obj_Ref : Node_Id;
Stmts : List_Id;
begin
if Ada_Version >= Ada_2005
and then Is_Class_Wide_Type (DesigT)
and then Tagged_Type_Expansion
and then not Scope_Suppress.Suppress (Accessibility_Check)
and then not No_Dynamic_Accessibility_Checks_Enabled (Ref)
and then
(Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
or else
(Is_Class_Wide_Type (Etype (Exp))
and then Scope (PtrT) /= Current_Scope))
then
-- If the allocator was built in place, Ref is already a reference
-- to the access object initialized to the result of the allocator
-- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
-- Remove_Side_Effects for cases where the build-in-place call may
-- still be the prefix of the reference (to avoid generating
-- duplicate calls). Otherwise, it is the entity associated with
-- the object containing the address of the allocated object.
if Built_In_Place then
Remove_Side_Effects (Ref);
Obj_Ref := New_Copy_Tree (Ref);
else
Obj_Ref := New_Occurrence_Of (Ref, Loc);
end if;
-- For access to interface types we must generate code to displace
-- the pointer to the base of the object since the subsequent code
-- references components located in the TSD of the object (which
-- is associated with the primary dispatch table --see a-tags.ads)
-- and also generates code invoking Free, which requires also a
-- reference to the base of the unallocated object.
if Is_Interface (DesigT) and then Tagged_Type_Expansion then
Obj_Ref :=
Unchecked_Convert_To (Etype (Obj_Ref),
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Base_Address), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address),
New_Copy_Tree (Obj_Ref)))));
end if;
-- Step 1: Create the object clean up code
Stmts := New_List;
-- Deallocate the object if the accessibility check fails. This
-- is done only on targets or profiles that support deallocation.
-- Free (Obj_Ref);
if RTE_Available (RE_Free) then
Free_Stmt := Make_Free_Statement (Loc, New_Copy_Tree (Obj_Ref));
Set_Storage_Pool (Free_Stmt, Pool_Id);
Append_To (Stmts, Free_Stmt);
-- The target or profile cannot deallocate objects
else
Free_Stmt := Empty;
end if;
-- Finalize the object if applicable. Generate:
-- [Deep_]Finalize (Obj_Ref.all);
if Needs_Finalization (DesigT)
and then not No_Heap_Finalization (PtrT)
then
Fin_Call :=
Make_Final_Call
(Obj_Ref =>
Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
Typ => DesigT);
-- Guard against a missing [Deep_]Finalize when the designated
-- type was not properly frozen.
if No (Fin_Call) then
Fin_Call := Make_Null_Statement (Loc);
end if;
-- When the target or profile supports deallocation, wrap the
-- finalization call in a block to ensure proper deallocation
-- even if finalization fails. Generate:
-- begin
-- <Fin_Call>
-- exception
-- when others =>
-- <Free_Stmt>
-- raise;
-- end;
if Present (Free_Stmt) then
Fin_Call :=
Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Fin_Call),
Exception_Handlers => New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (
Make_Others_Choice (Loc)),
Statements => New_List (
New_Copy_Tree (Free_Stmt),
Make_Raise_Statement (Loc))))));
end if;
Prepend_To (Stmts, Fin_Call);
end if;
-- Signal the accessibility failure through a Program_Error
Append_To (Stmts,
Make_Raise_Program_Error (Loc,
Reason => PE_Accessibility_Check_Failed));
-- Step 2: Create the accessibility comparison
-- Generate:
-- Ref'Tag
Obj_Ref :=
Make_Attribute_Reference (Loc,
Prefix => Obj_Ref,
Attribute_Name => Name_Tag);
-- For tagged types, determine the accessibility level by looking
-- at the type specific data of the dispatch table. Generate:
-- Type_Specific_Data (Address (Ref'Tag)).Access_Level
if Tagged_Type_Expansion then
Cond := Build_Get_Access_Level (Loc, Obj_Ref);
-- Use a runtime call to determine the accessibility level when
-- compiling on virtual machine targets. Generate:
-- Get_Access_Level (Ref'Tag)
else
Cond :=
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_Access_Level), Loc),
Parameter_Associations => New_List (Obj_Ref));
end if;
Cond :=
Make_Op_Gt (Loc,
Left_Opnd => Cond,
Right_Opnd => Accessibility_Level (N, Dynamic_Level));
-- Due to the complexity and side effects of the check, utilize an
-- if statement instead of the regular Program_Error circuitry.
Insert_Action (N,
Make_Implicit_If_Statement (N,
Condition => Cond,
Then_Statements => Stmts));
end if;
end Apply_Accessibility_Check;
-- Local variables
Indic : constant Node_Id := Subtype_Mark (Expression (N));
@ -884,7 +671,8 @@ package body Exp_Ch4 is
if Is_Build_In_Place_Function_Call (Exp) then
Make_Build_In_Place_Call_In_Allocator (N, Exp);
Apply_Accessibility_Check (N, Built_In_Place => True);
Apply_Accessibility_Check_For_Allocator
(N, Exp, N, Built_In_Place => True);
return;
-- Ada 2005 (AI-318-02): Specialization of the previous case for
@ -896,7 +684,8 @@ package body Exp_Ch4 is
elsif Present (Unqual_BIP_Iface_Function_Call (Exp)) then
Make_Build_In_Place_Iface_Call_In_Allocator (N, Exp);
Apply_Accessibility_Check (N, Built_In_Place => True);
Apply_Accessibility_Check_For_Allocator
(N, Exp, N, Built_In_Place => True);
return;
end if;
@ -1191,7 +980,7 @@ package body Exp_Ch4 is
-- Note: the accessibility check must be inserted after the call to
-- [Deep_]Adjust to ensure proper completion of the assignment.
Apply_Accessibility_Check (Temp);
Apply_Accessibility_Check_For_Allocator (N, Exp, Temp);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT);

1
gcc/ada/exp_ch5.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;

1
gcc/ada/exp_ch6.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
with Atree; use Atree;
with Aspects; use Aspects;
with Checks; use Checks;

1
gcc/ada/exp_ch9.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
with Atree; use Atree;
with Aspects; use Aspects;
with Checks; use Checks;

1
gcc/ada/exp_disp.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;

1
gcc/ada/gcc-interface/Make-lang.in
View File

@ -399,6 +399,7 @@ GNAT_ADA_OBJS = \
ada/sem_ch12.o \
ada/sem_ch13.o \
ada/sem_ch2.o \
ada/accessibility.o \
ada/sem_ch3.o \
ada/sem_ch4.o \
ada/sem_ch5.o \

1
gcc/ada/gen_il-fields.ads
View File

@ -98,6 +98,7 @@ package Gen_IL.Fields is
Cleanup_Actions,
Comes_From_Check_Or_Contract,
Comes_From_Extended_Return_Statement,
Comes_From_Iterator,
Compile_Time_Known_Aggregate,
Component_Associations,
Component_Clauses,

1
gcc/ada/gen_il-gen-gen_nodes.adb
View File

@ -906,6 +906,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sy (Subtype_Mark, Node_Id, Default_Empty),
Sy (Access_Definition, Node_Id, Default_Empty),
Sy (Name, Node_Id, Default_Empty),
Sm (Comes_From_Iterator, Flag),
Sm (Corresponding_Generic_Association, Node_Id)));
Cc (N_Package_Renaming_Declaration, N_Renaming_Declaration,

2
gcc/ada/sem_aggr.adb
View File

@ -3242,7 +3242,7 @@ package body Sem_Aggr is
end loop;
end;
else
elsif Present (Assign_Indexed_Subp) then
-- Indexed Aggregate. Positional or indexed component
-- can be present, but not both. Choices must be static
-- values or ranges with static bounds.

133
gcc/ada/sem_attr.adb
View File

@ -25,6 +25,7 @@
with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Casing; use Casing;
@ -10936,72 +10937,12 @@ package body Sem_Attr is
It : Interp;
Nom_Subt : Entity_Id;
procedure Accessibility_Message;
-- Error, or warning within an instance, if the static accessibility
-- rules of 3.10.2 are violated.
function Declared_Within_Generic_Unit
(Entity : Entity_Id;
Generic_Unit : Node_Id) return Boolean;
-- Returns True if Declared_Entity is declared within the declarative
-- region of Generic_Unit; otherwise returns False.
function Prefix_With_Safe_Accessibility_Level return Boolean;
-- Return True if the prefix does not have a value conversion of an
-- array because a value conversion is like an aggregate with respect
-- to determining accessibility level (RM 3.10.2); even if evaluation
-- of a value conversion is guaranteed to not create a new object,
-- accessibility rules are defined as if it might.
---------------------------
-- Accessibility_Message --
---------------------------
procedure Accessibility_Message is
Indic : Node_Id := Parent (Parent (N));
begin
-- In an instance, this is a runtime check, but one we
-- know will fail, so generate an appropriate warning.
if In_Instance_Body then
Error_Msg_Warn := SPARK_Mode /= On;
Error_Msg_F
("non-local pointer cannot point to local object<<", P);
Error_Msg_F ("\Program_Error [<<", P);
Rewrite (N,
Make_Raise_Program_Error (Loc,
Reason => PE_Accessibility_Check_Failed));
Set_Etype (N, Typ);
return;
else
Error_Msg_F ("non-local pointer cannot point to local object", P);
-- Check for case where we have a missing access definition
if Is_Record_Type (Current_Scope)
and then
Nkind (Parent (N)) in N_Discriminant_Association
| N_Index_Or_Discriminant_Constraint
then
Indic := Parent (Parent (N));
while Present (Indic)
and then Nkind (Indic) /= N_Subtype_Indication
loop
Indic := Parent (Indic);
end loop;
if Present (Indic) then
Error_Msg_NE
("\use an access definition for" &
" the access discriminant of&",
N, Entity (Subtype_Mark (Indic)));
end if;
end if;
end if;
end Accessibility_Message;
----------------------------------
-- Declared_Within_Generic_Unit --
----------------------------------
@ -11029,70 +10970,6 @@ package body Sem_Attr is
return False;
end Declared_Within_Generic_Unit;
------------------------------------------
-- Prefix_With_Safe_Accessibility_Level --
------------------------------------------
function Prefix_With_Safe_Accessibility_Level return Boolean is
function Safe_Value_Conversions return Boolean;
-- Return False if the prefix has a value conversion of an array type
----------------------------
-- Safe_Value_Conversions --
----------------------------
function Safe_Value_Conversions return Boolean is
PP : Node_Id := P;
begin
loop
if Nkind (PP) in N_Selected_Component | N_Indexed_Component then
PP := Prefix (PP);
elsif Comes_From_Source (PP)
and then Nkind (PP) in N_Type_Conversion
| N_Unchecked_Type_Conversion
and then Is_Array_Type (Etype (PP))
then
return False;
elsif Comes_From_Source (PP)
and then Nkind (PP) = N_Qualified_Expression
and then Is_Array_Type (Etype (PP))
and then Nkind (Original_Node (Expression (PP))) in
N_Aggregate | N_Extension_Aggregate
then
return False;
else
exit;
end if;
end loop;
return True;
end Safe_Value_Conversions;
-- Start of processing for Prefix_With_Safe_Accessibility_Level
begin
-- No check required for unchecked and unrestricted access
if Attr_Id = Attribute_Unchecked_Access
or else Attr_Id = Attribute_Unrestricted_Access
then
return True;
-- Check value conversions
elsif Ekind (Btyp) = E_General_Access_Type
and then not Safe_Value_Conversions
then
return False;
end if;
return True;
end Prefix_With_Safe_Accessibility_Level;
-- Start of processing for Resolve_Attribute
begin
@ -11778,7 +11655,7 @@ package body Sem_Attr is
Intval (Accessibility_Level (P, Dynamic_Level))
> Deepest_Type_Access_Level (Btyp)
then
Accessibility_Message;
Accessibility_Message (N, Typ);
return;
end if;
end;
@ -11804,7 +11681,7 @@ package body Sem_Attr is
and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type
and then Attr_Id /= Attribute_Unrestricted_Access
then
Accessibility_Message;
Accessibility_Message (N, Typ);
return;
-- AI05-0225: If the context is not an access to protected
@ -11963,8 +11840,8 @@ package body Sem_Attr is
-- array type since a value conversion is like an aggregate with
-- respect to determining accessibility level (RM 3.10.2).
if not Prefix_With_Safe_Accessibility_Level then
Accessibility_Message;
if not Prefix_With_Safe_Accessibility_Level (N, Typ) then
Accessibility_Message (N, Typ);
return;
end if;

1
gcc/ada/sem_ch13.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;

1
gcc/ada/sem_ch3.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;

1
gcc/ada/sem_ch4.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Debug; use Debug;

1
gcc/ada/sem_ch5.adb
View File

@ -2523,6 +2523,7 @@ package body Sem_Ch5 is
Subtype_Mark => New_Occurrence_Of (Typ, Loc),
Name =>
New_Copy_Tree (Iter_Name, New_Sloc => Loc));
Set_Comes_From_Iterator (Decl);
Insert_Actions (Parent (Parent (N)), New_List (Decl));
Rewrite (Name (N), New_Occurrence_Of (Id, Loc));

519
gcc/ada/sem_ch6.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
@ -745,10 +746,6 @@ package body Sem_Ch6 is
-- Ada 2022: Check that the return expression in a No_Return function
-- meets the conditions specified by RM 6.5.1(5.1/5).
procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id);
-- Apply legality rule of 6.5 (5.9) to the access discriminants of an
-- aggregate in a return statement.
procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id);
-- Check that the return_subtype_indication properly matches the result
-- subtype of the function, as required by RM-6.5(5.1/2-5.3/2).
@ -781,516 +778,6 @@ package body Sem_Ch6 is
Return_Expr);
end Check_No_Return_Expression;
------------------------------------------
-- Check_Return_Construct_Accessibility --
------------------------------------------
procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id) is
function First_Selector (Assoc : Node_Id) return Node_Id;
-- Obtain the first selector or choice from a given association
function Is_Formal_Of_Current_Function
(Assoc_Expr : Entity_Id) return Boolean;
-- Predicate to test if a given expression associated with a
-- discriminant is a formal parameter to the function in which the
-- return construct we checking applies to.
--------------------
-- First_Selector --
--------------------
function First_Selector (Assoc : Node_Id) return Node_Id is
begin
if Nkind (Assoc) = N_Component_Association then
return First (Choices (Assoc));
elsif Nkind (Assoc) = N_Discriminant_Association then
return (First (Selector_Names (Assoc)));
else
raise Program_Error;
end if;
end First_Selector;
-----------------------------------
-- Is_Formal_Of_Current_Function --
-----------------------------------
function Is_Formal_Of_Current_Function
(Assoc_Expr : Entity_Id) return Boolean is
begin
return Is_Entity_Name (Assoc_Expr)
and then Enclosing_Subprogram
(Entity (Assoc_Expr)) = Scope_Id
and then Is_Formal (Entity (Assoc_Expr));
end Is_Formal_Of_Current_Function;
-- Local declarations
Assoc : Node_Id := Empty;
-- Assoc should perhaps be renamed and declared as a
-- Node_Or_Entity_Id since it encompasses not only component and
-- discriminant associations, but also discriminant components within
-- a type declaration or subtype indication ???
Assoc_Expr : Node_Id;
Assoc_Present : Boolean := False;
Check_Cond : Node_Id;
Unseen_Disc_Count : Nat := 0;
Seen_Discs : Elist_Id;
Disc : Entity_Id;
First_Disc : Entity_Id;
Obj_Decl : Node_Id;
Return_Con : Node_Id;
Unqual : Node_Id;
-- Start of processing for Check_Return_Construct_Accessibility
begin
-- Only perform checks on record types with access discriminants and
-- non-internally generated functions.
if not Is_Record_Type (R_Type)
or else not Has_Anonymous_Access_Discriminant (R_Type)
or else not Comes_From_Source (Return_Stmt)
then
return;
end if;
-- We are only interested in return statements
if Nkind (Return_Stmt) not in
N_Extended_Return_Statement | N_Simple_Return_Statement
then
return;
end if;
-- Fetch the object from the return statement, in the case of a
-- simple return statement the expression is part of the node.
if Nkind (Return_Stmt) = N_Extended_Return_Statement then
-- Obtain the object definition from the expanded extended return
Return_Con := First (Return_Object_Declarations (Return_Stmt));
while Present (Return_Con) loop
-- Inspect the original node to avoid object declarations
-- expanded into renamings.
if Nkind (Original_Node (Return_Con)) = N_Object_Declaration
and then Comes_From_Source (Original_Node (Return_Con))
then
exit;
end if;
Nlists.Next (Return_Con);
end loop;
pragma Assert (Present (Return_Con));
-- Could be dealing with a renaming
Return_Con := Original_Node (Return_Con);
else
Return_Con := Expression (Return_Stmt);
end if;
-- Obtain the accessibility levels of the expressions associated
-- with all anonymous access discriminants, then generate a
-- dynamic check or static error when relevant.
-- Note the repeated use of Original_Node to avoid checking
-- expanded code.
Unqual := Original_Node (Unqualify (Original_Node (Return_Con)));
-- Get the corresponding declaration based on the return object's
-- identifier.
if Nkind (Unqual) = N_Identifier
and then Nkind (Parent (Entity (Unqual)))
in N_Object_Declaration
| N_Object_Renaming_Declaration
then
Obj_Decl := Original_Node (Parent (Entity (Unqual)));
-- We were passed the object declaration directly, so use it
elsif Nkind (Unqual) in N_Object_Declaration
| N_Object_Renaming_Declaration
then
Obj_Decl := Unqual;
-- Otherwise, we are looking at something else
else
Obj_Decl := Empty;
end if;
-- Hop up object renamings when present
if Present (Obj_Decl)
and then Nkind (Obj_Decl) = N_Object_Renaming_Declaration
then
while Nkind (Obj_Decl) = N_Object_Renaming_Declaration loop
if Nkind (Name (Obj_Decl)) not in N_Entity then
-- We may be looking at the expansion of iterators or
-- some other internally generated construct, so it is safe
-- to ignore checks ???
if not Comes_From_Source (Obj_Decl) then
return;
end if;
Obj_Decl := Original_Node
(Declaration_Node
(Ultimate_Prefix (Name (Obj_Decl))));
-- Move up to the next declaration based on the object's name
else
Obj_Decl := Original_Node
(Declaration_Node (Name (Obj_Decl)));
end if;
end loop;
end if;
-- Obtain the discriminant values from the return aggregate
-- Do we cover extension aggregates correctly ???
if Nkind (Unqual) = N_Aggregate then
if Present (Expressions (Unqual)) then
Assoc := First (Expressions (Unqual));
else
Assoc := First (Component_Associations (Unqual));
end if;
-- There is an object declaration for the return object
elsif Present (Obj_Decl) then
-- When a subtype indication is present in an object declaration
-- it must contain the object's discriminants.
if Nkind (Object_Definition (Obj_Decl)) = N_Subtype_Indication then
Assoc := First
(Constraints
(Constraint
(Object_Definition (Obj_Decl))));
-- The object declaration contains an aggregate
elsif Present (Expression (Obj_Decl)) then
if Nkind (Unqualify (Expression (Obj_Decl))) = N_Aggregate then
-- Grab the first associated discriminant expresion
if Present
(Expressions (Unqualify (Expression (Obj_Decl))))
then
Assoc := First
(Expressions
(Unqualify (Expression (Obj_Decl))));
else
Assoc := First
(Component_Associations
(Unqualify (Expression (Obj_Decl))));
end if;
-- Otherwise, this is something else
else
return;
end if;
-- There are no supplied discriminants in the object declaration,
-- so get them from the type definition since they must be default
-- initialized.
-- Do we handle constrained subtypes correctly ???
elsif Nkind (Unqual) = N_Object_Declaration then
Assoc := First_Discriminant
(Etype (Object_Definition (Obj_Decl)));
else
Assoc := First_Discriminant (Etype (Unqual));
end if;
-- When we are not looking at an aggregate or an identifier, return
-- since any other construct (like a function call) is not
-- applicable since checks will be performed on the side of the
-- callee.
else
return;
end if;
-- Obtain the discriminants so we know the actual type in case the
-- value of their associated expression gets implicitly converted.
if No (Obj_Decl) then
pragma Assert (Nkind (Unqual) = N_Aggregate);
Disc := First_Discriminant (Etype (Unqual));
else
Disc := First_Discriminant
(Etype (Defining_Identifier (Obj_Decl)));
end if;
-- Preserve the first discriminant for checking named associations
First_Disc := Disc;
-- Count the number of discriminants for processing an aggregate
-- which includes an others.
Disc := First_Disc;
while Present (Disc) loop
Unseen_Disc_Count := Unseen_Disc_Count + 1;
Next_Discriminant (Disc);
end loop;
Seen_Discs := New_Elmt_List;
-- Loop through each of the discriminants and check each expression
-- associated with an anonymous access discriminant.
-- When named associations occur in the return aggregate then
-- discriminants can be in any order, so we need to ensure we do
-- not continue to loop when all discriminants have been seen.
Disc := First_Disc;
while Present (Assoc)
and then (Present (Disc) or else Assoc_Present)
and then Unseen_Disc_Count > 0
loop
-- Handle named associations by searching through the names of
-- the relevant discriminant components.
if Nkind (Assoc)
in N_Component_Association | N_Discriminant_Association
then
Assoc_Expr := Expression (Assoc);
Assoc_Present := True;
-- We currently don't handle box initialized discriminants,
-- however, since default initialized anonymous access
-- discriminants are a corner case, this is ok for now ???
if Nkind (Assoc) = N_Component_Association
and then Box_Present (Assoc)
then
if Nkind (First_Selector (Assoc)) = N_Others_Choice then
Unseen_Disc_Count := 0;
end if;
-- When others is present we must identify a discriminant we
-- haven't already seen so as to get the appropriate type for
-- the static accessibility check.
-- This works because all components within an others clause
-- must have the same type.
elsif Nkind (First_Selector (Assoc)) = N_Others_Choice then
Disc := First_Disc;
Outer : while Present (Disc) loop
declare
Current_Seen_Disc : Elmt_Id;
begin
-- Move through the list of identified discriminants
Current_Seen_Disc := First_Elmt (Seen_Discs);
while Present (Current_Seen_Disc) loop
-- Exit the loop when we found a match
exit when
Chars (Node (Current_Seen_Disc)) = Chars (Disc);
Next_Elmt (Current_Seen_Disc);
end loop;
-- When we have exited the above loop without finding
-- a match then we know that Disc has not been seen.
exit Outer when No (Current_Seen_Disc);
end;
Next_Discriminant (Disc);
end loop Outer;
-- If we got to an others clause with a non-zero
-- discriminant count there must be a discriminant left to
-- check.
pragma Assert (Present (Disc));
-- Set the unseen discriminant count to zero because we know
-- an others clause sets all remaining components of an
-- aggregate.
Unseen_Disc_Count := 0;
-- Move through each of the selectors in the named association
-- and obtain a discriminant for accessibility checking if one
-- is referenced in the list. Also track which discriminants
-- are referenced for the purpose of handling an others clause.
else
declare
Assoc_Choice : Node_Id;
Curr_Disc : Node_Id;
begin
Disc := Empty;
Curr_Disc := First_Disc;
while Present (Curr_Disc) loop
-- Check each of the choices in the associations for a
-- match to the name of the current discriminant.
Assoc_Choice := First_Selector (Assoc);
while Present (Assoc_Choice) loop
-- When the name matches we track that we have seen
-- the discriminant, but instead of exiting the
-- loop we continue iterating to make sure all the
-- discriminants within the named association get
-- tracked.
if Chars (Assoc_Choice) = Chars (Curr_Disc) then
Append_Elmt (Curr_Disc, Seen_Discs);
Disc := Curr_Disc;
Unseen_Disc_Count := Unseen_Disc_Count - 1;
end if;
Next (Assoc_Choice);
end loop;
Next_Discriminant (Curr_Disc);
end loop;
end;
end if;
-- Unwrap the associated expression if we are looking at a default
-- initialized type declaration. In this case Assoc is not really
-- an association, but a component declaration. Should Assoc be
-- renamed in some way to be more clear ???
-- This occurs when the return object does not initialize
-- discriminant and instead relies on the type declaration for
-- their supplied values.
elsif Nkind (Assoc) in N_Entity
and then Ekind (Assoc) = E_Discriminant
then
Append_Elmt (Disc, Seen_Discs);
Assoc_Expr := Discriminant_Default_Value (Assoc);
Unseen_Disc_Count := Unseen_Disc_Count - 1;
-- Otherwise, there is nothing to do because Assoc is an
-- expression within the return aggregate itself.
else
Append_Elmt (Disc, Seen_Discs);
Assoc_Expr := Assoc;
Unseen_Disc_Count := Unseen_Disc_Count - 1;
end if;
-- Check the accessibility level of the expression when the
-- discriminant is of an anonymous access type.
if Present (Assoc_Expr)
and then Present (Disc)
and then Ekind (Etype (Disc)) = E_Anonymous_Access_Type
-- We disable the check when we have a tagged return type and
-- the associated expression for the discriminant is a formal
-- parameter since the check would require us to compare the
-- accessibility level of Assoc_Expr to the level of the
-- Extra_Accessibility_Of_Result of the function - which is
-- currently disabled for functions with tagged return types.
-- This may change in the future ???
-- See Needs_Result_Accessibility_Level for details.
and then not
(No (Extra_Accessibility_Of_Result (Scope_Id))
and then Is_Formal_Of_Current_Function (Assoc_Expr)
and then Is_Tagged_Type (Etype (Scope_Id)))
then
-- Generate a dynamic check based on the extra accessibility of
-- the result or the scope of the current function.
Check_Cond :=
Make_Op_Gt (Loc,
Left_Opnd => Accessibility_Level
(Expr => Assoc_Expr,
Level => Dynamic_Level,
In_Return_Context => True),
Right_Opnd =>
(if Present (Extra_Accessibility_Of_Result (Scope_Id))
-- When Assoc_Expr is a formal we have to look at the
-- extra accessibility-level formal associated with
-- the result.
and then Is_Formal_Of_Current_Function (Assoc_Expr)
then
New_Occurrence_Of
(Extra_Accessibility_Of_Result (Scope_Id), Loc)
-- Otherwise, we compare the level of Assoc_Expr to the
-- scope of the current function.
else
Make_Integer_Literal
(Loc, Scope_Depth (Scope (Scope_Id)))));
Insert_Before_And_Analyze (Return_Stmt,
Make_Raise_Program_Error (Loc,
Condition => Check_Cond,
Reason => PE_Accessibility_Check_Failed));
-- If constant folding has happened on the condition for the
-- generated error, then warn about it being unconditional when
-- we know an error will be raised.
if Nkind (Check_Cond) = N_Identifier
and then Entity (Check_Cond) = Standard_True
then
Error_Msg_N
("access discriminant in return object would be a dangling"
& " reference", Return_Stmt);
end if;
end if;
-- Iterate over the discriminants, except when we have encountered
-- a named association since the discriminant order becomes
-- irrelevant in that case.
if not Assoc_Present then
Next_Discriminant (Disc);
end if;
-- Iterate over associations
if not Is_List_Member (Assoc) then
exit;
else
Nlists.Next (Assoc);
end if;
end loop;
end Check_Return_Construct_Accessibility;
-------------------------------------
-- Check_Return_Subtype_Indication --
-------------------------------------
@ -1495,7 +982,7 @@ package body Sem_Ch6 is
Resolve (Expr, R_Type);
Check_Limited_Return (N, Expr, R_Type);
Check_Return_Construct_Accessibility (N);
Check_Return_Construct_Accessibility (N, Stm_Entity);
-- Ada 2022 (AI12-0269): Any return statement that applies to a
-- nonreturning function shall be a simple_return_statement with
@ -1551,7 +1038,7 @@ package body Sem_Ch6 is
Check_References (Stm_Entity);
Check_Return_Construct_Accessibility (N);
Check_Return_Construct_Accessibility (N, Stm_Entity);
-- Check RM 6.5 (5.9/3)

1
gcc/ada/sem_ch9.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;

1
gcc/ada/sem_res.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;

1299
gcc/ada/sem_util.adb
View File

File diff suppressed because it is too large Load Diff

130
gcc/ada/sem_util.ads
View File

@ -44,40 +44,6 @@ package Sem_Util is
-- including the cases where there can't be any because e.g. the type is
-- not tagged.
type Accessibility_Level_Kind is
(Dynamic_Level,
Object_Decl_Level,
Zero_On_Dynamic_Level);
-- Accessibility_Level_Kind is an enumerated type which captures the
-- different modes in which an accessibility level could be obtained for
-- a given expression.
-- When in the context of the function Accessibility_Level,
-- Accessibility_Level_Kind signals what type of accessibility level to
-- obtain. For example, when Level is Dynamic_Level, a defining identifier
-- associated with a SAOOAAT may be returned or an N_Integer_Literal node.
-- When the level is Object_Decl_Level, an N_Integer_Literal node is
-- returned containing the level of the declaration of the object if
-- relevant (be it a SAOOAAT or otherwise). Finally, Zero_On_Dynamic_Level
-- returns library level for all cases where the accessibility level is
-- dynamic (used to bypass static accessibility checks in dynamic cases).
function Accessibility_Level
(Expr : Node_Id;
Level : Accessibility_Level_Kind;
In_Return_Context : Boolean := False;
Allow_Alt_Model : Boolean := True) return Node_Id;
-- Centralized accessibility level calculation routine for finding the
-- accessibility level of a given expression Expr.
-- In_Return_Context forces the Accessibility_Level calculations to be
-- carried out "as if" Expr existed in a return value. This is useful for
-- calculating the accessibility levels for discriminant associations
-- and return aggregates.
-- The Allow_Alt_Model parameter allows the alternative level calculation
-- under the restriction No_Dynamic_Accessibility_Checks to be performed.
function Acquire_Warning_Match_String (Str_Lit : Node_Id) return String;
-- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to get
-- the given string argument, adding leading and trailing asterisks if they
@ -696,22 +662,6 @@ package Sem_Util is
-- as Needs_Finalization except with pragma Restrictions (No_Finalization),
-- in which case we know that class-wide objects do not need finalization.
function Deepest_Type_Access_Level
(Typ : Entity_Id;
Allow_Alt_Model : Boolean := True) return Uint;
-- Same as Type_Access_Level, except that if the type is the type of an Ada
-- 2012 stand-alone object of an anonymous access type, then return the
-- static accessibility level of the object. In that case, the dynamic
-- accessibility level of the object may take on values in a range. The low
-- bound of that range is returned by Type_Access_Level; this function
-- yields the high bound of that range. Also differs from Type_Access_Level
-- in the case of a descendant of a generic formal type (returns Int'Last
-- instead of 0).
-- The Allow_Alt_Model parameter allows the alternative level calculation
-- under the restriction No_Dynamic_Accessibility_Checks to be performed.
function Defining_Entity (N : Node_Id) return Entity_Id;
-- Given a declaration N, returns the associated defining entity. If the
-- declaration has a specification, the entity is obtained from the
@ -786,10 +736,6 @@ package Sem_Util is
-- private components of protected objects, but is generally useful when
-- restriction No_Implicit_Heap_Allocation is active.
function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id;
-- Same as Einfo.Extra_Accessibility except thtat object renames
-- are looked through.
function Effective_Reads_Enabled (Id : Entity_Id) return Boolean;
-- Id should be the entity of a state abstraction, an object, or a type.
-- Returns True iff Id is subject to external property Effective_Reads.
@ -1146,10 +1092,6 @@ package Sem_Util is
-- discriminants. Otherwise all components of the parent must be included
-- in the subtype for semantic analysis.
function Get_Dynamic_Accessibility (E : Entity_Id) return Entity_Id;
-- Obtain the accessibility level for a given entity formal taking into
-- account both extra and minimum accessibility.
function Get_Actual_Subtype (N : Node_Id) return Entity_Id;
-- Given a node for an expression, obtain the actual subtype of the
-- expression. In the case of a parameter where the formal is an
@ -1393,18 +1335,6 @@ package Sem_Util is
-- don't look inside packed array types. If Recurse is False, just
-- go down one level (so it's no longer the "fullest" view).
function Has_Access_Values (T : Entity_Id) return Boolean;
-- Returns true if the underlying type of T is an access type, or has a
-- component (at any recursive level) that is an access type. This is a
-- conservative predicate, if it is not known whether or not T contains
-- access values (happens for generic formals in some cases), then False is
-- returned. Note that tagged types return False. Even though the tag is
-- implemented as an access type internally, this function tests only for
-- access types known to the programmer. See also Has_Tagged_Component.
function Has_Anonymous_Access_Discriminant (Typ : Entity_Id) return Boolean;
-- Returns True if Typ has one or more anonymous access discriminants
type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible);
-- Result of Has_Compatible_Alignment test, description found below. Note
-- that the values are arranged in increasing order of problematicness.
@ -1544,20 +1474,6 @@ package Sem_Util is
-- Return True if the loop has no side effect and can therefore be
-- marked for removal. Return False if N is not a N_Loop_Statement.
subtype Static_Accessibility_Level_Kind
is Accessibility_Level_Kind range Object_Decl_Level
.. Zero_On_Dynamic_Level;
-- Restrict the reange of Accessibility_Level_Kind to be non-dynamic for
-- use in the static version of Accessibility_Level below.
function Static_Accessibility_Level
(Expr : Node_Id;
Level : Static_Accessibility_Level_Kind;
In_Return_Context : Boolean := False) return Uint;
-- Overloaded version of Accessibility_Level which returns a universal
-- integer for use in compile-time checking. Note: Level is restricted to
-- be non-dynamic.
function Is_Newly_Constructed
(Exp : Node_Id; Context_Requires_NC : Boolean) return Boolean;
-- Indicates whether a given expression is "newly constructed" (RM 4.4).
@ -1644,11 +1560,6 @@ package Sem_Util is
-- a tagged type or has a subcomponent that is tagged. Returns False for a
-- noncomposite type, or if no tagged subcomponents are present.
function Has_Unconstrained_Access_Discriminants
(Subtyp : Entity_Id) return Boolean;
-- Returns True if the given subtype is unconstrained and has one or more
-- access discriminants.
function Has_Undefined_Reference (Expr : Node_Id) return Boolean;
-- Given arbitrary expression Expr, determine whether it contains at
-- least one name whose entity is Any_Id.
@ -1822,10 +1733,6 @@ package Sem_Util is
-- pragma Initialize_Scalars or by the binder. Return an expression created
-- at source location Loc, which denotes the invalid value.
function Is_Anonymous_Access_Actual (N : Node_Id) return Boolean;
-- Determine if N is used as an actual for a call whose corresponding
-- formal is of an anonymous access type.
function Is_Access_Subprogram_Wrapper (E : Entity_Id) return Boolean;
-- True if E is the constructed wrapper for an access_to_subprogram
-- type with Pre/Postconditions.
@ -2400,21 +2307,6 @@ package Sem_Util is
-- Determine whether arbitrary entity Id denotes the anonymous object
-- created for a single task type.
function Is_Special_Aliased_Formal_Access
(Exp : Node_Id;
In_Return_Context : Boolean := False) return Boolean;
-- Determines whether a dynamic check must be generated for explicitly
-- aliased formals within a function Scop for the expression Exp.
-- In_Return_Context forces Is_Special_Aliased_Formal_Access to assume
-- that Exp is within a return value which is useful for checking
-- expressions within discriminant associations of return objects.
-- More specially, Is_Special_Aliased_Formal_Access checks that Exp is a
-- 'Access attribute reference within a return statement where the ultimate
-- prefix is an aliased formal of Scop and that Scop returns an anonymous
-- access type. See RM 3.10.2 for more details.
function Is_Specific_Tagged_Type (Typ : Entity_Id) return Boolean;
-- Determine whether an arbitrary [private] type is specifically tagged
@ -2692,12 +2584,6 @@ package Sem_Util is
-- syntactic ambiguity that results from an indexing of a function call
-- that returns an array, so that Obj.F (X, Y) may mean F (Ob) (X, Y).
function Needs_Result_Accessibility_Level
(Func_Id : Entity_Id) return Boolean;
-- Ada 2012 (AI05-0234): Return True if the function needs an implicit
-- parameter to identify the accessibility level of the function result
-- "determined by the point of call".
function Needs_Secondary_Stack (Id : Entity_Id) return Boolean;
-- Return true if functions whose result type is Id must return on the
-- secondary stack, i.e. allocate the return object on this stack.
@ -3340,9 +3226,6 @@ package Sem_Util is
-- Determine whether node N is a loop statement subject to at least one
-- 'Loop_Entry attribute.
function Subprogram_Access_Level (Subp : Entity_Id) return Uint;
-- Return the accessibility level of the view denoted by Subp
function Support_Atomic_Primitives (Typ : Entity_Id) return Boolean;
-- Return True if Typ supports the GCC built-in atomic operations (i.e. if
-- Typ is properly sized and aligned).
@ -3373,19 +3256,6 @@ package Sem_Util is
-- returned, i.e. Traverse_More_Func is called and the result is simply
-- discarded.
function Type_Access_Level
(Typ : Entity_Id;
Allow_Alt_Model : Boolean := True;
Assoc_Ent : Entity_Id := Empty) return Uint;
-- Return the accessibility level of Typ
-- The Allow_Alt_Model parameter allows the alternative level calculation
-- under the restriction No_Dynamic_Accessibility_Checks to be performed.
-- Assoc_Ent allows for the optional specification of the entity associated
-- with Typ. This gets utilized mostly for anonymous access type
-- processing, where context matters in interpreting Typ's level.
function Type_Without_Stream_Operation
(T : Entity_Id;
Op : TSS_Name_Type := TSS_Null) return Entity_Id;

1
gcc/ada/sem_warn.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;

5
gcc/ada/sinfo.ads
View File

@ -953,6 +953,11 @@ package Sinfo is
-- Present in N_Simple_Return_Statement nodes. True if this node was
-- constructed as part of the N_Extended_Return_Statement expansion.
-- Comes_From_Iterator
-- Present in N_Object_Renaming_Declaration nodes. True if this node was
-- was constructed as part of the expansion of an iterator
-- specification.
-- Compile_Time_Known_Aggregate
-- Present in N_Aggregate nodes. Set for aggregates which can be fully
-- evaluated at compile time without raising constraint error. Such