sem_ch3.ads, [...] (Check_Abstract_Overriding): Avoid generation of spurious…

sem_ch3.ads, [...] (Check_Abstract_Overriding): Avoid generation of spurious error if parent is an interface type...

2007-12-06  Javier Miranda  <miranda@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.ads, sem_ch3.adb (Check_Abstract_Overriding): Avoid
	generation of spurious error if parent is an interface type; caused
	because predefined primitive bodies will be generated later by
	Freeze_Record_Type.
	(Process_Subtype): The subtype inherits the Known_To_Have_Preelab_Init
	flag.
	(Derive_Subprograms): Handle derivations of predefined primitives
	after all the user-defined primitives to ensure that they are
	found in proper order in instantiations.
	(Add_Interface_Tag_Components, Inherit_Components): Update occurrences
	of Related_Interface to Related_Type.
	(Record_Type_Declaration): Minor reordering of calls to decorate the
	Tag component because the entity must have set its Ekind attribute
	before setting its Is_Tag attribute.
	(Analyze_Subtype_Declaration): In the case of subtypes with
	Private_Kind, inherit Known_To_Have_Preelab_Init from the parent.

From-SVN: r130883

gcc/ada/sem_ch3.adb

@@ -729,8 +729,8 @@ package body Sem_Ch3 is
       --  function, scope is the current one, because it is the one of the
       --  current type declaration.
 
-      if Nkind (Related_Nod) = N_Object_Declaration
-        or else Nkind (Related_Nod) = N_Access_Function_Definition
+      if Nkind_In (Related_Nod, N_Object_Declaration,
+                                N_Access_Function_Definition)
       then
          Anon_Scope := Current_Scope;
 
@@ -743,7 +743,7 @@ package body Sem_Ch3 is
       --  unit, we must traverse the the tree to retrieve the proper entity.
 
       elsif Nkind (Related_Nod) = N_Function_Specification
-         and then Nkind (Parent (N)) /= N_Parameter_Specification
+        and then Nkind (Parent (N)) /= N_Parameter_Specification
       then
          --  If the current scope is a protected type, the anonymous access
          --  is associated with one of the protected operations, and must
@@ -789,6 +789,9 @@ package body Sem_Ch3 is
               (Anon_Type, E_Anonymous_Access_Subprogram_Type);
          end if;
 
+         Set_Can_Use_Internal_Rep
+           (Anon_Type, not Always_Compatible_Rep_On_Target);
+
          --  If the anonymous access is associated with a protected operation
          --  create a reference to it after the enclosing protected definition
          --  because the itype will be used in the subsequent bodies.
@@ -932,16 +935,17 @@ package body Sem_Ch3 is
       --                                   (Z : access T)))
 
       D_Ityp := Associated_Node_For_Itype (Desig_Type);
-      while Nkind (D_Ityp) /= N_Full_Type_Declaration
-         and then Nkind (D_Ityp) /= N_Private_Type_Declaration
-         and then Nkind (D_Ityp) /= N_Private_Extension_Declaration
-         and then Nkind (D_Ityp) /= N_Procedure_Specification
-         and then Nkind (D_Ityp) /= N_Function_Specification
-         and then Nkind (D_Ityp) /= N_Object_Declaration
-         and then Nkind (D_Ityp) /= N_Object_Renaming_Declaration
-         and then Nkind (D_Ityp) /= N_Formal_Type_Declaration
-         and then Nkind (D_Ityp) /= N_Task_Type_Declaration
-         and then Nkind (D_Ityp) /= N_Protected_Type_Declaration
+      while not (Nkind_In (D_Ityp, N_Full_Type_Declaration,
+                                   N_Private_Type_Declaration,
+                                   N_Private_Extension_Declaration,
+                                   N_Procedure_Specification,
+                                   N_Function_Specification)
+                   or else
+                 Nkind_In (D_Ityp, N_Object_Declaration,
+                                   N_Object_Renaming_Declaration,
+                                   N_Formal_Type_Declaration,
+                                   N_Task_Type_Declaration,
+                                   N_Protected_Type_Declaration))
       loop
          D_Ityp := Parent (D_Ityp);
          pragma Assert (D_Ityp /= Empty);
@@ -949,22 +953,21 @@ package body Sem_Ch3 is
 
       Set_Associated_Node_For_Itype (Desig_Type, D_Ityp);
 
-      if Nkind (D_Ityp) = N_Procedure_Specification
-        or else Nkind (D_Ityp) = N_Function_Specification
+      if Nkind_In (D_Ityp, N_Procedure_Specification,
+                           N_Function_Specification)
       then
          Set_Scope (Desig_Type, Scope (Defining_Entity (D_Ityp)));
 
