Skip to content

R
riscv-gcc-1
Commit 66713d62 by Arnaud Charlet
Options

[multiple changes] 

2009-04-29  Bob Duff  <duff@adacore.com>

	* exp_ch7.adb (Build_Final_List): For an access type that designates a
	Taft Amendment type, if the access type needs finalization, make sure
	the implicit with clause for List_Controller occurs on the package spec.

	* rtsfind.adb (Text_IO_Kludge): Fine tune the creation of implicit
	with's created for the pseudo-children of Text_IO and friends. In
	particular, avoid cycles, such as Ada.Wide_Text_IO.Integer_IO and
	Ada.Text_IO.Integer_IO both with-ing each other.

	* sem.adb (Walk_Library_Items): Suppress assertion failure in certain
	oddball cases when pragma Extend_System is used.

	* sem_ch12.adb (Get_Associated_Node): Prevent direct 'with' cycles in
	the case where a package spec instantiates a generic whose body with's
	this package, so Walk_Library_Items won't complain about cyclic with's.

2009-04-29  Emmanuel Briot  <briot@adacore.com>

	* gnatcmd.adb, prj-proc.adb, make.adb, mlib-prj.adb, prj.adb, prj.ads,
	prj-pp.adb, prj-pp.ads, makeutl.adb, clean.adb, prj-nmsc.adb,
	mlib-tgt.adb, mlib-tgt.ads, prj-util.adb, prj-env.adb, prj-env.ads
	(Project_Id): now a real pointer to Project_Data, instead of an index
	into the Projects_Table. This simplifies the API significantly, avoiding
	extra lookups in this table and the need to pass the Project_Tree_Ref
	parameter in several cases

