einfo.ads, einfo.adb (Primitive_Operations): New synthesized attribute.

2010-10-18  Javier Miranda  <miranda@adacore.com>

	* einfo.ads, einfo.adb (Primitive_Operations): New synthesized
	attribute.
	(Direct_Primitive_Operations): Renaming of old Primitive_Operations.
	(Set_Direct_Primitive_Operations): Renaming of old
	Set_Primitive_Operations. Update documentation
	* sem_ch3.adb, exp_util.adb, sem_ch7.adb, sem_ch8.adb, exp_ch3.adb:
	Replace occurrences of Set_Primitive_Operations by
	Set_Direct_Primitive_Operations.
	* sem_cat.adb (Validate_RACW_Primitives): No action needed for tagged
	concurrent types.
	* exp_dist.adb (Add_RACW_Primitive_Declarations_And_Bodies): Do not
	process primitives of concurrent types.
	* lib-xref.adb (Generate_Prim_Op_References): Minor code cleanup.

From-SVN: r165618

11 files changed, 126 insertions, 76 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 37b23e9..0813f2e 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,19 @@
+2010-10-18  Javier Miranda  <miranda@adacore.com>
+
+	* einfo.ads, einfo.adb (Primitive_Operations): New synthesized
+	attribute.
+	(Direct_Primitive_Operations): Renaming of old Primitive_Operations.
+	(Set_Direct_Primitive_Operations): Renaming of old
+	Set_Primitive_Operations. Update documentation
+	* sem_ch3.adb, exp_util.adb, sem_ch7.adb, sem_ch8.adb, exp_ch3.adb:
+	Replace occurrences of Set_Primitive_Operations by
+	Set_Direct_Primitive_Operations.
+	* sem_cat.adb (Validate_RACW_Primitives): No action needed for tagged
+	concurrent types.
+	* exp_dist.adb (Add_RACW_Primitive_Declarations_And_Bodies): Do not
+	process primitives of concurrent types.
+	* lib-xref.adb (Generate_Prim_Op_References): Minor code cleanup.
+
 2010-10-18  Eric Botcazou  <ebotcazou@adacore.com>
 
 	* exp_ch6.adb (Expand_N_Subprogram_Declaration): Use Freeze_Before.
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 6782c5b..a8bb4d2 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -121,7 +121,7 @@ package body Einfo is
    --    Entry_Parameters_Type           Node15
    --    Extra_Formal                    Node15
    --    Lit_Indexes                     Node15
-   --    Primitive_Operations            Elist15
+   --    Direct_Primitive_Operations     Elist15
    --    Related_Instance                Node15
    --    Scale_Value                     Uint15
    --    Storage_Size_Variable           Node15
@@ -817,6 +817,12 @@ package body Einfo is
       return Uint17 (Id);
    end Digits_Value;
 
+   function Direct_Primitive_Operations (Id : E) return L is
+   begin
+      pragma Assert (Is_Tagged_Type (Id));
+      return Elist15 (Id);
+   end Direct_Primitive_Operations;
+
    function Directly_Designated_Type (Id : E) return E is
    begin
       pragma Assert (Is_Access_Type (Id));
@@ -2355,8 +2361,16 @@ package body Einfo is
 
    function Primitive_Operations (Id : E) return L is
    begin
-      pragma Assert (Is_Tagged_Type (Id));
-      return Elist15 (Id);
+      if Is_Concurrent_Type (Id) then
+         if Present (Corresponding_Record_Type (Id)) then
+            return Direct_Primitive_Operations
+                     (Corresponding_Record_Type (Id));
+         else
+            return No_Elist;
+         end if;
+      else
+         return Direct_Primitive_Operations (Id);
+      end if;
    end Primitive_Operations;
 
    function Prival (Id : E) return E is
@@ -4817,11 +4831,18 @@ package body Einfo is
       Set_Node8 (Id, V);
    end Set_Postcondition_Proc;
 
-   procedure Set_Primitive_Operations (Id : E; V : L) is
+   procedure Set_Direct_Primitive_Operations (Id : E; V : L) is
    begin
