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

[multiple changes] 

2015-11-18  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_aggr.adb (Is_Completely_Hidden_Discriminant): New routine.
	(Init_Hidden_Discriminants): Code reformatting. Do not initialize
	a completely hidden discriminant.
	* a-interr.ads (Get_CPU): Added SPARK_Mode, Volatile_Function
	and Global aspects on the function.

2015-11-18  Ed Schonberg  <schonberg@adacore.com>

	* exp_intr.adb (Expand_Unc_Deallocation): If the designated
	type is a concurrent type, the deallocation applies to the
	corresponding record type, or to its class-wide type if the type
	is tagged.

From-SVN: r230535
This commit is contained in:
Arnaud Charlet 2015-11-18 11:40:47 +01:00
parent 86e066aa7a
commit a25e72b5e5
4 changed files with 121 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gcc/ada/ChangeLog
View File

@ -1,3 +1,18 @@
2015-11-18 Hristian Kirtchev <kirtchev@adacore.com>
* exp_aggr.adb (Is_Completely_Hidden_Discriminant): New routine.
(Init_Hidden_Discriminants): Code reformatting. Do not initialize
a completely hidden discriminant.
* a-interr.ads (Get_CPU): Added SPARK_Mode, Volatile_Function
and Global aspects on the function.
2015-11-18 Ed Schonberg <schonberg@adacore.com>
* exp_intr.adb (Expand_Unc_Deallocation): If the designated
type is a concurrent type, the deallocation applies to the
corresponding record type, or to its class-wide type if the type
is tagged.
2015-11-18 Doug Rupp <rupp@adacore.com>
* s-parame-vxworks.adb: Reduce default stack size for stack

6
gcc/ada/a-interr.ads
View File

@ -83,7 +83,11 @@ package Ada.Interrupts is
Global => null;
function Get_CPU
(Interrupt : Interrupt_ID) return System.Multiprocessors.CPU_Range;
(Interrupt : Interrupt_ID) return System.Multiprocessors.CPU_Range
with
SPARK_Mode,
Volatile_Function,
Global => Ada.Task_Identification.Tasking_State;
private
pragma Inline (Is_Reserved);

127
gcc/ada/exp_aggr.adb
View File

