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

[multiple changes]

Browse Source 
2011-08-31  Javier Miranda  <miranda@adacore.com>

	* sem_ch4.adb (Try_Object_Operation): When a dispatching primitive is
	found check if there is a class-wide subprogram covering the primitive.
	
2011-08-31  Yannick Moy  <moy@adacore.com>

	* sem_res.adb: Further cases where full expansion test is needed,
	rather than expansion test.

2011-08-31  Pascal Obry  <obry@adacore.com>

	* prj-attr.adb: Fix Source_File_Switches attribute kind (must be a list)

2011-08-31  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch5.adb: Handle iterators over derived container types.

2011-08-31  Hristian Kirtchev  <kirtchev@adacore.com>

	* einfo.ads, einfo.adb: Add new flag Has_Anonymous_Master.
	(Has_Anonymous_Master): New routine.
	(Set_Has_Anonymous_Master): New routine.
	(Write_Entity_Flags): Add an entry for Has_Anonymous_Master.
	* exp_ch4.adb: Add with and use clause for Sem_Ch8.
	(Current_Anonymous_Master): New routine.
	(Current_Unit_First_Declaration): Removed.
	(Current_Unit_Scope): Removed.
	(Expand_N_Allocator): Anonymous access-to-controlled types now chain
	their objects on a per-unit heterogeneous finalization master.

2011-08-31  Matthew Heaney  <heaney@adacore.com>

	* a-cbhama.adb, a-cbhase.adb (Insert): Check for zero-length buckets
	array.

2011-08-31  Jose Ruiz  <ruiz@adacore.com>

	* s-taprop-linux.adb (Create_Task): Avoid changing the affinity mask
	when not needed.

2011-08-31  Gary Dismukes  <dismukes@adacore.com>

	* sem_disp.adb (Propagate_Tag): Return without propagating in the case
	where the actual is an unexpanded call to 'Input.

From-SVN: r178361
This commit is contained in:
Arnaud Charlet 2011-08-31 10:59:01 +02:00
parent d2b4b3da0d
commit 11fa950bd4
12 changed files with 339 additions and 125 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
gcc/ada/ChangeLog
View File

@ -1,3 +1,49 @@
2011-08-31 Javier Miranda <miranda@adacore.com>
* sem_ch4.adb (Try_Object_Operation): When a dispatching primitive is
found check if there is a class-wide subprogram covering the primitive.
2011-08-31 Yannick Moy <moy@adacore.com>
* sem_res.adb: Further cases where full expansion test is needed,
rather than expansion test.
2011-08-31 Pascal Obry <obry@adacore.com>
* prj-attr.adb: Fix Source_File_Switches attribute kind (must be a list)
2011-08-31 Ed Schonberg <schonberg@adacore.com>
* exp_ch5.adb: Handle iterators over derived container types.
2011-08-31 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.ads, einfo.adb: Add new flag Has_Anonymous_Master.
(Has_Anonymous_Master): New routine.
(Set_Has_Anonymous_Master): New routine.
(Write_Entity_Flags): Add an entry for Has_Anonymous_Master.
* exp_ch4.adb: Add with and use clause for Sem_Ch8.
(Current_Anonymous_Master): New routine.
(Current_Unit_First_Declaration): Removed.
(Current_Unit_Scope): Removed.
(Expand_N_Allocator): Anonymous access-to-controlled types now chain
their objects on a per-unit heterogeneous finalization master.
2011-08-31 Matthew Heaney <heaney@adacore.com>
* a-cbhama.adb, a-cbhase.adb (Insert): Check for zero-length buckets
array.
2011-08-31 Jose Ruiz <ruiz@adacore.com>
* s-taprop-linux.adb (Create_Task): Avoid changing the affinity mask
when not needed.
2011-08-31 Gary Dismukes <dismukes@adacore.com>
* sem_disp.adb (Propagate_Tag): Return without propagating in the case
where the actual is an unexpanded call to 'Input.
2011-08-31 Yannick Moy <moy@adacore.com>
* sem_ch4.adb: Code clean up.

47
gcc/ada/a-cbhama.adb
View File