-      elsif Nkind (D_Ityp) = N_Full_Type_Declaration
-        or else Nkind (D_Ityp) = N_Object_Declaration
-        or else Nkind (D_Ityp) = N_Object_Renaming_Declaration
-        or else Nkind (D_Ityp) = N_Formal_Type_Declaration
+      elsif Nkind_In (D_Ityp, N_Full_Type_Declaration,
+                              N_Object_Declaration,
+                              N_Object_Renaming_Declaration,
+                              N_Formal_Type_Declaration)
       then
          Set_Scope (Desig_Type, Scope (Defining_Identifier (D_Ityp)));
       end if;
 
       if Nkind (T_Def) = N_Access_Function_Definition then
          if Nkind (Result_Definition (T_Def)) = N_Access_Definition then
-
             declare
                Acc : constant Node_Id := Result_Definition (T_Def);
 
@@ -1057,6 +1060,8 @@ package body Sem_Ch3 is
          Set_Ekind (T_Name, E_Access_Subprogram_Type);
       end if;
 
+      Set_Can_Use_Internal_Rep (T_Name, not Always_Compatible_Rep_On_Target);
+
       Set_Etype                    (T_Name, T_Name);
       Init_Size_Align              (T_Name);
       Set_Directly_Designated_Type (T_Name, Desig_Type);
@@ -1229,7 +1234,7 @@ package body Sem_Ch3 is
          Set_Ekind               (Tag, E_Component);
          Set_Is_Tag              (Tag);
          Set_Is_Aliased          (Tag);
-         Set_Related_Interface   (Tag, Iface);
+         Set_Related_Type        (Tag, Iface);
          Init_Component_Location (Tag);
 
          pragma Assert (Is_Frozen (Iface));
@@ -1271,7 +1276,7 @@ package body Sem_Ch3 is
             Set_Analyzed (Decl);
             Set_Ekind               (Offset, E_Component);
             Set_Is_Aliased          (Offset);
-            Set_Related_Interface   (Offset, Iface);
+            Set_Related_Type        (Offset, Iface);
             Init_Component_Location (Offset);
             Insert_After (Last_Tag, Decl);
             Last_Tag := Decl;
@@ -1620,7 +1625,6 @@ package body Sem_Ch3 is
          declare
             Sindic : constant Node_Id :=
                        Subtype_Indication (Component_Definition (N));
-
          begin
             if Nkind (Sindic) = N_Subtype_Indication
               and then Present (Constraint (Sindic))
@@ -1764,9 +1768,9 @@ package body Sem_Ch3 is
          --  (This is needed in any case for early instantiations ???).
 
          if No (Next_Node) then
-            if Nkind (Parent (L)) = N_Component_List
-              or else Nkind (Parent (L)) = N_Task_Definition
-              or else Nkind (Parent (L)) = N_Protected_Definition
+            if Nkind_In (Parent (L), N_Component_List,
+                                     N_Task_Definition,
+                                     N_Protected_Definition)
             then
                null;
 
@@ -1810,12 +1814,13 @@ package body Sem_Ch3 is
          --  not cause unwanted freezing at that point.
 
          elsif not Analyzed (Next_Node)
-           and then (Nkind (Next_Node) = N_Subprogram_Body
-             or else Nkind (Next_Node) = N_Entry_Body
-             or else Nkind (Next_Node) = N_Package_Body
-             or else Nkind (Next_Node) = N_Protected_Body
-             or else Nkind (Next_Node) = N_Task_Body
-             or else Nkind (Next_Node) in N_Body_Stub)
+           and then (Nkind_In (Next_Node, N_Subprogram_Body,
+                                          N_Entry_Body,
+                                          N_Package_Body,
+                                          N_Protected_Body,
+                                          N_Task_Body)
+                       or else
+                     Nkind (Next_Node) in N_Body_Stub)
          then
             Adjust_D;
             Freeze_All (Freeze_From, D);
@@ -2070,9 +2075,7 @@ package body Sem_Ch3 is
          return;
       end if;
 
-      if Nkind (E) = N_Integer_Literal
-        or else Nkind (E) = N_Real_Literal
-      then
+      if Nkind_In (E, N_Integer_Literal, N_Real_Literal) then
          Set_Etype (E, Etype (Id));
       end if;
 
@@ -2364,20 +2367,6 @@ package body Sem_Ch3 is
 
          Set_Is_True_Constant (Id, True);
 
-         --  If the initialization expression is an access to constant,
-         --  it cannot be used with an access type.
-
-         if Is_Access_Type (Etype (E))
-           and then Is_Access_Constant (Etype (E))
-           and then Is_Access_Type (T)
-           and then not Is_Access_Constant (T)
-         then
-            Error_Msg_NE ("object of type& cannot be initialized with " &
-                          "an access-to-constant expression",
-                          E,
-                          T);
-         end if;
-
          --  If we are analyzing a constant declaration, set its completion
          --  flag after analyzing the expression.
 
@@ -3277,6 +3266,8 @@ package body Sem_Ch3 is
                Set_Is_Limited_Record  (Id, Is_Limited_Record     (T));
                Set_Has_Unknown_Discriminants
                                       (Id, Has_Unknown_Discriminants (T));