@ -2124,11 +2124,51 @@ package body Exp_Aggr is
-------------------------------
procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id) is
Btype : Entity_Id;
Parent_Type : Entity_Id;
Disc : Entity_Id;
Discr_Val : Elmt_Id;
function Is_Completely_Hidden_Discriminant
(Discr : Entity_Id) return Boolean;
-- Determine whether Discr is a completely hidden discriminant of
-- type Typ.
---------------------------------------
-- Is_Completely_Hidden_Discriminant --
---------------------------------------
function Is_Completely_Hidden_Discriminant
(Discr : Entity_Id) return Boolean
is
Item : Entity_Id;
begin
-- Use First/Next_Entity as First/Next_Discriminant do not yield
-- completely hidden discriminants.
Item := First_Entity (Typ);
while Present (Item) loop
if Ekind (Item) = E_Discriminant
and then Is_Completely_Hidden (Item)
and then Chars (Original_Record_Component (Item)) =
Chars (Discr)
then
return True;
end if;
Next_Entity (Item);
end loop;
return False;
end Is_Completely_Hidden_Discriminant;
-- Local variables
Base_Typ : Entity_Id;
Discr : Entity_Id;
Discr_Constr : Elmt_Id;
Discr_Init : Node_Id;
Discr_Val : Node_Id;
In_Aggr_Type : Boolean;
Par_Typ : Entity_Id;
-- Start of processing for Init_Hidden_Discriminants
begin
-- The constraints on the hidden discriminants, if present, are kept
@ -2139,67 +2179,84 @@ package body Exp_Aggr is
In_Aggr_Type := True;
Btype := Base_Type (Typ);
while Is_Derived_Type (Btype)
Base_Typ := Base_Type (Typ);
while Is_Derived_Type (Base_Typ)
and then
(Present (Stored_Constraint (Btype))
(Present (Stored_Constraint (Base_Typ))
or else
(In_Aggr_Type and then Present (Stored_Constraint (Typ))))
loop
Parent_Type := Etype (Btype);
Par_Typ := Etype (Base_Typ);
if not Has_Discriminants (Parent_Type) then
if not Has_Discriminants (Par_Typ) then
return;
end if;
Disc := First_Discriminant (Parent_Type);
Discr := First_Discriminant (Par_Typ);
-- We know that one of the stored-constraint lists is present
if Present (Stored_Constraint (Btype)) then
Discr_Val := First_Elmt (Stored_Constraint (Btype));
if Present (Stored_Constraint (Base_Typ)) then
Discr_Constr := First_Elmt (Stored_Constraint (Base_Typ));
-- For private extension, stored constraint may be on full view
elsif Is_Private_Type (Btype)
and then Present (Full_View (Btype))
and then Present (Stored_Constraint (Full_View (Btype)))
elsif Is_Private_Type (Base_Typ)
and then Present (Full_View (Base_Typ))
and then Present (Stored_Constraint (Full_View (Base_Typ)))
then
Discr_Val := First_Elmt (Stored_Constraint (Full_View (Btype)));
Discr_Constr :=
First_Elmt (Stored_Constraint (Full_View (Base_Typ)));
else
Discr_Val := First_Elmt (Stored_Constraint (Typ));
Discr_Constr := First_Elmt (Stored_Constraint (Typ));
end if;
while Present (Discr_Val) and then Present (Disc) loop
while Present (Discr) and then Present (Discr_Constr) loop
Discr_Val := Node (Discr_Constr);
-- Only those discriminants of the parent that are not
-- renamed by discriminants of the derived type need to
-- be added explicitly.
-- The parent discriminant is renamed in the derived type,
-- nothing to initialize.
if not Is_Entity_Name (Node (Discr_Val))
or else Ekind (Entity (Node (Discr_Val))) /= E_Discriminant
-- type Deriv_Typ (Discr : ...)
-- is new Parent_Typ (Discr => Discr);
if Is_Entity_Name (Discr_Val)
and then Ekind (Entity (Discr_Val)) = E_Discriminant
then
Comp_Expr :=
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name => New_Occurrence_Of (Disc, Loc));
null;
Instr :=
-- When the parent discriminant is constrained at the type
-- extension level, it does not appear in the derived type.
-- type Deriv_Typ (Discr : ...)
-- is new Parent_Typ (Discr => Discr,
-- Hidden_Discr => Expression);
elsif Is_Completely_Hidden_Discriminant (Discr) then
null;
-- Otherwise initialize the discriminant
else
Discr_Init :=
Make_OK_Assignment_Statement (Loc,
Name => Comp_Expr,
Expression => New_Copy_Tree (Node (Discr_Val)));
Name =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name => New_Occurrence_Of (Discr, Loc)),
Expression => New_Copy_Tree (Discr_Val));
Set_No_Ctrl_Actions (Instr);
Append_To (List, Instr);
Set_No_Ctrl_Actions (Discr_Init);
Append_To (List, Discr_Init);
end if;
Next_Discriminant (Disc);
Next_Elmt (Discr_Val);
Next_Elmt (Discr_Constr);
Next_Discriminant (Discr);
end loop;
In_Aggr_Type := False;
Btype := Base_Type (Parent_Type);
Base_Typ := Base_Type (Par_Typ);
end loop;
end Init_Hidden_Discriminants;

11
gcc/ada/exp_intr.adb
View File

@ -1071,10 +1071,17 @@ package body Exp_Intr is
-- If the designated type is tagged, the finalization call must
-- dispatch because the designated type may not be the actual type
-- of the object.
-- of the object. If the type is synchronized, the deallocation
-- applies to the corresponding record type.
if Is_Tagged_Type (Desig_Typ) then
if not Is_Class_Wide_Type (Desig_Typ) then
if Is_Concurrent_Type (Desig_Typ) then
Obj_Ref :=
Unchecked_Convert_To
(Class_Wide_Type (Corresponding_Record_Type (Desig_Typ)),
Obj_Ref);
elsif not Is_Class_Wide_Type (Desig_Typ) then
Obj_Ref :=
Unchecked_Convert_To (Class_Wide_Type (Desig_Typ), Obj_Ref);
end if;