OSDN Git Service

2012-01-30 Thomas Quinot <quinot@adacore.com>
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 30 Jan 2012 10:29:35 +0000 (10:29 +0000)
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>
Mon, 30 Jan 2012 10:29:35 +0000 (10:29 +0000)
* 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.

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@183701 138bc75d-0d04-0410-961f-82ee72b054a4

gcc/ada/ChangeLog
gcc/ada/exp_aggr.adb
gcc/ada/s-diflio.adb
gcc/ada/s-diflio.ads
gcc/ada/s-diinio.adb
gcc/ada/s-diinio.ads
gcc/ada/s-dimmks.ads
gcc/ada/s-llflex.ads
gcc/ada/sem_ch12.adb
gcc/ada/sem_dim.adb
gcc/ada/snames.ads-tmpl

index 829ae3b..704ff4b 100644 (file)
@@ -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,
index 9a4ee27..94f2c3d 100644 (file)
@@ -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
index e13abf9..82c47bd 100644 (file)
@@ -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;
index 3e04ea1..2eee802 100644 (file)
@@ -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);
 
index e8d8f5d..c1de526 100644 (file)
@@ -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;
index 00db9af..dfbcb79 100644 (file)
@@ -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);
 
index 88a29dd..1ee7387 100644 (file)
@@ -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"),
index c47d496..7575383 100644 (file)
@@ -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;
 
index ed7357a..90ff363 100644 (file)
@@ -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;
 
    ----------------------
index edb4343..16cbf8c 100644 (file)
@@ -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;
index aecebcd..f004adf 100644 (file)
@@ -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