+               Set_Known_To_Have_Preelab_Init
+                                      (Id, Known_To_Have_Preelab_Init (T));
 
                if Is_Tagged_Type (T) then
                   Set_Is_Tagged_Type       (Id);
@@ -4307,9 +4298,7 @@ package body Sem_Ch3 is
       --  Temporarily remove the current scope from the stack to add the new
       --  declarations to the enclosing scope
 
-      if Nkind (N) = N_Object_Declaration
-        or else Nkind (N) = N_Access_Function_Definition
-      then
+      if Nkind_In (N, N_Object_Declaration, N_Access_Function_Definition) then
          Analyze (Decl);
 
       else
@@ -4320,6 +4309,7 @@ package body Sem_Ch3 is
       end if;
 
       Set_Ekind (Anon, E_Anonymous_Access_Protected_Subprogram_Type);
+      Set_Can_Use_Internal_Rep (Anon, not Always_Compatible_Rep_On_Target);
       return Anon;
    end Replace_Anonymous_Access_To_Protected_Subprogram;
 
@@ -4635,7 +4625,7 @@ package body Sem_Ch3 is
 
                if Nkind (D_Constraint) = N_Identifier
                  and then Chars (D_Constraint) /=
-                   Chars (Defining_Identifier (Disc_Spec))
+                          Chars (Defining_Identifier (Disc_Spec))
                then
                   Error_Msg_N ("new discriminants must constrain old ones",
                     D_Constraint);
@@ -4967,8 +4957,11 @@ package body Sem_Ch3 is
       Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Parent_Base));
       Set_Parent         (Implicit_Base, Parent (Derived_Type));
 
-      if Is_Discrete_Type (Parent_Base) or else
-        Is_Decimal_Fixed_Point_Type (Parent_Base)
+      --  Set RM Size for discrete type or decimal fixed-point type
+      --  Ordinary fixed-point is excluded, why???
+
+      if Is_Discrete_Type (Parent_Base)
+        or else Is_Decimal_Fixed_Point_Type (Parent_Base)
       then
          Set_RM_Size (Implicit_Base, RM_Size (Parent_Base));
       end if;
@@ -5314,8 +5307,8 @@ package body Sem_Ch3 is
         and then  Has_Discriminants (Full_View (Parent_Type))
       then
          if Has_Unknown_Discriminants (Parent_Type)
-           and then Nkind (Subtype_Indication (Type_Definition (N)))
-             = N_Subtype_Indication
+           and then Nkind (Subtype_Indication (Type_Definition (N))) =
+                                                         N_Subtype_Indication
          then
             Error_Msg_N
               ("cannot constrain type with unknown discriminants",
@@ -5973,7 +5966,7 @@ package body Sem_Ch3 is
       Discriminant_Specs : constant Boolean :=
                              Present (Discriminant_Specifications (N));
       Private_Extension  : constant Boolean :=
-                             (Nkind (N) = N_Private_Extension_Declaration);
+                             Nkind (N) = N_Private_Extension_Declaration;
 
       Constraint_Present : Boolean;
       Inherit_Discrims   : Boolean := False;
@@ -7393,14 +7386,24 @@ package body Sem_Ch3 is
             Set_Ekind (Def_Id, E_Record_Subtype);
          end if;
 
+         --  Inherit preelaboration flag from base, for types for which it
+         --  may have been set: records, private types, protected types.
+
+         Set_Known_To_Have_Preelab_Init
+           (Def_Id, Known_To_Have_Preelab_Init (T));
+
       elsif Ekind (T) = E_Task_Type then
          Set_Ekind (Def_Id, E_Task_Subtype);
 
       elsif Ekind (T) = E_Protected_Type then
          Set_Ekind (Def_Id, E_Protected_Subtype);
+         Set_Known_To_Have_Preelab_Init
+           (Def_Id, Known_To_Have_Preelab_Init (T));
 
       elsif Is_Private_Type (T) then
          Set_Ekind (Def_Id, Subtype_Kind (Ekind (T)));
+         Set_Known_To_Have_Preelab_Init
+           (Def_Id, Known_To_Have_Preelab_Init (T));
 
       elsif Is_Class_Wide_Type (T) then
          Set_Ekind (Def_Id, E_Class_Wide_Subtype);
@@ -7529,9 +7532,7 @@ package body Sem_Ch3 is
 
       Analyze_And_Resolve (Bound, Base_Type (Par_T));
 
-      if Nkind (Bound) = N_Integer_Literal
-        or else Nkind (Bound) = N_Real_Literal
-      then
+      if Nkind_In (Bound, N_Integer_Literal, N_Real_Literal) then
          New_Bound := New_Copy (Bound);
          Set_Etype (New_Bound, Der_T);
          Set_Analyzed (New_Bound);
@@ -7826,8 +7827,6 @@ package body Sem_Ch3 is
          --  overriding in Ada2005, but wrappers need to be built for them
          --  (see exp_ch3, Build_Controlling_Function_Wrappers).
 
-         --  Use elseif here and avoid above goto???
-
          if Is_Null_Extension (T)
            and then Has_Controlling_Result (Subp)
            and then Ada_Version >= Ada_05
@@ -7835,15 +7834,15 @@ package body Sem_Ch3 is
            and then not Comes_From_Source (Subp)
            and then not Is_Abstract_Subprogram (Alias (Subp))
          then
-            goto Next_Subp;
-         end if;
+            null;
 
-         if (Is_Abstract_Subprogram (Subp)
+         elsif (Is_Abstract_Subprogram (Subp)
               or else Requires_Overriding (Subp)
-              or else (Has_Controlling_Result (Subp)
-                        and then Present (Alias_Subp)
-                        and then not Comes_From_Source (Subp)
-                        and then Sloc (Subp) = Sloc (First_Subtype (T))))
+              or else
+                (Has_Controlling_Result (Subp)
+                   and then Present (Alias_Subp)
+                   and then not Comes_From_Source (Subp)
+                   and then Sloc (Subp) = Sloc (First_Subtype (T))))
            and then not Is_TSS (Subp, TSS_Stream_Input)
            and then not Is_TSS (Subp, TSS_Stream_Output)
            and then not Is_Abstract_Type (T)
@@ -7851,6 +7850,7 @@ package body Sem_Ch3 is
            and then Chars (Subp) /= Name_uDisp_Asynchronous_Select
            and then Chars (Subp) /= Name_uDisp_Conditional_Select
            and then Chars (Subp) /= Name_uDisp_Get_Prim_Op_Kind
+           and then Chars (Subp) /= Name_uDisp_Requeue
            and then Chars (Subp) /= Name_uDisp_Timed_Select
 
             --  Ada 2005 (AI-251): Do not consider hidden entities associated
@@ -7877,6 +7877,7 @@ package body Sem_Ch3 is
                --  Exp_Ch3.Make_Controlling_Wrapper_Functions).
 
                Type_Def := Type_Definition (Parent (T));
