Skip to content

R
riscv-gcc-1
Commit 1b6897ce by Arnaud Charlet
Options

[multiple changes] 

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.

From-SVN: r183701
parent 50decc81
Showing with 189 additions and 102 deletions
gcc/ada/ChangeLog
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> 2012-01-30 Robert Dewar <dewar@adacore.com>
* einfo.ads, sem_prag.adb, sem_attr.adb, aspects.ads, * einfo.ads, sem_prag.adb, sem_attr.adb, aspects.ads,
......
gcc/ada/exp_aggr.adb
...@@ -5658,6 +5658,13 @@ package body Exp_Aggr is ...@@ -5658,6 +5658,13 @@ package body Exp_Aggr is
Expand_Record_Aggregate Expand_Record_Aggregate
(Parent_Aggr, Tag_Value, Parent_Expr); (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; end;
-- For a root type, the tag component is added (unless compiling -- For a root type, the tag component is added (unless compiling
......
gcc/ada/s-diflio.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -40,38 +40,38 @@ package body System.Dim_Float_IO is ...@@ -40,38 +40,38 @@ package body System.Dim_Float_IO is
procedure Put procedure Put
(File : File_Type; (File : File_Type;
Item : Num_Dim_Float; Item : Num_Dim_Float;
Unit : String := "";
Fore : Field := Default_Fore; Fore : Field := Default_Fore;
Aft : Field := Default_Aft; Aft : Field := Default_Aft;
Exp : Field := Default_Exp) Exp : Field := Default_Exp;
Symbols : String := "")
is is
begin begin
Num_Dim_Float_IO.Put (File, Item, Fore, Aft, Exp); Num_Dim_Float_IO.Put (File, Item, Fore, Aft, Exp);
Ada.Text_IO.Put (File, Unit); Ada.Text_IO.Put (File, Symbols);
end Put; end Put;
procedure Put procedure Put
(Item : Num_Dim_Float; (Item : Num_Dim_Float;
Unit : String := "";
Fore : Field := Default_Fore; Fore : Field := Default_Fore;
Aft : Field := Default_Aft; Aft : Field := Default_Aft;
Exp : Field := Default_Exp) Exp : Field := Default_Exp;
Symbols : String := "")
is is
begin begin
Num_Dim_Float_IO.Put (Item, Fore, Aft, Exp); Num_Dim_Float_IO.Put (Item, Fore, Aft, Exp);
Ada.Text_IO.Put (Unit); Ada.Text_IO.Put (Symbols);
end Put; end Put;
procedure Put procedure Put
(To : out String; (To : out String;
Item : Num_Dim_Float; Item : Num_Dim_Float;
Unit : String := "";
Aft : Field := Default_Aft; Aft : Field := Default_Aft;
Exp : Field := Default_Exp) Exp : Field := Default_Exp;
Symbols : String := "")
is is
begin begin
Num_Dim_Float_IO.Put (To, Item, Aft, Exp); Num_Dim_Float_IO.Put (To, Item, Aft, Exp);
To := To & Unit; To := To & Symbols;
end Put; end Put;
end System.Dim_Float_IO; end System.Dim_Float_IO;
gcc/ada/s-diflio.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -50,24 +50,24 @@ package System.Dim_Float_IO is ...@@ -50,24 +50,24 @@ package System.Dim_Float_IO is
procedure Put procedure Put
(File : File_Type; (File : File_Type;
Item : Num_Dim_Float; Item : Num_Dim_Float;
Unit : String := "";
Fore : Field := Default_Fore; Fore : Field := Default_Fore;
Aft : Field := Default_Aft; Aft : Field := Default_Aft;
Exp : Field := Default_Exp); Exp : Field := Default_Exp;
Symbols : String := "");
procedure Put procedure Put
(Item : Num_Dim_Float; (Item : Num_Dim_Float;
Unit : String := "";
Fore : Field := Default_Fore; Fore : Field := Default_Fore;
Aft : Field := Default_Aft; Aft : Field := Default_Aft;
Exp : Field := Default_Exp); Exp : Field := Default_Exp;
Symbols : String := "");
procedure Put procedure Put
(To : out String; (To : out String;
Item : Num_Dim_Float; Item : Num_Dim_Float;
Unit : String := "";
Aft : Field := Default_Aft; Aft : Field := Default_Aft;
Exp : Field := Default_Exp); Exp : Field := Default_Exp;
Symbols : String := "");
pragma Inline (Put); pragma Inline (Put);
......
gcc/ada/s-diinio.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -40,38 +40,38 @@ package body System.Dim_Integer_IO is ...@@ -40,38 +40,38 @@ package body System.Dim_Integer_IO is
procedure Put procedure Put
(File : File_Type; (File : File_Type;
Item : Num_Dim_Integer; Item : Num_Dim_Integer;
Unit : String := "";
Width : Field := Default_Width; Width : Field := Default_Width;
Base : Number_Base := Default_Base) Base : Number_Base := Default_Base;
Symbols : String := "")
is is
begin begin
Num_Dim_Integer_IO.Put (File, Item, Width, Base); Num_Dim_Integer_IO.Put (File, Item, Width, Base);
Ada.Text_IO.Put (File, Unit); Ada.Text_IO.Put (File, Symbols);
end Put; end Put;
procedure Put procedure Put
(Item : Num_Dim_Integer; (Item : Num_Dim_Integer;
Unit : String := "";
Width : Field := Default_Width; Width : Field := Default_Width;
Base : Number_Base := Default_Base) Base : Number_Base := Default_Base;
Symbols : String := "")
is is
begin begin
Num_Dim_Integer_IO.Put (Item, Width, Base); Num_Dim_Integer_IO.Put (Item, Width, Base);
Ada.Text_IO.Put (Unit); Ada.Text_IO.Put (Symbols);
end Put; end Put;
procedure Put procedure Put
(To : out String; (To : out String;
Item : Num_Dim_Integer; Item : Num_Dim_Integer;
Unit : String := ""; Base : Number_Base := Default_Base;
Base : Number_Base := Default_Base) Symbols : String := "")
is is
begin begin
Num_Dim_Integer_IO.Put (To, Item, Base); Num_Dim_Integer_IO.Put (To, Item, Base);
To := To & Unit; To := To & Symbols;
end Put; end Put;
end System.Dim_Integer_IO; end System.Dim_Integer_IO;
gcc/ada/s-diinio.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -49,21 +49,21 @@ package System.Dim_Integer_IO is ...@@ -49,21 +49,21 @@ package System.Dim_Integer_IO is
procedure Put procedure Put
(File : File_Type; (File : File_Type;
Item : Num_Dim_Integer; Item : Num_Dim_Integer;
Unit : String := "";
Width : Field := Default_Width; Width : Field := Default_Width;
Base : Number_Base := Default_Base); Base : Number_Base := Default_Base;
Symbols : String := "");
procedure Put procedure Put
(Item : Num_Dim_Integer; (Item : Num_Dim_Integer;
Unit : String := "";
Width : Field := Default_Width; Width : Field := Default_Width;
Base : Number_Base := Default_Base); Base : Number_Base := Default_Base;
Symbols : String := "");
procedure Put procedure Put
(To : out String; (To : out String;
Item : Num_Dim_Integer; Item : Num_Dim_Integer;
Unit : String := ""; Base : Number_Base := Default_Base;
Base : Number_Base := Default_Base); Symbols : String := "");
pragma Inline (Put); pragma Inline (Put);
......
gcc/ada/s-dimmks.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -44,7 +44,7 @@ package System.Dim_Mks is ...@@ -44,7 +44,7 @@ package System.Dim_Mks is
-- Dimensioned type Mks_Type -- Dimensioned type Mks_Type
type Mks_Type is new Long_Float type Mks_Type is new Long_Long_Float
with with
Dimension_System => ((Meter, 'm'), Dimension_System => ((Meter, 'm'),
(Kilogram, "kg"), (Kilogram, "kg"),
......
gcc/ada/s-llflex.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -29,8 +29,8 @@ ...@@ -29,8 +29,8 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This package contains an instantiation of the functions "**" and Sqrt -- This package contains an instantiation of the exponentiation between two
-- between two long long floats. -- long long floats.
with Ada.Numerics.Long_Long_Elementary_Functions; with Ada.Numerics.Long_Long_Elementary_Functions;
......
gcc/ada/sem_ch12.adb
...@@ -7142,13 +7142,12 @@ package body Sem_Ch12 is ...@@ -7142,13 +7142,12 @@ package body Sem_Ch12 is
end if; end if;
-- At this point either both nodes came from source or we approximated -- 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 Sloc (P1) < Sloc (P2);
return True;
else
return False;
end if;
end Earlier; end Earlier;
---------------------- ----------------------
......
gcc/ada/sem_dim.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -2160,21 +2160,63 @@ package body Sem_Dim is ...@@ -2160,21 +2160,63 @@ package body Sem_Dim is
Actuals : constant List_Id := Parameter_Associations (N); Actuals : constant List_Id := Parameter_Associations (N);
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Name_Call : constant Node_Id := Name (N); Name_Call : constant Node_Id := Name (N);
New_Actuals : constant List_Id := New_List;
Actual : Node_Id; Actual : Node_Id;
Base_Typ : Node_Id;
Dims_Of_Actual : Dimension_Type; Dims_Of_Actual : Dimension_Type;
Etyp : Entity_Id; Etyp : Entity_Id;
First_Actual : Node_Id; New_Str_Lit : Node_Id := Empty;
New_Actuals : List_Id;
New_Str_Lit : Node_Id;
Package_Name : Name_Id; Package_Name : Name_Id;
System : System_Type; 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; function Is_Procedure_Put_Call return Boolean;
-- Return True if the current call is a call of an instantiation of a -- 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 -- procedure Put defined in the package System.Dim_Float_IO and
-- System.Dim_Integer_IO. -- 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 -- -- Is_Procedure_Put_Call --
--------------------------- ---------------------------
...@@ -2214,69 +2256,55 @@ package body Sem_Dim is ...@@ -2214,69 +2256,55 @@ package body Sem_Dim is
return False; return False;
end Is_Procedure_Put_Call; end Is_Procedure_Put_Call;
-- Start of processing for Expand_Put_Call_With_Dimension_Symbol -----------------
-- Item_Actual --
begin -----------------
if Is_Procedure_Put_Call then
-- 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 -- Look for the item actual as a parameter association
-- (System.Dim_Float_IO) parameters.
if List_Length (Actuals) = 5 while Present (Actual) loop
or else List_Length (Actuals) = 4 if Nkind (Actual) = N_Parameter_Association
and then Chars (Selector_Name (Actual)) = Name_Item
then then
Actual := Next (First_Actual); 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 -- Case where the item has been defined without an association
-- from the first actual.
Actual := First_Actual; Actual := First (Actuals);
end if;
-- 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 else
Actual := Next (First_Actual); return Next (Actual);
end if; end if;
end Item_Actual;
Base_Typ := Base_Type (Etype (Actual)); -- Start of processing for Expand_Put_Call_With_Dimension_Symbol
System := System_Of (Base_Typ);
-- Check the base type of Actual is a dimensioned type
if Exists (System) then begin
if Is_Procedure_Put_Call
and then not Has_Dimension_Symbols
then
Actual := Item_Actual;
Dims_Of_Actual := Dimensions_Of (Actual); Dims_Of_Actual := Dimensions_Of (Actual);
Etyp := Etype (Actual); Etyp := Etype (Actual);
-- Add the symbol as a suffix of the value if the subtype has a -- Add the symbol as a suffix of the value if the subtype has a
-- dimension symbol or if the parameter is not dimensionless. -- dimension symbol or if the parameter is not dimensionless.
if Exists (Dims_Of_Actual)
or else Symbol_Of (Etyp) /= No_String
then
New_Actuals := New_List;
-- Add to the list First_Actual and Actual if they differ
if Actual /= First_Actual then
Append (New_Copy (First_Actual), New_Actuals);
end if;
Append (New_Copy (Actual), New_Actuals);
-- Look to the next parameter
Next (Actual);
-- Check if the type of N is a subtype that has a symbol of
-- dimensions in Aspect_Dimension_String_Id_Hash_Table.
if Symbol_Of (Etyp) /= No_String then if Symbol_Of (Etyp) /= No_String then
Start_String; Start_String;
...@@ -2286,20 +2314,51 @@ package body Sem_Dim is ...@@ -2286,20 +2314,51 @@ package body Sem_Dim is
Store_String_Chars (Symbol_Of (Etyp)); Store_String_Chars (Symbol_Of (Etyp));
New_Str_Lit := Make_String_Literal (Loc, End_String); New_Str_Lit := Make_String_Literal (Loc, End_String);
-- Rewrite the String_Literal of the second actual with the -- Check that the item is not dimensionless
-- new String_Id created by the routine -- Create the new String_Literal with the new String_Id generated by
-- From_Dimension_To_String. -- the routine From_Dimension_To_String.
else elsif Exists (Dims_Of_Actual) then
System := System_Of (Base_Type (Etyp));
New_Str_Lit := New_Str_Lit :=
Make_String_Literal (Loc, Make_String_Literal (Loc,
From_Dimension_To_String_Of_Symbols (Dims_Of_Actual, From_Dimension_To_String_Of_Symbols (Dims_Of_Actual, System));
System));
end if; end if;
Append (New_Str_Lit, New_Actuals); if Present (New_Str_Lit) then
-- Insert all actuals in New_Actuals
-- Rewrite the procedure call with the new list of parameters Actual := First (Actuals);
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;
Next (Actual);
end loop;
-- Create the new Symbols parameter association and append it in
-- New_Actuals.
Append (
Make_Parameter_Association (Loc,
Selector_Name => Make_Identifier (Loc, Name_Symbols),
Explicit_Actual_Parameter => New_Str_Lit),
New_Actuals);
-- Rewrite and analyze the procedure call
Rewrite (N, Rewrite (N,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
...@@ -2309,7 +2368,6 @@ package body Sem_Dim is ...@@ -2309,7 +2368,6 @@ package body Sem_Dim is
Analyze (N); Analyze (N);
end if; end if;
end if; end if;
end if;
end Expand_Put_Call_With_Dimension_Symbol; end Expand_Put_Call_With_Dimension_Symbol;
----------------------------------------- -----------------------------------------
......
gcc/ada/snames.ads-tmpl
...@@ -228,7 +228,9 @@ package Snames is ...@@ -228,7 +228,9 @@ package Snames is
Name_Dim_Float_IO : constant Name_Id := N + $; -- Ada 12 Name_Dim_Float_IO : constant Name_Id := N + $; -- Ada 12
Name_Dim_Integer_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_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_Sqrt : constant Name_Id := N + $; -- Ada 12
Name_Symbols : constant Name_Id := N + $; -- Ada 12
-- Some miscellaneous names used for error detection/recovery -- Some miscellaneous names used for error detection/recovery
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment