N_Iterated_Component_Association
then
null;
+
+ -- For mutably tagged class-wide type components that have an
+ -- initializing qualified expression, the expression must be
+ -- analyzed and resolved using the type of the qualified
+ -- expression; otherwise spurious errors would be reported
+ -- because components defined in derivations of the root type
+ -- of the mutably tagged class-wide type would not be visible.
+
+ -- Resolve_Aggr_Expr has previously checked that the type of
+ -- the qualified expression is a descendant of the root type
+ -- of the mutably class-wide tagged type.
+
+ elsif Is_Mutably_Tagged_Type (Comp_Typ)
+ and then Nkind (Expr) = N_Qualified_Expression
+ then
+ Analyze_And_Resolve (Expr_Q, Etype (Expr));
+
else
Analyze_And_Resolve (Expr_Q, Comp_Typ);
end if;
end if;
if Present (Expr) then
- Initialize_Component
- (N => N,
- Comp => Indexed_Comp,
- Comp_Typ => Comp_Typ,
- Init_Expr => Expr,
- Stmts => Stmts);
+
+ -- For mutably tagged abstract class-wide types, we rely on the
+ -- type of the initializing expression to initialize the tag of
+ -- each array component.
+
+ -- Generate:
+ -- expr_type!(Indexed_Comp) := expr;
+ -- expr_type!(Indexed_Comp)._tag := expr_type'Tag;
+
+ if Is_Mutably_Tagged_Type (Comp_Typ)
+ and then Is_Abstract_Type (Root_Type (Comp_Typ))
+ then
+ declare
+ Expr_Type : Entity_Id;
+
+ begin
+ if Nkind (Expr) in N_Has_Etype
+ and then Present (Etype (Expr))
+ then
+ Expr_Type := Etype (Expr);
+
+ elsif Nkind (Expr) = N_Qualified_Expression then
+ Analyze (Subtype_Mark (Expr));
+ Expr_Type := Etype (Subtype_Mark (Expr));
+
+ -- Unsupported case
+
+ else
+ pragma Assert (False);
+ raise Program_Error;
+ end if;
+
+ Initialize_Component
+ (N => N,
+ Comp => Unchecked_Convert_To (Expr_Type,
+ Indexed_Comp),
+ Comp_Typ => Expr_Type,
+ Init_Expr => Expr,
+ Stmts => Stmts);
+ end;
+ else
+ Initialize_Component
+ (N => N,
+ Comp => Indexed_Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Expr,
+ Stmts => Stmts);
+ end if;
-- Ada 2005 (AI-287): In case of default initialized component, call
-- the initialization subprogram associated with the component type.
-- object creation that will invoke it otherwise.
else
- if Present (Base_Init_Proc (Ctype)) then
+ -- For mutably tagged class-wide types, default initialization is
+ -- performed by the init procedure of their root type.
+
+ if Is_Mutably_Tagged_Type (Comp_Typ) then
+ Comp_Typ := Root_Type (Comp_Typ);
+ end if;
+
+ if Present (Base_Init_Proc (Comp_Typ)) then
Check_Restriction (No_Default_Initialization, N);
if not Restriction_Active (No_Default_Initialization) then
Append_List_To (Stmts,
Build_Initialization_Call (N,
Id_Ref => Indexed_Comp,
- Typ => Ctype,
+ Typ => Comp_Typ,
With_Default_Init => True));
end if;
-- be analyzed and resolved before the code for initialization
-- of other components.
- if Has_Invariants (Ctype) then
- Set_Etype (Indexed_Comp, Ctype);
+ if Has_Invariants (Comp_Typ) then
+ Set_Etype (Indexed_Comp, Comp_Typ);
Append_To (Stmts, Make_Invariant_Call (Indexed_Comp));
end if;
end if;
- if Needs_Finalization (Ctype) then
+ if Needs_Finalization (Comp_Typ) then
Init_Call :=
Make_Init_Call
(Obj_Ref => New_Copy_Tree (Indexed_Comp),
- Typ => Ctype);
+ Typ => Comp_Typ);
-- Guard against a missing [Deep_]Initialize when the component
-- type was not properly frozen.
-- is not empty, but a default init still applies, such as for
-- Default_Value cases, in which case we won't get here. ???
- if Has_DIC (Ctype) and then Present (DIC_Procedure (Ctype)) then
+ if Has_DIC (Comp_Typ)
+ and then Present (DIC_Procedure (Comp_Typ))
+ then
Append_To (Stmts,
- Build_DIC_Call (Loc, New_Copy_Tree (Indexed_Comp), Ctype));
+ Build_DIC_Call (Loc,
+ Obj_Name => New_Copy_Tree (Indexed_Comp),
+ Typ => Comp_Typ));
end if;
end if;
--------------
function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is
+ Comp_Typ : Entity_Id;
+
Is_Iterated_Component : constant Boolean :=
Parent_Kind (Expr) = N_Iterated_Component_Association;
Tcopy := New_Copy_Tree (Expr);
Set_Parent (Tcopy, N);
+ Comp_Typ := Component_Type (Etype (N));
+
+ if Is_Class_Wide_Equivalent_Type (Comp_Typ) then
+ Comp_Typ := Corresponding_Mutably_Tagged_Type (Comp_Typ);
+ end if;
+
-- For iterated_component_association analyze and resolve
-- the expression with name of the index parameter visible.
-- To manipulate scopes, we use entity of the implicit loop.
begin
Push_Scope (Scope (Index_Parameter));
Enter_Name (Index_Parameter);
- Analyze_And_Resolve
- (Tcopy, Component_Type (Etype (N)));
+ Analyze_And_Resolve (Tcopy, Comp_Typ);
End_Scope;
end;
-- resolve the expression.
else
- Analyze_And_Resolve (Tcopy, Component_Type (Etype (N)));
+ Analyze_And_Resolve (Tcopy, Comp_Typ);
end if;
Expander_Mode_Restore;
Set_Loop_Actions (Others_Assoc, New_List);
First := False;
end if;
+
Expr := Get_Assoc_Expr (Others_Assoc);
Append_List (Gen_Loop (Low, High, Expr), To => New_Code);
end if;
-- a call to the corresponding IP subprogram if available.
elsif Box_Present (Comp)
- and then Has_Non_Null_Base_Init_Proc (Etype (Selector))
- then
- Check_Restriction (No_Default_Initialization, N);
-
- if Ekind (Selector) /= E_Discriminant then
- Generate_Finalization_Actions;
- end if;
+ and then
+ (Has_Non_Null_Base_Init_Proc (Etype (Selector))
- -- Ada 2005 (AI-287): If the component type has tasks then
- -- generate the activation chain and master entities (except
- -- in case of an allocator because in that case these entities
- -- are generated by Build_Task_Allocate_Block).
+ -- Default initialization of mutably tagged class-wide type
+ -- components is performed by the IP subprogram.
+ or else Is_Class_Wide_Equivalent_Type (Etype (Selector)))
+ then
declare
- Ctype : constant Entity_Id := Etype (Selector);
- Inside_Allocator : Boolean := False;
- P : Node_Id := Parent (N);
+ Ctype : Entity_Id := Etype (Selector);
begin
- if Is_Task_Type (Ctype) or else Has_Task (Ctype) then
- while Present (P) loop
- if Nkind (P) = N_Allocator then
- Inside_Allocator := True;
- exit;
+ if Is_Class_Wide_Equivalent_Type (Ctype) then
+ Ctype :=
+ Root_Type (Corresponding_Mutably_Tagged_Type (Ctype));
+ end if;
+
+ Check_Restriction (No_Default_Initialization, N);
+
+ if Ekind (Selector) /= E_Discriminant then
+ Generate_Finalization_Actions;
+ end if;
+
+ -- Ada 2005 (AI-287): If the component type has tasks then
+ -- generate the activation chain and master entities (except
+ -- in case of an allocator because in that case these entities
+ -- are generated by Build_Task_Allocate_Block).
+
+ declare
+ Inside_Allocator : Boolean := False;
+ P : Node_Id := Parent (N);
+
+ begin
+ if Is_Task_Type (Ctype) or else Has_Task (Ctype) then
+ while Present (P) loop
+ if Nkind (P) = N_Allocator then
+ Inside_Allocator := True;
+ exit;
+ end if;
+
+ P := Parent (P);
+ end loop;
+
+ if not Inside_Init_Proc and not Inside_Allocator then
+ Build_Activation_Chain_Entity (N);
end if;
+ end if;
+ end;
- P := Parent (P);
- end loop;
+ if not Restriction_Active (No_Default_Initialization) then
+ Append_List_To (L,
+ Build_Initialization_Call (N,
+ Id_Ref => Make_Selected_Component (Loc,
+ Prefix =>
+ New_Copy_Tree (Target),
+ Selector_Name =>
+ New_Occurrence_Of
+ (Selector, Loc)),
+ Typ => Ctype,
+ Enclos_Type => Typ,
+ With_Default_Init => True));
+
+ if Is_Class_Wide_Equivalent_Type (Etype (Selector))
+ and then Is_Abstract_Type (Ctype)
+ then
+ Error_Msg_Name_1 := Chars (Selector);
+ Error_Msg_N
+ ("default initialization of abstract type "
+ & "component % not allowed??", Comp);
+ Error_Msg_N
+ ("\Program_Error will be raised at run time??", Comp);
- if not Inside_Init_Proc and not Inside_Allocator then
- Build_Activation_Chain_Entity (N);
+ Append_To (L,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Abstract_Type_Component));
end if;
end if;
end;
- if not Restriction_Active (No_Default_Initialization) then
- Append_List_To (L,
- Build_Initialization_Call (N,
- Id_Ref => Make_Selected_Component (Loc,
- Prefix =>
- New_Copy_Tree (Target),
- Selector_Name =>
- New_Occurrence_Of (Selector, Loc)),
- Typ => Etype (Selector),
- Enclos_Type => Typ,
- With_Default_Init => True));
- end if;
-
-- Prepare for component assignment
elsif Ekind (Selector) /= E_Discriminant
end if;
end if;
- Initialize_Component
- (N => N,
- Comp => Comp_Expr,
- Comp_Typ => Etype (Selector),
- Init_Expr => Expr_Q,
- Stmts => L);
+ -- For mutably tagged class-wide components with a qualified
+ -- initializing expressions use the qualified expression as
+ -- its Init_Expr; required to avoid reporting spurious errors.
+
+ if Is_Class_Wide_Equivalent_Type (Comp_Type)
+ and then Nkind (Expression (Comp)) = N_Qualified_Expression
+ then
+ Initialize_Component
+ (N => N,
+ Comp => Comp_Expr,
+ Comp_Typ => Etype (Selector),
+ Init_Expr => Expression (Comp),
+ Stmts => L);
+ else
+ Initialize_Component
+ (N => N,
+ Comp => Comp_Expr,
+ Comp_Typ => Etype (Selector),
+ Init_Expr => Expr_Q,
+ Stmts => L);
+ end if;
end if;
-- comment would be good here ???
when CE_Tag_Check_Failed =>
Add_Str_To_Name_Buffer ("CE_Tag_Check");
+ when PE_Abstract_Type_Component =>
+ Add_Str_To_Name_Buffer ("PE_Abstract_Type_Component");
when PE_Access_Before_Elaboration =>
Add_Str_To_Name_Buffer ("PE_Access_Before_Elaboration");
when PE_Accessibility_Check_Failed =>
--------------------
function Init_Component return List_Id is
- Comp : Node_Id;
+ Comp : Node_Id;
+ Result : List_Id;
begin
Comp :=
if Has_Default_Aspect (A_Type) then
Set_Assignment_OK (Comp);
- return New_List (
+ Result := New_List (
Make_Assignment_Statement (Loc,
Name => Comp,
Expression =>
elsif Comp_Simple_Init then
Set_Assignment_OK (Comp);
- return New_List (
+ Result := New_List (
Make_Assignment_Statement (Loc,
Name => Comp,
Expression =>
else
Clean_Task_Names (Comp_Type, Proc_Id);
- return
+ Result :=
Build_Initialization_Call
(N => Nod,
Id_Ref => Comp,
In_Init_Proc => True,
Enclos_Type => A_Type);
end if;
+
+ -- Raise Program_Error in the init procedure of arrays when the type
+ -- of their components is a mutably tagged abstract class-wide type.
+
+ if Is_Class_Wide_Equivalent_Type (Component_Type (A_Type))
+ and then Is_Abstract_Type (Comp_Type)
+ then
+ Append_To (Result,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Abstract_Type_Component));
+ end if;
+
+ return Result;
end Init_Component;
------------------------
Make_Tag_Assignment_From_Type
(Loc, Make_Identifier (Loc, Name_uInit), Rec_Type));
+ -- Ensure that Program_Error is raised if a mutably class-wide
+ -- abstract tagged type is initialized by default.
+
+ if Is_Abstract_Type (Rec_Type)
+ and then Is_Mutably_Tagged_Type (Class_Wide_Type (Rec_Type))
+ then
+ Append_To (Init_Tags_List,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Abstract_Type_Component));
+ end if;
+
-- Ada 2005 (AI-251): Initialize the secondary tags components
-- located at fixed positions (tags whose position depends on
-- variable size components are initialized later ---see below)
-- Explicit initialization
if Present (Expression (Decl)) then
+
+ -- Ensure that the type of the expression initializing a
+ -- mutably tagged class-wide type component is frozen.
+
+ if Nkind (Expression (Decl)) = N_Qualified_Expression
+ and then Is_Class_Wide_Equivalent_Type (Etype (Id))
+ then
+ Freeze_Before (N, Etype (Expression (Decl)));
+ end if;
+
if Is_CPP_Constructor_Call (Expression (Decl)) then
Actions :=
Build_Initialization_Call
Discr_Map => Discr_Map,
Init_Control_Actual => Init_Control_Actual);
+ if Is_Mutably_Tagged_CW_Equivalent_Type (Etype (Id))
+ and then not Is_Parent
+ and then Is_Abstract_Type (Typ)
+ then
+ Append_To (Init_Call_Stmts,
+ Make_Raise_Program_Error (Comp_Loc,
+ Reason => PE_Abstract_Type_Component));
+ end if;
+
if Is_Parent then
-- This is tricky. At first it looks like
-- we are going to end up with nested
if Present (Expression (Comp_Decl))
or else Has_Non_Null_Base_Init_Proc (Typ)
or else Component_Needs_Simple_Initialization (Typ)
+
+ -- Mutably tagged class-wide types require the init-proc since
+ -- it takes care of their default initialization.
+
+ or else Is_Mutably_Tagged_CW_Equivalent_Type (Typ)
then
return True;
end if;
(File : System.Address; Line : Integer);
procedure Rcheck_CE_Tag_Check
(File : System.Address; Line : Integer);
+ procedure Rcheck_PE_Abstract_Type_Component
+ (File : System.Address; Line : Integer);
procedure Rcheck_PE_Access_Before_Elaboration
(File : System.Address; Line : Integer);
procedure Rcheck_PE_Accessibility_Check
"__gnat_rcheck_CE_Range_Check");
pragma Export (C, Rcheck_CE_Tag_Check,
"__gnat_rcheck_CE_Tag_Check");
+ pragma Export (C, Rcheck_PE_Abstract_Type_Component,
+ "__gnat_rcheck_PE_Abstract_Type_Component");
pragma Export (C, Rcheck_PE_Access_Before_Elaboration,
"__gnat_rcheck_PE_Access_Before_Elaboration");
pragma Export (C, Rcheck_PE_Accessibility_Check,
pragma No_Return (Rcheck_CE_Partition_Check);
pragma No_Return (Rcheck_CE_Range_Check);
pragma No_Return (Rcheck_CE_Tag_Check);
+ pragma No_Return (Rcheck_PE_Abstract_Type_Component);
pragma No_Return (Rcheck_PE_Access_Before_Elaboration);
pragma No_Return (Rcheck_PE_Accessibility_Check);
pragma No_Return (Rcheck_PE_Address_Of_Intrinsic);
"expected_throw");
pragma Machine_Attribute (Rcheck_CE_Tag_Check,
"expected_throw");
+ pragma Machine_Attribute (Rcheck_PE_Abstract_Type_Component,
+ "expected_throw");
pragma Machine_Attribute (Rcheck_PE_Access_Before_Elaboration,
"expected_throw");
pragma Machine_Attribute (Rcheck_PE_Accessibility_Check,
"strub", "callable");
pragma Machine_Attribute (Rcheck_CE_Tag_Check,
"strub", "callable");
+ pragma Machine_Attribute (Rcheck_PE_Abstract_Type_Component,
+ "strub", "callable");
pragma Machine_Attribute (Rcheck_PE_Access_Before_Elaboration,
"strub", "callable");
pragma Machine_Attribute (Rcheck_PE_Accessibility_Check,
Rmsg_36 : constant String := "stream operation not allowed" & NUL;
Rmsg_37 : constant String := "build-in-place mismatch" & NUL;
Rmsg_38 : constant String := "raise check failed" & NUL;
+ Rmsg_39 : constant String := "initialization of abstract type" &
+ " component not allowed" & NUL;
---------
-- AAA --
Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_13'Address);
end Rcheck_CE_Tag_Check;
+ procedure Rcheck_PE_Abstract_Type_Component
+ (File : System.Address; Line : Integer)
+ is
+ begin
+ Raise_Program_Error_Msg (File, Line, Rmsg_39'Address);
+ end Rcheck_PE_Abstract_Type_Component;
+
procedure Rcheck_PE_Access_Before_Elaboration
(File : System.Address; Line : Integer)
is
& "has unknown discriminants", N, Typ);
end if;
- if Has_Unknown_Discriminants (Typ)
+ -- Mutably tagged class-wide types do not have discriminants;
+ -- however, all class-wide types are considered to have unknown
+ -- discriminants.
+
+ if not Is_Mutably_Tagged_Type (Typ)
+ and then Has_Unknown_Discriminants (Typ)
and then Present (Underlying_Record_View (Typ))
then
Discrim := First_Discriminant (Underlying_Record_View (Typ));
-- STEP 4: Set the Etype of the record aggregate
if Has_Discriminants (Typ)
- or else (Has_Unknown_Discriminants (Typ)
+
+ -- Handle types with unknown discriminants, excluding mutably tagged
+ -- class-wide types because, although they do not have discriminants,
+ -- all class-wide types are considered to have unknown discriminants.
+
+ or else (not Is_Mutably_Tagged_Type (Typ)
+ and then Has_Unknown_Discriminants (Typ)
and then Present (Underlying_Record_View (Typ)))
then
Build_Constrained_Itype (N, Typ, New_Assoc_List);
if Null_Present (Record_Def) then
null;
- elsif not Has_Unknown_Discriminants (Typ) then
+ -- Explicitly add here mutably class-wide types because they do
+ -- not have discriminants; however, all class-wide types are
+ -- considered to have unknown discriminants.
+
+ elsif not Has_Unknown_Discriminants (Typ)
+ or else Is_Mutably_Tagged_Type (Typ)
+ then
Gather_Components
(Base_Type (Typ),
Component_List (Record_Def),
Set_Has_Self_Reference (N);
elsif Needs_Simple_Initialization (Ctyp)
+
+ -- Mutably tagged class-wide type components are initialized
+ -- by the expander calling their IP subprogram.
+
+ or else Is_Mutably_Tagged_CW_Equivalent_Type (Ctyp)
or else Has_Non_Null_Base_Init_Proc (Ctyp)
or else not Expander_Active
then
then
return True;
- -- Mutably tagged types require default initialization
-
- elsif Is_Mutably_Tagged_CW_Equivalent_Type (Typ) then
- return True;
-
-- If Initialize/Normalize_Scalars is in effect, string objects also
-- need initialization, unless they are created in the course of
-- expanding an aggregate (since in the latter case they will be
SE_Object_Too_Large, -- 35
PE_Stream_Operation_Not_Allowed, -- 36
PE_Build_In_Place_Mismatch, -- 37
- PE_Raise_Check_Failed); -- 38
+ PE_Raise_Check_Failed, -- 38
+ PE_Abstract_Type_Component); -- 39
pragma Convention (C, RT_Exception_Code);
Last_Reason_Code : constant :=
CE_Range_Check_Failed => CE_Reason,
CE_Tag_Check_Failed => CE_Reason,
+ PE_Abstract_Type_Component => PE_Reason,
PE_Access_Before_Elaboration => PE_Reason,
PE_Accessibility_Check_Failed => PE_Reason,
PE_Address_Of_Intrinsic => PE_Reason,
SE_Object_Too_Large = 35,
PE_Stream_Operation_Not_Allowed = 36,
PE_Build_In_Place_Mismatch = 37,
- PE_Raise_Check_Failed = 38
+ PE_Raise_Check_Failed = 38,
+ PE_Abstract_Type_Component = 39
};
-#define LAST_REASON_CODE 38
+#define LAST_REASON_CODE 39
projects / thirdparty / gcc.git / commitdiff
