From patchwork Wed Feb 22 13:54:08 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 142457 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 32B32B6EE8 for ; Thu, 23 Feb 2012 00:54:44 +1100 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1330523687; h=Comment: DomainKey-Signature:Received:Received:Received:Received:Received: Received:Received:Date:From:To:Cc:Subject:Message-ID: MIME-Version:Content-Type:Content-Disposition:User-Agent: Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:Sender:Delivered-To; bh=zuSoZP3DCXu060q3xM9Y OatSQe4=; b=Its2X5CUXSaYkNhwqJTLZuQ1xNOBpuNoW/euJuyuBZ6/87FdOAjG RZNkXhfVK0iS56UicFuu2IFHIt9M0fY636I9VMouJneYz5ZjImxDor+0O/xz9W33 hCSoMlbeM33WoXDgqAps/rp9+KbVTdHj3GWT6BTFJcvklTC+QO4oB+g= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Received:Received:Received:Date:From:To:Cc:Subject:Message-ID:MIME-Version:Content-Type:Content-Disposition:User-Agent:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=kMwrcUq4lKER7FkS9EgUzEncJ1HOZe729Y4cGAhqidjsPkIJJb05esqkZ2D9zg MHu0rLGWpiuj5xlIaZ8+7WCt9FbcxwgkFRB5lR77gdObcPiz9cHDJIvxtoZR8zyp LMtiaBNWjbiY6E1XGrjjaJo8RD6Ejgvl6omUbTHHBzqcA=; Received: (qmail 11289 invoked by alias); 22 Feb 2012 13:54:32 -0000 Received: (qmail 11251 invoked by uid 22791); 22 Feb 2012 13:54:26 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL,BAYES_00 X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Wed, 22 Feb 2012 13:54:09 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 723531C6BAB; Wed, 22 Feb 2012 08:54:08 -0500 (EST) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id sFWuoTYRUatE; Wed, 22 Feb 2012 08:54:08 -0500 (EST) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 303891C6BBA; Wed, 22 Feb 2012 08:54:08 -0500 (EST) Received: by kwai.gnat.com (Postfix, from userid 4192) id 1EC3D3FEE8; Wed, 22 Feb 2012 08:54:08 -0500 (EST) Date: Wed, 22 Feb 2012 08:54:08 -0500 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Vincent Pucci Subject: [Ada] Minor changes for GNAT dimensionality checking system Message-ID: <20120222135408.GA6621@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) 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 Tested on x86_64-pc-linux-gnu, committed on trunk 2012-02-22 Vincent Pucci * rtsfind.adb (Get_Unit_Name): Ada_Numerics_Child and System_Dim_Child cases added. * rtsfind.ads: Ada_Numerics, Ada_Numerics_Generic_Elementary_Functions, System_Dim, System_Dim_Float_IO and System_Dim_Integer_IO added to the list of RTU_Id. Ada_Numerics_Child and System_Dim_Child added as new RTU_Id subtypes. * sem_dim.adb (Is_Dim_IO_Package_Entity): Use of Rtsfind to verify the package entity is located either in System.Dim.Integer_IO or in System.Dim.Float_IO. (Is_Dim_IO_Package_Instantiation): Minor changes. (Is_Elementary_Function_Call): Removed. (Is_Elementary_Function_Entity): New routine. (Is_Procedure_Put_Call): Is_Dim_IO_Package_Entity call added. * snames.ads-tmpl: Name_Dim and Name_Generic_Elementary_Functions removed. Index: sem_dim.adb =================================================================== --- sem_dim.adb (revision 184470) +++ sem_dim.adb (working copy) @@ -36,7 +36,6 @@ with Sem; use Sem; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; -with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; @@ -1359,94 +1358,105 @@ -- Analyze_Dimension_Function_Call -- ------------------------------------- + -- Propagate the dimensions from the returned type to the call node. Note + -- that there is a special treatment for elementary function calls. Indeed + -- for Sqrt call, the resulting dimensions equal to half the dimensions of + -- the actual, and for other elementary calls, this routine check that + -- every actuals are dimensionless. + procedure Analyze_Dimension_Function_Call (N : Node_Id) is + Actuals : constant List_Id := Parameter_Associations (N); Name_Call : constant Node_Id := Name (N); - Actuals : constant List_Id := Parameter_Associations (N); Actual : Node_Id; Dims_Of_Actual : Dimension_Type; Dims_Of_Call : Dimension_Type; + Ent : Entity_Id; - function Is_Elementary_Function_Call return Boolean; - -- Return True if the call is a call of an elementary function (see + function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean; + -- Given E the original subprogram entity, return True if the call is a + -- an elementary function call (see -- Ada.Numerics.Generic_Elementary_Functions). - --------------------------------- - -- Is_Elementary_Function_Call -- - --------------------------------- + ----------------------------------- + -- Is_Elementary_Function_Entity -- + ----------------------------------- - function Is_Elementary_Function_Call return Boolean is - Ent : Entity_Id; + function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean is + Loc : constant Source_Ptr := Sloc (E); begin - if Is_Entity_Name (Name_Call) then - Ent := Entity (Name_Call); + -- Check the function entity is located in + -- Ada.Numerics.Generic_Elementary_Functions. - -- Check the procedure is defined in an instantiation of a generic - -- package. + return + Loc > No_Location + and then + Is_RTU + (Cunit_Entity (Get_Source_Unit (Loc)), + Ada_Numerics_Generic_Elementary_Functions); + end Is_Elementary_Function_Entity; - if Is_Generic_Instance (Scope (Ent)) then - Ent := Cunit_Entity (Get_Source_Unit (Ent)); + -- Start of processing for Analyze_Dimension_Function_Call - -- Check the name of the generic package is - -- Generic_Elementary_Functions + begin + -- Look for elementary function call - return - Is_Library_Level_Entity (Ent) - and then Chars (Ent) = Name_Generic_Elementary_Functions; - end if; - end if; + if Is_Entity_Name (Name_Call) then + Ent := Entity (Name_Call); - return False; - end Is_Elementary_Function_Call; + -- Get the original subprogram entity following the renaming chain - -- Start of processing for Analyze_Dimension_Function_Call + if Present (Alias (Ent)) then + Ent := Alias (Ent); + end if; - begin - -- Elementary function case + -- Elementary function case - if Is_Elementary_Function_Call then + if Is_Elementary_Function_Entity (Ent) then -- Sqrt function call case - if Chars (Name_Call) = Name_Sqrt then - Dims_Of_Call := Dimensions_Of (First (Actuals)); + if Chars (Ent) = Name_Sqrt then + Dims_Of_Call := Dimensions_Of (First (Actuals)); - if Exists (Dims_Of_Call) then - for Position in Dims_Of_Call'Range loop - Dims_Of_Call (Position) := - Dims_Of_Call (Position) * Rational'(Numerator => 1, + if Exists (Dims_Of_Call) then + for Position in Dims_Of_Call'Range loop + Dims_Of_Call (Position) := + Dims_Of_Call (Position) * Rational'(Numerator => 1, Denominator => 2); - end loop; + end loop; - Set_Dimensions (N, Dims_Of_Call); - end if; + Set_Dimensions (N, Dims_Of_Call); + end if; - -- All other functions in Ada.Numerics.Generic_Elementary_Functions - -- case. Note that all parameters here should be dimensionless. + -- All other elementary functions case. Note that every actual + -- here should be dimensionless. - else - Actual := First (Actuals); - while Present (Actual) loop - Dims_Of_Actual := Dimensions_Of (Actual); + else + Actual := First (Actuals); + while Present (Actual) loop + Dims_Of_Actual := Dimensions_Of (Actual); - if Exists (Dims_Of_Actual) then - Error_Msg_NE ("parameter should be dimensionless for " & - "elementary function&", - Actual, - Name_Call); - Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual), - Actual); - end if; + if Exists (Dims_Of_Actual) then + Error_Msg_NE ("parameter should be dimensionless for " & + "elementary function&", + Actual, + Name_Call); + Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual), + Actual); + end if; - Next (Actual); - end loop; + Next (Actual); + end loop; + end if; + + return; end if; + end if; - -- Other case + -- Other cases - else - Analyze_Dimension_Has_Etype (N); - end if; + Analyze_Dimension_Has_Etype (N); end Analyze_Dimension_Function_Call; --------------------------------- @@ -2226,28 +2236,31 @@ function Is_Procedure_Put_Call return Boolean is Ent : Entity_Id; + Loc : Source_Ptr; begin - -- There are three different Put routine in each generic package - -- Check that the current procedure call is one of them + -- There are three different Put routines in each generic dim IO + -- package. Verify the current procedure call is one of them. if Is_Entity_Name (Name_Call) then Ent := Entity (Name_Call); - -- Check that the name of the procedure is Put - -- Check the procedure is defined in an instantiation of a - -- generic package. + -- Get the original subprogram entity following the renaming chain - if Chars (Name_Call) = Name_Put - and then Is_Generic_Instance (Scope (Ent)) - then - Ent := Cunit_Entity (Get_Source_Unit (Ent)); + if Present (Alias (Ent)) then + Ent := Alias (Ent); + end if; - -- Verify that the generic package is either - -- System.Dim.Float_IO or System.Dim.Integer_IO. + Loc := Sloc (Ent); - return Is_Dim_IO_Package_Entity (Ent); - end if; + -- Check the name of the entity subprogram is Put and verify this + -- entity is located in either System.Dim.Float_IO or + -- System.Dim.Integer_IO. + + return Chars (Ent) = Name_Put + and then Loc > No_Location + and then Is_Dim_IO_Package_Entity + (Cunit_Entity (Get_Source_Unit (Loc))); end if; return False; @@ -2499,22 +2512,14 @@ -- Is_Dim_IO_Package_Entity -- ------------------------------ - -- Why all this comparison of names, why not use Is_RTE and Is_RTU ??? - function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean is begin - -- Check the package entity is standard and its scope is either - -- System.Dim.Float_IO or System.Dim.Integer_IO. + -- Check the package entity corresponds to System.Dim.Float_IO or + -- System.Dim.Integer_IO. - if Is_Library_Level_Entity (E) - and then (Chars (E) = Name_Float_IO - or else Chars (E) = Name_Integer_IO) - then - return Chars (Scope (E)) = Name_Dim - and Chars (Scope (Scope (E))) = Name_System; - end if; - - return False; + return + Is_RTU (E, System_Dim_Float_IO) + or Is_RTU (E, System_Dim_Integer_IO); end Is_Dim_IO_Package_Entity; ------------------------------------- @@ -2523,19 +2528,14 @@ function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean is Gen_Id : constant Node_Id := Name (N); - Ent : Entity_Id; begin - if Is_Entity_Name (Gen_Id) then - Ent := Entity (Gen_Id); + -- Check that the instantiated package is either System.Dim.Float_IO + -- or System.Dim.Integer_IO. - -- Verify that the instantiated package is either System.Dim.Float_IO - -- or System.Dim.Integer_IO. - - return Is_Dim_IO_Package_Entity (Ent); - end if; - - return False; + return + Is_Entity_Name (Gen_Id) + and then Is_Dim_IO_Package_Entity (Entity (Gen_Id)); end Is_Dim_IO_Package_Instantiation; ---------------- Index: rtsfind.adb =================================================================== --- rtsfind.adb (revision 184470) +++ rtsfind.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -313,6 +313,9 @@ elsif U_Id in Ada_Interrupts_Child then Name_Buffer (15) := '.'; + elsif U_Id in Ada_Numerics_Child then + Name_Buffer (13) := '.'; + elsif U_Id in Ada_Real_Time_Child then Name_Buffer (14) := '.'; @@ -338,6 +341,10 @@ elsif U_Id in System_Child then Name_Buffer (7) := '.'; + if U_Id in System_Dim_Child then + Name_Buffer (11) := '.'; + end if; + if U_Id in System_Multiprocessors_Child then Name_Buffer (23) := '.'; end if; Index: rtsfind.ads =================================================================== --- rtsfind.ads (revision 184470) +++ rtsfind.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -125,6 +125,7 @@ Ada_Exceptions, Ada_Finalization, Ada_Interrupts, + Ada_Numerics, Ada_Real_Time, Ada_Streams, Ada_Strings, @@ -144,6 +145,10 @@ Ada_Interrupts_Names, + -- Children of Ada.Numerics + + Ada_Numerics_Generic_Elementary_Functions, + -- Children of Ada.Real_Time Ada_Real_Time_Delays, @@ -223,6 +228,7 @@ System_Concat_7, System_Concat_8, System_Concat_9, + System_Dim, System_DSA_Services, System_DSA_Types, System_Exception_Table, @@ -372,6 +378,11 @@ System_WWd_Enum, System_WWd_Wchar, + -- Children of System.Dim + + System_Dim_Float_IO, + System_Dim_Integer_IO, + -- Children of System.Multiprocessors System_Multiprocessors_Dispatching_Domains, @@ -413,6 +424,11 @@ Ada_Interrupts_Names .. Ada_Interrupts_Names; -- Range of values for children of Ada.Interrupts + subtype Ada_Numerics_Child is Ada_Child + range Ada_Numerics_Generic_Elementary_Functions .. + Ada_Numerics_Generic_Elementary_Functions; + -- Range of values for children of Ada.Numerics + subtype Ada_Real_Time_Child is Ada_Child range Ada_Real_Time_Delays .. Ada_Real_Time_Timing_Events; -- Range of values for children of Ada.Real_Time @@ -445,6 +461,10 @@ range System_Address_Image .. System_Tasking_Stages; -- Range of values for children or grandchildren of System + subtype System_Dim_Child is RTU_Id + range System_Dim_Float_IO .. System_Dim_Integer_IO; + -- Range of values for children of System.Dim + subtype System_Multiprocessors_Child is RTU_Id range System_Multiprocessors_Dispatching_Domains .. System_Multiprocessors_Dispatching_Domains; Index: snames.ads-tmpl =================================================================== --- snames.ads-tmpl (revision 184470) +++ snames.ads-tmpl (working copy) @@ -225,8 +225,6 @@ -- Names used by the analyzer and expander for aspect Dimension and -- Dimension_System to deal with Sqrt and IO routines. - Name_Dim : constant Name_Id := N + $; -- Ada 12 - Name_Generic_Elementary_Functions : constant Name_Id := N + $; -- Ada 12 Name_Item : constant Name_Id := N + $; -- Ada 12 Name_Sqrt : constant Name_Id := N + $; -- Ada 12 Name_Symbols : constant Name_Id := N + $; -- Ada 12