+
                if Nkind (Type_Def) = N_Derived_Type_Definition
                  and then Present (Record_Extension_Part (Type_Def))
                  and then
@@ -7888,32 +7889,46 @@ package body Sem_Ch3 is
                       or else Requires_Overriding (Subp)
                       or else Is_Access_Type (Etype (Subp)))
                then
-                  Error_Msg_NE
-                    ("type must be declared abstract or & overridden",
-                     T, Subp);
+                  --  The body of predefined primitives of tagged types derived
+                  --  from interface types are generated later by Freeze_Type.
 
-                  --  Traverse the whole chain of aliased subprograms to
-                  --  complete the error notification. This is especially
-                  --  useful for traceability of the chain of entities when the
-                  --  subprogram corresponds with an interface subprogram
-                  --  (which might be defined in another package)
+                  if Is_Predefined_Dispatching_Operation (Subp)
+                    and then Is_Abstract_Subprogram (Alias_Subp)
+                    and then Is_Interface
+                               (Root_Type (Find_Dispatching_Type (Subp)))
+                  then
+                     null;
 
-                  if Present (Alias_Subp) then
-                     declare
-                        E : Entity_Id;
+                  else
+                     Error_Msg_NE
+                       ("type must be declared abstract or & overridden",
+                        T, Subp);
 
-                     begin
-                        E := Subp;
-                        while Present (Alias (E)) loop
-                           Error_Msg_Sloc := Sloc (E);
-                           Error_Msg_NE ("\& has been inherited #", T, Subp);
-                           E := Alias (E);
-                        end loop;
+                     --  Traverse the whole chain of aliased subprograms to
+                     --  complete the error notification. This is especially
+                     --  useful for traceability of the chain of entities when
+                     --  the subprogram corresponds with an interface
+                     --  subprogram (which may be defined in another package).
+
+                     if Present (Alias_Subp) then
+                        declare
+                           E : Entity_Id;
+
+                        begin
+                           E := Subp;
+                           while Present (Alias (E)) loop
+                              Error_Msg_Sloc := Sloc (E);
+                              Error_Msg_NE
+                                ("\& has been inherited #", T, Subp);
+                              E := Alias (E);
+                           end loop;
 
-                        Error_Msg_Sloc := Sloc (E);
-                        Error_Msg_NE
-                          ("\& has been inherited from subprogram #", T, Subp);
-                     end;
+                           Error_Msg_Sloc := Sloc (E);
+                           Error_Msg_NE
+                             ("\& has been inherited from subprogram #",
+                              T, Subp);
+                        end;
+                     end if;
                   end if;
 
                --  Ada 2005 (AI-345): Protected or task type implementing
@@ -7960,8 +7975,36 @@ package body Sem_Ch3 is
             end if;
          end if;
 
