+2009-07-10 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch3.adb (Expand_Freeze_Record_Type): Handle constructors of
+ non-tagged record types.
+
+ * sem_prag.adb
+ (Process_Import_Or_Interface): Allow the use of "pragma Import (CPP,..)"
+ with non-tagged types. Required to import C++ classes that have no
+ virtual primitives.
+ (Analyze_Pragma): For pragma CPP_Constructor. Allow the use of functions
+ returning non-tagged types. For backward compatibility, if the
+ constructor returns a class wide type we internally change the
+ returned type to the corresponding non class-wide type.
+
+ * sem_aggr.adb
+ (Valid_Ancestor_Type): CPP_Constructors code cleanup.
+ (Resolve_Extension_Aggregate): CPP_Constructors code cleanup.
+ (Resolve_Aggr_Expr): CPP_Constructors code cleanup.
+ (Resolve_Record_Aggregate): CPP_Constructors code cleanup.
+
+ * sem_ch3.adb
+ (Analyze_Object_Declaration): CPP_Constructors code cleanup.
+
+ * sem_ch5.adb (Analyze_Assignment): CPP_Constructors code cleanup.
+
+ * sem_util.adb (Is_CPP_Constructor_Call): Code cleanup.
+
+ * sem_res.adb (Resolve_Allocator): CPP_Constructors code cleanup.
+
+ * exp_ch4.adb (Expand_Allocator_Expression): CPP_Constructors code
+ cleanup.
+
+ * exp_aggr.adb (Build_Record_Aggr_Code): CPP_Constructors code clean up.
+
+ * gnat_rm.texi
+ (pragma CPP_Class): Document that it can be used now with non-tagged
+ record types.
+ (pragma CPP_Constructor): Document that it can be used now with
+ functions returning specific types. For backward compatibility
+ we also support functions returning class-wide types.
+
+ * gnat_ugn.texi
+ (Interfacing with C++ constructors): Update the examples to incorporate
+ the new syntax in which the functions used to import C++ constructors
+ return specific types.
+ (Interfacing with C++ at the Class Level): Update the examples to
+ incorporate the new syntax in which the functions used to import
+ C++ constructors return specific types.
+
2009-07-10 Thomas Quinot <quinot@adacore.com>
* exp_disp.adb (Make_Disp_Asynchronous_Select_Body,
end Gen_Ctrl_Actions_For_Aggr;
function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result;
- -- If the default expression of a component mentions a discriminant of
- -- the type, it has to be rewritten as the discriminant of the target
- -- object.
+ -- If default expression of a component mentions a discriminant of the
+ -- type, it must be rewritten as the discriminant of the target object.
function Replace_Type (Expr : Node_Id) return Traverse_Result;
-- If the aggregate contains a self-reference, traverse each expression
then
Rewrite (Expr,
Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Obj, Loc),
+ Prefix => New_Occurrence_Of (Obj, Loc),
Selector_Name => Make_Identifier (Loc, Chars (Expr))));
end if;
return OK;
-- Handle calls to C++ constructors
elsif Is_CPP_Constructor_Call (A) then
- Init_Typ := Etype (Etype (A));
+ Init_Typ := Etype (A);
Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
Set_Assignment_OK (Ref);
Instr :=
Make_OK_Assignment_Statement (Loc,
Name => Comp_Expr,
- Expression => Expr_Q);
+ Expression => Expr_Q);
Set_No_Ctrl_Actions (Instr);
Append_To (L, Instr);
Next_Component (Comp);
end loop;
+ -- Handle constructors of non-tagged CPP_Class types
+
+ if not Is_Tagged_Type (Def_Id)
+ and then Is_CPP_Class (Def_Id)
+ then
+ Set_CPP_Constructors (Def_Id);
+ end if;
+
-- Creation of the Dispatch Table. Note that a Dispatch Table is built
-- for regular tagged types as well as for Ada types deriving from a C++
-- Class, but not for tagged types directly corresponding to C++ classes
-- Allocate the object with no expression
Node := Relocate_Node (N);
- Set_Expression (Node,
- New_Reference_To (Root_Type (Etype (Exp)), Loc));
+ Set_Expression (Node, New_Reference_To (Etype (Exp), Loc));
-- Avoid its expansion to avoid generating a call to the default
-- C++ constructor
Id_Ref =>
Make_Explicit_Dereference (Loc,
Prefix => New_Reference_To (Temp, Loc)),
- Typ => Root_Type (Etype (Exp)),
+ Typ => Etype (Exp),
Constructor_Ref => Exp));
end;
@noindent
The argument denotes an entity in the current declarative region that is
-declared as a tagged record type. It indicates that the type corresponds
-to an externally declared C++ class type, and is to be laid out the same
-way that C++ would lay out the type.
+declared as a record type. It indicates that the type corresponds to an
+externally declared C++ class type, and is to be laid out the same way
+that C++ would lay out the type. If the C++ class has virtual primitives
+then the record must be declared as a tagged record type.
Types for which @code{CPP_Class} is specified do not have assignment or
equality operators defined (such operations can be imported or declared
in a pragma @code{Import} with @code{Convention} = @code{CPP}. Such name
must be of one of the following forms:
+@itemize @bullet
+@item
+@code{function @var{Fname} return @var{T}}
+
@itemize @bullet
@item
@code{function @var{Fname} return @var{T}'Class}
+@item
+@code{function @var{Fname} (@dots{}) return @var{T}}
+@end itemize
+
@item
@code{function @var{Fname} (@dots{}) return @var{T}'Class}
@end itemize
@noindent
-where @var{T} is a tagged limited type imported from C++ with pragma
+where @var{T} is a limited record type imported from C++ with pragma
@code{Import} and @code{Convention} = @code{CPP}.
-The first form is the default constructor, used when an object of type
-@var{T} is created on the Ada side with no explicit constructor. The
-second form covers all the non-default constructors of the type. See
-the GNAT users guide for details.
+The first two forms import the default constructor, used when an object
+of type @var{T} is created on the Ada side with no explicit constructor.
+The latter two forms cover all the non-default constructors of the type.
+See the GNAT users guide for details.
If no constructors are imported, it is impossible to create any objects
on the Ada side and the type is implicitly declared abstract.
using an automatic binding generator tool.
See @ref{Interfacing to C++} for more related information.
+Note: The use of functions returning class-wide types for constructors is
+currently obsolete. They are supported for backward compatibility. The
+use of functions returning the type T leave the Ada sources more clear
+because the imported C++ constructors always return an object of type T;
+that is, they never return an object whose type is a descendant of type T.
+
@node Pragma CPP_Virtual
@unnumberedsec Pragma CPP_Virtual
@cindex Interfacing to C++
function Get_Value (Obj : Root) return int;
pragma Import (CPP, Get_Value);
- function Constructor return Root'Class;
+ function Constructor return Root;
pragma Cpp_Constructor (Constructor, "_ZN4RootC1Ev");
- function Constructor (v : Integer) return Root'Class;
+ function Constructor (v : Integer) return Root;
pragma Cpp_Constructor (Constructor, "_ZN4RootC1Ei");
- function Constructor (v, w : Integer) return Root'Class;
+ function Constructor (v, w : Integer) return Root;
pragma Cpp_Constructor (Constructor, "_ZN4RootC1Eii");
end Pkg_Root;
@end smallexample
procedure Set_Owner (A : in out Dog; Name : Chars_Ptr);
pragma Import (C_Plus_Plus, Set_Owner);
- function New_Dog return Dog'Class;
+ function New_Dog return Dog;
pragma CPP_Constructor (New_Dog);
pragma Import (CPP, New_Dog, "_ZN3DogC2Ev");
end Animals;
(this : access Dog; Name : Interfaces.C.Strings.chars_ptr);
pragma Import (CPP, Set_Owner, "_ZN3Dog9Set_OwnerEPc");
- function New_Dog return Dog'Class;
+ function New_Dog return Dog;
pragma CPP_Constructor (New_Dog);
pragma Import (CPP, New_Dog, "_ZN3DogC1Ev");
end;
if Etype (Imm_Type) = Base_Type (A_Type) then
return True;
- elsif Is_CPP_Constructor_Call (A)
- and then Etype (Imm_Type) = Base_Type (Etype (A_Type))
- then
- return True;
-
-- The base type of the parent type may appear as a private
-- extension if it is declared as such in a parent unit of
-- the current one. For consistency of the subsequent analysis
if Is_Class_Wide_Type (Etype (A))
and then Nkind (Original_Node (A)) = N_Function_Call
- and then not Is_CPP_Constructor_Call (Original_Node (A))
then
-- If the ancestor part is a dispatching call, it appears
-- statically to be a legal ancestor, but it yields any
-- Check wrong use of class-wide types
- if Is_Class_Wide_Type (Etype (Expr))
- and then not Is_CPP_Constructor_Call (Expr)
- then
+ if Is_Class_Wide_Type (Etype (Expr)) then
Error_Msg_N ("dynamically tagged expression not allowed", Expr);
end if;
-- ancestors, starting with the root.
if Nkind (N) = N_Extension_Aggregate then
-
- -- Handle case where ancestor part is a C++ constructor. In
- -- this case it must be a function returning a class-wide type.
- -- If the ancestor part is a C++ constructor, then it must be a
- -- function returning a class-wide type, so handle that here.
-
- if Is_CPP_Constructor_Call (Ancestor_Part (N)) then
- pragma Assert
- (Is_Class_Wide_Type (Etype (Ancestor_Part (N))));
- Root_Typ := Root_Type (Etype (Ancestor_Part (N)));
-
- -- Normal case, not a C++ constructor
- else
- Root_Typ := Base_Type (Etype (Ancestor_Part (N)));
- end if;
+ Root_Typ := Base_Type (Etype (Ancestor_Part (N)));
else
Root_Typ := Root_Type (Typ);
if (Is_Class_Wide_Type (Etype (E)) or else Is_Dynamically_Tagged (E))
and then Is_Tagged_Type (T)
and then not Is_Class_Wide_Type (T)
- and then not Is_CPP_Constructor_Call (E)
then
Error_Msg_N ("dynamically tagged expression not allowed!", E);
end if;
or else (Is_Dynamically_Tagged (Rhs)
and then not Is_Access_Type (T1)))
and then not Is_Class_Wide_Type (T1)
- and then not Is_CPP_Constructor_Call (Rhs)
then
Error_Msg_N ("dynamically tagged expression not allowed!", Rhs);
with Csets; use Csets;
with Debug; use Debug;
with Einfo; use Einfo;
+with Elists; use Elists;
with Errout; use Errout;
with Exp_Dist; use Exp_Dist;
with Lib; use Lib;
elsif Is_Record_Type (Def_Id)
and then C = Convention_CPP
then
- if not Is_Tagged_Type (Def_Id) then
- Error_Msg_Sloc := Sloc (Def_Id);
- Error_Pragma_Arg ("imported 'C'P'P type must be tagged", Arg2);
-
- else
- -- Types treated as CPP classes are treated as limited, but we
- -- don't require them to be declared this way. A warning is
- -- issued to encourage the user to declare them as limited.
- -- This is not an error, for compatibility reasons, because
- -- these types have been supported this way for some time.
+ -- Types treated as CPP classes are treated as limited, but we
+ -- don't require them to be declared this way. A warning is
+ -- issued to encourage the user to declare them as limited.
+ -- This is not an error, for compatibility reasons, because
+ -- these types have been supported this way for some time.
- if not Is_Limited_Type (Def_Id) then
- Error_Msg_N
- ("imported 'C'P'P type should be " &
- "explicitly declared limited?",
- Get_Pragma_Arg (Arg2));
- Error_Msg_N
- ("\type will be considered limited",
- Get_Pragma_Arg (Arg2));
- end if;
+ if not Is_Limited_Type (Def_Id) then
+ Error_Msg_N
+ ("imported 'C'P'P type should be " &
+ "explicitly declared limited?",
+ Get_Pragma_Arg (Arg2));
+ Error_Msg_N
+ ("\type will be considered limited",
+ Get_Pragma_Arg (Arg2));
+ end if;
- Set_Is_CPP_Class (Def_Id);
- Set_Is_Limited_Record (Def_Id);
+ Set_Is_CPP_Class (Def_Id);
+ Set_Is_Limited_Record (Def_Id);
- -- Imported CPP types must not have discriminants (because C++
- -- classes do not have discriminants).
+ -- Imported CPP types must not have discriminants (because C++
+ -- classes do not have discriminants).
- if Has_Discriminants (Def_Id) then
- Error_Msg_N
- ("imported 'C'P'P type cannot have discriminants",
- First (Discriminant_Specifications
- (Declaration_Node (Def_Id))));
- end if;
+ if Has_Discriminants (Def_Id) then
+ Error_Msg_N
+ ("imported 'C'P'P type cannot have discriminants",
+ First (Discriminant_Specifications
+ (Declaration_Node (Def_Id))));
+ end if;
- -- Components of imported CPP types must not have default
- -- expressions because the constructor (if any) is in the
- -- C++ side.
+ -- Components of imported CPP types must not have default
+ -- expressions because the constructor (if any) is in the
+ -- C++ side.
- declare
- Tdef : constant Node_Id :=
- Type_Definition (Declaration_Node (Def_Id));
- Clist : Node_Id;
- Comp : Node_Id;
+ declare
+ Tdef : constant Node_Id :=
+ Type_Definition (Declaration_Node (Def_Id));
+ Clist : Node_Id;
+ Comp : Node_Id;
- begin
- if Nkind (Tdef) = N_Record_Definition then
- Clist := Component_List (Tdef);
+ begin
+ if Nkind (Tdef) = N_Record_Definition then
+ Clist := Component_List (Tdef);
- else
- pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
- Clist := Component_List (Record_Extension_Part (Tdef));
- end if;
+ else
+ pragma Assert (Nkind (Tdef) = N_Derived_Type_Definition);
+ Clist := Component_List (Record_Extension_Part (Tdef));
+ end if;
- if Present (Clist) then
- Comp := First (Component_Items (Clist));
- while Present (Comp) loop
- if Present (Expression (Comp)) then
- Error_Msg_N
- ("component of imported 'C'P'P type cannot have" &
- " default expression", Expression (Comp));
- end if;
+ if Present (Clist) then
+ Comp := First (Component_Items (Clist));
+ while Present (Comp) loop
+ if Present (Expression (Comp)) then
+ Error_Msg_N
+ ("component of imported 'C'P'P type cannot have" &
+ " default expression", Expression (Comp));
+ end if;
- Next (Comp);
- end loop;
- end if;
- end;
- end if;
+ Next (Comp);
+ end loop;
+ end if;
+ end;
else
Error_Pragma_Arg
-- [, [Link_Name =>] static_string_EXPRESSION ]);
when Pragma_CPP_Constructor => CPP_Constructor : declare
- Id : Entity_Id;
- Def_Id : Entity_Id;
+ Elmt : Elmt_Id;
+ Id : Entity_Id;
+ Def_Id : Entity_Id;
+ Tag_Typ : Entity_Id;
begin
GNAT_Pragma;
Def_Id := Entity (Id);
if Ekind (Def_Id) = E_Function
- and then Is_Class_Wide_Type (Etype (Def_Id))
- and then Is_CPP_Class (Etype (Etype (Def_Id)))
+ and then (Is_CPP_Class (Etype (Def_Id))
+ or else (Is_Class_Wide_Type (Etype (Def_Id))
+ and then
+ Is_CPP_Class (Root_Type (Etype (Def_Id)))))
then
if Arg_Count >= 2 then
Set_Imported (Def_Id);
Set_Has_Completion (Def_Id);
Set_Is_Constructor (Def_Id);
+ -- Imported C++ constructors are not dispatching primitives
+ -- because in C++ they don't have a dispatch table slot.
+ -- However, in Ada the constructor has the profile of a
+ -- function that returns a tagged type and therefore it has
+ -- been considered by the Semantic analyzer a dispatching
+ -- primitive operation. We extract it now from the list of
+ -- primitive operations of the type.
+
+ if Is_Tagged_Type (Etype (Def_Id))
+ and then not Is_Class_Wide_Type (Etype (Def_Id))
+ then
+ pragma Assert (Is_Dispatching_Operation (Def_Id));
+ Tag_Typ := Etype (Def_Id);
+
+ Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
+ while Present (Elmt)
+ and then Node (Elmt) /= Def_Id
+ loop
+ Next_Elmt (Elmt);
+ end loop;
+
+ Remove_Elmt (Primitive_Operations (Tag_Typ), Elmt);
+ Set_Is_Dispatching_Operation (Def_Id, False);
+ end if;
+
+ -- For backward compatibility, if the constructor returns a
+ -- class wide type we internally change the returned type to
+ -- the corresponding non class-wide type.
+
+ if Is_Class_Wide_Type (Etype (Def_Id)) then
+ Set_Etype (Def_Id, Root_Type (Etype (Def_Id)));
+ end if;
else
Error_Pragma_Arg
("pragma% requires function returning a 'C'P'P_Class type",
Check_Unset_Reference (Expression (E));
-- A qualified expression requires an exact match of the type,
- -- class-wide matching is not allowed. We skip this test in a call
- -- to a CPP constructor because in such case, although the function
- -- profile indicates that it returns a class-wide type, the object
- -- returned by the C++ constructor has a concrete type.
+ -- class-wide matching is not allowed.
- if Is_Class_Wide_Type (Etype (Expression (E)))
- and then Is_CPP_Constructor_Call (Expression (E))
- then
- null;
-
- elsif (Is_Class_Wide_Type (Etype (Expression (E)))
+ if (Is_Class_Wide_Type (Etype (Expression (E)))
or else Is_Class_Wide_Type (Etype (E)))
and then Base_Type (Etype (Expression (E))) /= Base_Type (Etype (E))
then
function Is_CPP_Constructor_Call (N : Node_Id) return Boolean is
begin
return Nkind (N) = N_Function_Call
- and then Is_Class_Wide_Type (Etype (N))
and then Is_CPP_Class (Etype (Etype (N)))
and then Is_Constructor (Entity (Name (N)))
and then Is_Imported (Entity (Name (N)));
projects / gcc.git / commitdiff