diff mbox

[Ada] Introduce internal abstraction Is_Base_Type

Message ID 20101026122009.GA30636@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Oct. 26, 2010, 12:20 p.m. UTC 
This patch defines a new abstraction Is_Base_Type. We now prefer to
use Is_Base_Type (T) rather than T = Base_Type (T). The patch also
fixes many such references. No test needed, this is just an internal
cleanup.

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-10-26  Robert Dewar  <dewar@adacore.com>

	* einfo.ads, einfo.adb (Is_Base_Type): New function, use it where
	appropriate.
	* exp_ch6.adb, exp_dbug.adb, exp_disp.adb, freeze.adb, lib-xref.adb,
	sem_aux.adb, sem_ch3.adb, sem_ch7.adb, sem_ch8.adb (Is_Base_Type): Use
	this new abstraction where appropriate.
diff mbox

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 165945)
+++ sem_ch3.adb	(working copy)
@@ -11716,7 +11716,7 @@  package body Sem_Ch3 is
          Set_Direct_Primitive_Operations (Full,
            Direct_Primitive_Operations (Priv));
 
-         if Priv = Base_Type (Priv) then
+         if Is_Base_Type (Priv) then
             Set_Class_Wide_Type      (Full, Class_Wide_Type         (Priv));
          end if;
       end if;
Index: sem_aux.adb
===================================================================
--- sem_aux.adb	(revision 165935)
+++ sem_aux.adb	(working copy)
@@ -48,7 +48,7 @@  package body Sem_Aux is
       --  If this is first subtype, or is a base type, then there is no
       --  ancestor subtype, so we return Empty to indicate this fact.
 
-      if Is_First_Subtype (Typ) or else Typ = Base_Type (Typ) then
+      if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then
          return Empty;
       end if;
 
Index: sem_ch7.adb
===================================================================
--- sem_ch7.adb	(revision 165945)
+++ sem_ch7.adb	(working copy)
@@ -1500,7 +1500,7 @@  package body Sem_Ch7 is
                  (Nkind (Parent (E)) = N_Private_Extension_Declaration
                    and then Is_Generic_Type (E)))
            and then In_Open_Scopes (Scope (Etype (E)))
-           and then E = Base_Type (E)
+           and then Is_Base_Type (E)
          then
             if Is_Tagged_Type (E) then
                Op_List := Primitive_Operations (E);
@@ -2010,7 +2010,7 @@  package body Sem_Ch7 is
       ------------------------------
 
       procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is
-         Priv_Is_Base_Type : constant Boolean := Priv = Base_Type (Priv);
+         Priv_Is_Base_Type : constant Boolean := Is_Base_Type (Priv);
 
       begin
          Set_Size_Info (Priv, (Full));
Index: einfo.adb
===================================================================
--- einfo.adb	(revision 165945)
+++ einfo.adb	(working copy)
@@ -2996,7 +2996,7 @@  package body Einfo is
 
    procedure Set_Access_Disp_Table (Id : E; V : L) is
    begin
-      pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id));
+      pragma Assert (Is_Tagged_Type (Id) and then Is_Base_Type (Id));
       Set_Elist16 (Id, V);
    end Set_Access_Disp_Table;
 
@@ -3018,7 +3018,7 @@  package body Einfo is
 
    procedure Set_Associated_Storage_Pool (Id : E; V : E) is
    begin
-      pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id));
+      pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
       Set_Node22 (Id, V);
    end Set_Associated_Storage_Pool;
 
@@ -3082,7 +3082,7 @@  package body Einfo is
 
    procedure Set_C_Pass_By_Copy (Id : E; V : B := True) is
    begin
-      pragma Assert (Is_Record_Type (Id) and then Id = Base_Type (Id));
+      pragma Assert (Is_Record_Type (Id) and then Is_Base_Type (Id));
       Set_Flag125 (Id, V);
    end Set_C_Pass_By_Copy;
 
@@ -3122,13 +3122,13 @@  package body Einfo is
 
    procedure Set_Component_Size (Id : E; V : U) is
    begin
-      pragma Assert (Is_Array_Type (Id) and then Id = Base_Type (Id));
+      pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id));
       Set_Uint22 (Id, V);
    end Set_Component_Size;
 
    procedure Set_Component_Type (Id : E; V : E) is
    begin
-      pragma Assert (Is_Array_Type (Id) and then Id = Base_Type (Id));
+      pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id));
       Set_Node20 (Id, V);
    end Set_Component_Type;
 
@@ -3302,7 +3302,7 @@  package body Einfo is
 
    procedure Set_Dispatch_Table_Wrappers (Id : E; V : L) is
    begin
