From patchwork Tue Oct 26 12:20:09 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 69237 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id D8250B70D2 for ; Tue, 26 Oct 2010 23:20:48 +1100 (EST) Received: (qmail 11054 invoked by alias); 26 Oct 2010 12:20:41 -0000 Received: (qmail 11015 invoked by uid 22791); 26 Oct 2010 12:20:27 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (194.98.77.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Tue, 26 Oct 2010 12:20:12 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 1D299CB0240; Tue, 26 Oct 2010 14:20:10 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id KxOMGRjf3lmF; Tue, 26 Oct 2010 14:20:10 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id 00DA5CB01D7; Tue, 26 Oct 2010 14:20:10 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id D7653D9BB4; Tue, 26 Oct 2010 14:20:09 +0200 (CEST) Date: Tue, 26 Oct 2010 14:20:09 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Introduce internal abstraction Is_Base_Type Message-ID: <20101026122009.GA30636@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 * 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. 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