Make_Procedure_Specification (Loc,
Defining_Unit_Name => Subp,
Parameter_Specifications => Profile);
+ Mutate_Ekind (Subp, E_Procedure);
else
Spec :=
Make_Function_Specification (Loc,
Result_Definition =>
New_Copy_Tree
(Result_Definition (Type_Definition (Decl))));
+ Mutate_Ekind (Subp, E_Function);
end if;
New_Decl :=
Make_Subprogram_Declaration (Loc, Specification => Spec);
Set_Aspect_Specifications (New_Decl, Contracts);
+ Set_Is_Wrapper (Subp);
+
+ -- The wrapper is declared in the freezing actions to facilitate its
+ -- identification and thus avoid handling it as a primitive operation
+ -- of a tagged type (see Is_Access_To_Subprogram_Wrapper); otherwise it
+ -- may be handled as a dispatching operation and erroneously registered
+ -- in a dispatch table.
+
+ if not GNATprove_Mode then
+ Ensure_Freeze_Node (Id);
+ Append_Freeze_Actions (Id, New_List (New_Decl));
+
+ -- Under GNATprove mode there is no such problem but we do not declare
+ -- it in the freezing actions since they are not analyzed under this
+ -- mode.
+
+ else
+ Insert_After (Decl, New_Decl);
+ end if;
- Insert_After (Decl, New_Decl);
Set_Access_Subprogram_Wrapper (Designated_Type (Id), Subp);
Build_Access_Subprogram_Wrapper_Body (Decl, New_Decl);
end Build_Access_Subprogram_Wrapper;
Set_Is_Non_Static_Subtype (Def_Id);
end if;
end if;
+
+ Set_Parent (Def_Id, N);
end if;
-- Final step is to label the index with this constructed type
---------------------------------
procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
+ function Is_Access_To_Subprogram_Wrapper (E : Entity_Id) return Boolean;
+ -- Return True if E is an access to subprogram wrapper
+
procedure Warn_On_Late_Primitive_After_Private_Extension
(Typ : Entity_Id;
Prim : Entity_Id);
-- if it is a public primitive defined after some private extension of
-- the tagged type.
+ -------------------------------------
+ -- Is_Access_To_Subprogram_Wrapper --
+ -------------------------------------
+
+ function Is_Access_To_Subprogram_Wrapper (E : Entity_Id) return Boolean
+ is
+ Decl_N : constant Node_Id := Unit_Declaration_Node (E);
+ Par_N : constant Node_Id := Parent (List_Containing (Decl_N));
+
+ begin
+ -- Access to subprogram wrappers are declared in the freezing actions
+
+ return Nkind (Par_N) = N_Freeze_Entity
+ and then Ekind (Entity (Par_N)) = E_Access_Subprogram_Type;
+ end Is_Access_To_Subprogram_Wrapper;
+
----------------------------------------------------
-- Warn_On_Late_Primitive_After_Private_Extension --
----------------------------------------------------
or else Is_Partial_Invariant_Procedure (Subp)
then
return;
+
+ -- Wrappers of access to subprograms are not primitive subprograms.
+
+ elsif Is_Wrapper (Subp)
+ and then Is_Access_To_Subprogram_Wrapper (Subp)
+ then
+ return;
end if;
Set_Is_Dispatching_Operation (Subp, False);
Generate_Reference (Tagged_Type, Subp, 'P', False);
Override_Dispatching_Operation
(Tagged_Type, Old_Subp, Subp);
+ Set_Is_Dispatching_Operation (Subp);
+
+ -- Inherit decoration of controlling formals and
+ -- controlling result.
+
+ if Ekind (Old_Subp) = E_Function
+ and then Has_Controlling_Result (Old_Subp)
+ then
+ Set_Has_Controlling_Result (Subp);
+ end if;
+
+ if Present (First_Formal (Old_Subp)) then
+ declare
+ Old_Formal : Entity_Id;
+ Formal : Entity_Id;
+
+ begin
+ Formal := First_Formal (Subp);
+ Old_Formal := First_Formal (Old_Subp);
+
+ while Present (Old_Formal) loop
+ Set_Is_Controlling_Formal (Formal,
+ Is_Controlling_Formal (Old_Formal));
+
+ Next_Formal (Formal);
+ Next_Formal (Old_Formal);
+ end loop;
+ end;
+ end if;
end if;
end if;
end if;
if No (Tag_Typ) then
return Result (1 .. 0);
+
+ -- Prevent cascaded errors
+
+ elsif Is_Concurrent_Type (Tag_Typ)
+ and then No (Corresponding_Record_Type (Tag_Typ))
+ and then Serious_Errors_Detected > 0
+ then
+ return Result (1 .. 0);
end if;
if Is_Concurrent_Type (Tag_Typ) then
Tag_Typ := Corresponding_Record_Type (Tag_Typ);
end if;
+ if Present (Tag_Typ)
+ and then Is_Private_Type (Tag_Typ)
+ and then Present (Full_View (Tag_Typ))
+ then
+ Tag_Typ := Full_View (Tag_Typ);
+ end if;
+
-- Search primitive operations of dispatching type
if Present (Tag_Typ)