From-SVN: r146931
parent 059caa3e
Showing with 165 additions and 77 deletions
gcc/ada/ChangeLog
2009-04-29 Bob Duff <duff@adacore.com>
* exp_ch7.adb (Build_Final_List): For an access type that designates a
Taft Amendment type, if the access type needs finalization, make sure
the implicit with clause for List_Controller occurs on the package spec.
* rtsfind.adb (Text_IO_Kludge): Fine tune the creation of implicit
with's created for the pseudo-children of Text_IO and friends. In
particular, avoid cycles, such as Ada.Wide_Text_IO.Integer_IO and
Ada.Text_IO.Integer_IO both with-ing each other.
* sem.adb (Walk_Library_Items): Suppress assertion failure in certain
oddball cases when pragma Extend_System is used.
* sem_ch12.adb (Get_Associated_Node): Prevent direct 'with' cycles in
the case where a package spec instantiates a generic whose body with's
this package, so Walk_Library_Items won't complain about cyclic with's.
2009-04-29 Emmanuel Briot <briot@adacore.com>
* gnatcmd.adb, prj-proc.adb, make.adb, mlib-prj.adb, prj.adb, prj.ads,
prj-pp.adb, prj-pp.ads, makeutl.adb, clean.adb, prj-nmsc.adb,
mlib-tgt.adb, mlib-tgt.ads, prj-util.adb, prj-env.adb, prj-env.ads
(Project_Id): now a real pointer to Project_Data, instead of an index
into the Projects_Table. This simplifies the API significantly, avoiding
extra lookups in this table and the need to pass the Project_Tree_Ref
parameter in several cases
2009-04-29 Nicolas Setton <setton@adacore.com>
* gcc-interface/Makefile.in: Produce .dSYM files for shared libs on
......
gcc/ada/exp_ch7.adb
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -442,6 +442,37 @@ package body Exp_Ch7 is
New_Reference_To
(RTE (RE_List_Controller), Loc));
if Has_Completion_In_Body (Directly_Designated_Type (Typ))
and then In_Package_Body (Current_Scope)
and then
Nkind (Parent (Declaration_Node (Typ))) = N_Package_Specification
then
-- The type is declared in a package declaration and designates a
-- Taft amendment type that requires finalization. In general we
-- assume that TA types are controlled, but we inhibit this
-- worst-case assumption for runtime files, for efficiency reasons
-- (see exp_ch3.adb). The reference to RE_List_Controller may have
-- added a with_clause to the current body. Formally the spec needs
-- the with_clause as well, so we add it now, for use by codepeer.
declare
Loc : constant Source_Ptr := Sloc (Typ);
Spec_Unit : constant Node_Id :=
Library_Unit (Cunit (Current_Sem_Unit));
List_Scope : constant Entity_Id :=
Scope (RTE (RE_List_Controller));
With_Clause : constant Node_Id :=
Make_With_Clause (Loc,
Name => New_Occurrence_Of (List_Scope, Loc));
begin
Set_Library_Unit
(With_Clause, Parent (Unit_Declaration_Node (List_Scope)));
Set_Corresponding_Spec (With_Clause, List_Scope);
Set_Implicit_With (With_Clause);
Append (With_Clause, Context_Items (Spec_Unit));
end;
end if;
-- The type may have been frozen already, and this is a late freezing
-- action, in which case the declaration must be elaborated at once.
-- If the call is for an allocator, the chain must also be created now,
......
gcc/ada/makeutl.adb
......@@ -373,7 +373,6 @@ package body Makeutl is
procedure Recursive_Add (Proj : Project_Id; Dummy : in out Boolean) is
pragma Unreferenced (Dummy);
Data : Project_Data renames In_Tree.Projects.Table (Proj);
Linker_Package : Package_Id;
Options : Variable_Value;
......@@ -381,7 +380,7 @@ package body Makeutl is
Linker_Package :=
Prj.Util.Value_Of
(Name => Name_Linker,
In_Packages => Data.Decl.Packages,
In_Packages => Proj.Decl.Packages,
In_Tree => In_Tree);
Options :=
......@@ -412,20 +411,21 @@ package body Makeutl is
begin
Linker_Opts.Init;
For_All_Projects (Project, In_Tree, Dummy, Imported_First => True);
For_All_Projects (Project, Dummy, Imported_First => True);
Last_Linker_Option := 0;
for Index in reverse 1 .. Linker_Opts.Last loop
declare
Options : String_List_Id := Linker_Opts.Table (Index).Options;
Options : String_List_Id;
Proj : constant Project_Id :=
Linker_Opts.Table (Index).Project;
Option : Name_Id;
Dir_Path : constant String :=
Get_Name_String (In_Tree.Projects.Table (Proj).Directory.Name);
Get_Name_String (Proj.Directory.Name);
begin
Options := Linker_Opts.Table (Index).Options;
while Options /= Nil_String loop
Option := In_Tree.String_Elements.Table (Options).Value;
Get_Name_String (Option);
......@@ -444,8 +444,7 @@ package body Makeutl is
Including_L_Switch => True);
end if;
Options :=
In_Tree.String_Elements.Table (Options).Next;
Options := In_Tree.String_Elements.Table (Options).Next;
end loop;
end;
end loop;
......
gcc/ada/mlib-tgt.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2008, AdaCore --
-- Copyright (C) 2001-2009, AdaCore --
-- --
-- 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- --
......@@ -330,8 +330,9 @@ package body MLib.Tgt is
function Library_Exists_For_Default
(Project : Project_Id; In_Tree : Project_Tree_Ref) return Boolean
is
pragma Unreferenced (In_Tree);
begin
if not In_Tree.Projects.Table (Project).Library then
if not Project.Library then
Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " &
"for non library project");
return False;
......@@ -339,14 +340,12 @@ package body MLib.Tgt is
else
declare
Lib_Dir : constant String :=
Get_Name_String
(In_Tree.Projects.Table (Project).Library_Dir.Name);
Get_Name_String (Project.Library_Dir.Name);
Lib_Name : constant String :=
Get_Name_String
(In_Tree.Projects.Table (Project).Library_Name);
Get_Name_String (Project.Library_Name);
begin
if In_Tree.Projects.Table (Project).Library_Kind = Static then
if Project.Library_Kind = Static then
return Is_Regular_File
(Lib_Dir & Directory_Separator & "lib" &
Fil.Append_To (Lib_Name, Archive_Ext));
......@@ -380,8 +379,9 @@ package body MLib.Tgt is
(Project : Project_Id;
In_Tree : Project_Tree_Ref) return File_Name_Type
is
pragma Unreferenced (In_Tree);
begin
if not In_Tree.Projects.Table (Project).Library then
if not Project.Library then
Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
"for non library project");
return No_File;
......@@ -389,11 +389,10 @@ package body MLib.Tgt is
else
declare
Lib_Name : constant String :=
Get_Name_String
(In_Tree.Projects.Table (Project).Library_Name);
Get_Name_String (Project.Library_Name);
begin
if In_Tree.Projects.Table (Project).Library_Kind =
if Project.Library_Kind =
Static
then
Name_Len := 3;
......
gcc/ada/mlib-tgt.ads
......@@ -238,8 +238,7 @@ private
Library_Exists_For_Default'Access;
function Library_File_Name_For_Default
(Project : Project_Id;
In_Tree : Project_Tree_Ref) return File_Name_Type;
(Project : Project_Id; In_Tree : Project_Tree_Ref) return File_Name_Type;
Library_File_Name_For_Ptr : Library_File_Name_For_Function :=
Library_File_Name_For_Default'Access;
......
gcc/ada/prj-env.ads
......@@ -166,9 +166,7 @@ package Prj.Env is
generic
with procedure Action (Path : String);
procedure For_All_Object_Dirs
(Project : Project_Id;
In_Tree : Project_Tree_Ref);
procedure For_All_Object_Dirs (Project : Project_Id);
-- Iterate through all the object directories of a project, including
-- those of imported or modified projects.
......
gcc/ada/prj-nmsc.adb
This source diff could not be displayed because it is too large. You can view the blob instead.
gcc/ada/prj-pp.adb
......@@ -74,8 +74,7 @@ package body Prj.PP is
W_Eol : Write_Eol_Ap := null;
W_Str : Write_Str_Ap := null;
Backward_Compatibility : Boolean;
Id : Prj.Project_Id := Prj.No_Project;
Id_Tree : Prj.Project_Tree_Ref := null)
Id : Prj.Project_Id := Prj.No_Project)
is
procedure Print (Node : Project_Node_Id; Indent : Natural);
-- A recursive procedure that traverses a project file tree and outputs
......@@ -339,7 +338,7 @@ package body Prj.PP is
Write_String ("project ");
if Id /= Prj.No_Project then
Output_Name (Id_Tree.Projects.Table (Id).Display_Name);
Output_Name (Id.Display_Name);
else
Output_Name (Name_Of (Node, In_Tree));
end if;
......@@ -372,7 +371,7 @@ package body Prj.PP is
Write_String ("end ");
if Id /= Prj.No_Project then
Output_Name (Id_Tree.Projects.Table (Id).Display_Name);
Output_Name (Id.Display_Name);
else
Output_Name (Name_Of (Node, In_Tree));
end if;
......
gcc/ada/prj-pp.ads
......@@ -53,8 +53,7 @@ package Prj.PP is
W_Eol : Write_Eol_Ap := null;
W_Str : Write_Str_Ap := null;
Backward_Compatibility : Boolean;
Id : Prj.Project_Id := Prj.No_Project;
Id_Tree : Prj.Project_Tree_Ref := null);
Id : Prj.Project_Id := Prj.No_Project);
-- Output a project file, using either the default output routines, or the
-- ones specified by W_Char, W_Eol and W_Str.
--
......
gcc/ada/prj-util.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2008, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2009, 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- --
......@@ -114,8 +114,7 @@ package body Prj.Util is
is
pragma Assert (Project /= No_Project);
The_Packages : constant Package_Id :=
In_Tree.Projects.Table (Project).Decl.Packages;
The_Packages : constant Package_Id := Project.Decl.Packages;
Builder_Package : constant Prj.Package_Id :=
Prj.Util.Value_Of
......@@ -135,7 +134,7 @@ package body Prj.Util is
Executable_Suffix_Name : Name_Id := No_Name;
Naming : constant Naming_Data := In_Tree.Projects.Table (Project).Naming;
Naming : constant Naming_Data := Project.Naming;
Spec_Suffix : Name_Id := No_Name;
Body_Suffix : Name_Id := No_Name;
......@@ -188,8 +187,7 @@ package body Prj.Util is
if Builder_Package /= No_Package then
if Get_Mode = Multi_Language then
Executable_Suffix_Name :=
In_Tree.Projects.Table (Project).Config.Executable_Suffix;
Executable_Suffix_Name := Project.Config.Executable_Suffix;
else
Executable_Suffix := Prj.Util.Value_Of
......@@ -330,11 +328,9 @@ package body Prj.Util is
Result : File_Name_Type;
begin
if In_Tree.Projects.Table (Project).Config.Executable_Suffix /=
No_Name
then
if Project.Config.Executable_Suffix /= No_Name then
Executable_Extension_On_Target :=
In_Tree.Projects.Table (Project).Config.Executable_Suffix;
Project.Config.Executable_Suffix;
end if;
Result := Executable_Name (Name_Find);
......
gcc/ada/prj.ads
......@@ -160,8 +160,9 @@ package Prj is
No_Path_Information : constant Path_Information := (No_Path, No_Path);
type Project_Id is new Nat;
No_Project : constant Project_Id := 0;
type Project_Data;
type Project_Id is access Project_Data;
No_Project : constant Project_Id := null;
-- Id of a Project File
type String_List_Id is new Nat;
......@@ -323,10 +324,8 @@ package Prj is
function Hash (Name : Name_Id) return Header_Num;
function Hash (Name : File_Name_Type) return Header_Num;
function Hash (Name : Path_Name_Type) return Header_Num;
-- Used for computing hash values for names put into above hash table
function Hash (Project : Project_Id) return Header_Num;
-- Used for hash tables where Project_Id is the Key
-- Used for computing hash values for names put into above hash table
type Language_Kind is (File_Based, Unit_Based);
-- Type for the kind of language. All languages are file based, except Ada
......@@ -896,8 +895,7 @@ package Prj is
Suffix : File_Name_Type);
function Get_Object_Directory
(In_Tree : Project_Tree_Ref;
Project : Project_Id;
(Project : Project_Id;
Including_Libraries : Boolean;
Only_If_Ada : Boolean := False) return Path_Name_Type;
-- Return the object directory to use for the project. This depends on
......@@ -908,13 +906,12 @@ package Prj is
-- If Only_If_Ada is True, then No_Name will be returned when the project
-- doesn't Ada sources.
procedure Compute_All_Imported_Projects
(Project : Project_Id; In_Tree : Project_Tree_Ref);
procedure Compute_All_Imported_Projects (Project : Project_Id);
-- Compute, the list of the projects imported directly or indirectly by
-- project Project. The result is stored in Project.All_Imported_Projects
function Ultimate_Extending_Project_Of
(Proj : Project_Id; In_Tree : Project_Tree_Ref) return Project_Id;
(Proj : Project_Id) return Project_Id;
-- Returns the ultimate extending project of project Proj. If project Proj
-- is not extended, returns Proj.
......@@ -938,6 +935,14 @@ package Prj is
end record;
-- A list of projects
procedure Free_List
(List : in out Project_List;
Free_Project : Boolean;
Reset_Only : Boolean := True);
-- Free the list of projects. If Free_Project, each project is also freed.
-- When Free_Project is True, Reset_Only indicates whether the specific
-- languages should also be freed.
type Response_File_Format is
(None,
GNU,
......@@ -1317,33 +1322,24 @@ package Prj is
function Is_Extending
(Extending : Project_Id;
Extended : Project_Id;
In_Tree : Project_Tree_Ref) return Boolean;
-- ??? needs comment
Extended : Project_Id) return Boolean;
-- Return True if Extending is extending the Extended project.
function Is_A_Language
(Data : Project_Data;
(Project : Project_Id;
Language_Name : Name_Id) return Boolean;
-- Return True when Language_Name (which must be lower case) is one of the
-- languages used for the project.
function Has_Ada_Sources (Data : Project_Data) return Boolean;
function Has_Ada_Sources (Data : Project_Id) return Boolean;
-- Return True if the project has Ada sources
function Has_Foreign_Sources (Data : Project_Data) return Boolean;
function Has_Foreign_Sources (Data : Project_Id) return Boolean;
-- Return True if the project has foreign sources
Project_Error : exception;
-- Raised by some subprograms in Prj.Attr
package Project_Table is new GNAT.Dynamic_Tables (
Table_Component_Type => Project_Data,
Table_Index_Type => Project_Id,
Table_Low_Bound => 1,
Table_Initial => 100,
Table_Increment => 100);
-- The set of all project files
type Spec_Or_Body is (Specification, Body_Part);
type File_Name_Data is record
......@@ -1427,7 +1423,7 @@ package Prj is
Array_Elements : Array_Element_Table.Instance;
Arrays : Array_Table.Instance;
Packages : Package_Table.Instance;
Projects : Project_Table.Instance;
Projects : Project_List;
Units : Unit_Table.Instance;
Units_HT : Units_Htable.Instance;
Source_Paths_HT : Source_Paths_Htable.Instance;
......@@ -1486,7 +1482,6 @@ package Prj is
With_State : in out State);
procedure For_Every_Project_Imported
(By : Project_Id;
In_Tree : Project_Tree_Ref;
With_State : in out State;
Imported_First : Boolean := False);
-- Call Action for each project imported directly or indirectly by project
......@@ -1560,7 +1555,7 @@ private
type Source_Iterator is record
In_Tree : Project_Tree_Ref;
Project : Project_Id;
Project : Project_List;
All_Projects : Boolean;
-- Current project and whether we should move on to the next
......
gcc/ada/rtsfind.adb
......@@ -1396,7 +1396,7 @@ package body Rtsfind is
begin
-- Nothing to do if name is not an identifier or a selected component
-- whose selector_name is not an identifier.
-- whose selector_name is an identifier.
if Nkind (Nam) = N_Identifier then
Chrs := Chars (Nam);
......@@ -1448,8 +1448,40 @@ package body Rtsfind is
Load_RTU
(To_Load,
Use_Setting => In_Use (Cunit_Entity (U)));
Set_Is_Visible_Child_Unit
(RT_Unit_Table (To_Load).Entity);
Set_Is_Visible_Child_Unit (RT_Unit_Table (To_Load).Entity);
-- Prevent creation of an implicit 'with' from (for example)
-- Ada.Wide_Text_IO.Integer_IO to Ada.Text_IO.Integer_IO,
-- because these could create cycles. First check whether the
-- simple names match ("integer_io" = "integer_io"), and then
-- check whether the parent is indeed one of the
-- [[Wide_]Wide_]Text_IO packages.
if Chrs = Chars (Cunit_Entity (Current_Sem_Unit)) then
declare
Parent_Name : constant Unit_Name_Type
:= Get_Parent_Spec_Name (Unit_Name (Current_Sem_Unit));
begin
if Parent_Name /= No_Unit_Name then
Get_Name_String (Parent_Name);
declare
P : String renames Name_Buffer (1 .. Name_Len);
begin
if P = "ada.text_io%s"
or else P = "ada.wide_text_io%s"
or else P = "ada.wide_wide_text_io%s"
then
goto Continue;
end if;
end;
end if;
end;
end if;
-- Add an implicit with clause from the current unit to the
-- [[Wide_]Wide_]Text_IO child (if necessary).
Maybe_Add_With (RT_Unit_Table (To_Load));
end if;
......
gcc/ada/sem.adb
......@@ -1618,9 +1618,12 @@ package body Sem is
Write_Unit_Info (Unit_Num, Item, Withs => True);
end if;
-- Main unit should come last
-- Main unit should come last (except in the case where we
-- skipped System_Aux_Id, in which case we missed the things it
-- depends on).
pragma Assert (not Done (Main_Unit));
pragma Assert
(not Done (Main_Unit) or else Present (System_Aux_Id));
-- We shouldn't do the same thing twice
......
gcc/ada/sem_ch12.adb
......@@ -634,8 +634,8 @@ package body Sem_Ch12 is
-- loaded. In that case a missing body is acceptable.
procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id);
-- Add the context clause of the unit containing a generic unit to an
-- instantiation that is a compilation unit.
-- Add the context clause of the unit containing a generic unit to a
-- compilation unit that is, or contains, an instantiation.
function Get_Associated_Node (N : Node_Id) return Node_Id;
-- In order to propagate semantic information back from the analyzed copy
......@@ -6935,9 +6935,19 @@ package body Sem_Ch12 is
Item := First (Context_Items (Parent (Gen_Decl)));
while Present (Item) loop
if Nkind (Item) = N_With_Clause then
New_I := New_Copy (Item);
Set_Implicit_With (New_I, True);
Append (New_I, Current_Context);
-- Take care to prevent direct cyclic with's, which can happen
-- if the generic body with's the current unit. Such a case
-- would result in binder errors (or run-time errors if the
-- -gnatE switch is in effect), but we want to prevent it here,
-- because Sem.Walk_Library_Items doesn't like cycles. Note
-- that we don't bother to detect indirect cycles.
if Library_Unit (Item) /= Current_Unit then
New_I := New_Copy (Item);
Set_Implicit_With (New_I, True);
Append (New_I, Current_Context);
end if;
end if;
Next (Item);
......
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