OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2012-05-15  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch10.adb (Expand_With_Clause): In the context of a generic
	package declaration, a private with-clause on a child unit implies
	that the implicit with clauses on its parents are private as well.

2012-05-15  Javier Miranda  <miranda@adacore.com>

	* sem_ch6.adb (Is_Interface_Conformant): Add missing call to
	Base_Type to handle subtypes.
	* exp_ch6.adb (Expand_Call): For calls located in thunks handle
	unchecked conversions of access types found in actuals.
	* exp_disp.adb (Expand_Interface_Thunk): Add missing unchecked
	conversion to actuals whose type is an access type. Done to
	avoid reporting spurious errors.

2012-05-15  Vincent Celier  <celier@adacore.com>

	* prj-env.adb (Create_Mapping): Ignore sources that are
	suppressed (Create_Mapping_File.Process): Ditto
	* prj-nmsc.adb (Add_Source): Update to take into
	account suppressed files that may hide inherited sources.
	(Mark_Excluded_Sources): Mark excluded sources of the current
	project as suppressed.
	* prj.ads (Source_Data): New Boolean component Suppressed,
	defaulted to False

2012-05-15  Thomas Quinot  <quinot@adacore.com>

	* exp_intr.adb: Minor reformatting.

2012-05-15  Thomas Quinot  <quinot@adacore.com>

	* gnat_rm.texi: Document attribute Scalar_Storage_Order.

2012-05-15  Javier Miranda  <miranda@adacore.com>

	* exp_ch3.adb (Build_Offset_To_Top): Modify the
	expansion of the offset_to_top functions to ensure that their
	profile is conformant with the profile specified in Ada.Tags. No
	change in functionality.

2012-05-15  Eric Botcazou  <ebotcazou@adacore.com>

	* inline.adb (Subp_Info): Remove Count and Next_Nopred
	components, add Processed component and move around Next component.
	(Add_Call): Reverse meaning of Successors table to the natural one.
	(Add_Inlined_Body): Do not inline a package if it is in the main unit.
	(Add_Inlined_Subprogram): Do not add the subprogram to the list if the
	package is in the main unit. Do not recurse on the successors.
	(Add_Subp): Adjust to new contents of Subp_Info.
	(Analyze_Inlined_Bodies): Do not attempt
	to compute a topological order on the list of inlined subprograms,
	but compute the transitive closure from the main unit instead.
	(Get_Code_Unit_Entity): Always return the spec for a package.

From-SVN: r187526
This commit is contained in:
Arnaud Charlet 2012-05-15 13:07:26 +02:00
parent 8c5b2819fa
commit 8a49a499a5
12 changed files with 283 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
gcc/ada/ChangeLog
View File

@ -1,3 +1,59 @@
2012-05-15 Ed Schonberg <schonberg@adacore.com>
* sem_ch10.adb (Expand_With_Clause): In the context of a generic
package declaration, a private with-clause on a child unit implies
that the implicit with clauses on its parents are private as well.
2012-05-15 Javier Miranda <miranda@adacore.com>
* sem_ch6.adb (Is_Interface_Conformant): Add missing call to
Base_Type to handle subtypes.
* exp_ch6.adb (Expand_Call): For calls located in thunks handle
unchecked conversions of access types found in actuals.
* exp_disp.adb (Expand_Interface_Thunk): Add missing unchecked
conversion to actuals whose type is an access type. Done to
avoid reporting spurious errors.
2012-05-15 Vincent Celier <celier@adacore.com>
* prj-env.adb (Create_Mapping): Ignore sources that are
suppressed (Create_Mapping_File.Process): Ditto
* prj-nmsc.adb (Add_Source): Update to take into
account suppressed files that may hide inherited sources.
(Mark_Excluded_Sources): Mark excluded sources of the current
project as suppressed.
* prj.ads (Source_Data): New Boolean component Suppressed,
defaulted to False
2012-05-15 Thomas Quinot <quinot@adacore.com>
* exp_intr.adb: Minor reformatting.
2012-05-15 Thomas Quinot <quinot@adacore.com>
* gnat_rm.texi: Document attribute Scalar_Storage_Order.
2012-05-15 Javier Miranda <miranda@adacore.com>
* exp_ch3.adb (Build_Offset_To_Top): Modify the
expansion of the offset_to_top functions to ensure that their
profile is conformant with the profile specified in Ada.Tags. No
change in functionality.
2012-05-15 Eric Botcazou <ebotcazou@adacore.com>
* inline.adb (Subp_Info): Remove Count and Next_Nopred
components, add Processed component and move around Next component.
(Add_Call): Reverse meaning of Successors table to the natural one.
(Add_Inlined_Body): Do not inline a package if it is in the main unit.
(Add_Inlined_Subprogram): Do not add the subprogram to the list if the
package is in the main unit. Do not recurse on the successors.
(Add_Subp): Adjust to new contents of Subp_Info.
(Analyze_Inlined_Bodies): Do not attempt
to compute a topological order on the list of inlined subprograms,
but compute the transitive closure from the main unit instead.
(Get_Code_Unit_Entity): Always return the spec for a package.
2012-05-15 Yannick Moy <moy@adacore.com>
* aspects.ads: Minor addition of comments to provide info on