-      pragma Assert (Is_Tagged_Type (Id));
+      pragma Assert
+        (Is_Tagged_Type (Id)
+           and then
+             (Is_Record_Type (Id)
+                or else
+              Is_Incomplete_Type (Id)
+                or else
+              Ekind_In (Id, E_Private_Type, E_Private_Subtype)));
       Set_Elist15 (Id, V);
-   end Set_Primitive_Operations;
+   end Set_Direct_Primitive_Operations;
 
    procedure Set_Prival (Id : E; V : E) is
    begin
@@ -7583,7 +7604,7 @@ package body Einfo is
               E_Record_Type                                |
               E_Record_Subtype                             |
               Private_Kind                                 =>
-            Write_Str ("Primitive_Operations");
+            Write_Str ("Direct_Primitive_Operations");
 
          when E_Component                                  =>
             Write_Str ("DT_Entry_Count");
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index c459f64..3abc37b 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -769,6 +769,16 @@ package Einfo is
 --       Present in floating point types and subtypes and decimal types and
 --       subtypes. Contains the Digits value specified in the declaration.
 
+--    Direct_Primitive_Operations (Elist15)
+--       Present in tagged record types and subtypes, in tagged private types
+--       and in tagged incomplete types. Points to an element list of entities
+--       for primitive operations for the tagged type. Not present in untagged
+--       types (it is an error to reference the primitive operations field of a
+--       type that is not tagged). In order to fulfill the C++ ABI, entities of
+--       primitives that come from source must be stored in this list following
+--       their order of occurrence in the sources. For incomplete types the
+--       list is always empty.
+
 --    Directly_Designated_Type (Node20)
 --       Present in access types. This field points to the type that is
 --       directly designated by the access type. In the case of an access
@@ -3201,15 +3211,12 @@ package Einfo is
 --       to generate the call to this procedure in case the expander inserts
 --       implicit return statements.
 
---    Primitive_Operations (Elist15)
---       Present in tagged record types and subtypes and in tagged private
---       types. Points to an element list of entities for primitive operations
---       for the tagged type. Not present (and not set) in untagged types (it
---       is an error to reference the primitive operations field of a type
---       that is not tagged). In order to fulfill the C++ ABI, entities of
---       primitives that come from source must be stored in this list following
---       their order of occurrence in the sources. Also present in incomplete
---       types, but in this case the list is always empty.
+--    Primitive_Operations (synthesized)
+--       Present in concurrent types, tagged record types and subtypes, tagged
+--       private types and tagged incomplete types. For concurrent types that
+--       have available their Corresponding_Record_Type (CRT) returns the list
+--       of Direct_Primitive_Operations of its CRT; otherwise returns No_Elist.
+--       For all the other types returns its Direct_Primitive_Operations.
 
 --    Prival (Node17)
 --       Present in private components of protected types. Refers to the entity
@@ -5262,7 +5269,7 @@ package Einfo is
 
    --  E_Private_Type
    --  E_Private_Subtype
-   --    Primitive_Operations                (Elist15)
+   --    Direct_Primitive_Operations         (Elist15)
    --    First_Entity                        (Node17)
    --    Private_Dependents                  (Elist18)
    --    Underlying_Full_View                (Node19)
@@ -5369,7 +5376,7 @@ package Einfo is
 
    --  E_Record_Type
    --  E_Record_Subtype
-   --    Primitive_Operations                (Elist15)
+   --    Direct_Primitive_Operations         (Elist15)
    --    Access_Disp_Table                   (Elist16)  (base type only)
    --    Dispatch_Table_Wrappers             (Elist26)  (base type only)
    --    Cloned_Subtype                      (Node16)   (subtype case only)
@@ -5402,7 +5409,7 @@ package Einfo is
 
    --  E_Record_Type_With_Private
    --  E_Record_Subtype_With_Private
-   --    Primitive_Operations                (Elist15)
+   --    Direct_Primitive_Operations         (Elist15)
    --    Access_Disp_Table                   (Elist16)  (base type only)
    --    Dispatch_Table_Wrappers             (Elist26)  (base type only)
    --    First_Entity                        (Node17)
@@ -6072,7 +6079,7 @@ package Einfo is
    function Packed_Array_Type                   (Id : E) return E;
    function Parent_Subtype                      (Id : E) return E;
    function Postcondition_Proc                  (Id : E) return E;
