Skip to content

R
riscv-gcc-1
Commit 6bde3eb5 by Arnaud Charlet
Options

[multiple changes] 

2009-05-06  Ed Schonberg  <schonberg@adacore.com>

	* sem_aggr.adb (Resolve_Record_Aggregate): If a defaulted component of
	an aggregate with box default is of a discriminated private type, do
	not build a subaggregate for it.
	A proper call to the initialization procedure is generated for it.

2009-05-06  Thomas Quinot  <quinot@adacore.com>

	* rtsfind.adb, rtsfind.ads, exp_dist.adb, exp_dist.ads
	(Exp_Dist.Build_TC_Call, Build_From_Any_Call, Build_To_Any_Call):
	Use PolyORB strings to represent Ada.Strings.Unbounded_String value;
	use standard array code for Standard.String.
	(Exp_Dist): Bump PolyORB s-parint API version to 3.
	(Rtsfind): New entities TA_Std_String, Unbounded_String.

2009-05-06  Robert Dewar  <dewar@adacore.com>

	* g-comlin.ads: Minor reformatting

	* xoscons.adb: Minor reformatting

From-SVN: r147149
parent 3743d5bd
Showing with 79 additions and 17 deletions
gcc/ada/ChangeLog
2009-05-06 Ed Schonberg <schonberg@adacore.com>
* sem_aggr.adb (Resolve_Record_Aggregate): If a defaulted component of
an aggregate with box default is of a discriminated private type, do
not build a subaggregate for it.
A proper call to the initialization procedure is generated for it.
2009-05-06 Thomas Quinot <quinot@adacore.com>
* rtsfind.adb, rtsfind.ads, exp_dist.adb, exp_dist.ads
(Exp_Dist.Build_TC_Call, Build_From_Any_Call, Build_To_Any_Call):
Use PolyORB strings to represent Ada.Strings.Unbounded_String value;
use standard array code for Standard.String.
(Exp_Dist): Bump PolyORB s-parint API version to 3.
(Rtsfind): New entities TA_Std_String, Unbounded_String.
2009-05-06 Robert Dewar <dewar@adacore.com>
* g-comlin.ads: Minor reformatting
* xoscons.adb: Minor reformatting
2009-05-06 Gary Dismukes <dismukes@adacore.com> 2009-05-06 Gary Dismukes <dismukes@adacore.com>
* sem_aggr.adb (Resolve_Record_Aggregate): In step 5, get the * sem_aggr.adb (Resolve_Record_Aggregate): In step 5, get the
......
gcc/ada/exp_dist.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2009, 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- --
...@@ -6630,13 +6630,13 @@ package body Exp_Dist is ...@@ -6630,13 +6630,13 @@ package body Exp_Dist is
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => Name =>
New_Occurrence_Of New_Occurrence_Of
(RTE (RE_TA_String), Loc), (RTE (RE_TA_Std_String), Loc),
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Make_String_Literal (Loc, Name_String))), Make_String_Literal (Loc, Name_String))),
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => Name =>
New_Occurrence_Of New_Occurrence_Of
(RTE (RE_TA_String), Loc), (RTE (RE_TA_Std_String), Loc),
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Make_String_Literal (Loc, Make_String_Literal (Loc,
Strval => Repo_Id_String)))))))))))); Strval => Repo_Id_String))))))))))));
...@@ -8465,7 +8465,7 @@ package body Exp_Dist is ...@@ -8465,7 +8465,7 @@ package body Exp_Dist is
elsif U_Type = RTE (RE_Long_Long_Unsigned) then elsif U_Type = RTE (RE_Long_Long_Unsigned) then
Lib_RE := RE_FA_LLU; Lib_RE := RE_FA_LLU;
elsif U_Type = Standard_String then elsif Is_RTE (U_Type, RE_Unbounded_String) then
Lib_RE := RE_FA_String; Lib_RE := RE_FA_String;
-- Special DSA types -- Special DSA types
...@@ -8970,7 +8970,11 @@ package body Exp_Dist is ...@@ -8970,7 +8970,11 @@ package body Exp_Dist is
for J in 1 .. Ndim loop for J in 1 .. Ndim loop
Lnam := New_External_Name ('L', J); Lnam := New_External_Name ('L', J);
Hnam := New_External_Name ('H', J); Hnam := New_External_Name ('H', J);
Indt := Etype (Indx);
-- Note, for empty arrays bounds may be out of
-- the range of Etype (Indx).
Indt := Base_Type (Etype (Indx));
Append_To (Decls, Append_To (Decls,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
...@@ -9288,6 +9292,7 @@ package body Exp_Dist is ...@@ -9288,6 +9292,7 @@ package body Exp_Dist is
Typ : Entity_Id := Etype (N); Typ : Entity_Id := Etype (N);
U_Type : Entity_Id; U_Type : Entity_Id;
C_Type : Entity_Id;
Fnam : Entity_Id := Empty; Fnam : Entity_Id := Empty;
Lib_RE : RE_Id := RE_Null; Lib_RE : RE_Id := RE_Null;
...@@ -9383,7 +9388,7 @@ package body Exp_Dist is ...@@ -9383,7 +9388,7 @@ package body Exp_Dist is
elsif U_Type = RTE (RE_Long_Long_Unsigned) then elsif U_Type = RTE (RE_Long_Long_Unsigned) then
Lib_RE := RE_TA_LLU; Lib_RE := RE_TA_LLU;
elsif U_Type = Standard_String then elsif Is_RTE (U_Type, RE_Unbounded_String) then
Lib_RE := RE_TA_String; Lib_RE := RE_TA_String;
-- Special DSA types -- Special DSA types
...@@ -9416,11 +9421,23 @@ package body Exp_Dist is ...@@ -9416,11 +9421,23 @@ package body Exp_Dist is
Fnam := RTE (Lib_RE); Fnam := RTE (Lib_RE);
end if; end if;
-- If Fnam is already analyzed, find the proper expected type,
-- else we have a newly constructed To_Any function and we know
-- that the expected type of its parameter is U_Type.
if Ekind (Fnam) = E_Function
and then Present (First_Formal (Fnam))
then
C_Type := Etype (First_Formal (Fnam));
else
C_Type := U_Type;
end if;
return return
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => New_Occurrence_Of (Fnam, Loc), Name => New_Occurrence_Of (Fnam, Loc),
Parameter_Associations => Parameter_Associations =>
New_List (Unchecked_Convert_To (U_Type, N))); New_List (OK_Convert_To (C_Type, N)));
end Build_To_Any_Call; end Build_To_Any_Call;
--------------------------- ---------------------------
...@@ -10153,7 +10170,7 @@ package body Exp_Dist is ...@@ -10153,7 +10170,7 @@ package body Exp_Dist is
elsif U_Type = RTE (RE_Long_Long_Unsigned) then elsif U_Type = RTE (RE_Long_Long_Unsigned) then
Lib_RE := RE_TC_LLU; Lib_RE := RE_TC_LLU;
elsif U_Type = Standard_String then elsif Is_RTE (U_Type, RE_Unbounded_String) then
Lib_RE := RE_TC_String; Lib_RE := RE_TC_String;
-- Special DSA types -- Special DSA types
...@@ -10253,7 +10270,7 @@ package body Exp_Dist is ...@@ -10253,7 +10270,7 @@ package body Exp_Dist is
begin begin
Append_To (Parameter_List, Append_To (Parameter_List,
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_TA_String), Loc), Name => New_Occurrence_Of (RTE (RE_TA_Std_String), Loc),
Parameter_Associations => New_List ( Parameter_Associations => New_List (
Make_String_Literal (Loc, S)))); Make_String_Literal (Loc, S))));
end Add_String_Parameter; end Add_String_Parameter;
......
gcc/ada/exp_dist.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2009, 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- --
...@@ -35,7 +35,7 @@ package Exp_Dist is ...@@ -35,7 +35,7 @@ package Exp_Dist is
PCS_Version_Number : constant array (PCS_Names) of Int := PCS_Version_Number : constant array (PCS_Names) of Int :=
(Name_No_DSA => 1, (Name_No_DSA => 1,
Name_GARLIC_DSA => 1, Name_GARLIC_DSA => 1,
Name_PolyORB_DSA => 2); Name_PolyORB_DSA => 3);
-- PCS interface version. This is used to check for consistency between the -- PCS interface version. This is used to check for consistency between the
-- compiler used to generate distribution stubs and the PCS implementation. -- compiler used to generate distribution stubs and the PCS implementation.
-- It must be incremented whenever a change is made to the generated code -- It must be incremented whenever a change is made to the generated code
......
gcc/ada/g-comlin.ads
...@@ -112,6 +112,7 @@ ...@@ -112,6 +112,7 @@
-- contexts, either because your system does not support Ada.Command_Line, or -- contexts, either because your system does not support Ada.Command_Line, or
-- because you are manipulating other tools and creating their command line by -- because you are manipulating other tools and creating their command line by
-- hand, or for any other reason. -- hand, or for any other reason.
-- To create the list of strings, it is recommended to use -- To create the list of strings, it is recommended to use
-- GNAT.OS_Lib.Argument_String_To_List. -- GNAT.OS_Lib.Argument_String_To_List.
......
gcc/ada/rtsfind.adb
...@@ -305,6 +305,9 @@ package body Rtsfind is ...@@ -305,6 +305,9 @@ package body Rtsfind is
elsif U_Id in Ada_Streams_Child then elsif U_Id in Ada_Streams_Child then
Name_Buffer (12) := '.'; Name_Buffer (12) := '.';
elsif U_Id in Ada_Strings_Child then
Name_Buffer (12) := '.';
elsif U_Id in Ada_Text_IO_Child then elsif U_Id in Ada_Text_IO_Child then
Name_Buffer (12) := '.'; Name_Buffer (12) := '.';
......
gcc/ada/rtsfind.ads
...@@ -61,6 +61,9 @@ package Rtsfind is ...@@ -61,6 +61,9 @@ package Rtsfind is
-- Names of the form Ada_Streams_xxx are second level children -- Names of the form Ada_Streams_xxx are second level children
-- of Ada.Streams. -- of Ada.Streams.
-- Names of the form Ada_Strings_xxx are second level children
-- of Ada.Strings.
-- Names of the form Ada_Text_IO_xxx are second level children of -- Names of the form Ada_Text_IO_xxx are second level children of
-- Ada.Text_IO. -- Ada.Text_IO.
...@@ -120,6 +123,7 @@ package Rtsfind is ...@@ -120,6 +123,7 @@ package Rtsfind is
Ada_Interrupts, Ada_Interrupts,
Ada_Real_Time, Ada_Real_Time,
Ada_Streams, Ada_Streams,
Ada_Strings,
Ada_Tags, Ada_Tags,
Ada_Task_Identification, Ada_Task_Identification,
Ada_Task_Termination, Ada_Task_Termination,
...@@ -149,6 +153,10 @@ package Rtsfind is ...@@ -149,6 +153,10 @@ package Rtsfind is
Ada_Streams_Stream_IO, Ada_Streams_Stream_IO,
-- Children of Ada.Strings
Ada_Strings_Unbounded,
-- Children of Ada.Text_IO (for Text_IO_Kludge) -- Children of Ada.Text_IO (for Text_IO_Kludge)
Ada_Text_IO_Decimal_IO, Ada_Text_IO_Decimal_IO,
...@@ -404,6 +412,11 @@ package Rtsfind is ...@@ -404,6 +412,11 @@ package Rtsfind is
subtype Ada_Streams_Child is Ada_Child subtype Ada_Streams_Child is Ada_Child
range Ada_Streams_Stream_IO .. Ada_Streams_Stream_IO; range Ada_Streams_Stream_IO .. Ada_Streams_Stream_IO;
-- Range of values for children of Ada.Streams
subtype Ada_Strings_Child is Ada_Child
range Ada_Strings_Unbounded .. Ada_Strings_Unbounded;
-- Range of values for children of Ada.Strings
subtype Ada_Text_IO_Child is Ada_Child subtype Ada_Text_IO_Child is Ada_Child
range Ada_Text_IO_Decimal_IO .. Ada_Text_IO_Modular_IO; range Ada_Text_IO_Decimal_IO .. Ada_Text_IO_Modular_IO;
...@@ -530,6 +543,8 @@ package Rtsfind is ...@@ -530,6 +543,8 @@ package Rtsfind is
RE_Stream_Access, -- Ada.Streams.Stream_IO RE_Stream_Access, -- Ada.Streams.Stream_IO
RE_Unbounded_String, -- Ada.Strings.Unbounded
RE_Access_Level, -- Ada.Tags RE_Access_Level, -- Ada.Tags
RE_Address_Array, -- Ada.Tags RE_Address_Array, -- Ada.Tags
RE_Addr_Ptr, -- Ada.Tags RE_Addr_Ptr, -- Ada.Tags
...@@ -1226,6 +1241,7 @@ package Rtsfind is ...@@ -1226,6 +1241,7 @@ package Rtsfind is
RE_TA_WWC, -- System.Partition_Interface RE_TA_WWC, -- System.Partition_Interface
RE_TA_String, -- System.Partition_Interface RE_TA_String, -- System.Partition_Interface
RE_TA_ObjRef, -- System.Partition_Interface RE_TA_ObjRef, -- System.Partition_Interface
RE_TA_Std_String, -- System.Partition_Interface
RE_TA_TC, -- System.Partition_Interface RE_TA_TC, -- System.Partition_Interface
RE_TC_Alias, -- System.Partition_Interface RE_TC_Alias, -- System.Partition_Interface
...@@ -1693,6 +1709,8 @@ package Rtsfind is ...@@ -1693,6 +1709,8 @@ package Rtsfind is
RE_Stream_Access => Ada_Streams_Stream_IO, RE_Stream_Access => Ada_Streams_Stream_IO,
RE_Unbounded_String => Ada_Strings_Unbounded,
RE_Access_Level => Ada_Tags, RE_Access_Level => Ada_Tags,
RE_Address_Array => Ada_Tags, RE_Address_Array => Ada_Tags,
RE_Addr_Ptr => Ada_Tags, RE_Addr_Ptr => Ada_Tags,
...@@ -2380,6 +2398,7 @@ package Rtsfind is ...@@ -2380,6 +2398,7 @@ package Rtsfind is
RE_TA_WWC => System_Partition_Interface, RE_TA_WWC => System_Partition_Interface,
RE_TA_String => System_Partition_Interface, RE_TA_String => System_Partition_Interface,
RE_TA_ObjRef => System_Partition_Interface, RE_TA_ObjRef => System_Partition_Interface,
RE_TA_Std_String => System_Partition_Interface,
RE_TA_TC => System_Partition_Interface, RE_TA_TC => System_Partition_Interface,
RE_TC_Alias => System_Partition_Interface, RE_TC_Alias => System_Partition_Interface,
......
gcc/ada/sem_aggr.adb
...@@ -3156,11 +3156,7 @@ package body Sem_Aggr is ...@@ -3156,11 +3156,7 @@ package body Sem_Aggr is
end loop; end loop;
else else
-- We take the underlying type to account for private types when Record_Def := Type_Definition (Parent (Base_Type (Typ)));
-- the original association had a box default.
Record_Def :=
Type_Definition (Parent (Underlying_Type (Base_Type (Typ))));
if Null_Present (Record_Def) then if Null_Present (Record_Def) then
null; null;
...@@ -3317,6 +3313,7 @@ package body Sem_Aggr is ...@@ -3317,6 +3313,7 @@ package body Sem_Aggr is
then then
if Is_Record_Type (Ctyp) if Is_Record_Type (Ctyp)
and then Has_Discriminants (Ctyp) and then Has_Discriminants (Ctyp)
and then not Is_Private_Type (Ctyp)
then then
-- We build a partially initialized aggregate with the -- We build a partially initialized aggregate with the
-- values of the discriminants and box initialization -- values of the discriminants and box initialization
...@@ -3325,6 +3322,9 @@ package body Sem_Aggr is ...@@ -3325,6 +3322,9 @@ package body Sem_Aggr is
-- the component. The capture of discriminants must -- the component. The capture of discriminants must
-- be recursive because subcomponents may be contrained -- be recursive because subcomponents may be contrained
-- (transitively) by discriminants of enclosing types. -- (transitively) by discriminants of enclosing types.
-- For a private type with discriminants, a call to the
-- initialization procedure will be generated, and no
-- subaggregate is needed.
Capture_Discriminants : declare Capture_Discriminants : declare
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
......
gcc/ada/xoscons.adb
...@@ -30,7 +30,7 @@ ...@@ -30,7 +30,7 @@
-- - the preprocessed C file: s-oscons-tmplt.i -- - the preprocessed C file: s-oscons-tmplt.i
-- - the generated assembly file: s-oscons-tmplt.s -- - the generated assembly file: s-oscons-tmplt.s
-- The contents of s-oscons.ads is written on standard output. -- The contents of s-oscons.ads is written on standard output
with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Exceptions; use Ada.Exceptions; with Ada.Exceptions; use Ada.Exceptions;
......
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