Skip to content

GitLab

Commit 04e29e1d authored by charlet's avatar charlet
Browse files

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.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@183701 138bc75d-0d04-0410-961f-82ee72b054a4
parent c5824929
Show whitespace changes
Inline Side-by-side
Showing with 237 additions and 150 deletions
gcc/ada/ChangeLog
View file @ 04e29e1d
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,
......
gcc/ada/exp_aggr.adb
View file @ 04e29e1d
......@@ -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
......
gcc/ada/s-diflio.adb
View file @ 04e29e1d
......@@ -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- --
......@@ -40,38 +40,38 @@ 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)
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)
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)
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;
gcc/ada/s-diflio.ads
View file @ 04e29e1d
......@@ -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- --
......@@ -50,24 +50,24 @@ package 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);
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);
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);
Exp : Field := Default_Exp;
Symbols : String := "");
pragma Inline (Put);
......
gcc/ada/s-diinio.adb
View file @ 04e29e1d
......@@ -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- --
......@@ -40,38 +40,38 @@ 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)
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)
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)
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;
gcc/ada/s-diinio.ads
View file @ 04e29e1d
......@@ -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- --
......@@ -49,21 +49,21 @@ package 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);
Base : Number_Base := Default_Base;
Symbols : String := "");
procedure Put
(Item : Num_Dim_Integer;
Unit : String := "";
Width : Field := Default_Width;
Base : Number_Base := Default_Base);
Base : Number_Base := Default_Base;
Symbols : String := "");
procedure Put
(To : out String;
Item : Num_Dim_Integer;
Unit : String := "";
Base : Number_Base := Default_Base);
Base : Number_Base := Default_Base;
Symbols : String := "");
pragma Inline (Put);
......
gcc/ada/s-dimmks.ads
View file @ 04e29e1d
......@@ -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"),
......
gcc/ada/s-llflex.ads
View file @ 04e29e1d
......@@ -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;
......
gcc/ada/sem_ch12.adb
View file @ 04e29e1d
......@@ -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;
----------------------
......
gcc/ada/sem_dim.adb
View file @ 04e29e1d
......@@ -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,69 +2256,55 @@ 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
while Present (Actual) loop
if Nkind (Actual) = N_Parameter_Association
and then Chars (Selector_Name (Actual)) = Name_Item
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
-- 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
-- Start of processing for Expand_Put_Call_With_Dimension_Symbol
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);
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.
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
Start_String;
......@@ -2286,20 +2314,51 @@ package body Sem_Dim is
Store_String_Chars (Symbol_Of (Etyp));
New_Str_Lit := Make_String_Literal (Loc, End_String);
-- Rewrite the String_Literal of the second actual with the
-- new String_Id created by the routine
-- From_Dimension_To_String.
-- 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.
else
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));
From_Dimension_To_String_Of_Symbols (Dims_Of_Actual, System));
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,
Make_Procedure_Call_Statement (Loc,
......@@ -2309,7 +2368,6 @@ package body Sem_Dim is
Analyze (N);
end if;
end if;
end if;
end Expand_Put_Call_With_Dimension_Symbol;
-----------------------------------------
......
gcc/ada/snames.ads-tmpl
View file @ 04e29e1d
......@@ -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
......
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

Powered by Integricloud