+2017-04-25 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Set_Convention_From_Pragma): Cleanup code for
+ convention Stdcall, which has a number of exceptions. Convention
+ is legal on a component declaration whose type is an anonymous
+ access to subprogram.
+
+2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch4.adb: sem_ch4.adb Various reformattings.
+ (Try_One_Prefix_Interpretation): Use the base type when dealing
+ with a subtype created for purposes of constraining a private
+ type with discriminants.
+
+2017-04-25 Javier Miranda <miranda@adacore.com>
+
+ * einfo.ads, einfo.adb (Has_Private_Extension): new attribute.
+ * warnsw.ads, warnsw.adb (All_Warnings): Set warning on late
+ dispatching primitives (Restore_Warnings): Restore warning on
+ late dispatching primitives (Save_Warnings): Save warning on late
+ dispatching primitives (Do_Warning_Switch): Use -gnatw.j/-gnatw.J
+ to enable/disable this warning.
+ (WA_Warnings): Set warning on late dispatching primitives.
+ * sem_ch3.adb (Analyze_Private_Extension_Declaration): Remember
+ that its parent type has a private extension.
+ * sem_disp.adb (Warn_On_Late_Primitive_After_Private_Extension):
+ New subprogram.
+ * usage.adb: Document -gnatw.j and -gnatw.J.
+
2017-04-25 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb, checks.adb, sem_prag.adb, eval_fat.adb: Minor
-- Is_Underlying_Full_View Flag298
-- Body_Needed_For_Inlining Flag299
- -- (unused) Flag300
+ -- Has_Private_Extension Flag300
-- (unused) Flag301
-- (unused) Flag302
-- (unused) Flag303
return Flag155 (Id);
end Has_Private_Declaration;
+ function Has_Private_Extension (Id : E) return B is
+ begin
+ pragma Assert (Is_Tagged_Type (Id));
+ return Flag300 (Id);
+ end Has_Private_Extension;
+
function Has_Protected (Id : E) return B is
begin
return Flag271 (Base_Type (Id));
Set_Flag155 (Id, V);
end Set_Has_Private_Declaration;
+ procedure Set_Has_Private_Extension (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Tagged_Type (Id));
+ Set_Flag300 (Id, V);
+ end Set_Has_Private_Extension;
+
procedure Set_Has_Protected (Id : E; V : B := True) is
begin
Set_Flag271 (Id, V);
W ("Has_Primitive_Operations", Flag120 (Id));
W ("Has_Private_Ancestor", Flag151 (Id));
W ("Has_Private_Declaration", Flag155 (Id));
+ W ("Has_Private_Extension", Flag300 (Id));
W ("Has_Protected", Flag271 (Id));
W ("Has_Qualified_Name", Flag161 (Id));
W ("Has_RACW", Flag214 (Id));
-- indicate if a full type declaration is a completion. Used for semantic
-- checks in E.4(18) and elsewhere.
+-- Has_Private_Extension (Flag300)
+-- Defined in tagged types. Set to indicate that the tagged type has some
+-- private extension. Used to report a warning on public primitives added
+-- after defining its private extensions.
+
-- Has_Protected (Flag271) [base type only]
-- Defined in all type entities. Set on protected types themselves, and
-- also (recursively) on any composite type which has a component for
-- Has_Dispatch_Table (Flag220) (base tagged type only)
-- Has_Pragma_Pack (Flag121) (impl base type only)
-- Has_Private_Ancestor (Flag151)
+ -- Has_Private_Extension (Flag300)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_Static_Discriminants (Flag211) (subtype only)
-- Is_Class_Wide_Equivalent_Type (Flag35)
-- Interfaces (Elist25)
-- Has_Completion (Flag26)
-- Has_Private_Ancestor (Flag151)
+ -- Has_Private_Extension (Flag300)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Is_Concurrent_Record_Type (Flag20)
-- Is_Constrained (Flag12)
function Has_Primitive_Operations (Id : E) return B;
function Has_Private_Ancestor (Id : E) return B;
function Has_Private_Declaration (Id : E) return B;
+ function Has_Private_Extension (Id : E) return B;
function Has_Protected (Id : E) return B;
function Has_Qualified_Name (Id : E) return B;
function Has_RACW (Id : E) return B;
procedure Set_Has_Primitive_Operations (Id : E; V : B := True);
procedure Set_Has_Private_Ancestor (Id : E; V : B := True);
procedure Set_Has_Private_Declaration (Id : E; V : B := True);
+ procedure Set_Has_Private_Extension (Id : E; V : B := True);
procedure Set_Has_Protected (Id : E; V : B := True);
procedure Set_Has_Qualified_Name (Id : E; V : B := True);
procedure Set_Has_RACW (Id : E; V : B := True);
pragma Inline (Has_Primitive_Operations);
pragma Inline (Has_Private_Ancestor);
pragma Inline (Has_Private_Declaration);
+ pragma Inline (Has_Private_Extension);
pragma Inline (Has_Protected);
pragma Inline (Has_Qualified_Name);
pragma Inline (Has_RACW);
pragma Inline (Set_Has_Primitive_Operations);
pragma Inline (Set_Has_Private_Ancestor);
pragma Inline (Set_Has_Private_Declaration);
+ pragma Inline (Set_Has_Private_Extension);
pragma Inline (Set_Has_Protected);
pragma Inline (Set_Has_Qualified_Name);
pragma Inline (Set_Has_RACW);
end if;
end if;
+ -- Remember that its parent type has a private extension. Used to warn
+ -- on public primitives of the parent type defined after its private
+ -- extensions (see Check_Dispatching_Operation).
+
+ Set_Has_Private_Extension (Parent_Type);
+
<<Leave>>
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, T);
Loc : constant Source_Ptr := Sloc (N);
Obj : constant Node_Id := Prefix (N);
- Subprog : constant Node_Id :=
+ Subprog : constant Node_Id :=
Make_Identifier (Sloc (Selector_Name (N)),
Chars => Chars (Selector_Name (N)));
-- Identifier on which possible interpretations will be collected
Actual : Node_Id;
Candidate : Entity_Id := Empty;
- New_Call_Node : Node_Id := Empty;
+ New_Call_Node : Node_Id := Empty;
Node_To_Replace : Node_Id;
Obj_Type : Entity_Id := Etype (Obj);
- Success : Boolean := False;
-
- function Valid_Candidate
- (Success : Boolean;
- Call : Node_Id;
- Subp : Entity_Id) return Entity_Id;
- -- If the subprogram is a valid interpretation, record it, and add
- -- to the list of interpretations of Subprog. Otherwise return Empty.
+ Success : Boolean := False;
procedure Complete_Object_Operation
(Call_Node : Node_Id;
-- in the call, and complete the analysis of the call.
procedure Report_Ambiguity (Op : Entity_Id);
- -- If a prefixed procedure call is ambiguous, indicate whether the
- -- call includes an implicit dereference or an implicit 'Access.
+ -- If a prefixed procedure call is ambiguous, indicate whether the call
+ -- includes an implicit dereference or an implicit 'Access.
procedure Transform_Object_Operation
(Call_Node : out Node_Id;
function Try_Class_Wide_Operation
(Call_Node : Node_Id;
Node_To_Replace : Node_Id) return Boolean;
- -- Traverse all ancestor types looking for a class-wide subprogram
- -- for which the current operation is a valid non-dispatching call.
+ -- Traverse all ancestor types looking for a class-wide subprogram for
+ -- which the current operation is a valid non-dispatching call.
procedure Try_One_Prefix_Interpretation (T : Entity_Id);
-- If prefix is overloaded, its interpretation may include different
- -- tagged types, and we must examine the primitive operations and
- -- the class-wide operations of each in order to find candidate
+ -- tagged types, and we must examine the primitive operations and the
+ -- class-wide operations of each in order to find candidate
-- interpretations for the call as a whole.
function Try_Primitive_Operation
(Call_Node : Node_Id;
Node_To_Replace : Node_Id) return Boolean;
-- Traverse the list of primitive subprograms looking for a dispatching
- -- operation for which the current node is a valid call .
-
- ---------------------
- -- Valid_Candidate --
- ---------------------
+ -- operation for which the current node is a valid call.
function Valid_Candidate
(Success : Boolean;
Call : Node_Id;
- Subp : Entity_Id) return Entity_Id
- is
- Arr_Type : Entity_Id;
- Comp_Type : Entity_Id;
-
- begin
- -- If the subprogram is a valid interpretation, record it in global
- -- variable Subprog, to collect all possible overloadings.
-
- if Success then
- if Subp /= Entity (Subprog) then
- Add_One_Interp (Subprog, Subp, Etype (Subp));
- end if;
- end if;
-
- -- If the call may be an indexed call, retrieve component type of
- -- resulting expression, and add possible interpretation.
-
- Arr_Type := Empty;
- Comp_Type := Empty;
-
- if Nkind (Call) = N_Function_Call
- and then Nkind (Parent (N)) = N_Indexed_Component
- and then Needs_One_Actual (Subp)
- then
- if Is_Array_Type (Etype (Subp)) then
- Arr_Type := Etype (Subp);
-
- elsif Is_Access_Type (Etype (Subp))
- and then Is_Array_Type (Designated_Type (Etype (Subp)))
- then
- Arr_Type := Designated_Type (Etype (Subp));
- end if;
- end if;
-
- if Present (Arr_Type) then
-
- -- Verify that the actuals (excluding the object) match the types
- -- of the indexes.
-
- declare
- Actual : Node_Id;
- Index : Node_Id;
-
- begin
- Actual := Next (First_Actual (Call));
- Index := First_Index (Arr_Type);
- while Present (Actual) and then Present (Index) loop
- if not Has_Compatible_Type (Actual, Etype (Index)) then
- Arr_Type := Empty;
- exit;
- end if;
-
- Next_Actual (Actual);
- Next_Index (Index);
- end loop;
-
- if No (Actual)
- and then No (Index)
- and then Present (Arr_Type)
- then
- Comp_Type := Component_Type (Arr_Type);
- end if;
- end;
-
- if Present (Comp_Type)
- and then Etype (Subprog) /= Comp_Type
- then
- Add_One_Interp (Subprog, Subp, Comp_Type);
- end if;
- end if;
-
- if Etype (Call) /= Any_Type then
- return Subp;
- else
- return Empty;
- end if;
- end Valid_Candidate;
+ Subp : Entity_Id) return Entity_Id;
+ -- If the subprogram is a valid interpretation, record it, and add to
+ -- the list of interpretations of Subprog. Otherwise return Empty.
-------------------------------
-- Complete_Object_Operation --
if Nkind (Parent_Node) = N_Procedure_Call_Statement then
Call_Node :=
Make_Procedure_Call_Statement (Loc,
- Name => New_Copy (Subprog),
+ Name => New_Copy (Subprog),
Parameter_Associations => Actuals);
else
-----------------------------------
procedure Try_One_Prefix_Interpretation (T : Entity_Id) is
-
+ Prev_Obj_Type : constant Entity_Id := Obj_Type;
-- If the interpretation does not have a valid candidate type,
-- preserve current value of Obj_Type for subsequent errors.
- Prev_Obj_Type : constant Entity_Id := Obj_Type;
-
begin
Obj_Type := T;
Obj_Type := Designated_Type (Obj_Type);
end if;
- if Ekind (Obj_Type) = E_Private_Subtype then
+ if Ekind_In (Obj_Type, E_Private_Subtype,
+ E_Record_Subtype_With_Private)
+ then
Obj_Type := Base_Type (Obj_Type);
end if;
end if;
-- If the object is not tagged, or the type is still an incomplete
- -- type, this is not a prefixed call.
+ -- type, this is not a prefixed call. Restore the previous type as
+ -- the current one is not a legal candidate.
if not Is_Tagged_Type (Obj_Type)
or else Is_Incomplete_Type (Obj_Type)
then
-
- -- Restore previous type if current one is not legal candidate
-
Obj_Type := Prev_Obj_Type;
return;
end if;
-- primitive. This check must be done even if a candidate
-- was found in order to report ambiguous calls.
- if not (Prim_Result) then
+ if not Prim_Result then
CW_Result :=
Try_Class_Wide_Operation
(Call_Node => New_Call_Node,
if Is_Concurrent_Type (Obj_Type) then
if Present (Corresponding_Record_Type (Obj_Type)) then
Corr_Type := Base_Type (Corresponding_Record_Type (Obj_Type));
- Elmt := First_Elmt (Primitive_Operations (Corr_Type));
+ Elmt := First_Elmt (Primitive_Operations (Corr_Type));
else
Corr_Type := Obj_Type;
- Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type));
+ Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type));
end if;
elsif not Is_Generic_Type (Obj_Type) then
Corr_Type := Obj_Type;
- Elmt := First_Elmt (Extended_Primitive_Ops (Obj_Type));
+ Elmt := First_Elmt (Extended_Primitive_Ops (Obj_Type));
else
Corr_Type := Obj_Type;
- Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type));
+ Elmt := First_Elmt (Collect_Generic_Type_Ops (Obj_Type));
end if;
while Present (Elmt) loop
and then Valid_First_Argument_Of (Prim_Op)
and then
(Nkind (Call_Node) = N_Function_Call)
- =
+ =
(Ekind (Prim_Op) = E_Function)
then
-- Ada 2005 (AI-251): If this primitive operation corresponds
return Present (Matching_Op);
end Try_Primitive_Operation;
+ ---------------------
+ -- Valid_Candidate --
+ ---------------------
+
+ function Valid_Candidate
+ (Success : Boolean;
+ Call : Node_Id;
+ Subp : Entity_Id) return Entity_Id
+ is
+ Arr_Type : Entity_Id;
+ Comp_Type : Entity_Id;
+
+ begin
+ -- If the subprogram is a valid interpretation, record it in global
+ -- variable Subprog, to collect all possible overloadings.
+
+ if Success then
+ if Subp /= Entity (Subprog) then
+ Add_One_Interp (Subprog, Subp, Etype (Subp));
+ end if;
+ end if;
+
+ -- If the call may be an indexed call, retrieve component type of
+ -- resulting expression, and add possible interpretation.
+
+ Arr_Type := Empty;
+ Comp_Type := Empty;
+
+ if Nkind (Call) = N_Function_Call
+ and then Nkind (Parent (N)) = N_Indexed_Component
+ and then Needs_One_Actual (Subp)
+ then
+ if Is_Array_Type (Etype (Subp)) then
+ Arr_Type := Etype (Subp);
+
+ elsif Is_Access_Type (Etype (Subp))
+ and then Is_Array_Type (Designated_Type (Etype (Subp)))
+ then
+ Arr_Type := Designated_Type (Etype (Subp));
+ end if;
+ end if;
+
+ if Present (Arr_Type) then
+
+ -- Verify that the actuals (excluding the object) match the types
+ -- of the indexes.
+
+ declare
+ Actual : Node_Id;
+ Index : Node_Id;
+
+ begin
+ Actual := Next (First_Actual (Call));
+ Index := First_Index (Arr_Type);
+ while Present (Actual) and then Present (Index) loop
+ if not Has_Compatible_Type (Actual, Etype (Index)) then
+ Arr_Type := Empty;
+ exit;
+ end if;
+
+ Next_Actual (Actual);
+ Next_Index (Index);
+ end loop;
+
+ if No (Actual)
+ and then No (Index)
+ and then Present (Arr_Type)
+ then
+ Comp_Type := Component_Type (Arr_Type);
+ end if;
+ end;
+
+ if Present (Comp_Type)
+ and then Etype (Subprog) /= Comp_Type
+ then
+ Add_One_Interp (Subprog, Subp, Comp_Type);
+ end if;
+ end if;
+
+ if Etype (Call) /= Any_Type then
+ return Subp;
+ else
+ return Empty;
+ end if;
+ end Valid_Candidate;
+
-- Start of processing for Try_Object_Operation
begin
with Sinfo; use Sinfo;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
+with Warnsw; use Warnsw;
package body Sem_Disp is
---------------------------------
procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
+ procedure Warn_On_Late_Primitive_After_Private_Extension
+ (Typ : Entity_Id;
+ Prim : Entity_Id);
+ -- Prim is a dispatching primitive of the tagged type Typ. Warn on Prim
+ -- if it is a public primitive defined after some private extension of
+ -- the tagged type.
+
+ ----------------------------------------------------
+ -- Warn_On_Late_Primitive_After_Private_Extension --
+ ----------------------------------------------------
+
+ procedure Warn_On_Late_Primitive_After_Private_Extension
+ (Typ : Entity_Id;
+ Prim : Entity_Id)
+ is
+ E : Entity_Id;
+
+ begin
+ if Warn_On_Late_Primitives
+ and then Comes_From_Source (Prim)
+ and then Has_Private_Extension (Typ)
+ and then Is_Package_Or_Generic_Package (Current_Scope)
+ and then not In_Private_Part (Current_Scope)
+ then
+ E := Next_Entity (Typ);
+
+ while E /= Prim loop
+ if Ekind (E) = E_Record_Type_With_Private
+ and then Etype (E) = Typ
+ then
+ Error_Msg_Name_1 := Chars (Typ);
+ Error_Msg_Name_2 := Chars (E);
+ Error_Msg_Sloc := Sloc (E);
+ Error_Msg_N
+ ("?j?primitive of type % defined after private " &
+ "extension % #?", Prim);
+ Error_Msg_Name_1 := Chars (Prim);
+ Error_Msg_Name_2 := Chars (E);
+ Error_Msg_N
+ ("\spec of % should appear before declaration of type %!",
+ Prim);
+ exit;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end if;
+ end Warn_On_Late_Primitive_After_Private_Extension;
+
+ -- Local variables
+
Body_Is_Last_Primitive : Boolean := False;
Has_Dispatching_Parent : Boolean := False;
Ovr_Subp : Entity_Id := Empty;
end if;
end;
end if;
+
+ -- For similarity with record extensions, in Ada 9X the language should
+ -- have disallowed adding visible operations to a tagged type after
+ -- deriving a private extension from it. Report a warning if this
+ -- primitive is defined after a private extension of Tagged_Type.
+
+ Warn_On_Late_Primitive_After_Private_Extension (Tagged_Type, Subp);
end Check_Dispatching_Operation;
------------------------------------------
("dispatching subprogram# cannot use Stdcall convention!",
Arg1);
- -- Subprograms are not allowed
+ -- Several allowed cases
- elsif not Is_Subprogram_Or_Generic_Subprogram (E)
+ elsif Is_Subprogram_Or_Generic_Subprogram (E)
-- A variable is OK
- and then Ekind (E) /= E_Variable
+ or else Ekind (E) = E_Variable
+
+ -- A component as well. The entity does not have its
+ -- Ekind set until the enclosing record declaration is
+ -- fully analyzed.
+
+ or else Nkind (Parent (E)) = N_Component_Declaration
-- An access to subprogram is also allowed
- and then not
- (Is_Access_Type (E)
- and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
+ or else (Is_Access_Type (E)
+ and then Ekind (Designated_Type (E)) = E_Subprogram_Type)
-- Allow internal call to set convention of subprogram type
- and then not (Ekind (E) = E_Subprogram_Type)
+ or else (Ekind (E) = E_Subprogram_Type)
then
+ null;
+
+ else
Error_Pragma_Arg
("second argument of pragma% must be subprogram (type)",
Arg2);
"(annex J) feature");
Write_Line (" J* turn off warnings for obsolescent " &
"(annex J) feature");
+ Write_Line (" .j+ turn on warnings for late dispatching " &
+ "primitives");
+ Write_Line (" .J* turn off warnings for late dispatching " &
+ "primitives");
Write_Line (" k+ turn on warnings on constant variable");
Write_Line (" K* turn off warnings on constant variable");
Write_Line (" .k turn on warnings for standard redefinition");
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2016, 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- --
Warn_On_Dereference := Setting;
Warn_On_Export_Import := Setting;
Warn_On_Hiding := Setting;
+ Warn_On_Late_Primitives := Setting;
Warn_On_Modified_Unread := Setting;
Warn_On_No_Value_Assigned := Setting;
Warn_On_Non_Local_Exception := Setting;
W.Warn_On_Export_Import;
Warn_On_Hiding :=
W.Warn_On_Hiding;
+ Warn_On_Late_Primitives :=
+ W.Warn_On_Late_Primitives;
Warn_On_Modified_Unread :=
W.Warn_On_Modified_Unread;
Warn_On_No_Value_Assigned :=
Warn_On_Export_Import;
W.Warn_On_Hiding :=
Warn_On_Hiding;
+ W.Warn_On_Late_Primitives :=
+ Warn_On_Late_Primitives;
W.Warn_On_Modified_Unread :=
Warn_On_Modified_Unread;
W.Warn_On_No_Value_Assigned :=
when 'I' =>
Warn_On_Overlap := False;
+ when 'j' =>
+ Warn_On_Late_Primitives := True;
+
+ when 'J' =>
+ Warn_On_Late_Primitives := False;
+
when 'k' =>
Warn_On_Standard_Redefinition := True;
Warn_On_Biased_Representation := True; -- -gnatw.b
Warn_On_Constant := True; -- -gnatwk
Warn_On_Export_Import := True; -- -gnatwx
+ Warn_On_Late_Primitives := True; -- -gnatw.j
Warn_On_Modified_Unread := True; -- -gnatwm
Warn_On_No_Value_Assigned := True; -- -gnatwv
Warn_On_Non_Local_Exception := True; -- -gnatw.x
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2016, 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- --
-- here as time goes by. And in fact a really nice idea would be to put
-- them all in a Warn_Record so that they would be easy to save/restore.
+ Warn_On_Late_Primitives : Boolean := False;
+ -- Warn when tagged type public primitives are defined after its private
+ -- extensions.
+
Warn_On_Record_Holes : Boolean := False;
-- Warn when explicit record component clauses leave uncovered holes (gaps)
-- in a record layout. Off by default, set by -gnatw.h (but not -gnatwa).
Warn_On_Dereference : Boolean;
Warn_On_Export_Import : Boolean;
Warn_On_Hiding : Boolean;
+ Warn_On_Late_Primitives : Boolean;
Warn_On_Modified_Unread : Boolean;
Warn_On_No_Value_Assigned : Boolean;
Warn_On_Non_Local_Exception : Boolean;
projects / gcc.git / commitdiff