[Ada] Minor changes for GNAT dimensionality checking system

Message ID	20120130103001.GA9908@adacore.com
State	New
Headers	show Return-Path: <gcc-patches-return-312295-incoming=patchwork.ozlabs.org@gcc.gnu.org> Comment: DKIM? See http://www.dkim.org 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=IOB1dNQDJVuGssff6eOPmtikCrfLnTPBfjc8ryAKj7lv1Lqjzik/Rrk9blHQPo YWveiZGMbc7ZlZ39pbC/R3HnbCn7OpeS3PJYSm4Fzo/vW61GPuRDHmNBQJtx3xwP aNBbqjc3+44sTyRnC/e6dT0k9rh3FeAJ91SW4Qjzq1j5I=; Date: Mon, 30 Jan 2012 05:30:01 -0500 From: Arnaud Charlet <charlet@adacore.com> To: gcc-patches@gcc.gnu.org Cc: Vincent Pucci <pucci@adacore.com> Subject: [Ada] Minor changes for GNAT dimensionality checking system Message-ID: <20120130103001.GA9908@adacore.com> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="0F1p//8PRICkK4MW" 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 Sender: gcc-patches-owner@gcc.gnu.org

Index: s-diinio.adb =================================================================== --- s-diinio.adb (revision 183694) +++ s-diinio.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-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- -- @@ -38,40 +38,40 @@ --------- procedure Put - (File : File_Type; - Item : Num_Dim_Integer; - Unit : String := ""; - Width : Field := Default_Width; - Base : Number_Base := Default_Base) + (File : File_Type; + Item : Num_Dim_Integer; + Width : Field := Default_Width; + Base : Number_Base := Default_Base; + Symbols : String := "") is begin Num_Dim_Integer_IO.Put (File, Item, Width, Base); - Ada.Text_IO.Put (File, Unit); + Ada.Text_IO.Put (File, Symbols); end Put; procedure Put - (Item : Num_Dim_Integer; - Unit : String := ""; - Width : Field := Default_Width; - Base : Number_Base := Default_Base) + (Item : Num_Dim_Integer; + Width : Field := Default_Width; + Base : Number_Base := Default_Base; + Symbols : String := "") is begin Num_Dim_Integer_IO.Put (Item, Width, Base); - Ada.Text_IO.Put (Unit); + Ada.Text_IO.Put (Symbols); end Put; procedure Put - (To : out String; - Item : Num_Dim_Integer; - Unit : String := ""; - Base : Number_Base := Default_Base) + (To : out String; + Item : Num_Dim_Integer; + Base : Number_Base := Default_Base; + Symbols : String := "") is begin Num_Dim_Integer_IO.Put (To, Item, Base); - To := To & Unit; + To := To & Symbols; end Put; end System.Dim_Integer_IO; Index: s-diinio.ads =================================================================== --- s-diinio.ads (revision 183694) +++ s-diinio.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-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- -- @@ -47,23 +47,23 @@ Default_Base : Number_Base := 10; procedure Put - (File : File_Type; - Item : Num_Dim_Integer; - Unit : String := ""; - Width : Field := Default_Width; - Base : Number_Base := Default_Base); + (File : File_Type; + Item : Num_Dim_Integer; + Width : Field := Default_Width; + Base : Number_Base := Default_Base; + Symbols : String := ""); procedure Put - (Item : Num_Dim_Integer; - Unit : String := ""; - Width : Field := Default_Width; - Base : Number_Base := Default_Base); + (Item : Num_Dim_Integer; + Width : Field := Default_Width; + Base : Number_Base := Default_Base; + Symbols : String := ""); procedure Put - (To : out String; - Item : Num_Dim_Integer; - Unit : String := ""; - Base : Number_Base := Default_Base); + (To : out String; + Item : Num_Dim_Integer; + Base : Number_Base := Default_Base; + Symbols : String := ""); pragma Inline (Put); Index: sem_dim.adb =================================================================== --- sem_dim.adb (revision 183694) +++ sem_dim.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-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- -- @@ -2160,22 +2160,64 @@ Actuals : constant List_Id := Parameter_Associations (N); Loc : constant Source_Ptr := Sloc (N); Name_Call : constant Node_Id := Name (N); + New_Actuals : constant List_Id := New_List; Actual : Node_Id; - Base_Typ : Node_Id; Dims_Of_Actual : Dimension_Type; Etyp : Entity_Id; - First_Actual : Node_Id; - New_Actuals : List_Id; - New_Str_Lit : Node_Id; + New_Str_Lit : Node_Id := Empty; Package_Name : Name_Id; System : System_Type; + function Has_Dimension_Symbols return Boolean; + -- Return True if the current Put call already has a parameter + -- association for parameter "Symbols" with the correct string of + -- symbols. + function Is_Procedure_Put_Call return Boolean; -- Return True if the current call is a call of an instantiation of a -- procedure Put defined in the package System.Dim_Float_IO and -- System.Dim_Integer_IO. + function Item_Actual return Node_Id; + -- Return the item actual parameter node in the put call + --------------------------- + -- Has_Dimension_Symbols -- + --------------------------- + + function Has_Dimension_Symbols return Boolean is + Actual : Node_Id; + + begin + Actual := First (Actuals); + + -- Look for a symbols parameter association in the list of actuals + + while Present (Actual) loop + if Nkind (Actual) = N_Parameter_Association + and then Chars (Selector_Name (Actual)) = Name_Symbols + then + + -- return True if the actual comes from source or if the string + -- of symbols doesn't have the default value (i.e ""). + + return Comes_From_Source (Actual) + or else String_Length + (Strval + (Explicit_Actual_Parameter (Actual))) /= 0; + end if; + + Next (Actual); + end loop; + + -- At this point, the call has no parameter association + -- Look to the last actual since the symbols parameter is the last + -- one. + + return Nkind (Last (Actuals)) = N_String_Literal; + end Has_Dimension_Symbols; + + --------------------------- -- Is_Procedure_Put_Call -- --------------------------- @@ -2214,100 +2256,116 @@ return False; end Is_Procedure_Put_Call; - -- Start of processing for Expand_Put_Call_With_Dimension_Symbol + ----------------- + -- Item_Actual -- + ----------------- - begin - if Is_Procedure_Put_Call then + function Item_Actual return Node_Id is + Actual : Node_Id; - -- Get the first parameter + begin + Actual := First (Actuals); - First_Actual := First (Actuals); + -- Look for the item actual as a parameter association - -- Case when the Put routine has four (System.Dim_Integer_IO) or five - -- (System.Dim_Float_IO) parameters. + while Present (Actual) loop + if Nkind (Actual) = N_Parameter_Association + and then Chars (Selector_Name (Actual)) = Name_Item + then + return Explicit_Actual_Parameter (Actual); + end if; - if List_Length (Actuals) = 5 - or else List_Length (Actuals) = 4 - then - Actual := Next (First_Actual); + Next (Actual); + end loop; - if Nkind (Actual) = N_Parameter_Association then + -- Case where the item has been defined without an association - -- Get the dimensions and the corresponding dimension system - -- from the first actual. + Actual := First (Actuals); - Actual := First_Actual; - end if; + -- Depending on the procedure Put, Item actual could be first or + -- second in the list of actuals. - -- Case when the Put routine has six parameters - + if Has_Dimension_System (Base_Type (Etype (Actual))) then + return Actual; else - Actual := Next (First_Actual); + return Next (Actual); end if; + end Item_Actual; - Base_Typ := Base_Type (Etype (Actual)); - System := System_Of (Base_Typ); + -- Start of processing for Expand_Put_Call_With_Dimension_Symbol - -- Check the base type of Actual is a dimensioned type + begin + if Is_Procedure_Put_Call + and then not Has_Dimension_Symbols + then + Actual := Item_Actual; + Dims_Of_Actual := Dimensions_Of (Actual); + Etyp := Etype (Actual); - if Exists (System) then - Dims_Of_Actual := Dimensions_Of (Actual); - Etyp := Etype (Actual); + -- Add the symbol as a suffix of the value if the subtype has a + -- dimension symbol or if the parameter is not dimensionless. - -- Add the symbol as a suffix of the value if the subtype has a - -- dimension symbol or if the parameter is not dimensionless. + if Symbol_Of (Etyp) /= No_String then + Start_String; - if Exists (Dims_Of_Actual) - or else Symbol_Of (Etyp) /= No_String - then - New_Actuals := New_List; + -- Put a space between the value and the dimension - -- Add to the list First_Actual and Actual if they differ + Store_String_Char (' '); + Store_String_Chars (Symbol_Of (Etyp)); + New_Str_Lit := Make_String_Literal (Loc, End_String); - if Actual /= First_Actual then - Append (New_Copy (First_Actual), New_Actuals); - end if; + -- Check that the item is not dimensionless + -- Create the new String_Literal with the new String_Id generated by + -- the routine From_Dimension_To_String. - Append (New_Copy (Actual), New_Actuals); + elsif Exists (Dims_Of_Actual) then + System := System_Of (Base_Type (Etyp)); + New_Str_Lit := + Make_String_Literal (Loc, + From_Dimension_To_String_Of_Symbols (Dims_Of_Actual, System)); + end if; - -- Look to the next parameter + if Present (New_Str_Lit) then + -- Insert all actuals in New_Actuals - Next (Actual); + Actual := First (Actuals); - -- Check if the type of N is a subtype that has a symbol of - -- dimensions in Aspect_Dimension_String_Id_Hash_Table. + while Present (Actual) loop + -- Copy every comes from source actuals in New_Actuals - if Symbol_Of (Etyp) /= No_String then - Start_String; + if Comes_From_Source (Actual) then + if Nkind (Actual) = N_Parameter_Association then + Append ( + Make_Parameter_Association (Loc, + Selector_Name => New_Copy (Selector_Name (Actual)), + Explicit_Actual_Parameter => + New_Copy (Explicit_Actual_Parameter (Actual))), + New_Actuals); + else + Append (New_Copy (Actual), New_Actuals); + end if; + end if; - -- Put a space between the value and the dimension + Next (Actual); + end loop; - Store_String_Char (' '); - Store_String_Chars (Symbol_Of (Etyp)); - New_Str_Lit := Make_String_Literal (Loc, End_String); + -- Create the new Symbols parameter association and append it in + -- New_Actuals. - -- Rewrite the String_Literal of the second actual with the - -- new String_Id created by the routine - -- From_Dimension_To_String. + Append ( + Make_Parameter_Association (Loc, + Selector_Name => Make_Identifier (Loc, Name_Symbols), + Explicit_Actual_Parameter => New_Str_Lit), + New_Actuals); - else - New_Str_Lit := - Make_String_Literal (Loc, - From_Dimension_To_String_Of_Symbols (Dims_Of_Actual, - System)); - end if; + -- Rewrite and analyze the procedure call - Append (New_Str_Lit, New_Actuals); + Rewrite (N, + Make_Procedure_Call_Statement (Loc, + Name => New_Copy (Name_Call), + Parameter_Associations => New_Actuals)); - -- Rewrite the procedure call with the new list of parameters - - Rewrite (N, - Make_Procedure_Call_Statement (Loc, - Name => New_Copy (Name_Call), - Parameter_Associations => New_Actuals)); - - Analyze (N); - end if; + Analyze (N); end if; end if; end Expand_Put_Call_With_Dimension_Symbol; Index: s-diflio.adb =================================================================== --- s-diflio.adb (revision 183694) +++ s-diflio.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-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- -- @@ -38,40 +38,40 @@ --------- procedure Put - (File : File_Type; - Item : Num_Dim_Float; - Unit : String := ""; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) + (File : File_Type; + Item : Num_Dim_Float; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbols : String := "") is begin Num_Dim_Float_IO.Put (File, Item, Fore, Aft, Exp); - Ada.Text_IO.Put (File, Unit); + Ada.Text_IO.Put (File, Symbols); end Put; procedure Put - (Item : Num_Dim_Float; - Unit : String := ""; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) + (Item : Num_Dim_Float; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbols : String := "") is begin Num_Dim_Float_IO.Put (Item, Fore, Aft, Exp); - Ada.Text_IO.Put (Unit); + Ada.Text_IO.Put (Symbols); end Put; procedure Put - (To : out String; - Item : Num_Dim_Float; - Unit : String := ""; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) + (To : out String; + Item : Num_Dim_Float; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbols : String := "") is begin Num_Dim_Float_IO.Put (To, Item, Aft, Exp); - To := To & Unit; + To := To & Symbols; end Put; end System.Dim_Float_IO; Index: s-diflio.ads =================================================================== --- s-diflio.ads (revision 183694) +++ s-diflio.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-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- -- @@ -48,26 +48,26 @@ Default_Exp : Field := 3; procedure Put - (File : File_Type; - Item : Num_Dim_Float; - Unit : String := ""; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); + (File : File_Type; + Item : Num_Dim_Float; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbols : String := ""); procedure Put - (Item : Num_Dim_Float; - Unit : String := ""; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); + (Item : Num_Dim_Float; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbols : String := ""); procedure Put - (To : out String; - Item : Num_Dim_Float; - Unit : String := ""; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); + (To : out String; + Item : Num_Dim_Float; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbols : String := ""); pragma Inline (Put); Index: s-dimmks.ads =================================================================== --- s-dimmks.ads (revision 183694) +++ s-dimmks.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-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- -- @@ -44,7 +44,7 @@ -- Dimensioned type Mks_Type - type Mks_Type is new Long_Float + type Mks_Type is new Long_Long_Float with Dimension_System => ((Meter, 'm'), (Kilogram, "kg"), Index: snames.ads-tmpl =================================================================== --- snames.ads-tmpl (revision 183698) +++ snames.ads-tmpl (working copy) @@ -228,7 +228,9 @@ Name_Dim_Float_IO : constant Name_Id := N + $; -- Ada 12 Name_Dim_Integer_IO : 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 -- Some miscellaneous names used for error detection/recovery Index: s-llflex.ads =================================================================== --- s-llflex.ads (revision 183694) +++ s-llflex.ads (working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2011-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- -- @@ -29,8 +29,8 @@ -- -- ------------------------------------------------------------------------------ --- This package contains an instantiation of the functions "**" and Sqrt --- between two long long floats. +-- This package contains an instantiation of the exponentiation between two +-- long long floats. with Ada.Numerics.Long_Long_Elementary_Functions;

[Ada] Minor changes for GNAT dimensionality checking system

Commit Message

Patch