-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Ada 2005 (AI-251): Returns the fixed position in the dispatch table
-- of the default primitive operations.
+ function Find_Specific_Type (CW : Entity_Id) return Entity_Id;
+ -- Find specific type of a class-wide type, and handle the case of an
+ -- incomplete type coming either from a limited_with clause or from an
+ -- incomplete type declaration. Shouldn't this be in Sem_Util? It seems
+ -- like a general purpose semantic routine ???
+
function Has_DT (Typ : Entity_Id) return Boolean;
pragma Inline (Has_DT);
-- Returns true if we generate a dispatch table for tagged type Typ
CW_Typ := Class_Wide_Type (Ctrl_Typ);
end if;
- Typ := Root_Type (CW_Typ);
-
- if Ekind (Typ) = E_Incomplete_Type then
- Typ := Non_Limited_View (Typ);
- end if;
+ Typ := Find_Specific_Type (CW_Typ);
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
if Chars (E) = Name_uSize then
return Uint_1;
- elsif Chars (E) = Name_uAlignment then
- return Uint_2;
-
elsif TSS_Name = TSS_Stream_Read then
- return Uint_3;
+ return Uint_2;
elsif TSS_Name = TSS_Stream_Write then
- return Uint_4;
+ return Uint_3;
elsif TSS_Name = TSS_Stream_Input then
- return Uint_5;
+ return Uint_4;
elsif TSS_Name = TSS_Stream_Output then
- return Uint_6;
+ return Uint_5;
elsif Chars (E) = Name_Op_Eq then
- return Uint_7;
+ return Uint_6;
elsif Chars (E) = Name_uAssign then
- return Uint_8;
+ return Uint_7;
elsif TSS_Name = TSS_Deep_Adjust then
- return Uint_9;
+ return Uint_8;
elsif TSS_Name = TSS_Deep_Finalize then
- return Uint_10;
+ return Uint_9;
-- In VM targets unconditionally allow obtaining the position associated
-- with predefined interface primitives since in these platforms any
elsif Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion then
if Chars (E) = Name_uDisp_Asynchronous_Select then
- return Uint_11;
+ return Uint_10;
elsif Chars (E) = Name_uDisp_Conditional_Select then
- return Uint_12;
+ return Uint_11;
elsif Chars (E) = Name_uDisp_Get_Prim_Op_Kind then
- return Uint_13;
+ return Uint_12;
elsif Chars (E) = Name_uDisp_Get_Task_Id then
- return Uint_14;
+ return Uint_13;
elsif Chars (E) = Name_uDisp_Requeue then
- return Uint_15;
+ return Uint_14;
elsif Chars (E) = Name_uDisp_Timed_Select then
- return Uint_16;
+ return Uint_15;
end if;
end if;
end if;
-- Expand_Dispatching_Call is called directly from the semantics,
- -- so we need a check to see whether expansion is active before
- -- proceeding. In addition, there is no need to expand the call
- -- if we are compiling under restriction No_Dispatching_Calls;
- -- the semantic analyzer has previously notified the violation
- -- of this restriction.
+ -- so we only proceed if the expander is active.
+
+ if not Full_Expander_Active
+
+ -- And there is no need to expand the call if we are compiling under
+ -- restriction No_Dispatching_Calls; the semantic analyzer has
+ -- previously notified the violation of this restriction.
- if not Expander_Active
or else Restriction_Active (No_Dispatching_Calls)
then
return;
CW_Typ := Class_Wide_Type (Ctrl_Typ);
end if;
- Typ := Root_Type (CW_Typ);
-
- if Ekind (Typ) = E_Incomplete_Type then
- Typ := Non_Limited_View (Typ);
- end if;
+ Typ := Find_Specific_Type (CW_Typ);
if not Is_Limited_Type (Typ) then
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
Subp_Ptr_Typ := Create_Itype (E_Access_Subprogram_Type, Call_Node);
Set_Etype (Subp_Typ, Res_Typ);
Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
+ Set_Convention (Subp_Typ, Convention (Subp));
+
+ -- Notify gigi that the designated type is a dispatching primitive
+
+ Set_Is_Dispatch_Table_Entity (Subp_Typ);
-- Create a new list of parameters which is a copy of the old formal
-- list including the creation of a new set of matching entities.
Thunk_Id := Make_Temporary (Loc, 'T');
Set_Is_Thunk (Thunk_Id);
+ Set_Convention (Thunk_Id, Convention (Prim));
-- Procedure case
end if;
end Expand_Interface_Thunk;
+ ------------------------
+ -- Find_Specific_Type --
+ ------------------------
+
+ function Find_Specific_Type (CW : Entity_Id) return Entity_Id is
+ Typ : Entity_Id := Root_Type (CW);
+
+ begin
+ if Ekind (Typ) = E_Incomplete_Type then
+ if From_With_Type (Typ) then
+ Typ := Non_Limited_View (Typ);
+ else
+ Typ := Full_View (Typ);
+ end if;
+ end if;
+
+ return Typ;
+ end Find_Specific_Type;
+
--------------------------
-- Has_CPP_Constructors --
--------------------------
TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
.. Name_Len));
if Chars (E) = Name_uSize
- or else Chars (E) = Name_uAlignment
or else TSS_Name = TSS_Stream_Read
or else TSS_Name = TSS_Stream_Write
or else TSS_Name = TSS_Stream_Input
(Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
if Chars (E) = Name_uSize
- or else Chars (E) = Name_uAlignment
or else
(Chars (E) = Name_Op_Eq
and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
-- Start of processing for Check_Premature_Freezing
begin
+ -- Note that if the type is a (subtype of) a generic actual, the
+ -- actual will have been frozen by the instantiation.
+
if Present (N)
and then Is_Private_Type (Typ)
and then No (Full_View (Typ))
and then not Is_Generic_Type (Typ)
and then not Is_Tagged_Type (Typ)
and then not Is_Frozen (Typ)
+ and then not Is_Generic_Actual_Type (Typ)
then
Error_Msg_Sloc := Sloc (Subp);
Error_Msg_NE
end if;
-- Ensure that the value of Max_Predef_Prims defined in a-tags is
- -- correct. Valid values are 10 under configurable runtime or 16
+ -- correct. Valid values are 9 under configurable runtime or 15
-- with full runtime.
if RTE_Available (RE_Interface_Data) then
- if Max_Predef_Prims /= 16 then
+ if Max_Predef_Prims /= 15 then
Error_Msg_N ("run-time library configuration error", Typ);
return Result;
end if;
else
- if Max_Predef_Prims /= 10 then
+ if Max_Predef_Prims /= 9 then
Error_Msg_N ("run-time library configuration error", Typ);
Error_Msg_CRT ("tagged types", Typ);
return Result;
-- TSD : Type_Specific_Data (I_Depth) :=
-- (Idepth => I_Depth,
-- Access_Level => Type_Access_Level (Typ),
+ -- Alignment => Typ'Alignment,
-- Expanded_Name => Cstring_Ptr!(Exname'Address))
-- External_Tag => Cstring_Ptr!(Exname'Address))
-- HT_Link => HT_Link'Address,
-- Transportable => <<boolean-value>>,
-- Type_Is_Abstract => <<boolean-value>>,
-- Needs_Finalization => <<boolean-value>>,
- -- [ Size_Func => Size_Prim'Access ]
- -- [ Interfaces_Table => <<access-value>> ]
+ -- [ Size_Func => Size_Prim'Access, ]
+ -- [ Interfaces_Table => <<access-value>>, ]
-- [ SSD => SSD_Table'Address ]
-- Tags_Table => (0 => null,
-- 1 => Parent'Tag
Append_To (TSD_Aggr_List,
Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
+ -- Alignment
+
+ -- For CPP types we cannot rely on the value of 'Alignment provided
+ -- by the backend to initialize this TSD field.
+
+ if Convention (Typ) = Convention_CPP
+ or else Is_CPP_Class (Root_Type (Typ))
+ then
+ Append_To (TSD_Aggr_List,
+ Make_Integer_Literal (Loc, 0));
+ else
+ Append_To (TSD_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Alignment));
+ end if;
+
-- Expanded_Name
Append_To (TSD_Aggr_List,
Unchecked_Convert_To (RTE (RE_Cstring_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Exname, Loc),
+ Prefix => New_Reference_To (Exname, Loc),
Attribute_Name => Name_Address)));
-- External_Tag of a local tagged type
-- (Idepth => I_Depth,
-- Tag_Kind => <tag_kind-value>,
-- Access_Level => Type_Access_Level (Typ),
+ -- Alignment => Typ'Alignment,
-- HT_Link => null,
-- Type_Is_Abstract => <<boolean-value>>,
-- Type_Is_Library_Level => <<boolean-value>>,
Append_To (TSD_Aggr_List,
Make_Integer_Literal (Loc, Type_Access_Level (Typ)));
+ -- Alignment
+
+ -- For CPP types we cannot rely on the value of 'Alignment provided
+ -- by the backend to initialize this TSD field. Why not???
+
+ if Convention (Typ) = Convention_CPP
+ or else Is_CPP_Class (Root_Type (Typ))
+ then
+ Append_To (TSD_Aggr_List,
+ Make_Integer_Literal (Loc, 0));
+ else
+ Append_To (TSD_Aggr_List,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Typ, Loc),
+ Attribute_Name => Name_Alignment));
+ end if;
+
-- HT_Link
Append_To (TSD_Aggr_List,
Make_Aggregate (Loc,
Expressions => New_List (
- -- Iface_Tag
+ -- Iface_Tag
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Iface, Loc),
Attribute_Name => Name_Tag),
- -- OSD
+ -- OSD
Make_OSD (Iface))));
Append_To (TSD_Aggr_List,
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (SSD, Loc),
+ Prefix => New_Reference_To (SSD, Loc),
Attribute_Name => Name_Unchecked_Access));
else
Append_To (TSD_Aggr_List, Make_Null (Loc));
Append_To (TSD_Tags_List,
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Typ, Loc),
+ Prefix => New_Reference_To (Typ, Loc),
Attribute_Name => Name_Tag));
-- Fill the rest of the table with the tags of the ancestors
Append_To (TSD_Tags_List,
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Parent_Typ, Loc),
+ Prefix => New_Reference_To (Parent_Typ, Loc),
Attribute_Name => Name_Tag));
Pos := Pos + 1;
else
Tag_Node :=
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Typ, Loc),
+ Prefix => New_Reference_To (Typ, Loc),
Attribute_Name => Name_Tag);
end if;
else
Tag_Node :=
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Typ, Loc),
+ Prefix => New_Reference_To (Typ, Loc),
Attribute_Name => Name_Tag);
end if;
Defining_Identifier => DT_Ptr,
Constant_Present => True,
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
- Expression =>
+ Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
- Prefix => New_Reference_To (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
-- Generate the SCIL node for the previous object declaration
Make_Object_Declaration (Loc,
Defining_Identifier => Predef_Prims_Ptr,
Constant_Present => True,
- Object_Definition => New_Reference_To
- (RTE (RE_Address), Loc),
- Expression =>
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Address), Loc),
+ Expression =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
- Prefix => New_Reference_To (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Predef_Prims), Loc)),
+ Prefix => New_Reference_To (DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Predef_Prims), Loc)),
Attribute_Name => Name_Address)));
-- No dispatch table required
Defining_Identifier => DT_Ptr,
Constant_Present => True,
Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
- Expression =>
+ Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
Prefix => New_Reference_To (DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_NDT_Prims_Ptr),
+ Loc)),
Attribute_Name => Name_Address))));
end if;
Constant_Present => True,
Object_Definition => New_Reference_To
(RTE (RE_Interface_Tag), Loc),
- Expression =>
+ Expression =>
Unchecked_Convert_To (RTE (RE_Interface_Tag),
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
Make_Selected_Component (Loc,
- Prefix => New_Reference_To (Iface_DT, Loc),
- Selector_Name =>
- New_Occurrence_Of
- (RTE_Record_Component (RE_Prims_Ptr), Loc)),
+ Prefix =>
+ New_Reference_To (Iface_DT, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (RTE_Record_Component (RE_Prims_Ptr),
+ Loc)),
Attribute_Name => Name_Address))));
end if;
Address_Node =>
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Prim, Loc),
+ Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Unrestricted_Access))));
-- Register copy of the pointer to the 'size primitive in the TSD
Address_Node =>
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Prim, Loc),
+ Prefix => New_Reference_To (Prim, Loc),
Attribute_Name => Name_Unrestricted_Access))));
end if;
end if;
Address_Node =>
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Alias (Prim), Loc),
+ Prefix =>
+ New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
else
Address_Node =>
Unchecked_Convert_To (RTE (RE_Prim_Ptr),
Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Alias (Prim), Loc),
+ Prefix =>
+ New_Reference_To (Alias (Prim), Loc),
Attribute_Name => Name_Unrestricted_Access))));
end if;
Set_Init_Proc (Typ, Init);
Set_Is_Imported (Init);
+ Set_Is_Constructor (Init);
Set_Interface_Name (Init, Interface_Name (E));
- Set_Convention (Init, Convention_C);
+ Set_Convention (Init, Convention_CPP);
Set_Is_Public (Init);
Set_Has_Completion (Init);
end if;
Parameter_Specifications => Parms));
Set_Is_Imported (Constructor_Id);
+ Set_Is_Constructor (Constructor_Id);
Set_Interface_Name (Constructor_Id, Interface_Name (E));
- Set_Convention (Constructor_Id, Convention_C);
+ Set_Convention (Constructor_Id, Convention_CPP);
Set_Is_Public (Constructor_Id);
Set_Has_Completion (Constructor_Id);
OSDN Git Service