@ -513,6 +513,11 @@ package body Ada.Containers.Bounded_Hashed_Maps is
procedure Assign_Key (Node : in out Node_Type) is
begin
Node.Key := Key;
-- Note that we do not also assign the element component of the node
-- here, because this version of Insert does not accept an element
-- parameter.
-- Node.Element := New_Item;
end Assign_Key;
@ -530,20 +535,17 @@ package body Ada.Containers.Bounded_Hashed_Maps is
-- Start of processing for Insert
begin
-- ???
-- if HT_Ops.Capacity (HT) = 0 then
-- HT_Ops.Reserve_Capacity (HT, 1);
-- end if;
-- The buckets array length is specified by the user as a discriminant
-- of the container type, so it is possible for the buckets array to
-- have a length of zero. We must check for this case specifically, in
-- order to prevent divide-by-zero errors later, when we compute the
-- buckets array index value for a key, given its hash value.
if Container.Buckets'Length = 0 then
raise Capacity_Error with "No capacity for insertion";
end if;
Local_Insert (Container, Key, Position.Node, Inserted);
-- ???
-- if Inserted
-- and then HT.Length > HT_Ops.Capacity (HT)
-- then
-- HT_Ops.Reserve_Capacity (HT, HT.Length);
-- end if;
Position.Container := Container'Unchecked_Access;
end Insert;
@ -590,20 +592,17 @@ package body Ada.Containers.Bounded_Hashed_Maps is
-- Start of processing for Insert
begin
-- ??
-- if HT_Ops.Capacity (HT) = 0 then
-- HT_Ops.Reserve_Capacity (HT, 1);
-- end if;
-- The buckets array length is specified by the user as a discriminant
-- of the container type, so it is possible for the buckets array to
-- have a length of zero. We must check for this case specifically, in
-- order to prevent divide-by-zero errors later, when we compute the
-- buckets array index value for a key, given its hash value.
if Container.Buckets'Length = 0 then
raise Capacity_Error with "No capacity for insertion";
end if;
Local_Insert (Container, Key, Position.Node, Inserted);
-- ???
-- if Inserted
-- and then HT.Length > HT_Ops.Capacity (HT)
-- then
-- HT_Ops.Reserve_Capacity (HT, HT.Length);
-- end if;
Position.Container := Container'Unchecked_Access;
end Insert;

20
gcc/ada/a-cbhase.adb
View File

@ -710,19 +710,17 @@ package body Ada.Containers.Bounded_Hashed_Sets is
-- Start of processing for Insert
begin
-- ???
-- if HT_Ops.Capacity (HT) = 0 then
-- HT_Ops.Reserve_Capacity (HT, 1);
-- end if;
-- The buckets array length is specified by the user as a discriminant
-- of the container type, so it is possible for the buckets array to
-- have a length of zero. We must check for this case specifically, in
-- order to prevent divide-by-zero errors later, when we compute the
-- buckets array index value for an element, given its hash value.
if Container.Buckets'Length = 0 then
raise Capacity_Error with "No capacity for insertion";
end if;
Local_Insert (Container, New_Item, Node, Inserted);
-- ???
-- if Inserted
-- and then HT.Length > HT_Ops.Capacity (HT)
-- then
-- HT_Ops.Reserve_Capacity (HT, HT.Length);
-- end if;
end Insert;
------------------

17
gcc/ada/einfo.adb
View File

@ -521,8 +521,8 @@ package body Einfo is
-- Has_Implicit_Dereference Flag251
-- Is_Processed_Transient Flag252
-- Has_Anonymous_Master Flag253
-- (unused) Flag253
-- (unused) Flag254
-----------------------
@ -1183,6 +1183,13 @@ package body Einfo is
return Flag201 (Id);
end Has_Anon_Block_Suffix;
function Has_Anonymous_Master (Id : E) return B is
begin
pragma Assert
(Ekind_In (Id, E_Function, E_Package, E_Package_Body, E_Procedure));
return Flag253 (Id);
end Has_Anonymous_Master;
function Has_Atomic_Components (Id : E) return B is
begin
return Flag86 (Implementation_Base_Type (Id));
@ -3662,6 +3669,13 @@ package body Einfo is
Set_Flag201 (Id, V);
end Set_Has_Anon_Block_Suffix;
procedure Set_Has_Anonymous_Master (Id : E; V : B := True) is
begin
pragma Assert
(Ekind_In (Id, E_Function, E_Package, E_Package_Body, E_Procedure));
Set_Flag253 (Id, V);
end Set_Has_Anonymous_Master;
procedure Set_Has_Atomic_Components (Id : E; V : B := True) is
begin
pragma Assert (not Is_Type (Id) or else Is_Base_Type (Id));
@ -7418,6 +7432,7 @@ package body Einfo is
W ("Has_Alignment_Clause", Flag46 (Id));
W ("Has_All_Calls_Remote", Flag79 (Id));
W ("Has_Anon_Block_Suffix", Flag201 (Id));
W ("Has_Anonymous_Master", Flag253 (Id));
W ("Has_Atomic_Components", Flag86 (Id));
W ("Has_Biased_Representation", Flag139 (Id));
W ("Has_Completion", Flag26 (Id));

21
gcc/ada/einfo.ads
View File

@ -1341,6 +1341,13 @@ package Einfo is
-- more anonymous blocks and the Chars field contains a name with an
-- anonymous block suffix (see Exp_Dbug for further details).
-- Has_Anonymous_Master (Flag253)
-- Present in units (top-level functions and procedures, library-level
-- packages). Set to True if the associated unit contains a heterogeneous
-- finalization master. The master's name is of the form <unit>AM and it
-- services anonymous access-to-controlled types with an undetermined
-- lifetime.
-- Has_Atomic_Components (Flag86) [implementation base type only]
-- Present in all types and objects. Set only for an array type or
-- an array object if a valid pragma Atomic_Components applies to the
@ -5239,6 +5246,7 @@ package Einfo is
-- Delay_Cleanups (Flag114)
-- Delay_Subprogram_Descriptors (Flag50)
-- Discard_Names (Flag88)
-- Has_Anonymous_Master (Flag253)
-- Has_Completion (Flag26)
-- Has_Controlling_Result (Flag98)
-- Has_Invariants (Flag232)
@ -5429,6 +5437,7 @@ package Einfo is
-- Elaborate_Body_Desirable (Flag210) (non-generic case only)
-- From_With_Type (Flag159)
-- Has_All_Calls_Remote (Flag79)
-- Has_Anonymous_Master (Flag253)
-- Has_Completion (Flag26)
-- Has_Forward_Instantiation (Flag175)
-- Has_Master_Entity (Flag21)
@ -5439,10 +5448,10 @@ package Einfo is
-- Is_Instantiated (Flag126)
-- Is_Private_Descendant (Flag53)
-- Is_Visible_Child_Unit (Flag116)
-- Is_Wrapper_Package (synth) (non-generic case only)
-- Renamed_In_Spec (Flag231) (non-generic case only)
-- Scope_Depth (synth)
-- Static_Elaboration_Desired (Flag77) (non-generic case only)
-- Is_Wrapper_Package (synth) (non-generic case only)
-- Scope_Depth (synth)
-- E_Package_Body
-- Handler_Records (List10) (non-generic case only)
@ -5452,9 +5461,10 @@ package Einfo is
-- Last_Entity (Node20)
-- Scope_Depth_Value (Uint22)
-- Finalizer (Node24) (non-generic case only)
-- Scope_Depth (synth)
-- Delay_Subprogram_Descriptors (Flag50)
-- Has_Anonymous_Master (Flag253)
-- Has_Subprogram_Descriptor (Flag93)
-- Scope_Depth (synth)
-- E_Private_Type
-- E_Private_Subtype
@ -5505,6 +5515,7 @@ package Einfo is
-- Delay_Cleanups (Flag114)
-- Delay_Subprogram_Descriptors (Flag50)
-- Discard_Names (Flag88)
-- Has_Anonymous_Master (Flag253)
-- Has_Completion (Flag26)
-- Has_Invariants (Flag232)
-- Has_Master_Entity (Flag21)
@ -6073,6 +6084,7 @@ package Einfo is
function Has_Alignment_Clause (Id : E) return B;
function Has_All_Calls_Remote (Id : E) return B;
function Has_Anon_Block_Suffix (Id : E) return B;
function Has_Anonymous_Master (Id : E) return B;
function Has_Atomic_Components (Id : E) return B;
function Has_Biased_Representation (Id : E) return B;
function Has_Completion (Id : E) return B;
@ -6660,6 +6672,7 @@ package Einfo is
procedure Set_Has_Alignment_Clause (Id : E; V : B := True);
procedure Set_Has_All_Calls_Remote (Id : E; V : B := True);
procedure Set_Has_Anon_Block_Suffix (Id : E; V : B := True);
procedure Set_Has_Anonymous_Master (Id : E; V : B := True);
procedure Set_Has_Atomic_Components (Id : E; V : B := True);
procedure Set_Has_Biased_Representation (Id : E; V : B := True);
procedure Set_Has_Completion (Id : E; V : B := True);
@ -7360,6 +7373,7 @@ package Einfo is
pragma Inline (Has_Alignment_Clause);
pragma Inline (Has_All_Calls_Remote);
pragma Inline (Has_Anon_Block_Suffix);
pragma Inline (Has_Anonymous_Master);
pragma Inline (Has_Atomic_Components);
pragma Inline (Has_Biased_Representation);
pragma Inline (Has_Completion);
@ -7803,6 +7817,7 @@ package Einfo is
pragma Inline (Set_Has_Alignment_Clause);
pragma Inline (Set_Has_All_Calls_Remote);
pragma Inline (Set_Has_Anon_Block_Suffix);
pragma Inline (Set_Has_Anonymous_Master);
pragma Inline (Set_Has_Atomic_Components);
pragma Inline (Set_Has_Biased_Representation);
pragma Inline (Set_Has_Completion);

207
gcc/ada/exp_ch4.adb
View File

@ -58,6 +58,7 @@ with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
@ -92,13 +93,11 @@ package body Exp_Ch4 is
-- If a boolean array assignment can be done in place, build call to
-- corresponding library procedure.
function Current_Unit_First_Declaration return Node_Id;
-- Return the current unit's first declaration. If the declaration list is
-- empty, the routine generates a null statement and returns it.
function Current_Unit_Scope return Entity_Id;
-- Return the scope of the current unit. If the current unit is a body,
-- return the scope of the spec.
function Current_Anonymous_Master return Entity_Id;
-- Return the entity of the heterogeneous finalization master belonging to
-- the current unit (either function, package or procedure). This master
-- services all anonymous access-to-controlled types. If the current unit
-- does not have such master, create one.
procedure Displace_Allocator_Pointer (N : Node_Id);
-- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
@ -376,79 +375,166 @@ package body Exp_Ch4 is
return;
end Build_Boolean_Array_Proc_Call;
------------------------------------
-- Current_Unit_First_Declaration --
------------------------------------
------------------------------
-- Current_Anonymous_Master --
------------------------------
function Current_Unit_First_Declaration return Node_Id is
Sem_U : Node_Id := Unit (Cunit (Current_Sem_Unit));
Decl : Node_Id;
Decls : List_Id;
function Current_Anonymous_Master return Entity_Id is
Decls : List_Id;
Fin_Mas_Id : Entity_Id;
Loc : Source_Ptr;
Subp_Body : Node_Id;
Unit_Decl : Node_Id;
Unit_Id : Entity_Id;
begin
if Nkind (Sem_U) = N_Package_Declaration then
Sem_U := Specification (Sem_U);
Decls := Visible_Declarations (Sem_U);
Unit_Id := Cunit_Entity (Current_Sem_Unit);
-- Find the entity of the current unit
if Ekind (Unit_Id) = E_Subprogram_Body then
-- When processing subprogram bodies, the proper scope is always that
-- of the spec.
Subp_Body := Unit_Id;
while Present (Subp_Body)
and then Nkind (Subp_Body) /= N_Subprogram_Body
loop
Subp_Body := Parent (Subp_Body);
end loop;
Unit_Id := Corresponding_Spec (Subp_Body);
end if;
Loc := Sloc (Unit_Id);
Unit_Decl := Unit (Cunit (Current_Sem_Unit));
-- Find the declarations list of the current unit
if Nkind (Unit_Decl) = N_Package_Declaration then
Unit_Decl := Specification (Unit_Decl);
Decls := Visible_Declarations (Unit_Decl);
if No (Decls) then
Decl := Make_Null_Statement (Sloc (Sem_U));
Decls := New_List (Decl);
Set_Visible_Declarations (Sem_U, Decls);
Decls := New_List (Make_Null_Statement (Loc));
Set_Visible_Declarations (Unit_Decl, Decls);
elsif Is_Empty_List (Decls) then
Decl := Make_Null_Statement (Sloc (Sem_U));
Append_To (Decls, Decl);
else
Decl := First (Decls);
Append_To (Decls, Make_Null_Statement (Loc));
end if;
else
Decls := Declarations (Sem_U);
Decls := Declarations (Unit_Decl);
if No (Decls) then
Decl := Make_Null_Statement (Sloc (Sem_U));
Decls := New_List (Decl);
Set_Declarations (Sem_U, Decls);
Decls := New_List (Make_Null_Statement (Loc));
Set_Declarations (Unit_Decl, Decls);
elsif Is_Empty_List (Decls) then
Decl := Make_Null_Statement (Sloc (Sem_U));
Append_To (Decls, Decl);
else
Decl := First (Decls);
Append_To (Decls, Make_Null_Statement (Loc));
end if;
end if;
return Decl;
end Current_Unit_First_Declaration;
-- The current unit has an existing anonymous master, traverse its
-- declarations and locate the entity.
------------------------
-- Current_Unit_Scope --
------------------------
if Has_Anonymous_Master (Unit_Id) then
Fin_Mas_Id := First_Entity (Unit_Id);
while Present (Fin_Mas_Id) loop
function Current_Unit_Scope return Entity_Id is
Scop_Id : Entity_Id := Cunit_Entity (Current_Sem_Unit);
Subp_Bod : Node_Id;
-- Look for the first variable whose type is Finalization_Master
begin
if Ekind (Scop_Id) = E_Subprogram_Body then
if Ekind (Fin_Mas_Id) = E_Variable
and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master)
then
return Fin_Mas_Id;
end if;
-- When processing subprogram bodies, the proper scope is always
-- that of the spec.
Subp_Bod := Scop_Id;
while Present (Subp_Bod)
and then Nkind (Subp_Bod) /= N_Subprogram_Body
loop
Subp_Bod := Parent (Subp_Bod);
Next_Entity (Fin_Mas_Id);
end loop;
Scop_Id := Corresponding_Spec (Subp_Bod);
end if;
raise Program_Error;
return Scop_Id;
end Current_Unit_Scope;
-- Create a new anonymous master
else
declare
First_Decl : constant Node_Id := First (Decls);
Action : Node_Id;
begin
-- Since the master and its associated initialization is inserted
-- at top level, use the scope of the unit when analyzing.
Push_Scope (Unit_Id);
-- Create the finalization master
Fin_Mas_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Unit_Id), "AM"));
-- Generate:
-- <Fin_Mas_Id> : Finalization_Master;
Action :=
Make_Object_Declaration (Loc,
Defining_Identifier => Fin_Mas_Id,
Object_Definition =>
New_Reference_To (RTE (RE_Finalization_Master), Loc));
Insert_Before_And_Analyze (First_Decl, Action);
-- Mark the unit to prevent the generation of multiple masters
Set_Has_Anonymous_Master (Unit_Id);
-- Do not set the base pool and mode of operation on .NET/JVM
-- since those targets do not support pools and all VM masters
-- are heterogeneous by default.
if VM_Target = No_VM then
-- Generate:
-- Set_Base_Pool
-- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access);
Action :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Set_Base_Pool), Loc),
Parameter_Associations => New_List (
New_Reference_To (Fin_Mas_Id, Loc),
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (RTE (RE_Global_Pool_Object), Loc),
Attribute_Name => Name_Unrestricted_Access)));
Insert_Before_And_Analyze (First_Decl, Action);
-- Generate:
-- Set_Is_Heterogeneous (<Fin_Mas_Id>);
Action :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Reference_To (RTE (RE_Set_Is_Heterogeneous), Loc),
Parameter_Associations => New_List (
New_Reference_To (Fin_Mas_Id, Loc)));
Insert_Before_And_Analyze (First_Decl, Action);
end if;
-- Restore the original state of the scope stack
Pop_Scope;
return Fin_Mas_Id;
end;
end if;
end Current_Anonymous_Master;
--------------------------------
-- Displace_Allocator_Pointer --
@ -3373,18 +3459,15 @@ package body Exp_Ch4 is
if No (Associated_Storage_Pool (PtrT))
and then VM_Target = No_VM
then
Set_Associated_Storage_Pool (PtrT,
Get_Global_Pool_For_Access_Type (PtrT));
Set_Associated_Storage_Pool
(PtrT, Get_Global_Pool_For_Access_Type (PtrT));
end if;
-- The finalization master must be inserted and analyzed as part of
-- the current semantic unit.
if No (Finalization_Master (PtrT)) then
Build_Finalization_Master
(Typ => PtrT,
Ins_Node => Current_Unit_First_Declaration,
Encl_Scope => Current_Unit_Scope);
Set_Finalization_Master (PtrT, Current_Anonymous_Master);
end if;
end if;

18
gcc/ada/exp_ch5.adb
View File

@ -2985,7 +2985,7 @@ package body Exp_Ch5 is
-- If "reverse" is present, then the initialization of the cursor
-- uses Last and the step becomes Prev. Pack is the name of the
-- package which instantiates the container.
-- scope where the container package is instantiated.
declare
Element_Type : constant Entity_Id := Etype (Id);
@ -3007,13 +3007,23 @@ package body Exp_Ch5 is
-- use-visible, so we introduce the name of the enclosing package
-- in the declarations below. The Iterator type is declared in a
-- an instance within the container package itself.
-- If the container type is a derived type, the cursor type is
-- found in the package of the parent type.
Iter_Type := Etype (Name (I_Spec));
if Is_Iterator (Iter_Type) then
Pack := Scope (Scope (Etype (Container)));
if Is_Derived_Type (Container_Typ) then
Pack := Scope (Scope (Root_Type (Container_Typ)));
else
Pack := Scope (Scope (Container_Typ));
end if;
else
Pack := Scope (Etype (Container));
if Is_Derived_Type (Container_Typ) then
Pack := Scope (Root_Type (Container_Typ));
else
Pack := Scope (Container_Typ);
end if;
end if;
-- The "of" case uses an internally generated cursor whose type
@ -3128,7 +3138,7 @@ package body Exp_Ch5 is
end;
-- X in Iterate (S) : type of iterator is type of explicitly
-- given Iterate function.
-- given Iterate function, and the loop variable is the cursor.
else
Cursor := Id;

2
gcc/ada/prj-attr.adb
View File

@ -190,7 +190,7 @@ package body Prj.Attr is
"Latrailing_required_switches#" &
"Lapic_option#" &
"Sapath_syntax#" &
"Sasource_file_switches#" &
"Lasource_file_switches#" &
"Saobject_file_suffix#" &
"Laobject_file_switches#" &
"Lamulti_unit_switches#" &

11
gcc/ada/s-taprop-linux.adb
View File

@ -880,7 +880,16 @@ package body System.Task_Primitives.Operations is
-- Handle dispatching domains
elsif T.Common.Domain /= null then
-- To avoid changing CPU affinities when not needed, we set the
-- affinity only when assigning to a domain other than the default
-- one, or when the default one has been modified.
elsif T.Common.Domain /= null and then
(T.Common.Domain /= ST.System_Domain
or else T.Common.Domain.all /=
(Multiprocessors.CPU'First ..
Multiprocessors.Number_Of_CPUs => True))
then
declare
CPU_Set : aliased cpu_set_t := (bits => (others => False));

53
gcc/ada/sem_ch4.adb
View File

@ -6638,7 +6638,7 @@ package body Sem_Ch4 is
Call : Node_Id;
Subp : Entity_Id) return Entity_Id;
-- If the subprogram is a valid interpretation, record it, and add
-- to the list of interpretations of Subprog.
-- to the list of interpretations of Subprog. Otherwise return Empty.
procedure Complete_Object_Operation
(Call_Node : Node_Id;
@ -7104,6 +7104,14 @@ package body Sem_Ch4 is
and then N = Name (Parent (N))
then
goto Next_Hom;
-- If the context is a function call, ignore procedures
-- in the name of the call.
elsif Ekind (Hom) = E_Procedure
and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
then
goto Next_Hom;
end if;
Set_Etype (Call_Node, Any_Type);
@ -7271,16 +7279,39 @@ package body Sem_Ch4 is
return;
end if;
if Try_Primitive_Operation
(Call_Node => New_Call_Node,
Node_To_Replace => Node_To_Replace)
or else
Try_Class_Wide_Operation
(Call_Node => New_Call_Node,
Node_To_Replace => Node_To_Replace)
then
null;
end if;
declare
Dup_Call_Node : constant Node_Id := New_Copy (New_Call_Node);
CW_Result : Boolean;
Prim_Result : Boolean;
pragma Unreferenced (CW_Result);
begin
Prim_Result :=
Try_Primitive_Operation
(Call_Node => New_Call_Node,
Node_To_Replace => Node_To_Replace);
-- Check if there is a class-wide subprogram covering the
-- primitive. This check must be done even if a candidate
-- was found in order to report ambiguous calls.
if not (Prim_Result) then
CW_Result :=
Try_Class_Wide_Operation
(Call_Node => New_Call_Node,
Node_To_Replace => Node_To_Replace);
-- If we found a primitive we search for class-wide subprograms
-- using a duplicate of the call node (done to avoid missing its
-- decoration if there is no ambiguity).
else
CW_Result :=
Try_Class_Wide_Operation
(Call_Node => Dup_Call_Node,
Node_To_Replace => Node_To_Replace);
end if;
end;
end Try_One_Prefix_Interpretation;
-----------------------------

8
gcc/ada/sem_disp.adb
View File

@ -2262,6 +2262,14 @@ package body Sem_Disp is
then
return;
-- When expansion is suppressed, an unexpanded call to 'Input can occur,
-- and in that case we can simply return.
elsif Nkind (Actual) = N_Attribute_Reference then
pragma Assert (Attribute_Name (Actual) = Name_Input);
return;
-- Only other possibilities are parenthesized or qualified expression,
-- or an expander-generated unchecked conversion of a function call to
-- a stream Input attribute.

14
gcc/ada/sem_res.adb
View File

@ -1725,7 +1725,7 @@ package body Sem_Res is
-- Start of processing for Replace_Actual_Discriminants
begin
if not Expander_Active then
if not Full_Expander_Active then
return;
end if;
@ -1970,7 +1970,7 @@ package body Sem_Res is
if (Attr = Attribute_Access or else
Attr = Attribute_Unchecked_Access or else
Attr = Attribute_Unrestricted_Access)
and then Expander_Active
and then Full_Expander_Active
and then Get_PCS_Name /= Name_No_DSA
then
Check_Subtype_Conformant
@ -6833,7 +6833,7 @@ package body Sem_Res is
-- Why the Expander_Active test here ???
if Expander_Active
if Full_Expander_Active
and then
(Ekind_In (T, E_Anonymous_Access_Type,
E_Anonymous_Access_Subprogram_Type)
@ -7148,7 +7148,7 @@ package body Sem_Res is
-- We must preserve the original entity in a generic setting, so that
-- the legality of the operation can be verified in an instance.
if not Expander_Active then
if not Full_Expander_Active then
return;
end if;
@ -8197,7 +8197,7 @@ package body Sem_Res is
-- transformation while analyzing generic units, as type information
-- would be lost when reanalyzing the constant node in the instance.
if Is_Discrete_Type (Typ) and then Expander_Active then
if Is_Discrete_Type (Typ) and then Full_Expander_Active then
if Is_OK_Static_Expression (L) then
Fold_Uint (L, Expr_Value (L), Is_Static_Expression (L));
end if;
@ -9345,7 +9345,7 @@ package body Sem_Res is
-- expression coincides with the target type.
if Ada_Version >= Ada_2005
and then Expander_Active
and then Full_Expander_Active
and then Operand_Typ /= Target_Typ
then
declare
@ -9844,7 +9844,7 @@ package body Sem_Res is
-- premature (e.g. if the slice is within a transient scope). This needs
-- to be done only if expansion is enabled.
elsif Expander_Active then
elsif Full_Expander_Active then
Ensure_Defined (Typ => Slice_Subtype, N => N);
end if;
end Set_Slice_Subtype;