-   function Primitive_Operations                (Id : E) return L;
+   function Direct_Primitive_Operations         (Id : E) return L;
    function Prival                              (Id : E) return E;
    function Prival_Link                         (Id : E) return E;
    function Private_Dependents                  (Id : E) return L;
@@ -6248,8 +6255,9 @@ package Einfo is
    function Number_Dimensions                   (Id : E) return Pos;
    function Number_Entries                      (Id : E) return Nat;
    function Number_Formals                      (Id : E) return Pos;
-   function Root_Type                           (Id : E) return E;
    function Parameter_Mode                      (Id : E) return Formal_Kind;
+   function Primitive_Operations                (Id : E) return L;
+   function Root_Type                           (Id : E) return E;
    function Scope_Depth_Set                     (Id : E) return B;
    function Size_Clause                         (Id : E) return N;
    function Stream_Size_Clause                  (Id : E) return N;
@@ -6641,7 +6649,7 @@ package Einfo is
    procedure Set_Packed_Array_Type               (Id : E; V : E);
    procedure Set_Parent_Subtype                  (Id : E; V : E);
    procedure Set_Postcondition_Proc              (Id : E; V : E);
-   procedure Set_Primitive_Operations            (Id : E; V : L);
+   procedure Set_Direct_Primitive_Operations     (Id : E; V : L);
    procedure Set_Prival                          (Id : E; V : E);
    procedure Set_Prival_Link                     (Id : E; V : E);
    procedure Set_Private_Dependents              (Id : E; V : L);
@@ -7047,6 +7055,7 @@ package Einfo is
    pragma Inline (Dependent_Instances);
    pragma Inline (Depends_On_Private);
    pragma Inline (Digits_Value);
+   pragma Inline (Direct_Primitive_Operations);
    pragma Inline (Directly_Designated_Type);
    pragma Inline (Discard_Names);
    pragma Inline (Discriminal);
@@ -7358,7 +7367,6 @@ package Einfo is
    pragma Inline (Parameter_Mode);
    pragma Inline (Parent_Subtype);
    pragma Inline (Postcondition_Proc);
-   pragma Inline (Primitive_Operations);
    pragma Inline (Prival);
    pragma Inline (Prival_Link);
    pragma Inline (Private_Dependents);
@@ -7482,6 +7490,7 @@ package Einfo is
    pragma Inline (Set_Dependent_Instances);
    pragma Inline (Set_Depends_On_Private);
    pragma Inline (Set_Digits_Value);
+   pragma Inline (Set_Direct_Primitive_Operations);
    pragma Inline (Set_Directly_Designated_Type);
    pragma Inline (Set_Discard_Names);
    pragma Inline (Set_Discriminal);
@@ -7748,7 +7757,6 @@ package Einfo is
    pragma Inline (Set_Packed_Array_Type);
    pragma Inline (Set_Parent_Subtype);
    pragma Inline (Set_Postcondition_Proc);
-   pragma Inline (Set_Primitive_Operations);
    pragma Inline (Set_Prival);
    pragma Inline (Set_Prival_Link);
    pragma Inline (Set_Private_Dependents);
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index f67e1c4..aca005e 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6144,8 +6144,8 @@ package body Exp_Ch3 is
                     (Rep, Access_Disp_Table       (Def_Id));
                   Set_Dispatch_Table_Wrappers
                     (Rep, Dispatch_Table_Wrappers (Def_Id));
-                  Set_Primitive_Operations
-                    (Rep, Primitive_Operations    (Def_Id));
+                  Set_Direct_Primitive_Operations
+                    (Rep, Direct_Primitive_Operations (Def_Id));
                end;
             end if;
 
diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb
index b8feb09..2a0f800 100644
--- a/gcc/ada/exp_dist.adb
+++ b/gcc/ada/exp_dist.adb
@@ -1316,7 +1316,9 @@ package body Exp_Dist is
       --  Build callers, receivers for every primitive operations and a RPC
       --  receiver for this type.
 
-      if Present (Primitive_Operations (Designated_Type)) then
+      if not Is_Concurrent_Type (Designated_Type)
+        and then Present (Primitive_Operations (Designated_Type))
+      then
          Overload_Counter_Table.Reset;
 
          Current_Primitive_Elmt :=