-      pragma Assert (Is_Tagged_Type (Id) and then Id = Base_Type (Id));
+      pragma Assert (Is_Tagged_Type (Id) and then Is_Base_Type (Id));
       Set_Elist26 (Id, V);
    end Set_Dispatch_Table_Wrappers;
 
@@ -3477,8 +3477,7 @@  package body Einfo is
    procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True) is
    begin
       pragma Assert
-        (Is_Access_Subprogram_Type (Id)
-          and then Id = Base_Type (Id));
+        (Is_Access_Subprogram_Type (Id) and then Is_Base_Type (Id));
       Set_Flag229 (Id, V);
    end Set_Can_Use_Internal_Rep;
 
@@ -3489,7 +3488,7 @@  package body Einfo is
 
    procedure Set_Finalize_Storage_Only (Id : E; V : B := True) is
    begin
-      pragma Assert (Is_Type (Id) and then Id = Base_Type (Id));
+      pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
       Set_Flag158 (Id, V);
    end Set_Finalize_Storage_Only;
 
@@ -3597,7 +3596,7 @@  package body Einfo is
 
    procedure Set_Has_Atomic_Components (Id : E; V : B := True) is
    begin
-      pragma Assert (not Is_Type (Id) or else Id = Base_Type (Id));
+      pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id));
       Set_Flag86 (Id, V);
    end Set_Has_Atomic_Components;
 
@@ -3995,7 +3994,7 @@  package body Einfo is
 
    procedure Set_Has_Volatile_Components (Id : E; V : B := True) is
    begin
-      pragma Assert (not Is_Type (Id) or else Id = Base_Type (Id));
+      pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id));
       Set_Flag87 (Id, V);
    end Set_Has_Volatile_Components;
 
@@ -4118,7 +4117,7 @@  package body Einfo is
    procedure Set_Is_Bit_Packed_Array (Id : E; V : B := True) is
    begin
       pragma Assert ((not V)
-        or else (Is_Array_Type (Id) and then Id = Base_Type (Id)));
+        or else (Is_Array_Type (Id) and then Is_Base_Type (Id)));
 
       Set_Flag122 (Id, V);
    end Set_Is_Bit_Packed_Array;
@@ -4736,7 +4735,7 @@  package body Einfo is
 
    procedure Set_No_Pool_Assigned (Id : E; V : B := True) is
    begin
-      pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id));
+      pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
       Set_Flag131 (Id, V);
    end Set_No_Pool_Assigned;
 
@@ -4749,13 +4748,13 @@  package body Einfo is
 
    procedure Set_No_Strict_Aliasing (Id : E; V : B := True) is
    begin
-      pragma Assert (Is_Access_Type (Id) and then Id = Base_Type (Id));
+      pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
       Set_Flag136 (Id, V);
    end Set_No_Strict_Aliasing;
 
    procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is
    begin
-      pragma Assert (Is_Type (Id) and then Id = Base_Type (Id));
+      pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
       Set_Flag58 (Id, V);
    end Set_Non_Binary_Modulus;
 
@@ -4800,7 +4799,7 @@  package body Einfo is
    procedure Set_OK_To_Reorder_Components (Id : E; V : B := True) is
    begin
       pragma Assert
-        (Is_Record_Type (Id) and then Id = Base_Type (Id));
+        (Is_Record_Type (Id) and then Is_Base_Type (Id));
       Set_Flag239 (Id, V);
    end Set_OK_To_Reorder_Components;
 
@@ -4974,7 +4973,7 @@  package body Einfo is
 
    procedure Set_Relative_Deadline_Variable (Id : E; V : E) is
    begin
-      pragma Assert (Is_Task_Type (Id) and then Id = Base_Type (Id));
+      pragma Assert (Is_Task_Type (Id) and then Is_Base_Type (Id));
       Set_Node26 (Id, V);
    end Set_Relative_Deadline_Variable;
 
@@ -5023,7 +5022,7 @@  package body Einfo is
    procedure Set_Reverse_Bit_Order (Id : E; V : B := True) is
    begin
       pragma Assert
-        (Is_Record_Type (Id) and then Id = Base_Type (Id));
+        (Is_Record_Type (Id) and then Is_Base_Type (Id));
       Set_Flag164 (Id, V);
    end Set_Reverse_Bit_Order;
 
@@ -5209,7 +5208,7 @@  package body Einfo is
 
    procedure Set_Universal_Aliasing (Id : E; V : B := True) is
    begin
-      pragma Assert (Is_Type (Id) and then Id = Base_Type (Id));
+      pragma Assert (Is_Type (Id) and then Is_Base_Type (Id));
       Set_Flag216 (Id, V);
    end Set_Universal_Aliasing;
 