-         <<Next_Subp>>
-            Next_Elmt (Elmt);
+         --  Ada 2005 (AI05-0030): Inspect hidden subprograms which provide
+         --  the mapping between interface and implementing type primitives.
+         --  If the interface alias is marked as Implemented_By_Entry, the
+         --  alias must be an entry wrapper.
+
+         if Ada_Version >= Ada_05
+           and then Is_Hidden (Subp)
+           and then Present (Abstract_Interface_Alias (Subp))
+           and then Implemented_By_Entry (Abstract_Interface_Alias (Subp))
+           and then Present (Alias_Subp)
+           and then
+             (not Is_Primitive_Wrapper (Alias_Subp)
+                or else Ekind (Wrapped_Entity (Alias_Subp)) /= E_Entry)
+         then
+            declare
+               Error_Ent : Entity_Id := T;
+
+            begin
+               if Is_Concurrent_Record_Type (Error_Ent) then
+                  Error_Ent := Corresponding_Concurrent_Type (Error_Ent);
+               end if;
+
+               Error_Msg_Node_2 := Abstract_Interface_Alias (Subp);
+               Error_Msg_NE
+                 ("type & must implement abstract subprogram & with an entry",
+                  Error_Ent, Error_Ent);
+            end;
+         end if;
+
+         Next_Elmt (Elmt);
       end loop;
    end Check_Abstract_Overriding;
 
@@ -8125,8 +8168,8 @@ package body Sem_Ch3 is
                elsif Is_Overloadable (E)
                  and then Current_Entity_In_Scope (E) /= E
                then
-                  --  It may be that the completion is mistyped and appears
-                  --  as a  distinct overloading of the entity.
+                  --  It may be that the completion is mistyped and appears as
+                  --  a distinct overloading of the entity.
 
                   declare
                      Candidate : constant Entity_Id :=
@@ -8163,18 +8206,17 @@ package body Sem_Ch3 is
          if Is_Intrinsic_Subprogram (E) then
             null;
 
-         --  The following situation requires special handling: a child
-         --  unit that appears in the context clause of the body of its
-         --  parent:
+         --  The following situation requires special handling: a child unit
+         --  that appears in the context clause of the body of its parent:
 
          --    procedure Parent.Child (...);
 
          --    with Parent.Child;
          --    package body Parent is
 
