[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:
parent
86e066aa7a
commit
a25e72b5e5
|
@ -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
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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;
|
||||
|
||||
|
|
|
@ -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;
|
||||
|
|
Loading…
Reference in New Issue