+2009-07-13 Emmanuel Briot <briot@adacore.com>
+
+ * prj-err.adb (Error_Msg): One more case where a message should be
+ considered as a warning.
+
+ * gnatcmd.adb (GNATCmd): Fix previous change, which negated a test.
+
+2009-07-13 Thomas Quinot <quinot@adacore.com>
+
+ * exp_dist.adb (Expand_All_Calls_Remote_Subprogram_Call): Analyze
+ calling stubs in the (library level) scope of the RCI locator, where it
+ is attached, not in the caller's scope.
+
+2009-07-13 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): In case of class-wide
+ interface object declarations we delay the generation of the equivalent
+ record type declarations until its expansion because there are cases in
+ which they are not required.
+
+ * sem_util.adb (Implements_Interface): Add missing support for subtypes.
+
+ * sem_disp.adb (Check_Controlling_Formals): Minor code cleanup plus
+ addition of assertion.
+
+ * exp_util.adb (Expand_Subtype_From_Expr): Renamings of class-wide
+ interface types require no equivalent constrained type declarations
+ because the expanded code only references the tag component associated
+ with the interface.
+ (Find_Interface_Tag): Improve management of interfaces that are
+ ancestors of tagged types.
+
+ * exp_ch3.adb (Expand_N_Object_Declaration): Improve the expansion of
+ class-wide object declarations to add missing support to statically
+ displace the pointer to the object to reference the tag component
+ associated with the interface.
+
+ * exp_disp.adb (Make_Tags) Avoid generation of internally generated
+ auxiliary types associated with user-defined dispatching calls if the
+ type has no user-defined primitives.
+
2009-07-13 Vasiliy Fofanov <fofanov@adacore.com>
* mingw32.h: Make it explicit that we need XP or later.
return;
+ -- Ada 2005 (AI-251): Rewrite the expression that initializes a
+ -- class-wide object to ensure that we copy the full object,
+ -- unless we are targetting a VM where interfaces are handled by
+ -- VM itself. Note that if the root type of Typ is an ancestor
+ -- of Expr's type, both types share the same dispatch table and
+ -- there is no need to displace the pointer.
+
+ elsif Comes_From_Source (N)
+ and then Is_Interface (Typ)
+ then
+ pragma Assert (Is_Class_Wide_Type (Typ));
+
+ if Tagged_Type_Expansion then
+ declare
+ Iface : constant Entity_Id := Root_Type (Typ);
+ Expr_N : Node_Id := Expr;
+ Expr_Typ : Entity_Id;
+
+ Decl_1 : Node_Id;
+ Decl_2 : Node_Id;
+ New_Expr : Node_Id;
+
+ begin
+ -- If the original node of the expression was a conversion
+ -- to this specific class-wide interface type then we
+ -- restore the original node to generate code that
+ -- statically displaces the pointer to the interface
+ -- component.
+
+ if not Comes_From_Source (Expr_N)
+ and then Nkind (Expr_N) = N_Unchecked_Type_Conversion
+ and then Nkind (Original_Node (Expr_N)) = N_Type_Conversion
+ and then Etype (Original_Node (Expr_N)) = Typ
+ then
+ Rewrite (Expr_N, Original_Node (Expression (N)));
+ end if;
+
+ -- Avoid expansion of redundant interface conversion
+
+ if Is_Interface (Etype (Expr_N))
+ and then Nkind (Expr_N) = N_Type_Conversion
+ and then Etype (Expr_N) = Typ
+ then
+ Expr_N := Expression (Expr_N);
+ Set_Expression (N, Expr_N);
+ end if;
+
+ Expr_Typ := Base_Type (Etype (Expr_N));
+
+ if Is_Class_Wide_Type (Expr_Typ) then
+ Expr_Typ := Root_Type (Expr_Typ);
+ end if;
+
+ -- Replace
+ -- CW : I'Class := Obj;
+ -- by
+ -- Tmp : T := Obj;
+ -- CW : I'Class renames TiC!(Tmp.I_Tag);
+
+ if Comes_From_Source (Expr_N)
+ and then Nkind (Expr_N) = N_Identifier
+ and then not Is_Interface (Expr_Typ)
+ and then (Expr_Typ = Etype (Expr_Typ)
+ or else not
+ Is_Variable_Size_Record (Etype (Expr_Typ)))
+ then
+ Decl_1 :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D')),
+ Object_Definition =>
+ New_Occurrence_Of (Expr_Typ, Loc),
+ Expression =>
+ Unchecked_Convert_To (Expr_Typ,
+ Relocate_Node (Expr_N)));
+
+ -- Statically reference the tag associated with the
+ -- interface
+
+ Decl_2 :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D')),
+ Subtype_Mark =>
+ New_Occurrence_Of (Typ, Loc),
+ Name =>
+ Unchecked_Convert_To (Typ,
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (Defining_Identifier (Decl_1), Loc),
+ Selector_Name =>
+ New_Reference_To
+ (Find_Interface_Tag (Expr_Typ, Iface),
+ Loc))));
+
+ -- General case:
+
+ -- Replace
+ -- IW : I'Class := Obj;
+ -- by
+ -- type Equiv_Record is record ... end record;
+ -- implicit subtype CW is <Class_Wide_Subtype>;
+ -- Temp : CW := CW!(Obj'Address);
+ -- IW : I'Class renames Displace (Temp, I'Tag);
+
+ else
+ -- Generate the equivalent record type
+
+ Expand_Subtype_From_Expr
+ (N => N,
+ Unc_Type => Typ,
+ Subtype_Indic => Object_Definition (N),
+ Exp => Expression (N));
+
+ if not Is_Interface (Etype (Expression (N))) then
+ New_Expr := Relocate_Node (Expression (N));
+ else
+ New_Expr :=
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Expression (N)),
+ Attribute_Name => Name_Address)));
+ end if;
+
+ Decl_1 :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D')),
+ Object_Definition =>
+ New_Occurrence_Of
+ (Etype (Object_Definition (N)), Loc),
+ Expression =>
+ Unchecked_Convert_To
+ (Etype (Object_Definition (N)), New_Expr));
+
+ Decl_2 :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('D')),
+ Subtype_Mark =>
+ New_Occurrence_Of (Typ, Loc),
+ Name =>
+ Unchecked_Convert_To (Typ,
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Displace), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (Defining_Identifier (Decl_1), Loc),
+ Attribute_Name => Name_Address),
+
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Reference_To
+ (Node
+ (First_Elmt
+ (Access_Disp_Table (Iface))),
+ Loc))))))));
+ end if;
+
+ Insert_Action (N, Decl_1);
+ Rewrite (N, Decl_2);
+ Analyze (N);
+
+ -- Replace internal identifier of Decl_2 by the identifier
+ -- found in the sources. We also have to exchange entities
+ -- containing their defining identifiers to ensure the
+ -- correct replacement of the object declaration by this
+ -- object renaming declaration (because such definings
+ -- identifier have been previously added by Enter_Name to
+ -- the current scope). We must preserve the homonym chain
+ -- of the source entity as well.
+
+ Set_Chars (Defining_Identifier (N), Chars (Def_Id));
+ Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
+ Exchange_Entities (Defining_Identifier (N), Def_Id);
+ end;
+ end if;
+
+ return;
+
else
-- In most cases, we must check that the initial value meets any
-- constraint imposed by the declared type. However, there is one
end if;
end if;
- -- Ada 2005 (AI-251): Rewrite the expression that initializes a
- -- class-wide object to ensure that we copy the full object,
- -- unless we are targetting a VM where interfaces are handled by
- -- VM itself. Note that if the root type of Typ is an ancestor
- -- of Expr's type, both types share the same dispatch table and
- -- there is no need to displace the pointer.
-
- -- Replace
- -- CW : I'Class := Obj;
- -- by
- -- Temp : I'Class := I'Class (Base_Address (Obj'Address));
- -- CW : I'Class renames Displace (Temp, I'Tag);
-
- if Is_Interface (Typ)
- and then Is_Class_Wide_Type (Typ)
- and then
- (Is_Class_Wide_Type (Etype (Expr))
- or else
- not Is_Ancestor (Root_Type (Typ), Etype (Expr)))
- and then Comes_From_Source (Def_Id)
- and then Tagged_Type_Expansion
- then
- declare
- Decl_1 : Node_Id;
- Decl_2 : Node_Id;
-
- begin
- Decl_1 :=
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('D')),
-
- Object_Definition =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of
- (Root_Type (Etype (Def_Id)), Loc),
- Attribute_Name => Name_Class),
-
- Expression =>
- Unchecked_Convert_To
- (Class_Wide_Type (Root_Type (Etype (Def_Id))),
- Make_Explicit_Dereference (Loc,
- Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Base_Address),
- Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => Relocate_Node (Expr),
- Attribute_Name => Name_Address)))))));
-
- Insert_Action (N, Decl_1);
-
- Decl_2 :=
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('D')),
-
- Subtype_Mark =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of
- (Root_Type (Etype (Def_Id)), Loc),
- Attribute_Name => Name_Class),
-
- Name =>
- Unchecked_Convert_To (
- Class_Wide_Type (Root_Type (Etype (Def_Id))),
- Make_Explicit_Dereference (Loc,
- Unchecked_Convert_To (RTE (RE_Tag_Ptr),
- Make_Function_Call (Loc,
- Name =>
- New_Reference_To (RTE (RE_Displace), Loc),
-
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Reference_To
- (Defining_Identifier (Decl_1), Loc),
- Attribute_Name => Name_Address),
-
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To
- (Node
- (First_Elmt
- (Access_Disp_Table
- (Root_Type (Typ)))),
- Loc))))))));
-
- Rewrite (N, Decl_2);
- Analyze (N);
-
- -- Replace internal identifier of Decl_2 by the identifier
- -- found in the sources. We also have to exchange entities
- -- containing their defining identifiers to ensure the
- -- correct replacement of the object declaration by this
- -- object renaming declaration (because such definings
- -- identifier have been previously added by Enter_Name to
- -- the current scope). We must preserve the homonym chain
- -- of the source entity as well.
-
- Set_Chars (Defining_Identifier (N), Chars (Def_Id));
- Set_Homonym (Defining_Identifier (N), Homonym (Def_Id));
- Exchange_Entities (Defining_Identifier (N), Def_Id);
-
- return;
- end;
- end if;
-
-- If the type is controlled and not inherently limited, then
-- the target is adjusted after the copy and attached to the
-- finalization list. However, no adjustment is done in the case
end loop;
end if;
- -- 3) At the end of Access_Disp_Table we add the entity of an access
- -- type declaration. It is used by Build_Get_Prim_Op_Address to
- -- expand dispatching calls through the primary dispatch table.
+ -- 3) At the end of Access_Disp_Table, if the type has user-defined
+ -- primitives, we add the entity of an access type declaration that
+ -- is used by Build_Get_Prim_Op_Address to expand dispatching calls
+ -- through the primary dispatch table.
+
+ if UI_To_Int (DT_Entry_Count (First_Tag_Component (Typ))) = 0 then
+ Analyze_List (Result);
-- Generate:
-- type Typ_DT is array (1 .. Nb_Prims) of Prim_Ptr;
-- type Typ_DT_Acc is access Typ_DT;
- declare
- Name_DT_Prims : constant Name_Id :=
- New_External_Name (Tname, 'G');
- Name_DT_Prims_Acc : constant Name_Id :=
- New_External_Name (Tname, 'H');
- DT_Prims : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_DT_Prims);
- DT_Prims_Acc : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Name_DT_Prims_Acc);
- begin
- Append_To (Result,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => DT_Prims,
- Type_Definition =>
- Make_Constrained_Array_Definition (Loc,
- Discrete_Subtype_Definitions => New_List (
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound => Make_Integer_Literal (Loc,
- DT_Entry_Count
- (First_Tag_Component (Typ))))),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Subtype_Indication =>
- New_Reference_To (RTE (RE_Prim_Ptr), Loc)))));
+ else
+ declare
+ Name_DT_Prims : constant Name_Id :=
+ New_External_Name (Tname, 'G');
+ Name_DT_Prims_Acc : constant Name_Id :=
+ New_External_Name (Tname, 'H');
+ DT_Prims : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Name_DT_Prims);
+ DT_Prims_Acc : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Name_DT_Prims_Acc);
+ begin
+ Append_To (Result,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => DT_Prims,
+ Type_Definition =>
+ Make_Constrained_Array_Definition (Loc,
+ Discrete_Subtype_Definitions => New_List (
+ Make_Range (Loc,
+ Low_Bound => Make_Integer_Literal (Loc, 1),
+ High_Bound => Make_Integer_Literal (Loc,
+ DT_Entry_Count
+ (First_Tag_Component (Typ))))),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Subtype_Indication =>
+ New_Reference_To (RTE (RE_Prim_Ptr), Loc)))));
- Append_To (Result,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => DT_Prims_Acc,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (DT_Prims, Loc))));
+ Append_To (Result,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => DT_Prims_Acc,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (DT_Prims, Loc))));
- Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
+ Append_Elmt (DT_Prims_Acc, Access_Disp_Table (Typ));
- -- Analyze the resulting list and suppress the generation of the
- -- Init_Proc associated with the above array declaration because
- -- we never use such type in object declarations; this type is only
- -- used to simplify the expansion associated with dispatching calls.
+ -- Analyze the resulting list and suppress the generation of the
+ -- Init_Proc associated with the above array declaration because
+ -- this type is never used in object declarations. It is only used
+ -- to simplify the expansion associated with dispatching calls.
- Analyze_List (Result);
- Set_Suppress_Init_Proc (Base_Type (DT_Prims));
+ Analyze_List (Result);
+ Set_Suppress_Init_Proc (Base_Type (DT_Prims));
- -- Mark entity of dispatch table. Required by the backend to handle
- -- the properly.
+ -- Mark entity of dispatch table. Required by the back end to
+ -- handle them properly.
- Set_Is_Dispatch_Table_Entity (DT_Prims);
- end;
+ Set_Is_Dispatch_Table_Entity (DT_Prims);
+ end;
+ end if;
Set_Ekind (DT_Ptr, E_Constant);
Set_Is_Tag (DT_Ptr);
---------------------------------------------
procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
Called_Subprogram : constant Entity_Id := Entity (Name (N));
RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
- Loc : constant Source_Ptr := Sloc (N);
- RCI_Locator : Node_Id;
- RCI_Cache : Entity_Id;
+ RCI_Locator_Decl : Node_Id;
+ RCI_Locator : Entity_Id;
Calling_Stubs : Node_Id;
E_Calling_Stubs : Entity_Id;
E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
if E_Calling_Stubs = Empty then
- RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
-
- if RCI_Cache = Empty then
- RCI_Locator :=
- RCI_Package_Locator
- (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
- Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
-
- -- The RCI_Locator package is inserted at the top level in the
- -- current unit, and must appear in the proper scope, so that it
- -- is not prematurely removed by the GCC back-end.
+ RCI_Locator := RCI_Locator_Table.Get (RCI_Package);
- declare
- Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
-
- begin
- if Ekind (Scop) = E_Package_Body then
- Push_Scope (Spec_Entity (Scop));
+ -- The RCI_Locator package and calling stub are is inserted at the
+ -- top level in the current unit, and must appear in the proper scope
+ -- so that it is not prematurely removed by the GCC back end.
- elsif Ekind (Scop) = E_Subprogram_Body then
- Push_Scope
- (Corresponding_Spec (Unit_Declaration_Node (Scop)));
-
- else
- Push_Scope (Scop);
- end if;
-
- Analyze (RCI_Locator);
- Pop_Scope;
- end;
+ declare
+ Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
+ begin
+ if Ekind (Scop) = E_Package_Body then
+ Push_Scope (Spec_Entity (Scop));
+ elsif Ekind (Scop) = E_Subprogram_Body then
+ Push_Scope
+ (Corresponding_Spec (Unit_Declaration_Node (Scop)));
+ else
+ Push_Scope (Scop);
+ end if;
+ end;
- RCI_Cache := Defining_Unit_Name (RCI_Locator);
+ if RCI_Locator = Empty then
+ RCI_Locator_Decl :=
+ RCI_Package_Locator
+ (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
+ Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator_Decl);
+ Analyze (RCI_Locator_Decl);
+ RCI_Locator := Defining_Unit_Name (RCI_Locator_Decl);
else
- RCI_Locator := Parent (RCI_Cache);
+ RCI_Locator_Decl := Parent (RCI_Locator);
end if;
Calling_Stubs := Build_Subprogram_Calling_Stubs
Asynchronous => Nkind (N) = N_Procedure_Call_Statement
and then
Is_Asynchronous (Called_Subprogram),
- Locator => RCI_Cache,
+ Locator => RCI_Locator,
New_Name => New_Internal_Name ('S'));
- Insert_After (RCI_Locator, Calling_Stubs);
+ Insert_After (RCI_Locator_Decl, Calling_Stubs);
Analyze (Calling_Stubs);
+ Pop_Scope;
+
E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
end if;
Make_Subtype_From_Expr (Exp, Underlying_Record_View (Unc_Type)));
end if;
+ -- Renamings of class-wide interface types require no equivalent
+ -- constrained type declarations because we only need to reference
+ -- the tag component associated with the interface.
+
+ elsif Present (N)
+ and then Nkind (N) = N_Object_Renaming_Declaration
+ and then Is_Interface (Unc_Type)
+ then
+ pragma Assert (Is_Class_Wide_Type (Unc_Type));
+ null;
+
-- In Ada95, nothing to be done if the type of the expression is
-- limited, because in this case the expression cannot be copied,
-- and its use can only be by reference.
then
null;
- -- For limited interfaces, nothing to be done
-
- -- This branch may be redundant once the limited interface issue is
- -- sorted out???
-
- elsif Is_Interface (Exp_Typ)
- and then Is_Limited_Interface (Exp_Typ)
- then
- null;
-
-- For limited objects initialized with build in place function calls,
-- nothing to be done; otherwise we prematurely introduce an N_Reference
-- node in the expression initializing the object, which breaks the
AI : Node_Id;
begin
- -- Check if the interface is an immediate ancestor of the type and
- -- therefore shares the main tag.
+ -- This routine does not handle the case in which the interface is an
+ -- ancestor of Typ. That case is handled by the enclosing subprogram.
- if Typ = Iface then
- pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
- AI_Tag := First_Tag_Component (Typ);
- Found := True;
- return;
- end if;
+ pragma Assert (Typ /= Iface);
-- Climb to the root type handling private types
Typ := Corresponding_Record_Type (Typ);
end if;
- Find_Tag (Typ);
- pragma Assert (Found);
- return AI_Tag;
+ -- If the interface is an ancestor of the type, then it shared the
+ -- primary dispatch table.
+
+ if Is_Ancestor (Iface, Typ) then
+ pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+ return First_Tag_Component (Typ);
+
+ -- Otherwise we need to search for its associated tag component
+
+ else
+ Find_Tag (Typ);
+ pragma Assert (Found);
+ return AI_Tag;
+ end if;
end Find_Interface_Tag;
------------------
end if;
end loop;
- -- If the naming scheme of the project file is not standard,
- -- and if the file name ends with the spec suffix, then
- -- indicate to gnatstub the name of the body file with
- -- a -o switch.
+ -- If the project file naming scheme is not standard, and if
+ -- the file name ends with the spec suffix, then indicate to
+ -- gnatstub the name of the body file with a -o switch.
- if Is_Standard_GNAT_Naming (Lang.Config.Naming_Data) then
+ if not Is_Standard_GNAT_Naming (Lang.Config.Naming_Data) then
if File_Index /= 0 then
declare
Spec : constant String :=
- Base_Name (Last_Switches.Table (File_Index).all);
+ Base_Name
+ (Last_Switches.Table (File_Index).all);
Last : Natural := Spec'Last;
begin
end if;
-- For gnat check, -rules and the following switches need to be the
- -- last options. So, we move all these switches to table
- -- Rules_Switches.
+ -- last options, so move all these switches to table Rules_Switches.
if The_Command = Check then
declare
-- Let the application know there was an error
if Flags.Report_Error /= null then
- Flags.Report_Error (Project, Is_Warning => Msg (Msg'First) = '?');
+ Flags.Report_Error
+ (Project,
+ Is_Warning => Msg (Msg'First) = '?' or Msg (Msg'First) = '<');
end if;
end Error_Msg;
function Is_Progenitor
(Iface : Entity_Id;
- Typ : Entity_Id) return Boolean;
- -- Determine whether type Typ implements interface Iface. This requires
+ Typ : Entity_Id) return Boolean;
+ -- Determine whether the interface Iface is implemented by Typ. It requires
-- traversing the list of abstract interfaces of the type, as well as that
-- of the ancestor types. The predicate is used to determine when a formal
-- in the signature of an inherited operation must carry the derived type.
then
Act_T := Etype (E);
+ -- In case of class-wide interface object declarations we delay
+ -- the generation of the equivalent record type declarations until
+ -- its expansion because there are cases in they are not required.
+
+ elsif Is_Interface (T) then
+ null;
+
else
Expand_Subtype_From_Expr (N, T, Object_Definition (N), E);
Act_T := Find_Type_Of_Object (Object_Definition (N), N);
begin
Formal := First_Formal (Subp);
-
while Present (Formal) loop
Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
if Present (Ctrl_Type) then
- -- When the controlling type is concurrent and declared within a
- -- generic or inside an instance, use its corresponding record
- -- type.
+ -- When controlling type is concurrent and declared within a
+ -- generic or inside an instance use corresponding record type.
if Is_Concurrent_Type (Ctrl_Type)
and then Present (Corresponding_Record_Type (Ctrl_Type))
if Ctrl_Type = Typ then
Set_Is_Controlling_Formal (Formal);
- -- Ada 2005 (AI-231): Anonymous access types used in
+ -- Ada 2005 (AI-231): Anonymous access types that are used in
-- controlling parameters exclude null because it is necessary
-- to read the tag to dispatch, and null has no tag.
Next_Formal (Formal);
end loop;
- if Present (Etype (Subp)) then
+ if Ekind (Subp) = E_Function
+ or else
+ Ekind (Subp) = E_Generic_Function
+ then
Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
if Present (Ctrl_Type) then
else
Par := Parent (N);
-
while Present (Par) loop
-
- if (Nkind (Par) = N_Function_Call or else
- Nkind (Par) = N_Procedure_Call_Statement or else
- Nkind (Par) = N_Assignment_Statement or else
- Nkind (Par) = N_Op_Eq or else
- Nkind (Par) = N_Op_Ne)
+ if Nkind_In (Par, N_Function_Call,
+ N_Procedure_Call_Statement,
+ N_Assignment_Statement,
+ N_Op_Eq,
+ N_Op_Ne)
and then Is_Tagged_Type (Etype (Subp))
then
return;
-- Find a controlling argument, if any
if Present (Parameter_Associations (N)) then
- Actual := First_Actual (N);
-
Subp_Entity := Entity (Name (N));
- Formal := First_Formal (Subp_Entity);
+ Actual := First_Actual (N);
+ Formal := First_Formal (Subp_Entity);
while Present (Actual) loop
Control := Find_Controlling_Arg (Actual);
exit when Present (Control);
end if;
Actual := First_Actual (N);
-
while Present (Actual) loop
if Actual /= Control then
-- If the type is already frozen, the overriding is not allowed
-- except when Old_Subp is not a dispatching operation (which can
-- occur when Old_Subp was inherited by an untagged type). However,
- -- a body with no previous spec freezes the type "after" its
+ -- a body with no previous spec freezes the type *after* its
-- declaration, and therefore is a legal overriding (unless the type
-- has already been frozen). Only the first such body is legal.
then
declare
Subp_Body : constant Node_Id := Unit_Declaration_Node (Subp);
- Decl_Item : Node_Id := Next (Parent (Tagged_Type));
+ Decl_Item : Node_Id;
begin
-- ??? The checks here for whether the type has been
-- then the type has been frozen already so the overriding
-- primitive is illegal.
+ Decl_Item := Next (Parent (Tagged_Type));
while Present (Decl_Item)
and then (Decl_Item /= Subp_Body)
loop
elsif Has_Controlled_Component (Tagged_Type)
and then
(Chars (Subp) = Name_Initialize
- or else Chars (Subp) = Name_Adjust
- or else Chars (Subp) = Name_Finalize)
+ or else
+ Chars (Subp) = Name_Adjust
+ or else
+ Chars (Subp) = Name_Finalize)
then
declare
F_Node : constant Node_Id := Freeze_Node (Tagged_Type);
TSS_Deep_Finalize);
begin
- -- Remove previous controlled function, which was constructed
- -- and analyzed when the type was frozen. This requires
- -- removing the body of the redefined primitive, as well as
- -- its specification if needed (there is no spec created for
- -- Deep_Initialize, see exp_ch3.adb). We must also dismantle
- -- the exception information that may have been generated for
- -- it when front end zero-cost tables are enabled.
+ -- Remove previous controlled function which was constructed and
+ -- analyzed when the type was frozen. This requires removing the
+ -- body of the redefined primitive, as well as its specification
+ -- if needed (there is no spec created for Deep_Initialize, see
+ -- exp_ch3.adb). We must also dismantle the exception information
+ -- that may have been generated for it when front end zero-cost
+ -- tables are enabled.
for J in D_Names'Range loop
Old_P := TSS (Tagged_Type, D_Names (J));
Build_Late_Proc (Tagged_Type, Chars (Subp));
- -- The new operation is added to the actions of the freeze
- -- node for the type, but this node has already been analyzed,
- -- so we must retrieve and analyze explicitly the new body.
+ -- The new operation is added to the actions of the freeze node
+ -- for the type, but this node has already been analyzed, so we
+ -- must retrieve and analyze explicitly the new body.
if Present (F_Node)
and then Present (Actions (F_Node))
F1 := First_Formal (Proc);
F2 := First_Formal (Subp);
-
while Present (F1) and then Present (F2) loop
-
if Ekind (Etype (F1)) = E_Anonymous_Access_Type then
-
if Ekind (Etype (F2)) /= E_Anonymous_Access_Type then
return False;
-
elsif Designated_Type (Etype (F1)) = Parent_Typ
and then Designated_Type (Etype (F2)) /= Full
then
Op1 := First_Elmt (Old_Prim);
Op2 := First_Elmt (New_Prim);
-
while Present (Op1) and then Present (Op2) loop
-
if Derives_From (Node (Op1)) then
-
if No (Prev) then
-- Avoid adding it to the list of primitives if already there!
then
declare
Formal : Entity_Id;
+
begin
Formal := First_Formal (Old_Subp);
while Present (Formal) loop
-- Otherwise, update its alias and other attributes.
if Present (Alias (Old_Subp))
- and then Nkind (Unit_Declaration_Node (Old_Subp))
- /= N_Subprogram_Renaming_Declaration
+ and then Nkind (Unit_Declaration_Node (Old_Subp)) /=
+ N_Subprogram_Renaming_Declaration
then
Set_Alias (Old_Subp, Alias (Subp));
Typ := Etype (N);
if Is_Access_Type (Typ) then
- -- In the case of an Access attribute, use the type of
- -- the prefix, since in the case of an actual for an
- -- access parameter, the attribute's type may be of a
- -- specific designated type, even though the prefix
- -- type is class-wide.
+
+ -- In the case of an Access attribute, use the type of the prefix,
+ -- since in the case of an actual for an access parameter, the
+ -- attribute's type may be of a specific designated type, even
+ -- though the prefix type is class-wide.
if Nkind (N) = N_Attribute_Reference then
Typ := Etype (Prefix (N));
- -- An allocator is dispatching if the type of qualified
- -- expression is class_wide, in which case this is the
- -- controlling type.
+ -- An allocator is dispatching if the type of qualified expression
+ -- is class_wide, in which case this is the controlling type.
elsif Nkind (Orig_Node) = N_Allocator
and then Nkind (Expression (Orig_Node)) = N_Qualified_Expression
then
Typ := Etype (Expression (Orig_Node));
-
else
Typ := Designated_Type (Typ);
end if;
end if;
end if;
+ pragma Assert (not Is_Dispatching_Operation (Subp));
return Empty;
end Find_Dispatching_Type;
elsif Nkind (Actual) = N_Identifier
and then Nkind (Original_Node (Actual)) = N_Function_Call
then
- -- Call rewritten as object declaration when stack-checking
- -- is enabled. Propagate tag to expression in declaration, which
- -- is original call.
+ -- Call rewritten as object declaration when stack-checking is
+ -- enabled. Propagate tag to expression in declaration, which is
+ -- original call.
Call_Node := Expression (Parent (Entity (Actual)));
Call_Node := Expression (Actual);
end if;
- -- Do not set the Controlling_Argument if already set. This happens
- -- in the special case of _Input (see Exp_Attr, case Input).
+ -- Do not set the Controlling_Argument if already set. This happens in
+ -- the special case of _Input (see Exp_Attr, case Input).
if No (Controlling_Argument (Call_Node)) then
Set_Controlling_Argument (Call_Node, Control);
end loop;
-- Expansion of dispatching calls is suppressed when VM_Target, because
- -- the VM back-ends directly handle the generation of dispatching
- -- calls and would have to undo any expansion to an indirect call.
+ -- the VM back-ends directly handle the generation of dispatching calls
+ -- and would have to undo any expansion to an indirect call.
if Tagged_Type_Expansion then
Expand_Dispatching_Call (Call_Node);
is
Ifaces_List : Elist_Id;
Elmt : Elmt_Id;
- Iface : Entity_Id;
- Typ : Entity_Id;
+ Iface : Entity_Id := Base_Type (Iface_Ent);
+ Typ : Entity_Id := Base_Type (Typ_Ent);
begin
- if Is_Class_Wide_Type (Typ_Ent) then
- Typ := Etype (Typ_Ent);
- else
- Typ := Typ_Ent;
- end if;
-
- if Is_Class_Wide_Type (Iface_Ent) then
- Iface := Etype (Iface_Ent);
- else
- Iface := Iface_Ent;
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
end if;
if not Has_Interfaces (Typ) then
return False;
end if;
+ if Is_Class_Wide_Type (Iface) then
+ Iface := Root_Type (Iface);
+ end if;
+
Collect_Interfaces (Typ, Ifaces_List);
Elmt := First_Elmt (Ifaces_List);
projects / gcc.git / commitdiff