@@ -6167,6 +6166,15 @@  package body Einfo is
       end if;
    end Invariant_Procedure;
 
+   ------------------
+   -- Is_Base_Type --
+   ------------------
+
+   function Is_Base_Type (Id : E) return Boolean is
+   begin
+      return Id = Base_Type (Id);
+   end Is_Base_Type;
+
    ---------------------
    -- Is_Boolean_Type --
    ---------------------
@@ -6977,7 +6985,7 @@  package body Einfo is
    procedure Set_Component_Alignment (Id : E; V : C) is
    begin
       pragma Assert ((Is_Array_Type (Id) or else Is_Record_Type (Id))
-                       and then Id = Base_Type (Id));
+                       and then Is_Base_Type (Id));
 
       case V is
          when Calign_Default          =>
@@ -7264,7 +7272,7 @@  package body Einfo is
 
    begin
       if (Is_Array_Type (Id) or else Is_Record_Type (Id))
-        and then Id = Base_Type (Id)
+        and then Is_Base_Type (Id)
       then
          Write_Str (Prefix);
          Write_Str ("Component_Alignment = ");
Index: einfo.ads
===================================================================
--- einfo.ads	(revision 165945)
+++ einfo.ads	(working copy)
@@ -1992,6 +1992,9 @@  package Einfo is
 --       Present in all type entities and in procedure entities. Set
 --       if a pragma Asynchronous applies to the entity.
 
+--    Is_Base_Type (synthesized)
+--       Applies to type and subtype entities. True if entity is a base type
+
 --    Is_Bit_Packed_Array (Flag122) [implementation base type only]
 --       Present in all entities. This flag is set for a packed array type that
 --       is bit packed (i.e. the component size is known by the front end and
@@ -6341,6 +6344,7 @@  package Einfo is
    function Has_Private_Ancestor                (Id : E) return B;
    function Has_Private_Declaration             (Id : E) return B;
    function Implementation_Base_Type            (Id : E) return E;
+   function Is_Base_Type                        (Id : E) return B;
    function Is_Boolean_Type                     (Id : E) return B;
    function Is_Constant_Object                  (Id : E) return B;
    function Is_Discriminal                      (Id : E) return B;
@@ -7976,6 +7980,7 @@  package Einfo is
    --  things here which are small, but not of the canonical attribute
    --  access/set format that can be handled by xeinfo.
 
+   pragma Inline (Is_Base_Type);
    pragma Inline (Is_Package_Or_Generic_Package);
    pragma Inline (Is_Volatile);
    pragma Inline (Is_Wrapper_Package);
Index: freeze.adb
===================================================================
--- freeze.adb	(revision 165935)
+++ freeze.adb	(working copy)
@@ -2062,9 +2062,7 @@  package body Freeze is
 
          --  Set OK_To_Reorder_Components depending on debug flags
 
-         if Rec = Base_Type (Rec)
-           and then Convention (Rec) = Convention_Ada
-         then
+         if Is_Base_Type (Rec) and then Convention (Rec) = Convention_Ada then
             if (Has_Discriminants (Rec) and then Debug_Flag_Dot_V)
                   or else
                (not Has_Discriminants (Rec) and then Debug_Flag_Dot_R)
@@ -3818,9 +3816,7 @@  package body Freeze is
             --  these till the freeze-point since we need the small and range
             --  values. We only do these checks for base types
 
-            if Is_Ordinary_Fixed_Point_Type (E)
-              and then E = Base_Type (E)
-            then
+            if Is_Ordinary_Fixed_Point_Type (E) and then Is_Base_Type (E) then
                if Small_Value (E) < Ureal_2_M_80 then
                   Error_Msg_Name_1 := Name_Small;
                   Error_Msg_N
@@ -3865,7 +3861,7 @@  package body Freeze is
             --  only to base types.
 
             if Present (Default_Pool)
-              and then E = Base_Type (E)
+              and then Is_Base_Type (E)
               and then not Has_Storage_Size_Clause (E)
               and then No (Associated_Storage_Pool (E))
             then
Index: exp_dbug.adb
===================================================================
--- exp_dbug.adb	(revision 165935)
+++ exp_dbug.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1996-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1996-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -529,8 +529,7 @@  package body Exp_Dbug is
 
       --  Or if this is an enumeration base type
 
-        or else (Is_Enumeration_Type (E)
-                   and then E = Base_Type (E))
+        or else (Is_Enumeration_Type (E) and then Is_Base_Type (E))
 
       --  Or if this is a dummy type for a renaming
 
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb	(revision 165935)
+++ exp_ch6.adb	(working copy)
@@ -600,7 +600,7 @@  package body Exp_Ch6 is
       if Is_Derived_Type (Typ)
         and then not Is_Private_Type (Typ)
         and then In_Open_Scopes (Scope (Etype (Typ)))
-        and then Typ = Base_Type (Typ)
+        and then Is_Base_Type (Typ)
       then
          --  Subp overrides an inherited private operation if there is an
          --  inherited operation with a different name than Subp (see
Index: exp_disp.adb
===================================================================
--- exp_disp.adb	(revision 165941)
+++ exp_disp.adb	(working copy)
@@ -7359,7 +7359,7 @@  package body Exp_Disp is
                         (Nkind (Parent (Typ)) = N_Private_Extension_Declaration
                           and then Is_Generic_Type (Typ)))
            and then In_Open_Scopes (Scope (Etype (Typ)))
-           and then Typ = Base_Type (Typ)
+           and then Is_Base_Type (Typ)
          then
             Handle_Inherited_Private_Subprograms (Typ);
          end if;
Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb	(revision 165945)
+++ sem_ch8.adb	(working copy)
@@ -6001,9 +6001,8 @@  package body Sem_Ch8 is
       while Present (Id)
         and then Id /= Priv_Id
       loop
-         if Is_Standard_Character_Type (Id)
-           and then Id = Base_Type (Id)
-         then
+         if Is_Standard_Character_Type (Id) and then Is_Base_Type (Id) then
+
             --  We replace the node with the literal itself, resolve as a
             --  character, and set the type correctly.
 
@@ -6164,9 +6163,7 @@  package body Sem_Ch8 is
 
          when Name_Op_And | Name_Op_Not | Name_Op_Or  | Name_Op_Xor =>
             while Id  /= Priv_Id loop
-               if Valid_Boolean_Arg (Id)
-                 and then Id = Base_Type (Id)
-               then
+               if Valid_Boolean_Arg (Id) and then Is_Base_Type (Id) then
                   Add_Implicit_Operator (Id);
                   return True;
                end if;
@@ -6180,7 +6177,7 @@  package body Sem_Ch8 is
             while Id  /= Priv_Id loop
                if Is_Type (Id)
                  and then not Is_Limited_Type (Id)
-                 and then Id = Base_Type (Id)
+                 and then Is_Base_Type (Id)
                then
                   Add_Implicit_Operator (Standard_Boolean, Id);
                   return True;
@@ -6194,9 +6191,9 @@  package body Sem_Ch8 is
          when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge =>
             while Id  /= Priv_Id loop
                if (Is_Scalar_Type (Id)
-                 or else (Is_Array_Type (Id)
-                           and then Is_Scalar_Type (Component_Type (Id))))
-                 and then Id = Base_Type (Id)
+                    or else (Is_Array_Type (Id)
+                              and then Is_Scalar_Type (Component_Type (Id))))
+                 and then Is_Base_Type (Id)
                then
                   Add_Implicit_Operator (Standard_Boolean, Id);
                   return True;
