+2010-09-09 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch3.adb (Derive_Subprogram): The code that checks if a
+ dispatching primitive covers some interface primitive is incomplete.
+ Replace such code by the invocation of a new subprogram that provides
+ this functionality.
+ * sem_ch6.ads (Is_Interface_Conformant): Add missing documentation.
+ * sem_ch6.adb (Check_Missing_Return): Minor reformating
+ (Check_Convention): Complete if-statement conditition when reporting
+ errors (to avoid assertion failure).
+ * sem_ch13.adb (Make_Null_Procedure_Specs): This routine was previously
+ located in exp_ch3. Relocated inside Analyze_Freeze_Entity.
+ (Analyze_Freeze_Entity): Invoke routine that adds the spec of non
+ overridden null interface primitives.
+ * sem_type.adb (Is_Ancestor): If the parent of the partial view of a
+ private type is an interface then use the parent of its full view to
+ climb to its ancestor type.
+ * sem_disp.ads, sem_disp.adb (Covers_Some_Interface): New subprogram.
+ (Check_Dispatching_Operation): Extend assertion to handle wrappers of
+ null interface primitives.
+ (Is_Null_Interface_Primitive): New subprogram.
+ * exp_ch3.adb (Make_Null_Procedure_Specs): Removed.
+ (Expand_Freeze_Record_Type): Do not generate specs of null interface
+ subprograms because they are now generated by Analyze_Freeze_Entity.
+
2010-09-09 Robert Dewar <dewar@adacore.com>
* a-calfor.adb, sem_ch3.adb: Minor reformatting.
-- invoking the inherited subprogram's parent subprogram and extended
-- with a null association list.
- procedure Make_Null_Procedure_Specs
- (Tag_Typ : Entity_Id;
- Decl_List : out List_Id);
- -- Ada 2005 (AI-251): Makes specs for null procedures associated with any
- -- null procedures inherited from an interface type that have not been
- -- overridden. Only one null procedure will be created for a given set of
- -- inherited null procedures with homographic profiles.
-
function Predef_Spec_Or_Body
(Loc : Source_Ptr;
Tag_Typ : Entity_Id;
Wrapper_Decl_List : List_Id := No_List;
Wrapper_Body_List : List_Id := No_List;
- Null_Proc_Decl_List : List_Id := No_List;
-- Start of processing for Expand_Freeze_Record_Type
Insert_List_Before_And_Analyze (N, Wrapper_Decl_List);
end if;
- -- Ada 2005 (AI-251): For a nonabstract type extension, build
- -- null procedure declarations for each set of homographic null
- -- procedures that are inherited from interface types but not
- -- overridden. This is done to ensure that the dispatch table
- -- entry associated with such null primitives are properly filled.
-
- if Ada_Version >= Ada_05
- and then Etype (Def_Id) /= Def_Id
- and then not Is_Abstract_Type (Def_Id)
- then
- Make_Null_Procedure_Specs (Def_Id, Null_Proc_Decl_List);
- Insert_Actions (N, Null_Proc_Decl_List);
- end if;
-
Set_Is_Frozen (Def_Id);
Set_All_DT_Position (Def_Id);
end if;
end Make_Eq_If;
- -------------------------------
- -- Make_Null_Procedure_Specs --
- -------------------------------
-
- procedure Make_Null_Procedure_Specs
- (Tag_Typ : Entity_Id;
- Decl_List : out List_Id)
- is
- Loc : constant Source_Ptr := Sloc (Tag_Typ);
-
- Formal : Entity_Id;
- Formal_List : List_Id;
- New_Param_Spec : Node_Id;
- Parent_Subp : Entity_Id;
- Prim_Elmt : Elmt_Id;
- Proc_Decl : Node_Id;
- Subp : Entity_Id;
-
- function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean;
- -- Returns True if E is a null procedure that is an interface primitive
-
- ---------------------------------
- -- Is_Null_Interface_Primitive --
- ---------------------------------
-
- function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is
- begin
- return Comes_From_Source (E)
- and then Is_Dispatching_Operation (E)
- and then Ekind (E) = E_Procedure
- and then Null_Present (Parent (E))
- and then Is_Interface (Find_Dispatching_Type (E));
- end Is_Null_Interface_Primitive;
-
- -- Start of processing for Make_Null_Procedure_Specs
-
- begin
- Decl_List := New_List;
- Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
- while Present (Prim_Elmt) loop
- Subp := Node (Prim_Elmt);
-
- -- If a null procedure inherited from an interface has not been
- -- overridden, then we build a null procedure declaration to
- -- override the inherited procedure.
-
- Parent_Subp := Alias (Subp);
-
- if Present (Parent_Subp)
- and then Is_Null_Interface_Primitive (Parent_Subp)
- then
- Formal_List := No_List;
- Formal := First_Formal (Subp);
-
- if Present (Formal) then
- Formal_List := New_List;
-
- while Present (Formal) loop
-
- -- Copy the parameter spec including default expressions
-
- New_Param_Spec :=
- New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
-
- -- Generate a new defining identifier for the new formal.
- -- required because New_Copy_Tree does not duplicate
- -- semantic fields (except itypes).
-
- Set_Defining_Identifier (New_Param_Spec,
- Make_Defining_Identifier (Sloc (Formal),
- Chars => Chars (Formal)));
-
- -- For controlling arguments we must change their
- -- parameter type to reference the tagged type (instead
- -- of the interface type)
-
- if Is_Controlling_Formal (Formal) then
- if Nkind (Parameter_Type (Parent (Formal)))
- = N_Identifier
- then
- Set_Parameter_Type (New_Param_Spec,
- New_Occurrence_Of (Tag_Typ, Loc));
-
- else pragma Assert
- (Nkind (Parameter_Type (Parent (Formal)))
- = N_Access_Definition);
- Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
- New_Occurrence_Of (Tag_Typ, Loc));
- end if;
- end if;
-
- Append (New_Param_Spec, Formal_List);
-
- Next_Formal (Formal);
- end loop;
- end if;
-
- Proc_Decl :=
- Make_Subprogram_Declaration (Loc,
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Chars (Subp)),
- Parameter_Specifications => Formal_List,
- Null_Present => True));
- Append_To (Decl_List, Proc_Decl);
- Analyze (Proc_Decl);
- end if;
-
- Next_Elmt (Prim_Elmt);
- end loop;
- end Make_Null_Procedure_Specs;
-
-------------------------------------
-- Make_Predefined_Primitive_Specs --
-------------------------------------
with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
procedure Analyze_Freeze_Entity (N : Node_Id) is
E : constant Entity_Id := Entity (N);
+ function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
+ -- Ada 2005 (AI-251): Makes specs for null procedures associated with
+ -- null procedures inherited from interface types that have not been
+ -- overridden. Only one null procedure will be created for a given
+ -- set of inherited null procedures with homographic profiles.
+
+ -------------------------------
+ -- Make_Null_Procedure_Specs --
+ -------------------------------
+
+ function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id
+ is
+ Decl_List : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Tag_Typ);
+ Formal : Entity_Id;
+ Formal_List : List_Id;
+ New_Param_Spec : Node_Id;
+ Parent_Subp : Entity_Id;
+ Prim_Elmt : Elmt_Id;
+ Proc_Decl : Node_Id;
+ Subp : Entity_Id;
+
+ begin
+ Prim_Elmt := First_Elmt (Primitive_Operations (Tag_Typ));
+ while Present (Prim_Elmt) loop
+ Subp := Node (Prim_Elmt);
+
+ -- If a null procedure inherited from an interface has not been
+ -- overridden, then we build a null procedure declaration to
+ -- override the inherited procedure.
+
+ Parent_Subp := Alias (Subp);
+
+ if Present (Parent_Subp)
+ and then Is_Null_Interface_Primitive (Parent_Subp)
+ then
+ Formal_List := No_List;
+ Formal := First_Formal (Subp);
+
+ if Present (Formal) then
+ Formal_List := New_List;
+
+ while Present (Formal) loop
+
+ -- Copy the parameter spec including default expressions
+
+ New_Param_Spec :=
+ New_Copy_Tree (Parent (Formal), New_Sloc => Loc);
+
+ -- Generate a new defining identifier for the new formal.
+ -- required because New_Copy_Tree does not duplicate
+ -- semantic fields (except itypes).
+
+ Set_Defining_Identifier (New_Param_Spec,
+ Make_Defining_Identifier (Sloc (Formal),
+ Chars => Chars (Formal)));
+
+ -- For controlling arguments we must change their
+ -- parameter type to reference the tagged type (instead
+ -- of the interface type)
+
+ if Is_Controlling_Formal (Formal) then
+ if Nkind (Parameter_Type (Parent (Formal)))
+ = N_Identifier
+ then
+ Set_Parameter_Type (New_Param_Spec,
+ New_Occurrence_Of (Tag_Typ, Loc));
+
+ else pragma Assert
+ (Nkind (Parameter_Type (Parent (Formal)))
+ = N_Access_Definition);
+ Set_Subtype_Mark (Parameter_Type (New_Param_Spec),
+ New_Occurrence_Of (Tag_Typ, Loc));
+ end if;
+ end if;
+
+ Append (New_Param_Spec, Formal_List);
+
+ Next_Formal (Formal);
+ end loop;
+ end if;
+
+ Proc_Decl :=
+ Make_Subprogram_Declaration (Loc,
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Chars (Subp)),
+ Parameter_Specifications => Formal_List,
+ Null_Present => True));
+ Append_To (Decl_List, Proc_Decl);
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ return Decl_List;
+ end Make_Null_Procedure_Specs;
+
+ -- Start of processing for Analyze_Freeze_Entity
+
begin
-- For tagged types covering interfaces add internal entities that link
-- the primitives of the interfaces with the primitives that cover them.
and then not Is_Interface (E)
and then Has_Interfaces (E)
then
+ -- Add specs of non-overridden null interface primitives. During
+ -- semantic analysis this is required to ensure consistency of the
+ -- contents of the list of primitives of the tagged type. Routine
+ -- Add_Internal_Interface_Entities will take care of adding to such
+ -- list the internal entities that link each interface primitive with
+ -- the primitive of Tagged_Type that covers it; hence these specs
+ -- must be added before invoking Add_Internal_Interface_Entities.
+ -- In the expansion this consistency is required to ensure that the
+ -- dispatch table slots associated with non-overridden null interface
+ -- primitives are properly filled.
+
+ if not Is_Abstract_Type (E) then
+ Insert_Actions (N, Make_Null_Procedure_Specs (E));
+ end if;
+
-- This would be a good common place to call the routine that checks
-- overriding of interface primitives (and thus factorize calls to
-- Check_Abstract_Overriding located at different contexts in the
end if;
end Set_Derived_Name;
- -- Local variables
-
- Parent_Overrides_Interface_Primitive : Boolean := False;
-
-- Start of processing for Derive_Subprogram
begin
New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type));
Set_Ekind (New_Subp, Ekind (Parent_Subp));
- -- Check whether the parent overrides an interface primitive
-
- if Is_Overriding_Operation (Parent_Subp) then
- declare
- E : Entity_Id := Parent_Subp;
- begin
- while Present (Overridden_Operation (E)) loop
- E := Ultimate_Alias (Overridden_Operation (E));
- end loop;
-
- Parent_Overrides_Interface_Primitive :=
- Is_Dispatching_Operation (E)
- and then Present (Find_Dispatching_Type (E))
- and then Is_Interface (Find_Dispatching_Type (E));
- end;
- end if;
-
-- Check whether the inherited subprogram is a private operation that
-- should be inherited but not yet made visible. Such subprograms can
-- become visible at a later point (e.g., the private part of a public
-- overrides an interface primitive because interface primitives
-- must be visible in the partial view of the parent (RM 7.3 (7.3/2))
- elsif Parent_Overrides_Interface_Primitive then
+ elsif Ada_Version >= Ada_05
+ and then Is_Dispatching_Operation (Parent_Subp)
+ and then Covers_Some_Interface (Parent_Subp)
+ then
Set_Derived_Name;
-- Otherwise, the type is inheriting a private operation, so enter
and then Present (Spec_Id)
and then No_Return (Spec_Id)
then
- Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
+ Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
end if;
end Check_Missing_Return;
Error_Msg_Name_2 := Get_Convention_Name (Convention (Op));
Error_Msg_Sloc := Sloc (Op);
- if Comes_From_Source (Op) then
+ if Comes_From_Source (Op)
+ or else No (Alias (Op))
+ then
if not Is_Overriding_Operation (Op) then
Error_Msg_N ("\\primitive % defined #", Typ);
else
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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- --
(Tagged_Type : Entity_Id;
Iface_Prim : Entity_Id;
Prim : Entity_Id) return Boolean;
- -- Returns true if both primitives have a matching name and they are also
- -- type conformant. Special management is done for functions returning
- -- interfaces.
+ -- Returns true if both primitives have a matching name, they are type
+ -- conformant, and Prim is defined in the scope of Tagged_Type. Special
+ -- management is done for functions returning interfaces.
function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
-- Determine whether two callable entities (subprograms, entries,
Append_Unique_Elmt (New_Op, List);
end Add_Dispatching_Operation;
+ ---------------------------
+ -- Covers_Some_Interface --
+ ---------------------------
+
+ function Covers_Some_Interface (Prim : Entity_Id) return Boolean is
+ Tagged_Type : constant Entity_Id := Find_Dispatching_Type (Prim);
+ Elmt : Elmt_Id;
+ E : Entity_Id;
+
+ begin
+ pragma Assert (Is_Dispatching_Operation (Prim));
+
+ -- Although this is a dispatching primitive we must check if its
+ -- dispatching type is available because it may be the primitive
+ -- of a private type not defined as tagged in its partial view.
+
+ if Present (Tagged_Type) and then Has_Interfaces (Tagged_Type) then
+
+ -- If the tagged type is frozen then the internal entities associated
+ -- with interfaces are available in the list of primitives of the
+ -- tagged type and can be used to speed up this search.
+
+ if Is_Frozen (Tagged_Type) then
+ Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
+ while Present (Elmt) loop
+ E := Node (Elmt);
+
+ if Present (Interface_Alias (E))
+ and then Alias (E) = Prim
+ then
+ return True;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ -- Otherwise we must collect all the interface primitives and check
+ -- if the Prim will override some interface primitive.
+
+ else
+ declare
+ Ifaces_List : Elist_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface : Entity_Id;
+ Iface_Prim : Entity_Id;
+
+ begin
+ Collect_Interfaces (Tagged_Type, Ifaces_List);
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+
+ Elmt := First_Elmt (Primitive_Operations (Iface));
+ while Present (Elmt) loop
+ Iface_Prim := Node (Elmt);
+
+ if Chars (E) = Chars (Prim)
+ and then Is_Interface_Conformant
+ (Tagged_Type, Iface_Prim, Prim)
+ then
+ return True;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end;
+ end if;
+ end if;
+
+ return False;
+ end Covers_Some_Interface;
+
-------------------------------
-- Check_Controlling_Formals --
-------------------------------
-- type by Make_Controlling_Function_Wrappers. However, attribute
-- Is_Dispatching_Operation must be set to true.
- -- 2. Subprograms associated with stream attributes (built by
+ -- 2. Ada 2005 (AI-251): Wrapper procedures of null interface
+ -- primitives.
+
+ -- 3. Subprograms associated with stream attributes (built by
-- New_Stream_Subprogram)
if Present (Old_Subp)
((Ekind (Subp) = E_Function
and then Is_Dispatching_Operation (Old_Subp)
and then Is_Null_Extension (Base_Type (Etype (Subp))))
+ or else
+ (Ekind (Subp) = E_Procedure
+ and then Is_Dispatching_Operation (Old_Subp)
+ and then Present (Alias (Old_Subp))
+ and then Is_Null_Interface_Primitive
+ (Ultimate_Alias (Old_Subp)))
or else Get_TSS_Name (Subp) = TSS_Stream_Read
or else Get_TSS_Name (Subp) = TSS_Stream_Write);
+ Check_Controlling_Formals (Tagged_Type, Subp);
+ Override_Dispatching_Operation (Tagged_Type, Old_Subp, Subp);
Set_Is_Dispatching_Operation (Subp);
end if;
end if;
end Is_Dynamically_Tagged;
+ ---------------------------------
+ -- Is_Null_Interface_Primitive --
+ ---------------------------------
+
+ function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean is
+ begin
+ return Comes_From_Source (E)
+ and then Is_Dispatching_Operation (E)
+ and then Ekind (E) = E_Procedure
+ and then Null_Present (Parent (E))
+ and then Is_Interface (Find_Dispatching_Type (E));
+ end Is_Null_Interface_Primitive;
+
--------------------------
-- Is_Tag_Indeterminate --
--------------------------
-- of "OldSubp" is adjusted to point to the inherited procedure of the
-- full view because it is always this one which has to be called.
+ function Covers_Some_Interface (Prim : Entity_Id) return Boolean;
+ -- Returns true if Prim covers some interface primitive of its associated
+ -- tagged type. The tagged type of Prim must be frozen when this function
+ -- is invoked.
+
function Find_Controlling_Arg (N : Node_Id) return Node_Id;
-- Returns the actual controlling argument if N is dynamically tagged,
-- and Empty if it is not dynamically tagged.
-- an expression of a class_Wide type, or a call to a function with
-- controlling result where at least one operand is dynamically tagged.
+ function Is_Null_Interface_Primitive (E : Entity_Id) return Boolean;
+ -- Returns True if E is a null procedure that is an interface primitive
+
function Is_Tag_Indeterminate (N : Node_Id) return Boolean;
-- An expression is tag-indeterminate if it is a call that dispatches
-- on result, and all controlling operands are also indeterminate.
return True;
elsif Etype (Par) /= Par then
- Par := Etype (Par);
+
+ -- If this is a private type and its parent is an interface
+ -- then use the parent of the full view (which is a type that
+ -- implements such interface)
+
+ if Is_Private_Type (Par)
+ and then Is_Interface (Etype (Par))
+ and then Present (Full_View (Par))
+ then
+ Par := Etype (Full_View (Par));
+ else
+ Par := Etype (Par);
+ end if;
else
return False;
end if;