diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 21 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/s-diflio.adb | 40 | ||||
| -rw-r--r-- | gcc/ada/s-diflio.ads | 34 | ||||
| -rw-r--r-- | gcc/ada/s-diinio.adb | 34 | ||||
| -rw-r--r-- | gcc/ada/s-diinio.ads | 28 | ||||
| -rw-r--r-- | gcc/ada/s-dimmks.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/s-llflex.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/sem_dim.adb | 200 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 2 |
11 files changed, 237 insertions, 150 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 829ae3bba95..704ff4b48e5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,24 @@ +2012-01-30 Thomas Quinot <quinot@adacore.com> + + * exp_aggr.adb (Expand_Record_Aggregate): After creating the + _parent aggregate for an extension aggregate, check whether it + requires delayed (top-down) expansion. + +2012-01-30 Vincent Pucci <pucci@adacore.com> + + * sem_dim.adb (Expand_Put_Call_With_Dimension_Symbol): Rewritten. + * snames.ads-tmpl: Name_Item and Name_Symbols added. + * s-diflio.adb, s-diflio.ads, s-diinio.adb, s-diinio.ads: Rename + and change the position of parameter Symbols in every Put routine. + * s-dimmks.ads: Convert long float type Mks_Type into long + long float. + * s-llflex.ads: Modifications in comments. + +2012-01-30 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch12.adb (Earlier): Do not use the + top level source locations of the two input nodes. + 2012-01-30 Robert Dewar <dewar@adacore.com> * einfo.ads, sem_prag.adb, sem_attr.adb, aspects.ads, diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 9a4ee27234b..94f2c3dd68d 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -5658,6 +5658,13 @@ package body Exp_Aggr is Expand_Record_Aggregate (Parent_Aggr, Tag_Value, Parent_Expr); + + -- The ancestor part may be a nested aggregate that has + -- delayed expansion: recheck now. + + if Component_Not_OK_For_Backend then + Convert_To_Assignments (N, Typ); + end if; end; -- For a root type, the tag component is added (unless compiling diff --git a/gcc/ada/s-diflio.adb b/gcc/ada/s-diflio.adb index e13abf91550..82c47bddf00 100644 --- a/gcc/ada/s-diflio.adb +++ b/gcc/ada/s-diflio.adb @@ -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 @@ package body System.Dim_Float_IO is --------- 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; diff --git a/gcc/ada/s-diflio.ads b/gcc/ada/s-diflio.ads index 3e04ea105dd..2eee802f7a1 100644 --- a/gcc/ada/s-diflio.ads +++ b/gcc/ada/s-diflio.ads @@ -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 @@ package System.Dim_Float_IO is 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); diff --git a/gcc/ada/s-diinio.adb b/gcc/ada/s-diinio.adb index e8d8f5d7f95..c1de5265451 100644 --- a/gcc/ada/s-diinio.adb +++ b/gcc/ada/s-diinio.adb @@ -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 @@ package body System.Dim_Integer_IO is --------- 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; diff --git a/gcc/ada/s-diinio.ads b/gcc/ada/s-diinio.ads index 00db9afc634..dfbcb793755 100644 --- a/gcc/ada/s-diinio.ads +++ b/gcc/ada/s-diinio.ads @@ -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 @@ package System.Dim_Integer_IO is 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); diff --git a/gcc/ada/s-dimmks.ads b/gcc/ada/s-dimmks.ads index 88a29ddc352..1ee73872136 100644 --- a/gcc/ada/s-dimmks.ads +++ b/gcc/ada/s-dimmks.ads @@ -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 @@ package System.Dim_Mks is -- 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"), diff --git a/gcc/ada/s-llflex.ads b/gcc/ada/s-llflex.ads index c47d49601fb..7575383885a 100644 --- a/gcc/ada/s-llflex.ads +++ b/gcc/ada/s-llflex.ads @@ -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; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index ed7357ab086..90ff36346e0 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -7142,13 +7142,12 @@ package body Sem_Ch12 is end if; -- At this point either both nodes came from source or we approximated - -- their source locations through neighbouring source statements. + -- their source locations through neighbouring source statements. There + -- is no need to look at the top level locations of P1 and P2 because + -- both nodes are in the same list and whether the enclosing context is + -- instantiated is irrelevant. - if Top_Level_Location (Sloc (P1)) < Top_Level_Location (Sloc (P2)) then - return True; - else - return False; - end if; + return Sloc (P1) < Sloc (P2); end Earlier; ---------------------- diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index edb434396ab..16cbf8c7b19 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -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,21 +2160,63 @@ package body Sem_Dim is 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 @@ package body Sem_Dim is return False; end Is_Procedure_Put_Call; - -- Start of processing for Expand_Put_Call_With_Dimension_Symbol - - begin - if Is_Procedure_Put_Call then + ----------------- + -- Item_Actual -- + ----------------- - -- Get the first parameter + function Item_Actual return Node_Id is + Actual : Node_Id; - First_Actual := First (Actuals); + begin + Actual := First (Actuals); - -- Case when the Put routine has four (System.Dim_Integer_IO) or five - -- (System.Dim_Float_IO) parameters. + -- Look for the item actual as a parameter association - if List_Length (Actuals) = 5 - or else List_Length (Actuals) = 4 - then - Actual := Next (First_Actual); + 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 Nkind (Actual) = N_Parameter_Association then + Next (Actual); + end loop; - -- Get the dimensions and the corresponding dimension system - -- from the first actual. + -- Case where the item has been defined without an association - Actual := First_Actual; - end if; + Actual := First (Actuals); - -- Case when the Put routine has six parameters + -- Depending on the procedure Put, Item actual could be first or + -- second in the list of actuals. + 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); - - -- Check the base type of Actual is a dimensioned type - - 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. + -- Start of processing for Expand_Put_Call_With_Dimension_Symbol - if Exists (Dims_Of_Actual) - or else Symbol_Of (Etyp) /= No_String - then - New_Actuals := New_List; + 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); - -- Add to the list First_Actual and Actual if they differ + -- Add the symbol as a suffix of the value if the subtype has a + -- dimension symbol or if the parameter is not dimensionless. - if Actual /= First_Actual then - Append (New_Copy (First_Actual), New_Actuals); - end if; + if Symbol_Of (Etyp) /= No_String then + Start_String; - Append (New_Copy (Actual), New_Actuals); + -- Put a space between the value and the dimension - -- Look to the next parameter + Store_String_Char (' '); + Store_String_Chars (Symbol_Of (Etyp)); + New_Str_Lit := Make_String_Literal (Loc, End_String); - Next (Actual); + -- 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. - -- Check if the type of N is a subtype that has a symbol of - -- dimensions in Aspect_Dimension_String_Id_Hash_Table. + 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; - if Symbol_Of (Etyp) /= No_String then - Start_String; + if Present (New_Str_Lit) then + -- Insert all actuals in New_Actuals - -- Put a space between the value and the dimension + Actual := First (Actuals); - Store_String_Char (' '); - Store_String_Chars (Symbol_Of (Etyp)); - New_Str_Lit := Make_String_Literal (Loc, End_String); + while Present (Actual) loop + -- Copy every comes from source actuals in New_Actuals + + 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; - -- Rewrite the String_Literal of the second actual with the - -- new String_Id created by the routine - -- From_Dimension_To_String. + Next (Actual); + end loop; - else - New_Str_Lit := - Make_String_Literal (Loc, - From_Dimension_To_String_Of_Symbols (Dims_Of_Actual, - System)); - end if; + -- Create the new Symbols parameter association and append it in + -- New_Actuals. - Append (New_Str_Lit, New_Actuals); + Append ( + Make_Parameter_Association (Loc, + Selector_Name => Make_Identifier (Loc, Name_Symbols), + Explicit_Actual_Parameter => New_Str_Lit), + New_Actuals); - -- Rewrite the procedure call with the new list of parameters + -- Rewrite and analyze the procedure call - Rewrite (N, - Make_Procedure_Call_Statement (Loc, - Name => New_Copy (Name_Call), - Parameter_Associations => New_Actuals)); + 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; diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index aecebcd5353..f004adfd00c 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -228,7 +228,9 @@ package Snames is 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 |