@@ -1336,8 +1338,9 @@ package body Exp_Dist is
                  Is_TSS (Current_Primitive, TSS_Stream_Input)  or else
                  Is_TSS (Current_Primitive, TSS_Stream_Output) or else
                  Is_TSS (Current_Primitive, TSS_Stream_Read)   or else
-                 Is_TSS (Current_Primitive, TSS_Stream_Write)  or else
-                 Is_Predefined_Interface_Primitive (Current_Primitive))
+                 Is_TSS (Current_Primitive, TSS_Stream_Write)
+                   or else
+                     Is_Predefined_Interface_Primitive (Current_Primitive))
               and then not Is_Hidden (Current_Primitive)
             then
                --  The first thing to do is build an up-to-date copy of the
@@ -1413,8 +1416,8 @@ package body Exp_Dist is
                        RACW_Type                => Stub_Elements.RACW_Type,
                        Parent_Primitive         => Current_Primitive);
 
-                  Current_Receiver := Defining_Unit_Name (
-                    Specification (Current_Receiver_Body));
+                  Current_Receiver :=
+                    Defining_Unit_Name (Specification (Current_Receiver_Body));
 
                   Append_To (Body_Decls, Current_Receiver_Body);
 
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 77ad7a0..7068e22 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -4115,8 +4115,8 @@ package body Exp_Util is
          if Is_Tagged_Type  (Priv_Subtyp) then
             Set_Class_Wide_Type
               (Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
-            Set_Primitive_Operations (Priv_Subtyp,
-              Primitive_Operations (Unc_Typ));
+            Set_Direct_Primitive_Operations (Priv_Subtyp,
+              Direct_Primitive_Operations (Unc_Typ));
          end if;
 
          Set_Full_View (Priv_Subtyp, Full_Subtyp);
diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb
index 02af70c..db8097a 100644
--- a/gcc/ada/lib-xref.adb
+++ b/gcc/ada/lib-xref.adb
@@ -241,14 +241,7 @@ package body Lib.Xref is
       --  The check for Present here is to protect against previously
       --  reported critical errors.
 
-      if Is_Concurrent_Type (Base_T)
-        and then Present (Corresponding_Record_Type (Base_T))
-      then
-         Prim_List := Primitive_Operations
-                       (Corresponding_Record_Type (Base_T));
-      else
-         Prim_List := Primitive_Operations (Base_T);
-      end if;
+      Prim_List := Primitive_Operations (Base_T);
 
       if No (Prim_List) then
          return;
diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb
index aa62305..9f64223 100644
--- a/gcc/ada/sem_cat.adb
+++ b/gcc/ada/sem_cat.adb
@@ -1334,6 +1334,12 @@ package body Sem_Cat is
    begin
       Desig_Type := Etype (Designated_Type (T));
 
+      --  No action needed for concurrent types
+
+      if Is_Concurrent_Type (Desig_Type) then
+         return;
+      end if;
+
       Primitive_Subprograms := Primitive_Operations (Desig_Type);
 
       Subprogram_Elmt := First_Elmt (Primitive_Subprograms);
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index d99db52..a17ab53 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -2444,7 +2444,7 @@ package body Sem_Ch3 is
       if Tagged_Present (N) then
          Set_Is_Tagged_Type (T);
          Make_Class_Wide_Type (T);
-         Set_Primitive_Operations (T, New_Elmt_List);
+         Set_Direct_Primitive_Operations (T, New_Elmt_List);
       end if;
 
       Push_Scope (T);
@@ -2496,7 +2496,7 @@ package body Sem_Ch3 is
               or else Task_Present (Def));
 
       Set_Interfaces (T, New_Elmt_List);
-      Set_Primitive_Operations (T, New_Elmt_List);
+      Set_Direct_Primitive_Operations (T, New_Elmt_List);
 
       --  Complete the decoration of the class-wide entity if it was already
       --  built (i.e. during the creation of the limited view)
@@ -3936,8 +3936,8 @@ package body Sem_Ch3 is
                if Is_Tagged_Type (T) then
                   Set_Is_Tagged_Type    (Id);
                   Set_Is_Abstract_Type  (Id, Is_Abstract_Type (T));
