ada: Initial implementation of Extended_Access aspect (FE portion only)

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.

10 files changed, 204 insertions, 5 deletions

diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 2a5e0f2..ebf0960 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 8b953b3..1a2a7b6 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 9ab1972..4e06ec5 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 3bc533a..3ef4e69 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 9a3e7ac..eb11ceb 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 48a1603..e26583d 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 d28e724..658f9eb 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 5d3a4e6..1a51221 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 cefc8e8..289d601 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 b706896..3281b6f 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,