+2013-01-03 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch8.adb, einfo.ads, einfo.adb: Minor code reorganization.
+
+2013-01-03 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch3.adb (Make_Controlling_Function_Wrappers): Exclude
+ internal entities associated with interfaces and add minimum
+ decoration to the defining entity of the generated wrapper to
+ allow overriding interface primitives.
+ * sem_disp.ads (Override_Dispatching_Operation): Addition of a
+ new formal (Is_Wrapper).
+ * sem_disp.adb (Override_Dispatching_Operation): When overriding
+ interface primitives the new formal helps identifying that the
+ new operation is not fully decorated.
+
2013-01-03 Thomas Quinot <quinot@adacore.com>
* sem_ch7.adb, sem_ch10.adb, einfo.adb, einfo.ads, sem_ch12.adb,
return Flag127 (Id);
end Is_Valued_Procedure;
- function Is_Visible_Lib_Unit (Id : E) return B is
- begin
- return Flag116 (Id);
- end Is_Visible_Lib_Unit;
-
function Is_Visible_Formal (Id : E) return B is
begin
return Flag206 (Id);
end Is_Visible_Formal;
+ function Is_Visible_Lib_Unit (Id : E) return B is
+ begin
+ return Flag116 (Id);
+ end Is_Visible_Lib_Unit;
+
function Is_VMS_Exception (Id : E) return B is
begin
return Flag133 (Id);
Set_Flag127 (Id, V);
end Set_Is_Valued_Procedure;
- procedure Set_Is_Visible_Lib_Unit (Id : E; V : B := True) is
- begin
- Set_Flag116 (Id, V);
- end Set_Is_Visible_Lib_Unit;
-
procedure Set_Is_Visible_Formal (Id : E; V : B := True) is
begin
Set_Flag206 (Id, V);
end Set_Is_Visible_Formal;
+ procedure Set_Is_Visible_Lib_Unit (Id : E; V : B := True) is
+ begin
+ Set_Flag116 (Id, V);
+ end Set_Is_Visible_Lib_Unit;
+
procedure Set_Is_VMS_Exception (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Exception);
W ("Is_Unsigned_Type", Flag144 (Id));
W ("Is_VMS_Exception", Flag133 (Id));
W ("Is_Valued_Procedure", Flag127 (Id));
- W ("Is_Visible_Lib_Unit", Flag116 (Id));
W ("Is_Visible_Formal", Flag206 (Id));
+ W ("Is_Visible_Lib_Unit", Flag116 (Id));
W ("Is_Volatile", Flag16 (Id));
W ("Itype_Printed", Flag202 (Id));
W ("Kill_Elaboration_Checks", Flag32 (Id));
-- full details of the use of discriminals.
-- Discriminal_Link (Node10)
--- Defined in discriminals (which have an Ekind of E_In_Parameter,
--- or E_Constant), points back to corresponding discriminant.
+-- Defined in E_In_Parameter or E_Constant entities. For discriminals,
+-- points back to corresponding discriminant. For other entities, must
+-- remain Empty.
-- Discriminant_Checking_Func (Node20)
-- Defined in components. Points to the defining identifier of the
-- Is_Discriminal (synthesized)
-- Applies to all entities, true for renamings of discriminants. Such
--- entities appear as constants or in parameters.
+-- entities appear as constants or IN parameters.
-- Is_Dispatch_Table_Entity (Flag234)
-- Applies to all entities. Set to indicate to the backend that this
-- Defined in procedure entities. Set if an Import_Valued_Procedure
-- or Export_Valued_Procedure pragma applies to the procedure entity.
--- Is_Visible_Lib_Unit (Flag116)
--- Defined in all (root or child) library unit entities. Once compiled,
--- library units remain chained to the entities in the parent scope, and
--- a separate flag must be used to indicate whether the names are visible
--- by selected notation, or not.
-
-- Is_Visible_Formal (Flag206)
-- Defined in all entities. Set True for instances of the formals of a
-- formal package. Indicates that the entity must be made visible in the
-- body of the instance, to reproduce the visibility of the generic.
-- This simplifies visibility settings in instance bodies.
+-- Is_Visible_Lib_Unit (Flag116)
+-- Defined in all (root or child) library unit entities. Once compiled,
+-- library units remain chained to the entities in the parent scope, and
+-- a separate flag must be used to indicate whether the names are visible
+-- by selected notation, or not.
+
-- Is_VMS_Exception (Flag133)
-- Defined in all entities. Set only for exception entities where the
-- exception was specified in an Import_Exception or Export_Exception
-- E_Constant
-- E_Loop_Parameter
-- Current_Value (Node9) (always Empty)
- -- Discriminal_Link (Node10) (discriminals only)
+ -- Discriminal_Link (Node10)
-- Full_View (Node11)
-- Esize (Uint12)
-- Extra_Accessibility (Node13) (constants only)
function Is_Unsigned_Type (Id : E) return B;
function Is_VMS_Exception (Id : E) return B;
function Is_Valued_Procedure (Id : E) return B;
- function Is_Visible_Lib_Unit (Id : E) return B;
function Is_Visible_Formal (Id : E) return B;
+ function Is_Visible_Lib_Unit (Id : E) return B;
function Is_Volatile (Id : E) return B;
function Itype_Printed (Id : E) return B;
function Kill_Elaboration_Checks (Id : E) return B;
procedure Set_Is_Unsigned_Type (Id : E; V : B := True);
procedure Set_Is_VMS_Exception (Id : E; V : B := True);
procedure Set_Is_Valued_Procedure (Id : E; V : B := True);
- procedure Set_Is_Visible_Lib_Unit (Id : E; V : B := True);
procedure Set_Is_Visible_Formal (Id : E; V : B := True);
+ procedure Set_Is_Visible_Lib_Unit (Id : E; V : B := True);
procedure Set_Is_Volatile (Id : E; V : B := True);
procedure Set_Itype_Printed (Id : E; V : B := True);
procedure Set_Kill_Elaboration_Checks (Id : E; V : B := True);
pragma Inline (Is_Unsigned_Type);
pragma Inline (Is_VMS_Exception);
pragma Inline (Is_Valued_Procedure);
- pragma Inline (Is_Visible_Lib_Unit);
pragma Inline (Is_Visible_Formal);
+ pragma Inline (Is_Visible_Lib_Unit);
pragma Inline (Itype_Printed);
pragma Inline (Kill_Elaboration_Checks);
pragma Inline (Kill_Range_Checks);
pragma Inline (Set_Is_Unsigned_Type);
pragma Inline (Set_Is_VMS_Exception);
pragma Inline (Set_Is_Valued_Procedure);
- pragma Inline (Set_Is_Visible_Lib_Unit);
pragma Inline (Set_Is_Visible_Formal);
+ pragma Inline (Set_Is_Visible_Lib_Unit);
pragma Inline (Set_Is_Volatile);
pragma Inline (Set_Itype_Printed);
pragma Inline (Set_Kill_Elaboration_Checks);
-- Input attributes, since each type will have its own version of
-- Input constructed by the expander. The test for Comes_From_Source
-- is needed to distinguish inherited operations from renamings
- -- (which also have Alias set).
+ -- (which also have Alias set). We exclude internal entities with
+ -- Interface_Alias to avoid generating duplicated wrappers since
+ -- the primitive which covers the interface is also available in
+ -- the list of primitive operations.
-- The function may be abstract, or require_Overriding may be set
-- for it, because tests for null extensions may already have reset
if Comes_From_Source (Subp)
or else No (Alias (Subp))
+ or else Present (Interface_Alias (Subp))
or else Ekind (Subp) /= E_Function
or else not Has_Controlling_Result (Subp)
or else Is_Access_Type (Etype (Subp))
Append_To (Body_List, Func_Body);
- -- Replace the inherited function with the wrapper function
- -- in the primitive operations list.
+ -- Replace the inherited function with the wrapper function in the
+ -- primitive operations list. We add the minimum decoration needed
+ -- to override interface primitives.
+
+ Set_Ekind (Defining_Unit_Name (Func_Spec), E_Function);
Override_Dispatching_Operation
- (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec));
+ (Tag_Typ, Subp, New_Op => Defining_Unit_Name (Func_Spec),
+ Is_Wrapper => True);
end if;
<<Next_Prim>>
elsif not Is_Immediately_Visible (Uname) then
Set_Is_Visible_Lib_Unit (Uname);
- if not Private_Present (With_Clause)
- or else Private_With_OK
- then
+
+ if not Private_Present (With_Clause) or else Private_With_OK then
Set_Is_Immediately_Visible (Uname);
end if;
and then Ada_Version >= Ada_2005
then
declare
- Decl1 : constant Node_Id := Unit_Declaration_Node (P);
+ Decl1 : constant Node_Id := Unit_Declaration_Node (P);
Decl2 : Node_Id;
P2 : Entity_Id;
U2 : Entity_Id;
P2 := Scope (U2);
Decl2 := Unit_Declaration_Node (P2);
- if Is_Child_Unit (U2)
- and then Is_Visible_Lib_Unit (U2)
- then
+ if Is_Child_Unit (U2) and then Is_Visible_Lib_Unit (U2) then
if Is_Generic_Instance (P)
and then Nkind (Decl1) = N_Package_Declaration
and then Generic_Parent (Specification (Decl1)) = P2
(Is_Immediately_Visible (Scope (DT))
or else
(Is_Child_Unit (Scope (DT))
- and then Is_Visible_Lib_Unit (Scope (DT))))
+ and then Is_Visible_Lib_Unit (Scope (DT))))
then
Set_Etype (N, Available_View (DT));
(Is_Immediately_Visible (Scope (Typ))
or else
(Is_Child_Unit (Scope (Typ))
- and then Is_Visible_Lib_Unit (Scope (Typ))))
+ and then Is_Visible_Lib_Unit (Scope (Typ))))
then
return Available_View (Typ);
else
return Typ;
end if;
-
end Process_Implicit_Dereference_Prefix;
--------------------------------
if Is_New_Candidate then
if Is_Child_Unit (Id) or else P_Name = Standard_Standard then
- exit when Is_Visible_Lib_Unit (Id)
- or else Is_Immediately_Visible (Id);
-
+ exit when Is_Visible_Lib_Unit (Id);
else
- exit when not Is_Hidden (Id)
- or else Is_Immediately_Visible (Id);
+ exit when not Is_Hidden (Id);
end if;
+
+ exit when Is_Immediately_Visible (Id);
end if;
Id := Homonym (Id);
-- declares the desired entity. This error can use a
-- specialized message.
- if In_Open_Scopes (P_Name)
- and then Present (Homonym (P_Name))
- and then Is_Compilation_Unit (Homonym (P_Name))
- and then
- (Is_Immediately_Visible (Homonym (P_Name))
- or else Is_Visible_Lib_Unit (Homonym (P_Name)))
- then
+ if In_Open_Scopes (P_Name) then
declare
H : constant Entity_Id := Homonym (P_Name);
begin
- Id := First_Entity (H);
- while Present (Id) loop
- if Chars (Id) = Chars (Selector) then
- Error_Msg_Qual_Level := 99;
- Error_Msg_Name_1 := Chars (Selector);
- Error_Msg_NE
- ("% not declared in&", N, P_Name);
- Error_Msg_NE
- ("\use fully qualified name starting with"
- & " Standard to make& visible", N, H);
- Error_Msg_Qual_Level := 0;
- goto Done;
- end if;
+ if Present (H)
+ and then Is_Compilation_Unit (H)
+ and then
+ (Is_Immediately_Visible (H)
+ or else Is_Visible_Lib_Unit (H))
+ then
+ Id := First_Entity (H);
+ while Present (Id) loop
+ if Chars (Id) = Chars (Selector) then
+ Error_Msg_Qual_Level := 99;
+ Error_Msg_Name_1 := Chars (Selector);
+ Error_Msg_NE
+ ("% not declared in&", N, P_Name);
+ Error_Msg_NE
+ ("\use fully qualified name starting with "
+ & "Standard to make& visible", N, H);
+ Error_Msg_Qual_Level := 0;
+ goto Done;
+ end if;
- Next_Entity (Id);
- end loop;
+ Next_Entity (Id);
+ end loop;
+ end if;
-- If not found, standard error message
-- appear after all visible declarations in the parent entity list.
while Present (Id) loop
- if Is_Child_Unit (Id)
- and then Is_Visible_Lib_Unit (Id)
- then
+ if Is_Child_Unit (Id) and then Is_Visible_Lib_Unit (Id) then
Set_Is_Potentially_Use_Visible (Id);
end if;
Write_Str (" === ");
Write_Name (Chars (E));
Write_Eol;
-
Next_Entity (E);
end loop;
end we;
procedure Override_Dispatching_Operation
(Tagged_Type : Entity_Id;
Prev_Op : Entity_Id;
- New_Op : Entity_Id)
+ New_Op : Entity_Id;
+ Is_Wrapper : Boolean := False)
is
Elmt : Elmt_Id;
Prim : Node_Id;
-- operations that it implements (for operations inherited from the
-- parent itself, this check is made when building the derived type).
- -- Note: This code is only executed in case of late overriding
+ -- Note: This code is executed with internally generated wrappers of
+ -- functions with controlling result and late overridings.
Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
while Present (Elmt) loop
elsif Is_Subprogram (Prim)
and then Present (Interface_Alias (Prim))
and then Alias (Prim) = Prev_Op
- and then Present (Etype (New_Op))
then
Set_Alias (Prim, New_Op);
- Check_Subtype_Conformant (New_Op, Prim);
- Set_Is_Abstract_Subprogram (Prim,
- Is_Abstract_Subprogram (New_Op));
- -- Ensure that this entity will be expanded to fill the
- -- corresponding entry in its dispatch table.
+ -- No further decoration needed yet for internally generated
+ -- wrappers of controlling functions since (at this stage)
+ -- they are not yet decorated.
+
+ if not Is_Wrapper then
+ Check_Subtype_Conformant (New_Op, Prim);
+
+ Set_Is_Abstract_Subprogram (Prim,
+ Is_Abstract_Subprogram (New_Op));
- if not Is_Abstract_Subprogram (Prim) then
- Set_Has_Delayed_Freeze (Prim);
+ -- Ensure that this entity will be expanded to fill the
+ -- corresponding entry in its dispatch table.
+
+ if not Is_Abstract_Subprogram (Prim) then
+ Set_Has_Delayed_Freeze (Prim);
+ end if;
end if;
end if;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, 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- --
procedure Override_Dispatching_Operation
(Tagged_Type : Entity_Id;
Prev_Op : Entity_Id;
- New_Op : Entity_Id);
+ New_Op : Entity_Id;
+ Is_Wrapper : Boolean := False);
-- Replace an implicit dispatching operation with an explicit one.
-- Prev_Op is an inherited primitive operation which is overridden
- -- by the explicit declaration of New_Op.
+ -- by the explicit declaration of New_Op. Is_Wrapper is True when
+ -- New_Op is an internally generated wrapper of a controlling function.
procedure Propagate_Tag (Control : Node_Id; Actual : Node_Id);
-- If a function call is tag-indeterminate, its controlling argument is
projects / platform / upstream / gcc.git / commitdiff