-                  Set_Primitive_Operations
-                                        (Id, Primitive_Operations (T));
+                  Set_Direct_Primitive_Operations
+                                        (Id, Direct_Primitive_Operations (T));
                   Set_Class_Wide_Type   (Id, Class_Wide_Type (T));
 
                   if Is_Interface (T) then
@@ -3960,10 +3960,11 @@ package body Sem_Ch3 is
                                       (Id, Known_To_Have_Preelab_Init (T));
 
                if Is_Tagged_Type (T) then
-                  Set_Is_Tagged_Type       (Id);
-                  Set_Is_Abstract_Type     (Id, Is_Abstract_Type (T));
-                  Set_Primitive_Operations (Id, Primitive_Operations (T));
-                  Set_Class_Wide_Type      (Id, Class_Wide_Type (T));
+                  Set_Is_Tagged_Type              (Id);
+                  Set_Is_Abstract_Type            (Id, Is_Abstract_Type (T));
+                  Set_Class_Wide_Type             (Id, Class_Wide_Type (T));
+                  Set_Direct_Primitive_Operations (Id,
+                    Direct_Primitive_Operations (T));
                end if;
 
                --  In general the attributes of the subtype of a private type
@@ -7352,7 +7353,7 @@ package body Sem_Ch3 is
       --  Set fields for tagged types
 
       if Is_Tagged then
-         Set_Primitive_Operations (Derived_Type, New_Elmt_List);
+         Set_Direct_Primitive_Operations (Derived_Type, New_Elmt_List);
 
          --  All tagged types defined in Ada.Finalization are controlled
 
@@ -8237,7 +8238,8 @@ package body Sem_Ch3 is
             Set_Corresponding_Record_Type (Def_Id,
                Corresponding_Record_Type (T));
          else
-            Set_Primitive_Operations (Def_Id, Primitive_Operations (T));
+            Set_Direct_Primitive_Operations (Def_Id,
+              Direct_Primitive_Operations (T));
          end if;
 
          Set_Is_Abstract_Type (Def_Id, Is_Abstract_Type (T));
@@ -9811,7 +9813,8 @@ package body Sem_Ch3 is
 
       if Is_Tagged_Type (Full_Base) then
          Set_Is_Tagged_Type (Full);
-         Set_Primitive_Operations (Full, Primitive_Operations (Full_Base));
+         Set_Direct_Primitive_Operations (Full,
+           Direct_Primitive_Operations (Full_Base));
 
          --  Inherit class_wide type of full_base in case the partial view was
          --  not tagged. Otherwise it has already been created when the private
@@ -11552,7 +11555,8 @@ package body Sem_Ch3 is
       Conditional_Delay              (Full,                          Priv);
 
       if Is_Tagged_Type (Full) then
-         Set_Primitive_Operations    (Full, Primitive_Operations    (Priv));
+         Set_Direct_Primitive_Operations (Full,
+           Direct_Primitive_Operations (Priv));
 
          if Priv = Base_Type (Priv) then
             Set_Class_Wide_Type      (Full, Class_Wide_Type         (Priv));
@@ -13529,8 +13533,10 @@ package body Sem_Ch3 is
          Set_Etype        (T, Any_Type);
          Set_Scalar_Range (T, Scalar_Range (Any_Type));
 
-         if Is_Tagged_Type (T) then
-            Set_Primitive_Operations (T, New_Elmt_List);
+         if Is_Tagged_Type (T)
+           and then Is_Record_Type (T)
+         then
+            Set_Direct_Primitive_Operations (T, New_Elmt_List);
          end if;
 
          return;
@@ -14290,7 +14296,6 @@ package body Sem_Ch3 is
                if not Tagged_Present (Type_Definition (N)) then
                   Tag_Mismatch;
                   Set_Is_Tagged_Type (Id);
-                  Set_Primitive_Operations (Id, New_Elmt_List);
                end if;
 
             elsif Nkind (Type_Definition (N)) = N_Derived_Type_Definition then
@@ -14302,7 +14307,6 @@ package body Sem_Ch3 is
                   --  Set some attributes to produce a usable full view
 
                   Set_Is_Tagged_Type (Id);
