git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[multiple changes] 

2009-07-28  Emmanuel Briot  <briot@adacore.com>

	* prj.adb, prj.ads (Compute_All_Imported_Projects): Make sure the
	importing project does not end up in the list, in the case of extending
	projects.
	* make.adb, makeutl.adb, makeutl.ads (File_Not_A_Source_Of): Moved to
	makeutl.ads, for better sharing with gprbuild.

2009-07-28  Arnaud Charlet  <charlet@adacore.com>

	* gnat_ugn.texi: Fix typo.

2009-07-28  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Build_Derived_Concurrent_Type): Handle properly a
	derivation that renames some discriminants and constrain others.
	* exp_ch9.adb (Build_Protected_Subprogram_Call): If the type of the
	prefix is a derived untagged type, convert to the root type to conform
	to the signature of the protected operations.

2009-07-28  Robert Dewar  <dewar@adacore.com>

	* sinfo.ads: Update comments.
	* exp_attr.adb: Minor reformatting

From-SVN: r150152
This commit is contained in:
Arnaud Charlet 2009-07-28 11:25:52 +02:00
parent 55603e5ee2
commit f7e71125e2
10 changed files with 344 additions and 159 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
gcc/ada/ChangeLog
View File

@ -1,3 +1,28 @@
2009-07-28 Emmanuel Briot <briot@adacore.com>
* prj.adb, prj.ads (Compute_All_Imported_Projects): Make sure the
importing project does not end up in the list, in the case of extending
projects.
* make.adb, makeutl.adb, makeutl.ads (File_Not_A_Source_Of): Moved to
makeutl.ads, for better sharing with gprbuild.
2009-07-28 Arnaud Charlet <charlet@adacore.com>
* gnat_ugn.texi: Fix typo.
2009-07-28 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Build_Derived_Concurrent_Type): Handle properly a
derivation that renames some discriminants and constrain others.
* exp_ch9.adb (Build_Protected_Subprogram_Call): If the type of the
prefix is a derived untagged type, convert to the root type to conform
to the signature of the protected operations.
2009-07-28 Robert Dewar <dewar@adacore.com>
* sinfo.ads: Update comments.
* exp_attr.adb: Minor reformatting
2009-07-28 Ed Schonberg <schonberg@adacore.com>
* sem_aggr.adb (Get_Value): A named association in a record aggregate

12
gcc/ada/exp_attr.adb
View File

@ -358,7 +358,7 @@ package body Exp_Attr is
Sub_Ref :=
Make_Attribute_Reference (Loc,
Prefix => Sub,
Prefix => Sub,
Attribute_Name => Name_Access);
-- We set the type of the access reference to the already generated
@ -370,17 +370,13 @@ package body Exp_Attr is
Agg :=
Make_Aggregate (Loc,
Expressions =>
New_List (
Obj_Ref, Sub_Ref));
Expressions => New_List (Obj_Ref, Sub_Ref));
Rewrite (N, Agg);
Analyze_And_Resolve (N, E_T);
-- For subsequent analysis, the node must retain its type.
-- The backend will replace it with the equivalent type where
-- needed.
-- For subsequent analysis, the node must retain its type. The backend
-- will replace it with the equivalent type where needed.
Set_Etype (N, Typ);
end Expand_Access_To_Protected_Op;

16
gcc/ada/exp_ch9.adb
View File

@ -3193,6 +3193,18 @@ package body Exp_Ch9 is
Params := New_List;
end if;
-- If the type is an untagged derived type, convert to the root type,
-- which is the one on which the operations are defined.
if Nkind (Rec) = N_Unchecked_Type_Conversion
and then not Is_Tagged_Type (Etype (Rec))
and then Is_Derived_Type (Etype (Rec))
then
Set_Etype (Rec, Root_Type (Etype (Rec)));
Set_Subtype_Mark (Rec,
New_Occurrence_Of (Root_Type (Etype (Rec)), Sloc (N)));
end if;
Prepend (Rec, Params);
if Ekind (Sub) = E_Procedure then
@ -4358,8 +4370,8 @@ package body Exp_Ch9 is
return N;
else
return
Unchecked_Convert_To (Corresponding_Record_Type (Typ),
New_Copy_Tree (N));
Unchecked_Convert_To
(Corresponding_Record_Type (Typ), New_Copy_Tree (N));
end if;
end Convert_Concurrent;

97
gcc/ada/make.adb
View File