26
gcc/ada/exp_ch3.adb
View File

@ -1883,9 +1883,10 @@ package body Exp_Ch3 is
procedure Build_Offset_To_Top_Function (Iface_Comp : Entity_Id);
-- Generate:
-- function Fxx (O : in Rec_Typ) return Storage_Offset is
-- function Fxx (O : Address) return Storage_Offset is
-- type Acc is access all <Typ>;
-- begin
-- return O.Iface_Comp'Position;
-- return Acc!(O).Iface_Comp'Position;
-- end Fxx;
----------------------------------
@ -1896,6 +1897,7 @@ package body Exp_Ch3 is
Body_Node : Node_Id;
Func_Id : Entity_Id;
Spec_Node : Node_Id;
Acc_Type : Entity_Id;
begin
Func_Id := Make_Temporary (Loc, 'F');
@ -1912,7 +1914,7 @@ package body Exp_Ch3 is
Make_Defining_Identifier (Loc, Name_uO),
In_Present => True,
Parameter_Type =>
New_Reference_To (Rec_Type, Loc))));
New_Reference_To (RTE (RE_Address), Loc))));
Set_Result_Definition (Spec_Node,
New_Reference_To (RTE (RE_Storage_Offset), Loc));
@ -1924,7 +1926,19 @@ package body Exp_Ch3 is
Body_Node := New_Node (N_Subprogram_Body, Loc);
Set_Specification (Body_Node, Spec_Node);
Set_Declarations (Body_Node, New_List);
Acc_Type := Make_Temporary (Loc, 'T');
Set_Declarations (Body_Node, New_List (
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Acc_Type,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Null_Exclusion_Present => False,
Constant_Present => False,
Subtype_Indication =>
New_Reference_To (Rec_Type, Loc)))));
Set_Handled_Statement_Sequence (Body_Node,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
@ -1933,7 +1947,9 @@ package body Exp_Ch3 is
Make_Attribute_Reference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uO),
Prefix =>
Unchecked_Convert_To (Acc_Type,
Make_Identifier (Loc, Name_uO)),
Selector_Name =>
New_Reference_To (Iface_Comp, Loc)),
Attribute_Name => Name_Position)))));

8
gcc/ada/exp_ch6.adb
View File

@ -2711,6 +2711,14 @@ package body Exp_Ch6 is
Next_Entity (Parm_Ent);
end loop;
-- Handle unchecked conversion of access types generated
-- in thunks (cf. Expand_Interface_Thunk)
elsif Is_Access_Type (Etype (Actual))
and then Nkind (Actual) = N_Unchecked_Type_Conversion
then
Parm_Ent := Entity (Expression (Actual));
else pragma Assert (Is_Entity_Name (Actual));
Parm_Ent := Entity (Actual);
end if;

8
gcc/ada/exp_disp.adb
View File

@ -1829,6 +1829,14 @@ package body Exp_Disp is
Make_Explicit_Dereference (Loc,
New_Reference_To (Defining_Identifier (Decl_2), Loc))));
-- Ensure proper matching of access types. Required to avoid
-- reporting spurious errors.
elsif Is_Access_Type (Etype (Target_Formal)) then
Append_To (Actuals,
Unchecked_Convert_To (Base_Type (Etype (Target_Formal)),
New_Reference_To (Defining_Identifier (Formal), Loc)));
-- No special management required for this actual
else

