ada: Implement new experimental attribute 'Super

This patch implements (under -gnatX0) the 'Super attribute which can be
applied to tagged objects in order to get a view conversion to their
immediate parent.

gcc/ada/

	* doc/gnat_rm/implementation_defined_attributes.rst: Add entry for
	Super attribute.
	* accessibility.adb (Accessibility_Level): Add handling for Super.
	* exp_attr.adb (Expand_N_Attribute_Reference): Add entry for
	Super.
	* sem_attr.adb (Analyze_Attribute): Create a case to handle the
	semantic checking and expansion for Super.
	(Eval_Attribute): Add entry for Super.
	* sem_attr.ads: Add entry for Super.
	* sem_util.adb (Is_Aliased_View, Is_Variable): Add case to handle
	references to 'Super.
	* snames.ads-tmpl: Register Name_Super and Attribute_Super.
	* gnat_rm.texi: Regenerate.

1 files changed, 57 insertions, 0 deletions

diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 2fa7d7d..c78b11b 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -6683,6 +6683,62 @@ package body Sem_Attr is
 
       --  Shares processing with Pred attribute
 
+      -----------
+      -- Super --
+      -----------
+
+      when Attribute_Super =>
+         Error_Msg_Name_1 := Aname;
+         Error_Msg_GNAT_Extension ("attribute %", Sloc (N));
+
+         Check_E0;
+
+         --  Verify that we are looking at a type with ancestors
+
+         if not Is_Record_Type (P_Type)
+           or else not Is_Tagged_Type (P_Type)
+         then
+            Error_Attr_P
+              ("prefix type of % attribute must be tagged or class-wide");
+         end if;
+
+         --  Verify that the immediate parent type is suitable for 'Super
+
+         declare
+            Parents : constant Elist_Id :=
+              --  Grab all immediate ancestor types of the prefix's type
+
+              Visible_Ancestors
+                ((if Ekind (P_Type) = E_Class_Wide_Type then Etype (P_Type)
+                  else P_Type));
+         begin
+            --  No parent type to reference
+
+            if Is_Empty_Elmt_List (Parents) then
+               Error_Attr_P ("prefix type of % must be type extension");
+
+            --  We can't grant access of a child to a parent's private part
+
+            elsif Depends_On_Private (P_Type) then
+               Error_Attr_P ("prefix type of % is a private extension");
+
+            --  Check that we don't view convert to an abstract type
+
+            elsif Is_Abstract_Type (Node (First_Elmt (Parents))) then
+               Error_Attr_P ("type of % cannot be abstract");
+            end if;
+
+            --  Generate a view conversion and analyze it
+
+            Rewrite (N,
+              Make_Type_Conversion (Loc,
+                Expression   => Relocate_Node (P),
+                Subtype_Mark =>
+                  New_Occurrence_Of (Node (First_Elmt (Parents)), Loc)));
+
+            Analyze_And_Resolve (N);
+         end;
+
       --------------------------------
       -- System_Allocator_Alignment --
       --------------------------------
@@ -10978,6 +11034,7 @@ package body Sem_Attr is
          | Attribute_Storage_Size
          | Attribute_Storage_Unit
          | Attribute_Stub_Type
+         | Attribute_Super
          | Attribute_System_Allocator_Alignment
          | Attribute_Tag
          | Attribute_Target_Name