-         --  Here Parent.Child appears as a local entity, but should not
-         --  be flagged as requiring completion, because it is a
-         --  compilation unit.
+         --  Here Parent.Child appears as a local entity, but should not be
+         --  flagged as requiring completion, because it is a compilation
+         --  unit.
 
          --  Ignore missing completion for a subprogram that does not come from
          --  source (including the _Call primitive operation of RAS types,
@@ -8359,7 +8401,7 @@ package body Sem_Ch3 is
 
                else
                   Error_Msg_N
-                    ("initialization of limited object requires agggregate "
+                    ("initialization of limited object requires aggregate "
                       & "or function call",  Exp);
                end if;
             end if;
@@ -11086,10 +11128,10 @@ package body Sem_Ch3 is
          Next_Elmt (Elmt);
       end loop;
 
-      --  Complete the derivation of the interface subprograms. Assignate to
-      --  each entity associated with abstract interfaces their aliased entity
-      --  and complete their decoration as hidden interface entities that will
-      --  be used later to build the secondary dispatch tables.
+      --  Complete the derivation of the interface subprograms. Assign to each
+      --  entity associated with abstract interfaces their aliased entity and
+      --  complete their decoration as hidden interface entities that will be
+      --  used later to build the secondary dispatch tables.
 
       if not Is_Empty_Elmt_List (Ifaces_List) then
          if Ekind (Parent_Type) = E_Record_Type_With_Private
@@ -11605,13 +11647,14 @@ package body Sem_Ch3 is
    ------------------------
 
    procedure Derive_Subprograms
-     (Parent_Type           : Entity_Id;
-      Derived_Type          : Entity_Id;
-      Generic_Actual        : Entity_Id := Empty)
+     (Parent_Type    : Entity_Id;
+      Derived_Type   : Entity_Id;
+      Generic_Actual : Entity_Id := Empty)
    is
       Op_List      : constant Elist_Id :=
                        Collect_Primitive_Operations (Parent_Type);
       Ifaces_List  : constant Elist_Id := New_Elmt_List;
+      Predef_Prims : constant Elist_Id := New_Elmt_List;
       Act_List     : Elist_Id;
       Act_Elmt     : Elmt_Id;
       Elmt         : Elmt_Id;
@@ -11629,7 +11672,9 @@ package body Sem_Ch3 is
          Parent_Base := Parent_Type;
       end if;
 
-      --  Derive primitives inherited from the parent
+      --  Derive primitives inherited from the parent. Note that if the generic
+      --  actual is present, this is not really a type derivation, it is a
+      --  completion within an instance.
 
       if Present (Generic_Actual) then
          Act_List := Collect_Primitive_Operations (Generic_Actual);
@@ -11652,18 +11697,27 @@ package body Sem_Ch3 is
             then
                null;
 
+            --  We derive predefined primitives in a later round to ensure that
+            --  they are always added to the list of primitives after user
+            --  defined primitives (because predefined primitives have to be
+            --  skipped when matching the operations of a parent interface to
+            --  those of a concrete type). However it is unclear why those
+            --  primitives would be needed in an instantiation???
+
+            elsif Is_Predefined_Dispatching_Operation (Subp) then
+               Append_Elmt (Subp, Predef_Prims);
+
             elsif No (Generic_Actual) then
                Derive_Subprogram (New_Subp, Subp, Derived_Type, Parent_Base);
 
-               --  Ada 2005 (AI-251): Add the derivation of an abstract
-               --  interface primitive to the list of entities to which
-               --  we have to associate an aliased entity.
+               --  Ada 2005 (AI-251): Add derivation of an abstract interface
+               --  primitive to the list of entities to which we have to
+               --  associate an aliased entity.
 
                if Ada_Version >= Ada_05
                  and then Is_Dispatching_Operation (Subp)
                  and then Present (Find_Dispatching_Type (Subp))
                  and then Is_Interface (Find_Dispatching_Type (Subp))
-                 and then not Is_Predefined_Dispatching_Operation (Subp)
                then
                   Append_Elmt (New_Subp, Ifaces_List);
                end if;
@@ -11714,13 +11768,12 @@ package body Sem_Ch3 is
          Next_Elmt (Elmt);
       end loop;
 
-      --  Inherit additional operations from progenitor interfaces.
-      --  However, if the derived type is a generic actual, there
-      --  are not new primitive operations for the type, because
-      --  it has those of the actual, so nothing needs to be done.
-      --  The renamings generated above are not primitive operations,
-      --  and their purpose is simply to make the proper operations
-      --  visible within an instantiation.
+      --  Inherit additional operations from progenitor interfaces. However,
+      --  if the derived type is a generic actual, there are not new primitive
+      --  operations for the type, because it has those of the actual, so
+      --  nothing needs to be done. The renamings generated above are not
+      --  primitive operations, and their purpose is simply to make the proper
+      --  operations visible within an instantiation.
 
       if Ada_Version >= Ada_05
         and then Is_Tagged_Type (Derived_Type)
@@ -11728,6 +11781,17 @@ package body Sem_Ch3 is
       then
          Derive_Interface_Subprograms (Parent_Type, Derived_Type, Ifaces_List);
       end if;
+
+      --  Derive predefined primitives
+
+      if not Is_Empty_Elmt_List (Predef_Prims) then
+         Elmt := First_Elmt (Predef_Prims);
+         while Present (Elmt) loop
+            Derive_Subprogram
+              (New_Subp, Node (Elmt), Derived_Type, Parent_Base);
+            Next_Elmt (Elmt);
+         end loop;
+      end if;
    end Derive_Subprograms;
 
    --------------------------------
@@ -11795,12 +11859,12 @@ package body Sem_Ch3 is
 
       Convert_Scalar_Bounds (N, Parent_Type, Derived_Type, Loc);
 
-      --  Because the implicit base is used in the conversion of the bounds,
-      --  we have to freeze it now. This is similar to what is done for
-      --  numeric types, and it equally suspicious, but otherwise a non-
-      --  static bound will have a reference to an unfrozen type, which is
-      --  rejected by Gigi (???). This requires specific care for definition
-      --  of stream attributes. For details, see comments at the end of
+      --  Because the implicit base is used in the conversion of the bounds, we
+      --  have to freeze it now. This is similar to what is done for numeric
+      --  types, and it equally suspicious, but otherwise a non-static bound
+      --  will have a reference to an unfrozen type, which is rejected by Gigi
+      --  (???). This requires specific care for definition of stream
+      --  attributes. For details, see comments at the end of
       --  Build_Derived_Numeric_Type.
 
       Freeze_Before (N, Implicit_Base);
@@ -12495,9 +12559,9 @@ package body Sem_Ch3 is
             Enter_Name (Id);
             New_Id := Id;
 
-         elsif Nkind (N) /= N_Full_Type_Declaration
-           and then Nkind (N) /= N_Task_Type_Declaration
-           and then Nkind (N) /= N_Protected_Type_Declaration
+         elsif not Nkind_In (N, N_Full_Type_Declaration,
+                                N_Task_Type_Declaration,
+                                N_Protected_Type_Declaration)
          then
             --  Completion must be a full type declarations (RM 7.3(4))
 
@@ -12542,17 +12606,15 @@ package body Sem_Ch3 is
                   New_Id := Id;
 
                elsif Ekind (Prev) = E_Private_Type
-                 and then
-                   (Nkind (N) = N_Task_Type_Declaration
-                     or else Nkind (N) = N_Protected_Type_Declaration)
+                 and then Nkind_In (N, N_Task_Type_Declaration,
+                                       N_Protected_Type_Declaration)
                then
                   Error_Msg_N
                    ("completion of nonlimited type cannot be limited", N);
 
                elsif Ekind (Prev) = E_Record_Type_With_Private
-                 and then
-                   (Nkind (N) = N_Task_Type_Declaration
-                     or else Nkind (N) = N_Protected_Type_Declaration)
+                 and then Nkind_In (N, N_Task_Type_Declaration,
+                                       N_Protected_Type_Declaration)
                then
                   if not Is_Limited_Record (Prev) then
                      Error_Msg_N
@@ -12569,8 +12631,8 @@ package body Sem_Ch3 is
             --  type or a protected type. This case arises when covering
             --  interface types.
 
-            elsif Nkind (N) = N_Task_Type_Declaration
-              or else Nkind (N) = N_Protected_Type_Declaration
+            elsif Nkind_In (N, N_Task_Type_Declaration,
+                               N_Protected_Type_Declaration)
             then
                null;
 
@@ -12643,8 +12705,8 @@ package body Sem_Ch3 is
          if Is_Type (Prev)
            and then (Is_Tagged_Type (Prev)
                       or else Present (Class_Wide_Type (Prev)))
-           and then (Nkind (N) /= N_Task_Type_Declaration
-                      and then Nkind (N) /= N_Protected_Type_Declaration)
+           and then not Nkind_In (N, N_Task_Type_Declaration,
+                                     N_Protected_Type_Declaration)
          then
             --  The full declaration is either a tagged record or an
             --  extension otherwise this is an error
@@ -12706,8 +12768,8 @@ package body Sem_Ch3 is
 
       --  Case of an anonymous array subtype
 
-      if Def_Kind = N_Constrained_Array_Definition
-        or else Def_Kind = N_Unconstrained_Array_Definition
+      if Nkind_In (Def_Kind, N_Constrained_Array_Definition,
+                             N_Unconstrained_Array_Definition)
       then
          T := Empty;
          Array_Type_Declaration (T, Obj_Def);
@@ -13457,7 +13519,7 @@ package body Sem_Ch3 is
          --  secondary tags of the parent.
 
          if Ekind (Component) = E_Component
-           and then Present (Related_Interface (Component))
+           and then Present (Related_Type (Component))
          then
             null;
 
@@ -13568,22 +13630,16 @@ package body Sem_Ch3 is
             return Constraint_Kind = N_Range_Constraint;
 
          when Decimal_Fixed_Point_Kind =>
-            return
-              Constraint_Kind = N_Digits_Constraint
-                or else
-              Constraint_Kind = N_Range_Constraint;
+            return Nkind_In (Constraint_Kind, N_Digits_Constraint,
+                                              N_Range_Constraint);
 
          when Ordinary_Fixed_Point_Kind =>
-            return
-              Constraint_Kind = N_Delta_Constraint
-                or else
-              Constraint_Kind = N_Range_Constraint;
+            return Nkind_In (Constraint_Kind, N_Delta_Constraint,
+                                              N_Range_Constraint);
 
          when Float_Kind =>
-            return
-              Constraint_Kind = N_Digits_Constraint
-                or else
-              Constraint_Kind = N_Range_Constraint;
+            return Nkind_In (Constraint_Kind, N_Digits_Constraint,
+                                              N_Range_Constraint);
 
          when Access_Kind       |
               Array_Kind        |
@@ -15520,19 +15576,14 @@ package body Sem_Ch3 is
 
                Type_Decl := Parent (R);
                while Present (Type_Decl) and then not
-                 (Nkind (Type_Decl) = N_Full_Type_Declaration
-                    or else
-                  Nkind (Type_Decl) = N_Subtype_Declaration
-                    or else
-                  Nkind (Type_Decl) = N_Loop_Statement
-                    or else
-                  Nkind (Type_Decl) = N_Task_Type_Declaration
-                    or else
-                  Nkind (Type_Decl) = N_Single_Task_Declaration
+                 (Nkind_In (Type_Decl, N_Full_Type_Declaration,
+                                       N_Subtype_Declaration,
+                                       N_Loop_Statement,
+                                       N_Task_Type_Declaration)
                     or else
-                  Nkind (Type_Decl) = N_Protected_Type_Declaration
-                    or else
-                  Nkind (Type_Decl) = N_Single_Protected_Declaration)
+                  Nkind_In (Type_Decl, N_Single_Task_Declaration,
+                                       N_Protected_Type_Declaration,
+                                       N_Single_Protected_Declaration))
                loop
                   Type_Decl := Parent (Type_Decl);
                end loop;
@@ -15550,8 +15601,8 @@ package body Sem_Ch3 is
 
                      begin
                         Indic := Parent (R);
-                        while Present (Indic) and then not
-                          (Nkind (Indic) = N_Subtype_Indication)
+                        while Present (Indic)
+                          and then Nkind (Indic) /= N_Subtype_Indication
                         loop
                            Indic := Parent (Indic);
                         end loop;
@@ -15694,7 +15745,6 @@ package body Sem_Ch3 is
       --  Case of no constraints present
 
       if Nkind (S) /= N_Subtype_Indication then
-
          Find_Type (S);
          Check_Incomplete (S);
          P := Parent (S);
@@ -15710,18 +15760,21 @@ package body Sem_Ch3 is
             Error_Msg_N ("`NOT NULL` only allowed for an access type", S);
          end if;
 
+         --  The following is ugly, can't we have a range or even a flag???
+
          May_Have_Null_Exclusion :=
-           Nkind (P) = N_Access_Definition
-           or else Nkind (P) = N_Access_Function_Definition
-           or else Nkind (P) = N_Access_Procedure_Definition
-           or else Nkind (P) = N_Access_To_Object_Definition
-           or else Nkind (P) = N_Allocator
-           or else Nkind (P) = N_Component_Definition
-           or else Nkind (P) = N_Derived_Type_Definition
-           or else Nkind (P) = N_Discriminant_Specification
-           or else Nkind (P) = N_Object_Declaration
-           or else Nkind (P) = N_Parameter_Specification
-           or else Nkind (P) = N_Subtype_Declaration;
+           Nkind_In (P, N_Access_Definition,
+                        N_Access_Function_Definition,
+                        N_Access_Procedure_Definition,
+                        N_Access_To_Object_Definition,
+                        N_Allocator,
+                        N_Component_Definition)
+             or else
+           Nkind_In (P, N_Derived_Type_Definition,
+                        N_Discriminant_Specification,
+                        N_Object_Declaration,
+                        N_Parameter_Specification,
+                        N_Subtype_Declaration);
 
          --  Create an Itype that is a duplicate of Entity (S) but with the
          --  null-exclusion attribute
@@ -16079,7 +16132,6 @@ package body Sem_Ch3 is
       ------------------
 
       function Designates_T (Subt : Node_Id) return Boolean is
-
          Type_Id : constant Name_Id := Chars (Typ);
 
          function Names_T (Nam : Node_Id) return Boolean;
@@ -16108,9 +16160,11 @@ package body Sem_Ch3 is
                   else
                      return False;
                   end if;
+
                else
                   return False;
                end if;
+
             else
                return False;
             end if;
@@ -16143,8 +16197,8 @@ package body Sem_Ch3 is
                        or else
                          (Is_Class_Wide_Type (Entity (Subt))
                            and then
-                           Chars (Etype (Base_Type (Entity (Subt))))
-                             = Type_Id));
+                           Chars (Etype (Base_Type (Entity (Subt)))) =
+                                                                  Type_Id));
             end if;
 
          --  A reference to the current type may appear as the prefix of