@ -557,25 +557,6 @@ package body Make is
procedure List_Bad_Compilations;
-- Prints out the list of all files for which the compilation failed
procedure Verbose_Msg
(N1 : Name_Id;
S1 : String;
N2 : Name_Id := No_Name;
S2 : String := "";
Prefix : String := " -> ";
Minimum_Verbosity : Verbosity_Level_Type := Opt.Low);
procedure Verbose_Msg
(N1 : File_Name_Type;
S1 : String;
N2 : File_Name_Type := No_File;
S2 : String := "";
Prefix : String := " -> ";
Minimum_Verbosity : Verbosity_Level_Type := Opt.Low);
-- If the verbose flag (Verbose_Mode) is set and the verbosity level is
-- at least equal to Minimum_Verbosity, then print Prefix to standard
-- output followed by N1 and S1. If N2 /= No_Name then N2 is printed after
-- S1. S2 is printed last. Both N1 and N2 are printed in quotation marks.
Usage_Needed : Boolean := True;
-- Flag used to make sure Makeusg is call at most once
@ -1434,10 +1415,6 @@ package body Make is
O_File : out File_Name_Type;
O_Stamp : out Time_Stamp_Type)
is
function File_Not_A_Source_Of
(Uname : Name_Id;
Sfile : File_Name_Type) return Boolean;
function First_New_Spec (A : ALI_Id) return File_Name_Type;
-- Looks in the with table entries of A and returns the spec file name
-- of the first withed unit (subprogram) for which no spec existed when
@ -1452,34 +1429,6 @@ package body Make is
-- services, but this causes the whole compiler to be dragged along
-- for gnatbind and gnatmake.
--------------------------
-- File_Not_A_Source_Of --
--------------------------
function File_Not_A_Source_Of
(Uname : Name_Id;
Sfile : File_Name_Type) return Boolean
is
UID : Prj.Unit_Index;
begin
UID := Units_Htable.Get (Project_Tree.Units_HT, Uname);
if UID /= Prj.No_Unit_Index then
if (UID.File_Names (Impl) = null
or else UID.File_Names (Impl).File /= Sfile)
and then
(UID.File_Names (Spec) = null
or else UID.File_Names (Spec).File /= Sfile)
then
Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile));
return True;
end if;
end if;
return False;
end File_Not_A_Source_Of;
--------------------
-- First_New_Spec --
--------------------
@ -8240,52 +8189,6 @@ package body Make is
end if;
end Usage;
-----------------
-- Verbose_Msg --
-----------------
procedure Verbose_Msg
(N1 : Name_Id;
S1 : String;
N2 : Name_Id := No_Name;
S2 : String := "";
Prefix : String := " -> ";
Minimum_Verbosity : Verbosity_Level_Type := Opt.Low)
is
begin
if (not Verbose_Mode) or else (Minimum_Verbosity > Verbosity_Level) then
return;
end if;
Write_Str (Prefix);
Write_Str ("""");
Write_Name (N1);
Write_Str (""" ");
Write_Str (S1);
if N2 /= No_Name then
Write_Str (" """);
Write_Name (N2);
Write_Str (""" ");
end if;
Write_Str (S2);
Write_Eol;
end Verbose_Msg;
procedure Verbose_Msg
(N1 : File_Name_Type;
S1 : String;
N2 : File_Name_Type := No_File;
S2 : String := "";
Prefix : String := " -> ";
Minimum_Verbosity : Verbosity_Level_Type := Opt.Low)
is
begin
Verbose_Msg
(Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity);
end Verbose_Msg;
begin
-- Make sure that in case of failure, the temp files will be deleted

90
gcc/ada/makeutl.adb
View File

@ -26,6 +26,7 @@
with Debug;
with Osint; use Osint;
with Output; use Output;
with Opt; use Opt;
with Prj.Ext;
with Prj.Util;
with Snames; use Snames;
@ -264,6 +265,47 @@ package body Makeutl is
end;
end Executable_Prefix_Path;
--------------------------
-- File_Not_A_Source_Of --
--------------------------
function File_Not_A_Source_Of
(Uname : Name_Id;
Sfile : File_Name_Type) return Boolean
is
Unit : constant Unit_Index :=
Units_Htable.Get (Project_Tree.Units_HT, Uname);
At_Least_One_File : Boolean := False;
begin
if Unit /= No_Unit_Index then
for F in Unit.File_Names'Range loop
if Unit.File_Names (F) /= null then
At_Least_One_File := True;
if Unit.File_Names (F).File = Sfile then
return False;
end if;
end if;
end loop;
if not At_Least_One_File then
-- The unit was probably created initially for a separate unit
-- (which are initially created as IMPL when both suffixes are the
-- same). Later on, Override_Kind changed the type of the file,
-- and the unit is no longer valid in fact.
return False;
end if;
Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile));
return True;
end if;
return False;
end File_Not_A_Source_Of;
----------
-- Hash --
----------
@ -749,4 +791,52 @@ package body Makeutl is
return Result;
end Unit_Index_Of;
-----------------
-- Verbose_Msg --
-----------------
procedure Verbose_Msg
(N1 : Name_Id;
S1 : String;
N2 : Name_Id := No_Name;
S2 : String := "";
Prefix : String := " -> ";
Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
is
begin
if not Opt.Verbose_Mode
or else Minimum_Verbosity > Opt.Verbosity_Level
then
return;
end if;
Write_Str (Prefix);
Write_Str ("""");
Write_Name (N1);
Write_Str (""" ");
Write_Str (S1);
if N2 /= No_Name then
Write_Str (" """);
Write_Name (N2);
Write_Str (""" ");
end if;
Write_Str (S2);
Write_Eol;
end Verbose_Msg;
procedure Verbose_Msg
(N1 : File_Name_Type;
S1 : String;
N2 : File_Name_Type := No_File;
S2 : String := "";
Prefix : String := " -> ";
Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
is
begin
Verbose_Msg
(Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity);
end Verbose_Msg;
end Makeutl;

27
gcc/ada/makeutl.ads
View File

@ -24,6 +24,7 @@
------------------------------------------------------------------------------
with Namet; use Namet;
with Opt;
with Osint;
with Prj; use Prj;
with Types; use Types;
@ -69,6 +70,13 @@ package Makeutl is
procedure Inform (N : File_Name_Type; Msg : String);
-- Prints out the program name followed by a colon, N and S
function File_Not_A_Source_Of
(Uname : Name_Id;
Sfile : File_Name_Type) return Boolean;
-- Check that file name Sfile is one of the source of unit Uname.
-- Returns True if the unit is in one of the project file, but the file
-- name is not one of its source. Returns False otherwise.
function Is_External_Assignment (Argv : String) return Boolean;
-- Verify that an external assignment switch is syntactically correct
--
@ -82,6 +90,25 @@ package Makeutl is
-- been entered by a call to Prj.Ext.Add, so that in a project
-- file, External ("name") will return "value".
procedure Verbose_Msg
(N1 : Name_Id;
S1 : String;
N2 : Name_Id := No_Name;
S2 : String := "";
Prefix : String := " -> ";
Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low);
procedure Verbose_Msg
(N1 : File_Name_Type;
S1 : String;
N2 : File_Name_Type := No_File;
S2 : String := "";
Prefix : String := " -> ";
Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low);
-- If the verbose flag (Verbose_Mode) is set and the verbosity level is
-- at least equal to Minimum_Verbosity, then print Prefix to standard
-- output followed by N1 and S1. If N2 /= No_Name then N2 is printed after
-- S1. S2 is printed last. Both N1 and N2 are printed in quotation marks.
function Linker_Options_Switches
(Project : Project_Id;
In_Tree : Project_Tree_Ref) return String_List;

4
gcc/ada/prj.adb
View File

@ -1069,8 +1069,8 @@ package body Prj is
begin
-- A project is not importing itself
if Project /= Prj then
Prj2 := Ultimate_Extending_Project_Of (Prj);
Prj2 := Ultimate_Extending_Project_Of (Prj);
if Project /= Prj2 then
-- Check that the project is not already in the list. We know the
-- one passed to Recursive_Add have never been visited before, but

3
gcc/ada/prj.ads
View File

@ -1061,7 +1061,8 @@ package Prj is
-- The list of all directly imported projects, if any
All_Imported_Projects : Project_List;
-- The list of all projects imported directly or indirectly, if any
-- The list of all projects imported directly or indirectly, if any.
-- This does not include the project itself.
-----------------
-- Directories --

212
gcc/ada/sem_ch3.adb
View File

@ -4826,17 +4826,72 @@ package body Sem_Ch3 is
Parent_Type : Entity_Id;
Derived_Type : Entity_Id)
is
D_Constraint : Node_Id;
Disc_Spec : Node_Id;
Old_Disc : Entity_Id;
New_Disc : Entity_Id;
Loc : constant Source_Ptr := Sloc (N);
Constraint_Present : constant Boolean :=
Nkind (Subtype_Indication (Type_Definition (N)))
= N_Subtype_Indication;
Corr_Record : constant Entity_Id
:= Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
Corr_Decl : Node_Id;
Corr_Decl_Needed : Boolean;
-- If the derived type has fewer discriminants than its parent,
-- the corresponding record is also a derived type, in order to
-- account for the bound discriminants. We create a full type
-- declaration for it in this case.
Constraint_Present : constant Boolean
:= Nkind (Subtype_Indication (Type_Definition (N)))
= N_Subtype_Indication;
D_Constraint : Node_Id;
New_Constraint : Elist_Id;
Old_Disc : Entity_Id;
New_Disc : Entity_Id;
New_N : Node_Id;
begin
Set_Stored_Constraint (Derived_Type, No_Elist);
Corr_Decl_Needed := False;
Old_Disc := Empty;
if Present (Discriminant_Specifications (N))
and then Constraint_Present
then
Old_Disc := First_Discriminant (Parent_Type);
New_Disc := First (Discriminant_Specifications (N));
while Present (New_Disc) and then Present (Old_Disc) loop
Next_Discriminant (Old_Disc);
Next (New_Disc);
end loop;
end if;
if Present (Old_Disc) then
-- The new type has fewer discriminants, so we need to create a new
-- corresponding record, which is derived from the corresponding
-- record of the parent, and has a stored constraint that
-- captures the values of the discriminant constraints.
-- The type declaration for the derived corresponding record has
-- the same discriminant part and constraints as the current
-- declaration. Copy the unanalyzed tree to build declaration.
Corr_Decl_Needed := True;
New_N := Copy_Separate_Tree (N);
Corr_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Corr_Record,
Discriminant_Specifications =>
Discriminant_Specifications (New_N),
Type_Definition =>
Make_Derived_Type_Definition (Loc,
Subtype_Indication =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of
(Corresponding_Record_Type (Parent_Type), Loc),
Constraint =>
Constraint
(Subtype_Indication (Type_Definition (New_N))))));
end if;
-- Copy Storage_Size and Relative_Deadline variables if task case
@ -4850,6 +4905,16 @@ package body Sem_Ch3 is
if Present (Discriminant_Specifications (N)) then
Push_Scope (Derived_Type);
Check_Or_Process_Discriminants (N, Derived_Type);
if Constraint_Present then
New_Constraint :=
Expand_To_Stored_Constraint
(Parent_Type,
Build_Discriminant_Constraints
(Parent_Type,
Subtype_Indication (Type_Definition (N)), True));
end if;
End_Scope;
elsif Constraint_Present then
@ -4880,9 +4945,9 @@ package body Sem_Ch3 is
end;
end if;
-- All attributes are inherited from parent. In particular,
-- entries and the corresponding record type are the same.
-- Discriminants may be renamed, and must be treated separately.
-- By default, operations and private data are inherited from parent.
-- However, in the presence of bound discriminants, a new corresponding
-- record will be created, see below.
Set_Has_Discriminants
(Derived_Type, Has_Discriminants (Parent_Type));
@ -4910,44 +4975,99 @@ package body Sem_Ch3 is
(Constraints
(Constraint (Subtype_Indication (Type_Definition (N)))));
Old_Disc := First_Discriminant (Parent_Type);
New_Disc := First_Discriminant (Derived_Type);
Disc_Spec := First (Discriminant_Specifications (N));
while Present (Old_Disc) and then Present (Disc_Spec) loop
if Nkind (Discriminant_Type (Disc_Spec)) /=
N_Access_Definition
then
Analyze (Discriminant_Type (Disc_Spec));
Old_Disc := First_Discriminant (Parent_Type);
if not Subtypes_Statically_Compatible (
Etype (Discriminant_Type (Disc_Spec)),
Etype (Old_Disc))
then
Error_Msg_N
("not statically compatible with parent discriminant",
Discriminant_Type (Disc_Spec));
while Present (D_Constraint) loop
if Nkind (D_Constraint) /= N_Discriminant_Association then
-- Positional constraint. If it is a reference to a
-- new discriminant, it constrains the corresponding
-- old one.
if Nkind (D_Constraint) = N_Identifier then
New_Disc := First_Discriminant (Derived_Type);
while Present (New_Disc) loop
exit when
Chars (New_Disc) = Chars (D_Constraint);
Next_Discriminant (New_Disc);
end loop;
if Present (New_Disc) then
Set_Corresponding_Discriminant (New_Disc, Old_Disc);
end if;
end if;
Next_Discriminant (Old_Disc);
-- if this is a named constraint, search by name for the
-- old discriminants constrained by the new one.
elsif Nkind (Expression (D_Constraint)) = N_Identifier then
-- Find new discriminant with that name.
New_Disc := First_Discriminant (Derived_Type);
while Present (New_Disc) loop
exit when
Chars (New_Disc) = Chars (Expression (D_Constraint));
Next_Discriminant (New_Disc);
end loop;
if Present (New_Disc) then
-- Verify that the new discriminant renames
-- some discriminant of the parent type, and
-- associate the new discriminant with an old
-- one that it renames (may be more than one).
declare
Selector : Node_Id;
begin
Selector := First (Selector_Names (D_Constraint));
while Present (Selector) loop
Old_Disc := First_Discriminant (Parent_Type);
while Present (Old_Disc) loop
exit when Chars (Old_Disc) = Chars (Selector);
Next_Discriminant (Old_Disc);
end loop;
if Present (Old_Disc) then
Set_Corresponding_Discriminant
(New_Disc, Old_Disc);
end if;
Next (Selector);
end loop;
end;
end if;
end if;
if Nkind (D_Constraint) = N_Identifier
and then Chars (D_Constraint) /=
Chars (Defining_Identifier (Disc_Spec))
then
Error_Msg_N ("new discriminants must constrain old ones",
D_Constraint);
else
Set_Corresponding_Discriminant (New_Disc, Old_Disc);
end if;
Next_Discriminant (Old_Disc);
Next_Discriminant (New_Disc);
Next (Disc_Spec);
Next (D_Constraint);
end loop;
if Present (Old_Disc) or else Present (Disc_Spec) then
Error_Msg_N ("discriminant mismatch in derivation", N);
end if;
New_Disc := First_Discriminant (Derived_Type);
while Present (New_Disc) loop
if No (Corresponding_Discriminant (New_Disc)) then
Error_Msg_NE
("new discriminant& must constraint old one",
N, New_Disc);
elsif not
Subtypes_Statically_Compatible (
Etype (New_Disc),
Etype (Corresponding_Discriminant (New_Disc)))
then
Error_Msg_NE
("& not statically compatible with parent discriminant",
N, New_Disc);
end if;
Next_Discriminant (New_Disc);
end loop;
end if;
elsif Present (Discriminant_Specifications (N)) then
@ -4956,6 +5076,9 @@ package body Sem_Ch3 is
N);
end if;
-- The entity chain of the derived type includes the new
-- discriminants but shares operations with the parent.
if Present (Discriminant_Specifications (N)) then
Old_Disc := First_Discriminant (Parent_Type);
while Present (Old_Disc) loop
@ -4983,6 +5106,13 @@ package body Sem_Ch3 is
Set_Last_Entity (Derived_Type, Last_Entity (Parent_Type));
Set_Has_Completion (Derived_Type);
if Corr_Decl_Needed then
Set_Stored_Constraint (Derived_Type, New_Constraint);
Insert_After (N, Corr_Decl);
Analyze (Corr_Decl);
Set_Corresponding_Record_Type (Derived_Type, Corr_Record);
end if;
end Build_Derived_Concurrent_Type;
------------------------------------

17
gcc/ada/sinfo.ads
View File

@ -6850,15 +6850,16 @@ package Sinfo is
-- SCIL Nodes --
-----------------
-- SCIL nodes are special nodes added to the tree when the CodePeer mode
-- is active. They help CodePeer backend to locate nodes that require
-- special processing.
-- SCIL nodes are special nodes added to the tree when the CodePeer
-- mode is active. They help the CodePeer backend to locate nodes that
-- require special processing.
-- Where is the detailed description of what these nodes are for??? The
-- above is not sufficient. The description should be here, or perhaps
-- it could be in a new Sem_SCIL unit, with a pointer from here. But
-- right now I am afraid this documentation is missing and the purpose
-- of these nodes remains secret???
-- Major documentation on the general design of the SCIL interface, and
-- in particular detailed description of these nodes is missing and is
-- to be supplied in the future, when the design has finalized ???
-- Meanwhile these nodes should be considered in experimental form, and
-- should be ignored by all code generating back ends. ???
-- N_SCIL_Dispatch_Table_Object_Init
-- Sloc references a declaration node containing a dispatch table