From: Steve Baird <ba...@adacore.com>
The Extended_Access aspect can be specified to be True for certain
access-to-unconstrained-array-subtype types. Such extended access types
can designate objects that a normal general access type (with the same
designated subtype) cannot, such as a slice of an aliased array object
or an object that is represented without contiguous bounds information.
gcc/ada/ChangeLog:
* aspects.ads: Add Aspect_Extended_Access to Aspect_Id
enumeration.
* par-prag.adb: Add Pragma_Extended_Access to list of pragmas that
get no interesting processing in the parser.
* sem_attr.adb: Relax legality checks on Access/Unchecked_Access
attribute references if access type is Extended_Access.
* sem_ch12.adb (Validate_Access_Type_Instance): For an instance of
a generic with a formal access type, check that formal and actual
agree with with respect to Extended_Access aspect.
* sem_prag.adb (Analyze_Pragma): Add analysis code for pragma
Extended_Access. Set Pragma_Extended_Access element in Sig_Flags
aggregate.
* sem_prag.ads: Set Pragma_Extended_Access element in
Aspect_Specifying_Pragma aggregate.
* sem_res.adb (Valid_Conversion): Disallow
extended-to-not-extended access conversion.
* sem_util.adb (Is_Extended_Access_Access_Type): Implement new
function.
(Is_Aliased_View): If (and only if) the new Boolean For_Extended
parameter is True, then a slice of an aliased non-bitpacked array
is aliased, a constrained nominal subtype does not force a result
of False, and a dereference of an extended access value is
aliased. The last point is somewhat subtle. This is how we prevent
covert fat-to-nonfat type conversions via things like
"Not_Extended_Type'(Extended_Ptr.all'Access)" or passing
Extended_Ptr.all as an actual parameter corresponding to an
explicitly aliased formal parameter.
* sem_util.ads (Is_Extended_Access_Type): Declare new function.
(Is_Aliased_View): Add new defaults-False parameter For_Extended.
* snames.ads-tmpl: Declare Name_Extended_Access Name_Id constant
and Pragma_Extended_Access Pragma_Id enumeration literal.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/aspects.ads | 5 +++
gcc/ada/par-prag.adb | 1 +
gcc/ada/sem_attr.adb | 10 +++++-
gcc/ada/sem_ch12.adb | 16 +++++++++
gcc/ada/sem_prag.adb | 74 ++++++++++++++++++++++++++++++++++++++++-
gcc/ada/sem_prag.ads | 1 +
gcc/ada/sem_res.adb | 32 ++++++++++++++++++
gcc/ada/sem_util.adb | 57 +++++++++++++++++++++++++++++--
gcc/ada/sem_util.ads | 11 +++++-
gcc/ada/snames.ads-tmpl | 2 ++
10 files changed, 204 insertions(+), 5 deletions(-)
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 2a5e0f21601..ebf09602ea5 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -197,6 +197,7 @@ package Aspects is
Aspect_Effective_Writes, -- GNAT
Aspect_Exclusive_Functions,
Aspect_Export,
+ Aspect_Extended_Access, -- GNAT
Aspect_Extensions_Visible, -- GNAT
Aspect_Favor_Top_Level, -- GNAT
Aspect_First_Controlling_Parameter, -- GNAT
@@ -293,6 +294,7 @@ package Aspects is
Aspect_Effective_Reads => True,
Aspect_Effective_Writes => True,
Aspect_Exceptional_Cases => True,
+ Aspect_Extended_Access => True,
Aspect_Extensions_Visible => True,
Aspect_External_Initialization => True,
Aspect_Favor_Top_Level => True,
@@ -539,6 +541,7 @@ package Aspects is
Aspect_Dynamic_Predicate => False,
Aspect_Exceptional_Cases => False,
Aspect_Exclusive_Functions => False,
+ Aspect_Extended_Access => True,
Aspect_External_Initialization => False,
Aspect_External_Name => False,
Aspect_External_Tag => False,
@@ -714,6 +717,7 @@ package Aspects is
Aspect_Exceptional_Cases => Name_Exceptional_Cases,
Aspect_Exclusive_Functions => Name_Exclusive_Functions,
Aspect_Export => Name_Export,
+ Aspect_Extended_Access => Name_Extended_Access,
Aspect_Extensions_Visible => Name_Extensions_Visible,
Aspect_External_Initialization => Name_External_Initialization,
Aspect_External_Name => Name_External_Name,
@@ -1095,6 +1099,7 @@ package Aspects is
Aspect_Atomic_Components => Rep_Aspect,
Aspect_Bit_Order => Rep_Aspect,
Aspect_Component_Size => Rep_Aspect,
+ Aspect_Extended_Access => Rep_Aspect,
Aspect_Full_Access_Only => Rep_Aspect,
Aspect_Machine_Radix => Rep_Aspect,
Aspect_Object_Size => Rep_Aspect,
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index 8b953b3e877..1a2a7b6b77b 100644
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -1442,6 +1442,7 @@ begin
| Pragma_Export_Procedure
| Pragma_Export_Valued_Procedure
| Pragma_Extend_System
+ | Pragma_Extended_Access
| Pragma_Extensions_Visible
| Pragma_External
| Pragma_External_Name_Casing
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 9ab197299ba..4e06ec54978 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -11922,6 +11922,12 @@ package body Sem_Attr is
then
null;
+ -- Nominal subtype static matching requirement does not apply
+ -- for an extended access type.
+
+ elsif Is_Extended_Access_Type (Typ) then
+ null;
+
else
Error_Msg_F
("object subtype must statically match "
@@ -12127,7 +12133,9 @@ package body Sem_Attr is
and then not (Nkind (P) = N_Selected_Component
and then
Is_Overloadable (Entity (Selector_Name (P))))
- and then not Is_Aliased_View (Original_Node (P))
+ and then not Is_Aliased_View
+ (Original_Node (P),
+ For_Extended => Is_Extended_Access_Type (Btyp))
and then not In_Instance
and then not In_Inlined_Body
and then Comes_From_Source (N)
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 3bc533a30de..3ef4e698e81 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -13974,6 +13974,22 @@ package body Sem_Ch12 is
("non null exclusion of actual and formal & do not match",
Actual, Gen_T);
end if;
+
+ -- formal/actual extended access match required (regardless of
+ -- whether a formal extended access type is currently possible)
+
+ if Is_Extended_Access_Type (Act_T)
+ /= Is_Extended_Access_Type (A_Gen_T)
+ then
+ Error_Msg_N
+ ("actual type must" &
+ String'(if Is_Extended_Access_Type (A_Gen_T)
+ then ""
+ else " not") &
+ " be extended access type", Actual);
+
+ Abandon_Instantiation (Actual);
+ end if;
end Validate_Access_Type_Instance;
----------------------------------
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 9a3e7acf34f..eb11ceb7044 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -90,7 +90,7 @@ with Stylesw; use Stylesw;
with Table;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
-with Ttypes;
+with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Uname; use Uname;
with Urealp; use Urealp;
@@ -17459,6 +17459,77 @@ package body Sem_Prag is
Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
end if;
+ ---------------------
+ -- Extended_Access --
+ ---------------------
+
+ -- pragma Extended_Access (first_subtype_LOCAL_NAME);
+
+ when Pragma_Extended_Access => Extended_Access : declare
+ Assoc : constant Node_Id := Arg1;
+ Typ : Entity_Id;
+ Type_Id : Node_Id;
+
+ begin
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Arg_Is_Local_Name (Arg1);
+ Type_Id := Get_Pragma_Arg (Assoc);
+
+ if not Is_Entity_Name (Type_Id)
+ or else not Is_Type (Entity (Type_Id))
+ then
+ Error_Pragma_Arg
+ ("argument for pragma% must be type or subtype", Arg1);
+ end if;
+
+ Find_Type (Type_Id);
+ Typ := Entity (Type_Id);
+
+ if Typ = Any_Type
+ or else Rep_Item_Too_Early (Typ, N)
+ then
+ return;
+ else
+ Typ := Underlying_Type (Typ);
+ end if;
+
+ -- A pragma that applies to a Ghost entity becomes Ghost for the
+ -- purposes of legality checks and removal of ignored Ghost code.
+
+ Mark_Ghost_Pragma (N, Typ);
+
+ if Ekind (Typ) = E_Access_Subtype then
+ Error_Pragma
+ ("pragma% not specifiable for subtype");
+ elsif Ekind (Typ) /= E_General_Access_Type then
+ Error_Pragma
+ ("pragma% only specifiable for general access type");
+ elsif Is_Derived_Type (Typ) then
+ Error_Pragma
+ ("pragma% not specifiable for derived type");
+ else
+ declare
+ Designated : constant Entity_Id := Designated_Type (Typ);
+ begin
+ if not (Is_Array_Type (Designated))
+ or else Is_Constrained (Designated)
+ then
+ Error_Pragma
+ ("pragma% only specifiable for access type" &
+ " having unconstrained array designated subtype");
+ end if;
+ end;
+ end if;
+
+ Check_First_Subtype (Arg1);
+ Check_Duplicate_Pragma (Typ);
+
+ if Rep_Item_Too_Late (Typ, N) then
+ return;
+ end if;
+ end Extended_Access;
+
------------------------
-- Extensions_Allowed --
------------------------
@@ -32963,6 +33034,7 @@ package body Sem_Prag is
Pragma_Export_Procedure => -1,
Pragma_Export_Valued_Procedure => -1,
Pragma_Extend_System => -1,
+ Pragma_Extended_Access => 0,
Pragma_Extensions_Allowed => 0,
Pragma_Extensions_Visible => 0,
Pragma_External => -1,
diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
index 48a16038f38..e26583d1111 100644
--- a/gcc/ada/sem_prag.ads
+++ b/gcc/ada/sem_prag.ads
@@ -62,6 +62,7 @@ package Sem_Prag is
Pragma_Elaborate_Body => True,
Pragma_Exceptional_Cases => True,
Pragma_Export => True,
+ Pragma_Extended_Access => True,
Pragma_Extensions_Visible => True,
Pragma_Favor_Top_Level => True,
Pragma_First_Controlling_Parameter => True,
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index d28e724e882..658f9eb2b72 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -14428,6 +14428,37 @@ package body Sem_Res is
return False;
end if;
+ declare
+ Extended_Opnd : constant Boolean :=
+ Is_Extended_Access_Type (Opnd_Type);
+ Extended_Target : constant Boolean :=
+ Is_Extended_Access_Type (Target_Type);
+ begin
+ -- An extended access value may designate objects that are
+ -- impossible to reference using a non-extended type, so
+ -- prohibit conversions that would require being able to
+ -- do the impossible.
+
+ if Extended_Opnd then
+ if not Extended_Target then
+ Conversion_Error_N
+ ("cannot convert extended access value"
+ & " to non-extended access type",
+ Operand);
+ return False;
+ end if;
+
+ -- Detect bad conversion on copy back for a view conversion
+
+ elsif Extended_Target and then Is_View_Conversion (N) then
+ Conversion_Error_N
+ ("cannot convert non-extended value"
+ & " to extended access type in view conversion",
+ Operand);
+ return False;
+ end if;
+ end;
+
-- Check the static accessibility rule of 4.6(17). Note that the
-- check is not enforced when within an instance body, since the RM
-- requires such cases to be caught at run time.
@@ -14476,6 +14507,7 @@ package body Sem_Res is
then
Conversion_Error_N
("operand has deeper level than target", Operand);
+ return False;
end if;
-- Implicit conversions aren't allowed for objects of an
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 5d3a4e68c84..1a512219e59 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -12356,6 +12356,27 @@ package body Sem_Util is
and then not Is_Record_Aggregate;
end Is_Container_Aggregate;
+ -----------------------------
+ -- Is_Extended_Access_Type --
+ -----------------------------
+
+ function Is_Extended_Access_Type (Ent : Entity_Id) return Boolean is
+ Btype : constant Entity_Id := Available_View (Base_Type (Ent));
+ begin
+ if Has_Aspect (Btype, Aspect_Extended_Access) then
+ declare
+ Aspect_Expr : constant Node_Id :=
+ Expression (Find_Aspect (Btype, Aspect_Extended_Access));
+ begin
+ return No (Aspect_Expr) or else Expr_Value (Aspect_Expr) /= 0;
+ end;
+ elsif Is_Derived_Type (Btype) then
+ return Is_Extended_Access_Type (Etype (Btype));
+ else
+ return False;
+ end if;
+ end Is_Extended_Access_Type;
+
---------------------------------
-- Side_Effect_Free_Statements --
---------------------------------
@@ -15153,9 +15174,18 @@ package body Sem_Util is
-- Is_Aliased_View --
---------------------
- function Is_Aliased_View (Obj : Node_Id) return Boolean is
+ function Is_Aliased_View
+ (Obj : Node_Id; For_Extended : Boolean := False) return Boolean
+ is
E : Entity_Id;
+ -- Ensure that For_Extended parameter is propagated in recursive
+ -- calls by hiding the version that has the wrong default.
+
+ function Is_Aliased_View
+ (Obj : Node_Id; For_SF : Boolean := For_Extended) return Boolean
+ renames Sem_Util.Is_Aliased_View;
+
begin
if Is_Entity_Name (Obj) then
E := Entity (Obj);
@@ -15236,11 +15266,34 @@ package body Sem_Util is
-- rewritten constructs that introduce artificial dereferences.
elsif Nkind (Obj) = N_Explicit_Dereference then
+ -- If For_Extended is False then a dereference of an extended access
+ -- value is, by definition, not aliased.
+ -- This is to prevent covert illegal type conversion via either
+ -- Not_Extended_Type'(Extended_Ptr.all'Access)
+ -- or by passing Extended_Ptr.all as an actual parameter
+ -- corresponding to an explicitly aliased formal parameter
+ -- (which would allow the callee to evaluate Aliased_Param'Access).
+
+ if Is_Extended_Access_Type (Etype (Prefix (Obj)))
+ and then not For_Extended
+ then
+ return False;
+ end if;
+
return not Is_Captured_Function_Call (Obj)
and then not
(Nkind (Parent (Obj)) = N_Object_Renaming_Declaration
and then Is_Return_Object (Defining_Entity (Parent (Obj))));
+ elsif Nkind (Obj) = N_Slice then
+ -- A slice of a bit-packed array is not considered aliased even
+ -- for an extended access type because even extended access types
+ -- don't support bit pointers.
+
+ return For_Extended
+ and then Is_Aliased_View (Prefix (Obj))
+ and then not Is_Bit_Packed_Array (Etype (Obj));
+
else
return False;
end if;
@@ -15668,7 +15721,7 @@ package body Sem_Util is
Expression (Item_2));
end;
- -- A confirming aspect for Implicit_Derenfence on a derived type
+ -- A confirming aspect for Implicit_Dereference on a derived type
-- has already been checked in Analyze_Aspect_Implicit_Dereference,
-- including the presence of renamed discriminants.
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index cefc8e8f688..289d601ec88 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1460,6 +1460,11 @@ package Sem_Util is
function Is_Container_Aggregate (Exp : Node_Id) return Boolean;
-- Is the given expression a container aggregate?
+ function Is_Extended_Access_Type (Ent : Entity_Id) return Boolean;
+ -- Ent is any entity. Returns True if Ent is a type (or a subtype thereof)
+ -- for which the Extended_Access aspect has been specified, either
+ -- explicitly or by inheritance.
+
function Is_Function_With_Side_Effects (Subp : Entity_Id) return Boolean;
-- Return True if Subp is a function with side effects, ie. it has a
-- (direct or inherited) pragma Side_Effects with static value True.
@@ -1768,7 +1773,8 @@ package Sem_Util is
function Is_Actual_Parameter (N : Node_Id) return Boolean;
-- Determines if N is an actual parameter in a subprogram or entry call
- function Is_Aliased_View (Obj : Node_Id) return Boolean;
+ function Is_Aliased_View
+ (Obj : Node_Id; For_Extended : Boolean := False) return Boolean;
-- Determine if Obj is an aliased view, i.e. the name of an object to which
-- 'Access or 'Unchecked_Access can apply. Note that this routine uses the
-- rules of the language, it does not take into account the restriction
@@ -1776,6 +1782,9 @@ package Sem_Util is
-- and Obj violates the restriction. The caller is responsible for calling
-- Restrict.Check_No_Implicit_Aliasing if True is returned, but there is a
-- requirement for obeying the restriction in the call context.
+ -- If For_Extended is True, then slightly different rules apply (as per
+ -- the definition of the Extended_Access aspect); for example, a slice
+ -- of an aliased array is considered to be aliased.
function Is_Ancestor_Package
(E1 : Entity_Id;
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index b706896073f..3281b6f12f8 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -565,6 +565,7 @@ package Snames is
Name_Export_Object : constant Name_Id := N + $; -- GNAT
Name_Export_Procedure : constant Name_Id := N + $; -- GNAT
Name_Export_Valued_Procedure : constant Name_Id := N + $; -- GNAT
+ Name_Extended_Access : constant Name_Id := N + $; -- GNAT
Name_Extensions_Visible : constant Name_Id := N + $; -- GNAT
Name_External : constant Name_Id := N + $; -- GNAT
Name_Finalize_Storage_Only : constant Name_Id := N + $; -- GNAT
@@ -1870,6 +1871,7 @@ package Snames is
Pragma_Export_Object,
Pragma_Export_Procedure,
Pragma_Export_Valued_Procedure,
+ Pragma_Extended_Access,
Pragma_Extensions_Visible,
Pragma_External,
Pragma_Finalize_Storage_Only,
--
2.43.0