@@ -16168,7 +16222,7 @@ package body Sem_Ch3 is
          Param_Spec : Node_Id;
 
          Acc_Subprg : constant Node_Id :=
-           Access_To_Subprogram_Definition (Acc_Def);
+                        Access_To_Subprogram_Definition (Acc_Def);
 
       begin
          if No (Acc_Subprg) then
@@ -16203,7 +16257,6 @@ package body Sem_Ch3 is
          end if;
 
          return False;
-
       end Mentions_T;
 
    --  Start of processing for Check_Anonymous_Access_Components
@@ -16445,9 +16498,9 @@ package body Sem_Ch3 is
             Tag_Comp := Make_Defining_Identifier (Sloc (Def), Name_uTag);
             Enter_Name (Tag_Comp);
 
+            Set_Ekind                     (Tag_Comp, E_Component);
             Set_Is_Tag                    (Tag_Comp);
             Set_Is_Aliased                (Tag_Comp);
-            Set_Ekind                     (Tag_Comp, E_Component);
             Set_Etype                     (Tag_Comp, RTE (RE_Tag));
             Set_DT_Entry_Count            (Tag_Comp, No_Uint);
             Set_Original_Record_Component (Tag_Comp, Tag_Comp);

gcc/ada/sem_ch3.ads

@@ -120,18 +120,16 @@ package Sem_Ch3  is
    --  subprogram of the parent type.
 
    procedure Derive_Subprograms
-     (Parent_Type           : Entity_Id;
-      Derived_Type          : Entity_Id;
-      Generic_Actual        : Entity_Id := Empty);
+     (Parent_Type    : Entity_Id;
+      Derived_Type   : Entity_Id;
+      Generic_Actual : Entity_Id := Empty);
    --  To complete type derivation, collect/retrieve the primitive operations
    --  of the parent type, and replace the subsidiary subtypes with the derived
    --  type, to build the specs of the inherited ops. For generic actuals, the
    --  mapping of the primitive operations to those of the parent type is also
    --  done by rederiving the operations within the instance. For tagged types,
    --  the derived subprograms are aliased to those of the actual, not those of
-   --  the ancestor. The last two params are used in case of derivation from
-   --  abstract interface types: No_Predefined_Prims is used to avoid the
-   --  derivation of predefined primitives from an abstract interface.
+   --  the ancestor.
    --
    --  Note: one might expect this to be private to the package body, but
    --  there is one rather unusual usage in package Exp_Dist.