11
gcc/ada/exp_intr.adb
View File

@ -564,16 +564,15 @@ package body Exp_Intr is
-- conventions and this has already been checked.
elsif Present (Alias (E)) then
Expand_Intrinsic_Call (N, Alias (E));
Expand_Intrinsic_Call (N, Alias (E));
elsif Nkind (N) in N_Binary_Op then
Expand_Binary_Operator_Call (N);
-- The only other case is where an external name was specified,
-- since this is the only way that an otherwise unrecognized
-- name could escape the checking in Sem_Prag. Nothing needs
-- to be done in such a case, since we pass such a call to the
-- back end unchanged.
-- The only other case is where an external name was specified, since
-- this is the only way that an otherwise unrecognized name could
-- escape the checking in Sem_Prag. Nothing needs to be done in such
-- a case, since we pass such a call to the back end unchanged.
else
null;

52
gcc/ada/gnat_rm.texi
View File

@ -272,6 +272,7 @@ Implementation Defined Attributes
* Result::
* Safe_Emax::
* Safe_Large::
* Scalar_Storage_Order::
* Simple_Storage_Pool::
* Small::
* Storage_Unit::
@ -6023,6 +6024,7 @@ consideration, you should minimize the use of these attributes.
* Result::
* Safe_Emax::
* Safe_Large::
* Scalar_Storage_Order::
* Simple_Storage_Pool::
* Small::
* Storage_Unit::
@ -6750,6 +6752,54 @@ The @code{Safe_Large} attribute is provided for compatibility with Ada 83. See
the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Scalar_Storage_Order
@unnumberedsec Scalar_Storage_Order
@cindex Endianness
@cindex Scalar storage order
@findex Scalar_Storage_Order
@noindent
For every record subtype @var{S}, the representation attribute
@code{Scalar_Storage_Order} denotes the order in which storage elements
that make up scalar components are ordered within S. Other properties are
as for standard representation attribute @code{Bit_Order}, as defined by
Ada RM 13.5.3(4). The default is @code{System.Default_Bit_Order}.
If @code{@var{S}'Scalar_Storage_Order} is specified explicitly, it shall be
equal to @code{@var{S}'Bit_Order}. Note: This means that if a
@code{Scalar_Storage_Order} attribute definition clause is not confirming,
then the type's @code{Bit_Order} shall be specified explicitly and set to
the same value.
A confirming @code{Scalar_Storage_Order} attribute definition clause (i.e.
with a value equal to @code{System.Default_Bit_Order}) has no effect.
If the opposite storage order is specified, then whenever the
value of a scalar component of S is read, the storage elements of the
enclosing machine scalar are first reversed (before retrieving the
component value, possibly applying some shift and mask operatings on the
enclosing machine scalar), and the opposite operation is done for
writes.
In that case, the restrictions set forth in 10.3/2 for scalar components
are relaxed. Instead, the following rules apply:
@itemize @bullet
@item the underlying storage elements are those at positions
@code{(position + first_bit / storage_element_size) ..
(position + (last_bit + storage_element_size - 1) /
storage_element_size)}
@item the sequence of underlying storage elements shall have
a size no greater than the largest machine scalar
@item the enclosing machine scalar is defined as the smallest machine
scalar starting at a position no greater than
@code{position + first_bit / storage_element_size} and covering
storage elements at least up to @code{position + (last_bit +
storage_element_size - 1) / storage_element_size}
@item the position of the component is interpreted relative to that machine
scalar.
@end itemize
@node Simple_Storage_Pool
@unnumberedsec Simple_Storage_Pool
@cindex Storage pool, simple
@ -15452,7 +15502,7 @@ sequences for various UCS input formats.
@section @code{GNAT.Byte_Swapping} (@file{g-bytswa.ads})
@cindex @code{GNAT.Byte_Swapping} (@file{g-bytswa.ads})
@cindex Byte swapping
@cindex Endian
@cindex Endianness
@noindent
General routines for swapping the bytes in 2-, 4-, and 8-byte quantities.

170
gcc/ada/inline.adb
View File

@ -70,15 +70,12 @@ package body Inline is
-----------------------
-- For each call to an inlined subprogram, we make entries in a table
-- that stores caller and callee, and indicates a prerequisite from
-- that stores caller and callee, and indicates the call direction from
-- one to the other. We also record the compilation unit that contains
-- the callee. After analyzing the bodies of all such compilation units,
-- we produce a list of subprograms in topological order, for use by the
-- back-end. If P2 is a prerequisite of P1, then P1 calls P2, and for
-- proper inlining the back-end must analyze the body of P2 before that of
-- P1. The code below guarantees that the transitive closure of inlined
-- subprograms called from the main compilation unit is made available to
-- the code generator.
-- we compute the transitive closure of inlined subprograms called from
-- the main compilation unit and make it available to the code generator
-- in no particular order, thus allowing cycles in the call graph.
Last_Inlined : Entity_Id := Empty;
@ -117,12 +114,11 @@ package body Inline is
type Subp_Info is record
Name : Entity_Id := Empty;
Next : Subp_Index := No_Subp;
First_Succ : Succ_Index := No_Succ;
Count : Integer := 0;
Listed : Boolean := False;
Main_Call : Boolean := False;
Next : Subp_Index := No_Subp;
Next_Nopred : Subp_Index := No_Subp;
Processed : Boolean := False;
end record;
package Inlined is new Table.Table (
@ -139,7 +135,8 @@ package body Inline is
function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id;
pragma Inline (Get_Code_Unit_Entity);
-- Return the entity node for the unit containing E
-- Return the entity node for the unit containing E. Always return
-- the spec for a package.
function Scope_In_Main_Unit (Scop : Entity_Id) return Boolean;
-- Return True if Scop is in the main unit or its spec
@ -166,9 +163,7 @@ package body Inline is
-- example, an initialization procedure).
procedure Add_Inlined_Subprogram (Index : Subp_Index);
-- Add subprogram to Inlined List once all of its predecessors have been
-- placed on the list. Decrement the count of all its successors, and
-- add them to list (recursively) if count drops to zero.
-- Add the subprogram to the list of inlined subprogram for the unit
------------------------------
-- Deferred Cleanup Actions --
@ -203,29 +198,26 @@ package body Inline is
if Present (Caller) then
P2 := Add_Subp (Caller);
-- Add P2 to the list of successors of P1, if not already there.
-- Add P1 to the list of successors of P2, if not already there.
-- Note that P2 may contain more than one call to P1, and only
-- one needs to be recorded.
J := Inlined.Table (P1).First_Succ;
J := Inlined.Table (P2).First_Succ;
while J /= No_Succ loop
if Successors.Table (J).Subp = P2 then
if Successors.Table (J).Subp = P1 then
return;
end if;
J := Successors.Table (J).Next;
end loop;
-- On exit, make a successor entry for P2
-- On exit, make a successor entry for P1
Successors.Increment_Last;
Successors.Table (Successors.Last).Subp := P2;
Successors.Table (Successors.Last).Subp := P1;
Successors.Table (Successors.Last).Next :=
Inlined.Table (P1).First_Succ;
Inlined.Table (P1).First_Succ := Successors.Last;
Inlined.Table (P2).Count := Inlined.Table (P2).Count + 1;
Inlined.Table (P2).First_Succ;
Inlined.Table (P2).First_Succ := Successors.Last;
else
Inlined.Table (P1).Main_Call := True;
end if;
@ -345,9 +337,11 @@ package body Inline is
-- or other internally generated subprogram, because in that
-- case the subprogram body appears in the same unit that
-- declares the type, and that body is visible to the back end.
-- Do not inline it either if it is in the main unit.
elsif not Is_Inlined (Pack)
and then Comes_From_Source (E)
and then not Scope_In_Main_Unit (Pack)
then
Set_Is_Inlined (Pack);
Inlined_Bodies.Increment_Last;
@ -365,8 +359,6 @@ package body Inline is
procedure Add_Inlined_Subprogram (Index : Subp_Index) is
E : constant Entity_Id := Inlined.Table (Index).Name;
Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
Succ : Succ_Index;
Subp : Subp_Index;
function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean;
-- There are various conditions under which back-end inlining cannot
@ -441,7 +433,7 @@ package body Inline is
and then (Is_Inlined (Pack)
or else Is_Generic_Instance (Pack)
or else Is_Internal (E))
and then not Scope_In_Main_Unit (E)
and then not Scope_In_Main_Unit (Pack)
and then not Is_Nested (E)
and then not Has_Initialized_Type (E)
then
@ -460,27 +452,6 @@ package body Inline is
end if;
Inlined.Table (Index).Listed := True;
-- Now add to the list those callers of the current subprogram that
-- are themselves called. They may appear on the graph as callers
-- of the current one, even if they are themselves not called, and
-- there is no point in including them in the list for the backend.
-- Furthermore, they might not even be public, in which case the
-- back-end cannot handle them at all.
Succ := Inlined.Table (Index).First_Succ;
while Succ /= No_Succ loop
Subp := Successors.Table (Succ).Subp;
Inlined.Table (Subp).Count := Inlined.Table (Subp).Count - 1;
if Inlined.Table (Subp).Count = 0
and then Is_Called (Inlined.Table (Subp).Name)
then
Add_Inlined_Subprogram (Subp);
end if;
Succ := Successors.Table (Succ).Next;
end loop;
end Add_Inlined_Subprogram;
------------------------
@ -545,12 +516,11 @@ package body Inline is
begin
Inlined.Increment_Last;
Inlined.Table (Inlined.Last).Name := E;
Inlined.Table (Inlined.Last).Next := No_Subp;
Inlined.Table (Inlined.Last).First_Succ := No_Succ;
Inlined.Table (Inlined.Last).Count := 0;
Inlined.Table (Inlined.Last).Listed := False;
Inlined.Table (Inlined.Last).Main_Call := False;
Inlined.Table (Inlined.Last).Next := No_Subp;
Inlined.Table (Inlined.Last).Next_Nopred := No_Subp;
Inlined.Table (Inlined.Last).Processed := False;
end New_Entry;
-- Start of processing for Add_Subp
@ -589,8 +559,20 @@ package body Inline is
Comp_Unit : Node_Id;
J : Int;
Pack : Entity_Id;
Subp : Subp_Index;
S : Succ_Index;
type Pending_Index is new Nat;
package Pending_Inlined is new Table.Table (
Table_Component_Type => Subp_Index,
Table_Index_Type => Pending_Index,
Table_Low_Bound => 1,
Table_Initial => Alloc.Inlined_Initial,
Table_Increment => Alloc.Inlined_Increment,
Table_Name => "Pending_Inlined");
-- The workpile used to compute the transitive closure
function Is_Ancestor_Of_Main
(U_Name : Entity_Id;
Nam : Node_Id) return Boolean;
@ -757,67 +739,57 @@ package body Inline is
-- as part of an inlined package, but are not themselves called. An
-- accurate computation of just those subprograms that are needed
-- requires that we perform a transitive closure over the call graph,
-- starting from calls in the main program. Here we do one step of
-- the inverse transitive closure, and reset the Is_Called flag on
-- subprograms all of whose callers are not.
-- starting from calls in the main program.
for Index in Inlined.First .. Inlined.Last loop
S := Inlined.Table (Index).First_Succ;
if not Is_Called (Inlined.Table (Index).Name) then
-- This means that Add_Inlined_Body added the subprogram to the
-- table but wasn't able to handle its code unit. Do nothing.
if S /= No_Succ
and then not Inlined.Table (Index).Main_Call
then
null;
elsif Inlined.Table (Index).Main_Call then
Pending_Inlined.Increment_Last;
Pending_Inlined.Table (Pending_Inlined.Last) := Index;
Inlined.Table (Index).Processed := True;
else
Set_Is_Called (Inlined.Table (Index).Name, False);
while S /= No_Succ loop
if Is_Called
(Inlined.Table (Successors.Table (S).Subp).Name)
or else Inlined.Table (Successors.Table (S).Subp).Main_Call
then
Set_Is_Called (Inlined.Table (Index).Name);
exit;
end if;
S := Successors.Table (S).Next;
end loop;
end if;
end loop;
-- Now that the units are compiled, chain the subprograms within
-- that are called and inlined. Produce list of inlined subprograms
-- sorted in topological order. Start with all subprograms that
-- have no prerequisites, i.e. inlined subprograms that do not call
-- other inlined subprograms.
-- Iterate over the workpile until it is emptied, propagating the
-- Is_Called flag to the successors of the processed subprogram.
while Pending_Inlined.Last >= Pending_Inlined.First loop
Subp := Pending_Inlined.Table (Pending_Inlined.Last);
Pending_Inlined.Decrement_Last;
S := Inlined.Table (Subp).First_Succ;
while S /= No_Succ loop
Subp := Successors.Table (S).Subp;
Set_Is_Called (Inlined.Table (Subp).Name);
if not Inlined.Table (Subp).Processed then
Pending_Inlined.Increment_Last;
Pending_Inlined.Table (Pending_Inlined.Last) := Subp;
Inlined.Table (Subp).Processed := True;
end if;
S := Successors.Table (S).Next;
end loop;
end loop;
-- Finally add the called subprograms to the list of inlined
-- subprograms for the unit.
for Index in Inlined.First .. Inlined.Last loop
if Is_Called (Inlined.Table (Index).Name)
and then Inlined.Table (Index).Count = 0
and then not Inlined.Table (Index).Listed
then
Add_Inlined_Subprogram (Index);
end if;
end loop;
-- Because Add_Inlined_Subprogram treats recursively nodes that have
-- no prerequisites left, at the end of the loop all subprograms
-- must have been listed. If there are any unlisted subprograms
-- left, there must be some recursive chains that cannot be inlined.
for Index in Inlined.First .. Inlined.Last loop
if Is_Called (Inlined.Table (Index).Name)
and then Inlined.Table (Index).Count /= 0
and then not Is_Predefined_File_Name
(Unit_File_Name
(Get_Source_Unit (Inlined.Table (Index).Name)))
then
Error_Msg_N
("& cannot be inlined?", Inlined.Table (Index).Name);
-- A warning on the first one might be sufficient ???
end if;
end loop;
Pop_Scope;
end if;
end Analyze_Inlined_Bodies;
@ -994,8 +966,12 @@ package body Inline is
--------------------------
function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id is
Unit : Entity_Id := Cunit_Entity (Get_Code_Unit (E));
begin
return Cunit_Entity (Get_Code_Unit (E));
if Ekind (Unit) = E_Package_Body then
Unit := Spec_Entity (Unit);
end if;
return Unit;
end Get_Code_Unit_Entity;
--------------------------

5
gcc/ada/prj-env.adb
View File

@ -754,7 +754,7 @@ package body Prj.Env is
exit when Data = No_Source;
if Data.Unit /= No_Unit_Index then
if Data.Locally_Removed then
if Data.Locally_Removed and then (not Data.Suppressed) then
Fmap.Add_Forbidden_File_Name (Data.File);
else
Fmap.Add_To_File_Map
@ -829,7 +829,8 @@ package body Prj.Env is
Source := Prj.Element (Iter);
exit when Source = No_Source;
if Source.Replaced_By = No_Source
if (not Source.Suppressed)
and then Source.Replaced_By = No_Source
and then Source.Path.Name /= No_Path
and then (Source.Language.Config.Kind = File_Based
or else Source.Unit /= No_Unit_Index)

69
gcc/ada/prj-nmsc.adb
View File

@ -642,32 +642,45 @@ package body Prj.Nmsc is
Add_Src := True;
if Unit /= No_Name then
Prev_Unit := Units_Htable.Get (Data.Tree.Units_HT, Unit);
end if;
if Prev_Unit /= No_Unit_Index
and then (Kind = Impl or else Kind = Spec)
and then Prev_Unit.File_Names (Kind) /= null
then
-- Suspicious, we need to check later whether this is authorized
Add_Src := False;
Source := Prev_Unit.File_Names (Kind);
else
Source := Source_Files_Htable.Get
(Data.Tree.Source_Files_HT, File_Name);
if Source /= No_Source and then Source.Index = Index then
Add_Src := False;
end if;
end if;
-- Always add the source if it is locally removed, to avoid incorrect
-- duplicate checks.
if not Locally_Removed then
if Unit /= No_Name then
Prev_Unit := Units_Htable.Get (Data.Tree.Units_HT, Unit);
end if;
if Locally_Removed then
Add_Src := True;
if Prev_Unit /= No_Unit_Index
and then (Kind = Impl or else Kind = Spec)
and then Prev_Unit.File_Names (Kind) /= null
-- A locally removed source may first replace a source in a project
-- being extended.
if Source /= No_Source
and then Is_Extending (Project, Source.Project)
and then Naming_Exception /= Inherited
then
-- Suspicious, we need to check later whether this is authorized
Add_Src := False;
Source := Prev_Unit.File_Names (Kind);
else
Source := Source_Files_Htable.Get
(Data.Tree.Source_Files_HT, File_Name);
if Source /= No_Source and then Source.Index = Index then
Add_Src := False;
end if;
Source_To_Replace := Source;
end if;
else
-- Duplication of file/unit in same project is allowed if order of
-- source directories is known, or if there is no compiler for the
-- language.
@ -725,7 +738,7 @@ package body Prj.Nmsc is
elsif Is_Extending (Project, Source.Project) then
if not Locally_Removed
and then Naming_Exception /= Inherited
and then Naming_Exception /= Inherited
then
Source_To_Replace := Source;
end if;
@ -733,6 +746,7 @@ package body Prj.Nmsc is
elsif Prev_Unit /= No_Unit_Index
and then Prev_Unit.File_Names (Kind) /= null
and then not Source.Locally_Removed
and then Source.Replaced_By = No_Source
and then not Data.In_Aggregate_Lib
then
-- Path is set if this is a source we found on the disk, in
@ -768,6 +782,7 @@ package body Prj.Nmsc is
Add_Src := False;
elsif not Source.Locally_Removed
and then Source.Replaced_By /= No_Source
and then not Data.Flags.Allow_Duplicate_Basenames
and then Lang_Id.Config.Kind = Unit_Based
and then Source.Language.Config.Kind = Unit_Based
@ -785,10 +800,10 @@ package body Prj.Nmsc is
Add_Src := True;
end if;
end if;
end if;
if not Add_Src then
return;
end if;
if not Add_Src then
return;
end if;
-- Add the new file
@ -868,7 +883,7 @@ package body Prj.Nmsc is
-- Note that this updates Unit information as well
if Naming_Exception /= Inherited then
if Naming_Exception /= Inherited and then not Locally_Removed then
Override_Kind (Id, Kind);
end if;
end if;
@ -7799,8 +7814,12 @@ package body Prj.Nmsc is
(Project.Excluded, Source.File);
if Excluded /= No_File_Found then
Source.Locally_Removed := True;
Source.In_Interfaces := False;
Source.Locally_Removed := True;
if Proj = Project.Project then
Source.Suppressed := True;
end if;
if Current_Verbosity = High then
Debug_Indent;

8
gcc/ada/prj.ads
View File

@ -783,8 +783,13 @@ package Prj is
Locally_Removed : Boolean := False;
-- True if the source has been "excluded"
Suppressed : Boolean := False;
-- True if the source is a locally removed direct source of the project.
-- These sources should not be put in the mapping file.
Replaced_By : Source_Id := No_Source;
-- Missing comment ???
-- Indicate the source in an extending project that replaces the current
-- source.
File : File_Name_Type := No_File;
-- Canonical file name of the source
@ -866,6 +871,7 @@ package Prj is
Unit => No_Unit_Index,
Index => 0,
Locally_Removed => False,
Suppressed => False,
Compilable => Unknown,
In_The_Queue => False,
Replaced_By => No_Source,

9
gcc/ada/sem_ch10.adb
View File

@ -2987,10 +2987,13 @@ package body Sem_Ch10 is
Set_First_Name (Withn, True);
Set_Implicit_With (Withn, True);
-- If the unit is a package declaration, a private_with_clause on a
-- child unit implies the implicit with on the parent is also private.
-- If the unit is a package or generic package declaration, a private_
-- with_clause on a child unit implies that the implicit with on the
-- parent is also private.
if Nkind (Unit (N)) = N_Package_Declaration then
if Nkind_In
(Unit (N), N_Package_Declaration, N_Generic_Package_Declaration)
then
Set_Private_Present (Withn, Private_Present (Item));
end if;

2
gcc/ada/sem_ch6.adb
View File

@ -8934,7 +8934,7 @@ package body Sem_Ch6 is
or else not Is_Dispatching_Operation (Prim)
or else Scope (Prim) /= Scope (Tagged_Type)
or else No (Typ)
or else Base_Type (Typ) /= Tagged_Type
or else Base_Type (Typ) /= Base_Type (Tagged_Type)
or else not Primitive_Names_Match (Iface_Prim, Prim)
then
return False;