@@ -6216,9 +6213,7 @@  package body Sem_Ch8 is
               Name_Op_Divide   |
               Name_Op_Expon    =>
             while Id  /= Priv_Id loop
-               if Is_Numeric_Type (Id)
-                 and then Id = Base_Type (Id)
-               then
+               if Is_Numeric_Type (Id) and then Is_Base_Type (Id) then
                   Add_Implicit_Operator (Id);
                   return True;
                end if;
@@ -6230,8 +6225,9 @@  package body Sem_Ch8 is
 
          when Name_Op_Concat =>
             while Id  /= Priv_Id loop
-               if Is_Array_Type (Id) and then Number_Dimensions (Id) = 1
-                 and then Id = Base_Type (Id)
+               if Is_Array_Type (Id)
+                 and then Number_Dimensions (Id) = 1
+                 and then Is_Base_Type (Id)
                then
                   Add_Implicit_Operator (Id);
                   return True;
Index: lib-xref.adb
===================================================================
--- lib-xref.adb	(revision 165945)
+++ lib-xref.adb	(working copy)
@@ -1172,7 +1172,7 @@  package body Lib.Xref is
 
             if Is_Type (Ent)
               and then Is_Tagged_Type (Ent)
-              and then Ent = Base_Type (Ent)
+              and then Is_Base_Type (Ent)
               and then In_Extended_Main_Source_Unit (Ent)
             then
                Generate_Prim_Op_References (Ent);
@@ -1281,7 +1281,7 @@  package body Lib.Xref is
             if Is_Type (Ent)
               and then Is_Tagged_Type (Ent)
               and then Is_Derived_Type (Ent)
-              and then Ent = Base_Type (Ent)
+              and then Is_Base_Type (Ent)
               and then In_Extended_Main_Source_Unit (Ent)
             then
                declare