-                  Set_Primitive_Operations (Id, New_Elmt_List);
                end if;
 
             else
@@ -15421,12 +15425,12 @@ package body Sem_Ch3 is
       --  Customize the class-wide type: It has no prim. op., it cannot be
       --  abstract and its Etype points back to the specific root type.
 
-      Set_Ekind                (CW_Type, E_Class_Wide_Type);
-      Set_Is_Tagged_Type       (CW_Type, True);
-      Set_Primitive_Operations (CW_Type, New_Elmt_List);
-      Set_Is_Abstract_Type     (CW_Type, False);
-      Set_Is_Constrained       (CW_Type, False);
-      Set_Is_First_Subtype     (CW_Type, Is_First_Subtype (T));
+      Set_Ekind                       (CW_Type, E_Class_Wide_Type);
+      Set_Is_Tagged_Type              (CW_Type, True);
+      Set_Direct_Primitive_Operations (CW_Type, New_Elmt_List);
+      Set_Is_Abstract_Type            (CW_Type, False);
+      Set_Is_Constrained              (CW_Type, False);
+      Set_Is_First_Subtype            (CW_Type, Is_First_Subtype (T));
 
       if Ekind (T) = E_Class_Wide_Subtype then
          Set_Etype             (CW_Type, Etype (Base_Type (T)));
@@ -16990,7 +16994,7 @@ package body Sem_Ch3 is
             --  of the class-wide type which depend on the full declaration.
 
             if Is_Tagged_Type (Priv_T) then
-               Set_Primitive_Operations (Priv_T, Full_List);
+               Set_Direct_Primitive_Operations (Priv_T, Full_List);
                Set_Class_Wide_Type
                  (Base_Type (Full_T), Class_Wide_Type (Priv_T));
 
@@ -18268,14 +18272,13 @@ package body Sem_Ch3 is
          end if;
 
          Make_Class_Wide_Type (T);
-         Set_Primitive_Operations (T, New_Elmt_List);
+         Set_Direct_Primitive_Operations (T, New_Elmt_List);
       end if;
 
-      --  We must suppress range checks when processing the components
-      --  of a record in the presence of discriminants, since we don't
-      --  want spurious checks to be generated during their analysis, but
-      --  must reset the Suppress_Range_Checks flags after having processed
-      --  the record definition.
+      --  We must suppress range checks when processing record components in
+      --  the presence of discriminants, since we don't want spurious checks to
+      --  be generated during their analysis, but Suppress_Range_Checks flags
+      --  must be reset the after processing the record definition.
 
       --  Note: this is the only use of Kill_Range_Checks, and is a bit odd,
       --  couldn't we just use the normal range check suppression method here.
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index ae14084..08d68bf 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -1956,11 +1956,11 @@ package body Sem_Ch7 is
       Set_Private_Dependents (Id, New_Elmt_List);
 
       if Tagged_Present (Def) then
-         Set_Ekind                (Id, E_Record_Type_With_Private);
-         Set_Primitive_Operations (Id, New_Elmt_List);
-         Set_Is_Abstract_Type     (Id, Abstract_Present (Def));
-         Set_Is_Limited_Record    (Id, Limited_Present (Def));
-         Set_Has_Delayed_Freeze   (Id, True);
+         Set_Ekind                       (Id, E_Record_Type_With_Private);
+         Set_Direct_Primitive_Operations (Id, New_Elmt_List);
+         Set_Is_Abstract_Type            (Id, Abstract_Present (Def));
+         Set_Is_Limited_Record           (Id, Limited_Present (Def));
+         Set_Has_Delayed_Freeze          (Id, True);
 
          --  Create a class-wide type with the same attributes
 
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index d45ebda..e891e70 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -5707,7 +5707,7 @@ package body Sem_Ch8 is
                   end if;
 
                   Set_Is_Tagged_Type (T);
-                  Set_Primitive_Operations (T, New_Elmt_List);
+                  Set_Direct_Primitive_Operations (T, New_Elmt_List);
                   Make_Class_Wide_Type (T);
                   Set_Entity (N, Class_Wide_Type (T));
                   Set_Etype  (N, Class_Wide_Type (T));