From: Javier Miranda <mira...@adacore.com>
This patch adds support for a new GNAT aspect/pragma that modifies
the semantics of dispatching primitives. When a tagged type has
this aspect/pragma, only subprograms that have the first parameter
of this type will be considered dispatching primitives; this new
pragma/aspect is inherited by all descendant types.
gcc/ada/
* aspects.ads (Aspect_First_Controlling_Parameter): New aspect.
Defined as implementation defined aspect that has a static boolean
value and it is converted to pragma when the value is True.
* einfo.ads (Has_First_Controlling_Parameter): New attribute.
* exp_ch9.adb (Build_Corresponding_Record): Propagate the aspect
to the corresponding record type.
(Expand_N_Protected_Type_Declaration): Analyze the inherited
aspect to add the pragma.
(Expand_N_Task_Type_Declaration): ditto.
* freeze.adb (Warn_If_Implicitly_Inherited_Aspects): New
subprogram.
(Has_First_Ctrl_Param_Aspect): New subprogram.
(Freeze_Record_Type): Call Warn_If_Implicitly_Inherited_Aspects.
(Freeze_Subprogram): Check illegal subprograms of tagged types and
interface types that have this new aspect.
* gen_il-fields.ads (Has_First_Controlling_Parameter): New entity
field.
* gen_il-gen-gen_entities.adb (Has_First_Controlling_Parameter):
The new field is a semantic flag.
* gen_il-internals.adb (Image): Add
Has_First_Controlling_Parameter.
* par-prag.adb (Prag): No action for
Pragma_First_Controlling_Parameter since processing is handled
entirely in Sem_Prag.
* sem_ch12.adb (Validate_Private_Type_Instance): When the generic
formal has this new aspect, check that the actual type also has
this aspect.
* sem_ch13.adb (Analyze_One_Aspect): Check that the aspect is
applied to a tagged type or a concurrent type.
* sem_ch3.adb (Analyze_Full_Type_Declaration): Derived tagged
types inherit this new aspect, and also from their implemented
interface types.
(Process_Full_View): Propagate the aspect to the full view.
* sem_ch6.adb (Is_A_Primitive): New subprogram; used to factor
code and also clarify detection of primitives.
* sem_ch9.adb (Check_Interfaces): Propagate this new aspect to the
type implementing interface types.
* sem_disp.adb (Check_Controlling_Formals): Handle tagged type
that has the aspect and has subprograms overriding primitives of
tagged types that lack this aspect.
(Check_Dispatching_Operation): Warn on dispatching primitives
disallowed by this new aspect.
(Has_Predefined_Dispatching_Operation_Name): New subprogram.
(Find_Dispatching_Type): Handle dispatching functions of tagged
types that have the new aspect.
(Find_Primitive_Covering_Interface): For primitives of tagged
types that have the aspect and override a primitive of a parent
type that does not have the aspect, we must temporarily unset
attribute First_Controlling_ Parameter to properly check
conformance.
* sem_prag.ads (Aspect_Specifying_Pragma): Add new pragma.
* sem_prag.adb (Pragma_First_Controlling_Parameter): Handle new
pragma.
* snames.ads-tmpl (Name_First_Controlling_Parameter): New name.
* warnsw.ads (Warn_On_Non_Dispatching_Primitives): New warning.
* warnsw.adb (Warn_On_Non_Dispatching_Primitives): New warning;
not set by default when GNAT_Mode warnings are enabled, nor when
all warnings are enabled (-gnatwa).
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/aspects.ads | 5 +
gcc/ada/einfo.ads | 9 +
gcc/ada/exp_ch9.adb | 73 ++++++++
gcc/ada/freeze.adb | 279 ++++++++++++++++++++++++++++
gcc/ada/gen_il-fields.ads | 1 +
gcc/ada/gen_il-gen-gen_entities.adb | 3 +
gcc/ada/gen_il-internals.adb | 2 +
gcc/ada/par-prag.adb | 1 +
gcc/ada/sem_ch12.adb | 12 ++
gcc/ada/sem_ch13.adb | 52 ++++++
gcc/ada/sem_ch3.adb | 48 +++++
gcc/ada/sem_ch6.adb | 83 +++++++--
gcc/ada/sem_ch9.adb | 8 +
gcc/ada/sem_disp.adb | 207 ++++++++++++++++++++-
gcc/ada/sem_prag.adb | 86 +++++++++
gcc/ada/sem_prag.ads | 1 +
gcc/ada/snames.ads-tmpl | 2 +
gcc/ada/warnsw.adb | 4 +-
gcc/ada/warnsw.ads | 7 +
19 files changed, 860 insertions(+), 23 deletions(-)
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 9d0a9eb0110..adaa11f8a93 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -198,6 +198,7 @@ package Aspects is
Aspect_Export,
Aspect_Extensions_Visible, -- GNAT
Aspect_Favor_Top_Level, -- GNAT
+ Aspect_First_Controlling_Parameter, -- GNAT
Aspect_Full_Access_Only,
Aspect_Ghost, -- GNAT
Aspect_Import,
@@ -294,6 +295,7 @@ package Aspects is
Aspect_Extensions_Visible => True,
Aspect_Favor_Top_Level => True,
Aspect_Finalizable => True,
+ Aspect_First_Controlling_Parameter => True,
Aspect_Ghost => True,
Aspect_Ghost_Predicate => True,
Aspect_Global => True,
@@ -537,6 +539,7 @@ package Aspects is
Aspect_External_Name => False,
Aspect_External_Tag => False,
Aspect_Finalizable => False,
+ Aspect_First_Controlling_Parameter => False,
Aspect_Ghost_Predicate => False,
Aspect_Global => False,
Aspect_GNAT_Annotate => False,
@@ -712,6 +715,7 @@ package Aspects is
Aspect_External_Tag => Name_External_Tag,
Aspect_Favor_Top_Level => Name_Favor_Top_Level,
Aspect_Finalizable => Name_Finalizable,
+ Aspect_First_Controlling_Parameter => Name_First_Controlling_Parameter,
Aspect_Full_Access_Only => Name_Full_Access_Only,
Aspect_Ghost => Name_Ghost,
Aspect_Ghost_Predicate => Name_Ghost_Predicate,
@@ -1046,6 +1050,7 @@ package Aspects is
Aspect_Exceptional_Cases => Never_Delay,
Aspect_Export => Never_Delay,
Aspect_Extensions_Visible => Never_Delay,
+ Aspect_First_Controlling_Parameter => Never_Delay,
Aspect_Ghost => Never_Delay,
Aspect_Global => Never_Delay,
Aspect_GNAT_Annotate => Never_Delay,
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 4486ab3636f..2fb45703a4f 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -1651,6 +1651,11 @@ package Einfo is
-- that this does not imply a representation with holes, since the rep
-- clause may merely confirm the default 0..N representation.
+-- Has_First_Controlling_Parameter_Aspect
+-- Defined in tagged types, concurrent types and concurrent record types.
+-- Set to indicate that the type has a First_Controlling_Parameter of
+-- True (whether by an aspect_specification, a pragma, or inheritance).
+
-- Has_Exit
-- Defined in loop entities. Set if the loop contains an exit statement.
@@ -5973,6 +5978,7 @@ package Einfo is
-- First_Entity
-- Corresponding_Record_Type
-- Entry_Bodies_Array
+ -- Has_First_Controlling_Parameter_Aspect
-- Last_Entity
-- Discriminant_Constraint
-- Scope_Depth_Value
@@ -6014,6 +6020,7 @@ package Einfo is
-- Component_Alignment (special) (base type only)
-- C_Pass_By_Copy (base type only)
-- Has_Dispatch_Table (base tagged type only)
+ -- Has_First_Controlling_Parameter_Aspect
-- Has_Pragma_Pack (impl base type only)
-- Has_Private_Ancestor
-- Has_Private_Extension
@@ -6049,6 +6056,7 @@ package Einfo is
-- Underlying_Record_View $$$ (base type only)
-- Predicated_Parent (subtype only)
-- Has_Completion
+ -- Has_First_Controlling_Parameter_Aspect
-- Has_Private_Ancestor
-- Has_Private_Extension
-- Has_Record_Rep_Clause (base type only)
@@ -6144,6 +6152,7 @@ package Einfo is
-- Corresponding_Record_Type
-- Last_Entity
-- Discriminant_Constraint
+ -- Has_First_Controlling_Parameter_Aspect
-- Scope_Depth_Value
-- Stored_Constraint
-- Task_Body_Procedure
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 939a8e25d5a..958657f298d 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -1344,6 +1344,9 @@ package body Exp_Ch9 is
Rec_Ent : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_External_Name (Chars (Ctyp), 'V'));
+ Alist : List_Id;
+ Asp_Copy : Node_Id;
+ Aspect : Node_Id;
Disc : Entity_Id;
Dlist : List_Id;
New_Disc : Entity_Id;
@@ -1394,6 +1397,37 @@ package body Exp_Ch9 is
Dlist := No_List;
end if;
+ -- Propagate the aspect First_Controlling_Parameter to the corresponding
+ -- record to reuse the tagged types machinery. This is not needed if
+ -- the concurrent type does not implement interface types, as the
+ -- corresponding record will not be a tagged type in such case.
+
+ Alist := No_List;
+
+ if Present (Parent (Ctyp))
+ and then Present (Interface_List (Parent (Ctyp)))
+ and then Present (Aspect_Specifications (N))
+ then
+ Aspect := First (Aspect_Specifications (N));
+ while Present (Aspect) loop
+ if Chars (Identifier (Aspect))
+ = Name_First_Controlling_Parameter
+ then
+ Alist := New_List;
+ Asp_Copy := New_Copy_Tree (Aspect);
+
+ -- Force its analysis in the corresponding record to add
+ -- the pragma.
+
+ Set_Analyzed (Asp_Copy, False);
+ Append_To (Alist, Asp_Copy);
+ exit;
+ end if;
+
+ Next (Aspect);
+ end loop;
+ end if;
+
-- Now we can construct the record type declaration. Note that this
-- record is "limited tagged". It is "limited" to reflect the underlying
-- limitedness of the task or protected object that it represents, and
@@ -1405,6 +1439,7 @@ package body Exp_Ch9 is
return
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Rec_Ent,
+ Aspect_Specifications => Alist,
Discriminant_Specifications => Dlist,
Type_Definition =>
Make_Record_Definition (Loc,
@@ -9257,6 +9292,25 @@ package body Exp_Ch9 is
Analyze (Rec_Decl, Suppress => All_Checks);
+ -- Analyze aspects of the corresponding record type. They may have been
+ -- propagated to it and its analysis is required to add the pragma (see
+ -- propagation of aspect First_Controlling_Parameter in the subprogram
+ -- Build_Corresponding_Record).
+
+ if Has_Aspects (Rec_Decl) then
+ Analyze_Aspect_Specifications (Rec_Decl, Rec_Id);
+
+ -- Handle aspects that may have been implicitly inherited and must be
+ -- explicitly propagated to the corresponding record type. This applies
+ -- specifically when the First_Controlling_Parameter aspect has been
+ -- implicitly inherited from an implemented interface.
+
+ elsif Present (Interface_List (Parent (Prot_Typ)))
+ and then Has_First_Controlling_Parameter_Aspect (Prot_Typ)
+ then
+ Set_Has_First_Controlling_Parameter_Aspect (Rec_Id);
+ end if;
+
-- Ada 2005 (AI-345): Construct the primitive entry wrappers before
-- the corresponding record is frozen. If any wrappers are generated,
-- Current_Node is updated accordingly.
@@ -12162,6 +12216,25 @@ package body Exp_Ch9 is
Analyze (Rec_Decl);
+ -- Analyze aspects of the corresponding record type. They may have been
+ -- propagated to it and its analysis is required to add the pragma (see
+ -- propagation of aspect First_Controlling_Parameter in the subprogram
+ -- Build_Corresponding_Record).
+
+ if Has_Aspects (Rec_Decl) then
+ Analyze_Aspect_Specifications (Rec_Decl, Rec_Ent);
+
+ -- Handle aspects that may have been implicitly inherited and must be
+ -- explicitly propagated to the corresponding record type. This applies
+ -- specifically when the First_Controlling_Parameter aspect has been
+ -- implicitly inherited from an implemented interface.
+
+ elsif Present (Interface_List (Parent (Tasktyp)))
+ and then Has_First_Controlling_Parameter_Aspect (Tasktyp)
+ then
+ Set_Has_First_Controlling_Parameter_Aspect (Rec_Ent);
+ end if;
+
-- Create the declaration of the task body procedure
Proc_Spec := Build_Task_Proc_Specification (Tasktyp);
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 7d5be6b6744..f8e8cf38bb6 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -5066,6 +5066,11 @@ package body Freeze is
-- variants referenceed by the Variant_Part VP are frozen. This is
-- a recursive routine to deal with nested variants.
+ procedure Warn_If_Implicitly_Inherited_Aspects (Tag_Typ : Entity_Id);
+ -- Report a warning for Tag_Typ when it implicitly inherits the
+ -- First_Controlling_Parameter aspect but does not explicitly
+ -- specify it.
+
-----------------
-- Check_Itype --
-----------------
@@ -5144,6 +5149,193 @@ package body Freeze is
end loop;
end Freeze_Choices_In_Variant_Part;
+ ------------------------------------------
+ -- Warn_If_Implicitly_Inherited_Aspects --
+ ------------------------------------------
+
+ procedure Warn_If_Implicitly_Inherited_Aspects (Tag_Typ : Entity_Id)
+ is
+ function Has_First_Ctrl_Param_Aspect return Boolean;
+ -- Determines if Tag_Typ explicitly has the aspect/pragma
+ -- First_Controlling_Parameter.
+
+ ---------------------------------
+ -- Has_First_Ctrl_Param_Aspect --
+ ---------------------------------
+
+ function Has_First_Ctrl_Param_Aspect return Boolean is
+ Decl_Nod : constant Node_Id := Parent (Tag_Typ);
+ Asp_Nod : Node_Id;
+ Nod : Node_Id;
+ Pragma_Arg : Node_Id;
+ Pragma_Ent : Entity_Id;
+
+ begin
+ pragma Assert (Nkind (Decl_Nod) = N_Full_Type_Declaration);
+
+ if Present (Aspect_Specifications (Decl_Nod)) then
+ Asp_Nod := First (Aspect_Specifications (Decl_Nod));
+ while Present (Asp_Nod) loop
+ if Chars (Identifier (Asp_Nod))
+ = Name_First_Controlling_Parameter
+ then
+ return True;
+ end if;
+
+ Next (Asp_Nod);
+ end loop;
+ end if;
+
+ -- Search for the occurrence of the pragma
+
+ Nod := Next (Decl_Nod);
+ while Present (Nod) loop
+ if Nkind (Nod) = N_Pragma
+ and then Chars (Pragma_Identifier (Nod))
+ = Name_First_Controlling_Parameter
+ and then Present (Pragma_Argument_Associations (Nod))
+ then
+ Pragma_Arg :=
+ Expression (First (Pragma_Argument_Associations (Nod)));
+
+ if Nkind (Pragma_Arg) = N_Identifier
+ and then Present (Entity (Pragma_Arg))
+ then
+ Pragma_Ent := Entity (Pragma_Arg);
+
+ if Pragma_Ent = Tag_Typ
+ or else
+ (Is_Concurrent_Type (Pragma_Ent)
+ and then
+ Corresponding_Record_Type (Pragma_Ent)
+ = Tag_Typ)
+ then
+ return True;
+ end if;
+ end if;
+ end if;
+
+ Next (Nod);
+ end loop;
+
+ return False;
+ end Has_First_Ctrl_Param_Aspect;
+
+ -- Local Variables
+
+ Has_Aspect_First_Ctrl_Param : constant Boolean :=
+ Has_First_Ctrl_Param_Aspect;
+
+ -- Start of processing for Warn_Implicitly_Inherited_Aspects
+
+ begin
+ -- Handle cases where reporting the warning is not needed
+
+ if not Warn_On_Non_Dispatching_Primitives then
+ return;
+
+ -- No check needed when this is the full view of a private type
+ -- declaration since the pragma/aspect must be placed and checked
+ -- in the partial view, and it is implicitly propagated to the
+ -- full view.
+
+ elsif Has_Private_Declaration (Tag_Typ)
+ and then Is_Tagged_Type (Incomplete_Or_Partial_View (Tag_Typ))
+ then
+ return;
+
+ -- Similar case but applied to concurrent types
+
+ elsif Is_Concurrent_Record_Type (Tag_Typ)
+ and then Has_Private_Declaration
+ (Corresponding_Concurrent_Type (Tag_Typ))
+ and then Is_Tagged_Type
+ (Incomplete_Or_Partial_View
+ (Corresponding_Concurrent_Type (Tag_Typ)))
+ then
+ return;
+ end if;
+
+ if Etype (Tag_Typ) /= Tag_Typ
+ and then Has_First_Controlling_Parameter_Aspect (Etype (Tag_Typ))
+ then
+ -- The attribute was implicitly inherited
+ pragma Assert
+ (Has_First_Controlling_Parameter_Aspect (Tag_Typ));
+
+ -- No warning needed when the current tagged type is not
+ -- an interface type since by definition the aspect is
+ -- implicitly propagated from its parent type; the warning
+ -- is reported on interface types since it may not be so
+ -- clear when some implemented interface types have the
+ -- aspect and other interface types don't have it. For
+ -- interface types, we don't report the warning when the
+ -- interface type is an extension of a single interface
+ -- type (for similarity with the behavior with regular
+ -- tagged types).
+
+ if not Has_Aspect_First_Ctrl_Param
+ and then Is_Interface (Tag_Typ)
+ and then not Is_Empty_Elmt_List (Interfaces (Tag_Typ))
+ then
+ Error_Msg_N
+ ("?_j?implicitly inherits aspect 'First_'Controlling_'"
+ & "Parameter!", Tag_Typ);
+ Error_Msg_NE
+ ("\?_j?from & and must be confirmed explicitly!",
+ Tag_Typ, Etype (Tag_Typ));
+ end if;
+
+ elsif Present (Interfaces (Tag_Typ))
+ and then not Is_Empty_Elmt_List (Interfaces (Tag_Typ))
+ then
+ -- To maintain consistency with the behavior when the aspect
+ -- is implicitly inherited from its parent type, we do not
+ -- report a warning for concurrent record types that implement
+ -- a single interface type. By definition, the aspect is
+ -- propagated from that interface type as if it were the parent
+ -- type. For example:
+
+ -- type Iface is interface with First_Controlling_Parameter;
+ -- task type T is new Iface with ...
+
+ if Is_Concurrent_Record_Type (Tag_Typ)
+ and then No (Next_Elmt (First_Elmt (Interfaces (Tag_Typ))))
+ then
+ null;
+
+ else
+ declare
+ Elmt : Elmt_Id := First_Elmt (Interfaces (Tag_Typ));
+ Iface : Entity_Id;
+
+ begin
+ while Present (Elmt) loop
+ Iface := Node (Elmt);
+ pragma Assert (Present (Iface));
+
+ if Has_First_Controlling_Parameter_Aspect (Iface)
+ and then not Has_Aspect_First_Ctrl_Param
+ then
+ pragma Assert
+ (Has_First_Controlling_Parameter_Aspect
+ (Tag_Typ));
+ Error_Msg_N
+ ("?_j?implicitly inherits aspect 'First_'"
+ & "Controlling_'Parameter", Tag_Typ);
+ Error_Msg_NE
+ ("\?_j?from & and must be confirmed explicitly!",
+ Tag_Typ, Iface);
+ exit;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+ end if;
+ end if;
+ end Warn_If_Implicitly_Inherited_Aspects;
+
-- Start of processing for Freeze_Record_Type
begin
@@ -5919,6 +6111,13 @@ package body Freeze is
end loop;
end;
end if;
+
+ -- For tagged types, warn on an implicitly inherited aspect/pragma
+ -- First_Controlling_Parameter that is not explicitly set.
+
+ if Is_Tagged_Type (Rec) then
+ Warn_If_Implicitly_Inherited_Aspects (Rec);
+ end if;
end Freeze_Record_Type;
-------------------------------
@@ -10276,6 +10475,86 @@ package body Freeze is
then
Check_Overriding_Indicator (E, Empty, Is_Primitive (E));
end if;
+
+ -- Check illegal subprograms of tagged types and interface types that
+ -- have aspect/pragma First_Controlling_Parameter.
+
+ if Comes_From_Source (E)
+ and then Is_Abstract_Subprogram (E)
+ then
+ if Is_Dispatching_Operation (E) then
+ if Ekind (E) = E_Function
+ and then Is_Interface (Etype (E))
+ and then not Is_Class_Wide_Type (Etype (E))
+ and then Has_First_Controlling_Parameter_Aspect
+ (Find_Dispatching_Type (E))
+ then
+ Error_Msg_NE
+ ("'First_'Controlling_'Parameter disallows returning a "
+ & "non-class-wide interface type",
+ E, Etype (E));
+ end if;
+
+ else
+ -- The type of the formals cannot be an interface type
+
+ if Present (First_Formal (E)) then
+ declare
+ Formal : Entity_Id := First_Formal (E);
+ Has_Aspect : Boolean := False;
+
+ begin
+ -- Check if some formal has the aspect
+
+ while Present (Formal) loop
+ if Is_Tagged_Type (Etype (Formal))
+ and then
+ Has_First_Controlling_Parameter_Aspect
+ (Etype (Formal))
+ then
+ Has_Aspect := True;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ -- If the aspect is present then report the error
+
+ if Has_Aspect then
+ Formal := First_Formal (E);
+
+ while Present (Formal) loop
+ if Is_Interface (Etype (Formal))
+ and then not Is_Class_Wide_Type (Etype (Formal))
+ then
+ Error_Msg_NE
+ ("not a dispatching primitive of interface type&",
+ E, Etype (Formal));
+ Error_Msg_N
+ ("\disallowed by 'First_'Controlling_'Parameter "
+ & "aspect", E);
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+ end if;
+ end;
+ end if;
+
+ if Ekind (E) = E_Function
+ and then Is_Interface (Etype (E))
+ and then not Is_Class_Wide_Type (Etype (E))
+ and then Has_First_Controlling_Parameter_Aspect (Etype (E))
+ then
+ Error_Msg_NE
+ ("not a dispatching primitive of interface type&",
+ E, Etype (E));
+ Error_Msg_N
+ ("\disallowed by 'First_'Controlling_'Parameter "
+ & "aspect", E);
+ end if;
+ end if;
+ end if;
end Freeze_Subprogram;
----------------------
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 22fd1e372f6..8011fa31b23 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -575,6 +575,7 @@ package Gen_IL.Fields is
Has_Enumeration_Rep_Clause,
Has_Exit,
Has_Expanded_Contract,
+ Has_First_Controlling_Parameter_Aspect,
Has_Forward_Instantiation,
Has_Fully_Qualified_Name,
Has_Ghost_Predicate_Aspect,
diff --git a/gcc/ada/gen_il-gen-gen_entities.adb
b/gcc/ada/gen_il-gen-gen_entities.adb
index 29b22c62587..4d2444ea347 100644
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -478,6 +478,9 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Has_Dispatch_Table, Flag,
Pre => "Is_Tagged_Type (N)"),
Sm (Has_Dynamic_Predicate_Aspect, Flag),
+ Sm (Has_First_Controlling_Parameter_Aspect, Flag,
+ Pre => "Is_Tagged_Type (N) or else Is_Concurrent_Type (N)"
+ & " or else Is_Concurrent_Record_Type (N)"),
Sm (Has_Ghost_Predicate_Aspect, Flag),
Sm (Has_Inheritable_Invariants, Flag, Base_Type_Only),
Sm (Has_Inherited_DIC, Flag, Base_Type_Only),
diff --git a/gcc/ada/gen_il-internals.adb b/gcc/ada/gen_il-internals.adb
index e08397f7d4e..c26d3faaec4 100644
--- a/gcc/ada/gen_il-internals.adb
+++ b/gcc/ada/gen_il-internals.adb
@@ -279,6 +279,8 @@ package body Gen_IL.Internals is
return "DT_Position";
when Forwards_OK =>
return "Forwards_OK";
+ when Has_First_Controlling_Parameter_Aspect =>
+ return "Has_First_Controlling_Parameter_Aspect";
when Has_Inherited_DIC =>
return "Has_Inherited_DIC";
when Has_Own_DIC =>
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index 181b0d4c125..f464da9c436 100644
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -1442,6 +1442,7 @@ begin
| Pragma_Fast_Math
| Pragma_Favor_Top_Level
| Pragma_Finalize_Storage_Only
+ | Pragma_First_Controlling_Parameter
| Pragma_Ghost
| Pragma_Global
| Pragma_GNAT_Annotate
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index bc0d34e871d..81068d0e6c0 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -14952,6 +14952,18 @@ package body Sem_Ch12 is
then
Error_Msg_NE
("actual for & must be a tagged type", Actual, Gen_T);
+
+ -- For generic formal tagged types with the First_Controlling_Param
+ -- aspect, ensure that the actual type also has this aspect.
+
+ elsif Is_Tagged_Type (Act_T)
+ and then Is_Tagged_Type (A_Gen_T)
+ and then not Has_First_Controlling_Parameter_Aspect (Act_T)
+ and then Has_First_Controlling_Parameter_Aspect (A_Gen_T)
+ then
+ Error_Msg_NE
+ ("actual for & must be a 'First_'Controlling_'Parameter tagged "
+ & "type", Actual, Gen_T);
end if;
Validate_Discriminated_Formal_Type;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 3fb0209f612..f4ff3a28273 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -4512,6 +4512,58 @@ package body Sem_Ch13 is
Pragma_Name => Nam);
end if;
+ -- Minimum check of First_Controlling_Parameter aspect;
+ -- the checks shared by the aspect and its corresponding
+ -- pragma are performed when the pragma is analyzed.
+
+ if A_Id = Aspect_First_Controlling_Parameter then
+ if Present (Expr) then
+ Analyze (Expr);
+ end if;
+
+ if (No (Expr) or else Entity (Expr) = Standard_True)
+ and then not Core_Extensions_Allowed
+ then
+ Error_Msg_GNAT_Extension
+ ("'First_'Controlling_'Parameter", Sloc (Aspect),
+ Is_Core_Extension => True);
+ goto Continue;
+ end if;
+
+ if not (Is_Type (E)
+ and then
+ (Is_Tagged_Type (E)
+ or else Is_Concurrent_Type (E)))
+ then
+ Error_Msg_N
+ ("aspect 'First_'Controlling_'Parameter can only "
+ & "apply to tagged type or concurrent type",
+ Aspect);
+ goto Continue;
+ end if;
+
+ -- If the aspect is specified for a derived type, the
+ -- specified value shall be confirming.
+
+ if Present (Expr)
+ and then Is_Derived_Type (E)
+ and then
+ Has_First_Controlling_Parameter_Aspect (Etype (E))
+ and then Entity (Expr) = Standard_False
+ then
+ Error_Msg_Name_1 := Nam;
+ Error_Msg_N
+ ("specification of inherited aspect% can only "
+ & "confirm parent value", Id);
+ end if;
+
+ -- Given that the aspect has been explicitly given,
+ -- we take note to avoid checking for its implicit
+ -- inheritance (see Analyze_Full_Type_Declaration).
+
+ Set_Has_First_Controlling_Parameter_Aspect (E);
+ end if;
+
-- In general cases, the corresponding pragma/attribute
-- definition clause will be inserted later at the freezing
-- point, and we do not need to build it now.
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index ce3fe18080d..2b703dd13c0 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3510,6 +3510,46 @@ package body Sem_Ch3 is
then
Check_Restriction (No_Local_Tagged_Types, T);
end if;
+
+ -- Derived tagged types inherit aspect First_Controlling_Parameter
+ -- from their parent type and also from implemented interface types.
+ -- We implicitly perform inheritance here and will check for the
+ -- explicit confirming pragma or aspect in the sources when this type
+ -- is frozen (required for pragmas since they are placed at any place
+ -- after the type declaration; otherwise, when the pragma is used after
+ -- some non-first-controlling-parameter primitive, the reported errors
+ -- and warning would differ when the pragma is used).
+
+ if Is_Tagged_Type (T)
+ and then Is_Derived_Type (T)
+ and then not Has_First_Controlling_Parameter_Aspect (T)
+ then
+ pragma Assert (Etype (T) /= T);
+
+ if Has_First_Controlling_Parameter_Aspect (Etype (T)) then
+ Set_Has_First_Controlling_Parameter_Aspect (T);
+
+ elsif Present (Interfaces (T))
+ and then not Is_Empty_Elmt_List (Interfaces (T))
+ then
+ declare
+ Elmt : Elmt_Id := First_Elmt (Interfaces (T));
+ Iface : Entity_Id;
+
+ begin
+ while Present (Elmt) loop
+ Iface := Node (Elmt);
+
+ if Has_First_Controlling_Parameter_Aspect (Iface) then
+ Set_Has_First_Controlling_Parameter_Aspect (T);
+ exit;
+ end if;
+
+ Next_Elmt (Elmt);
+ end loop;
+ end;
+ end if;
+ end if;
end Analyze_Full_Type_Declaration;
----------------------------------
@@ -21870,6 +21910,14 @@ package body Sem_Ch3 is
end;
end if;
+ -- Propagate First_Controlling_Parameter aspect to the full type
+
+ if Is_Tagged_Type (Priv_T)
+ and then Has_First_Controlling_Parameter_Aspect (Priv_T)
+ then
+ Set_Has_First_Controlling_Parameter_Aspect (Full_T);
+ end if;
+
-- Propagate predicates to full type, and predicate function if already
-- defined. It is not clear that this can actually happen? the partial
-- view cannot be frozen yet, and the predicate function has not been
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 5735efb327c..fcd15445a07 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -11348,11 +11348,6 @@ package body Sem_Ch6 is
-- replace the overridden primitive in Typ's primitives list with
-- the new subprogram.
- function Visible_Part_Type (T : Entity_Id) return Boolean;
- -- Returns true if T is declared in the visible part of the current
- -- package scope; otherwise returns false. Assumes that T is declared
- -- in a package.
-
procedure Check_Private_Overriding (T : Entity_Id);
-- Checks that if a primitive abstract subprogram of a visible
-- abstract type is declared in a private part, then it must override
@@ -11361,6 +11356,17 @@ package body Sem_Ch6 is
-- in a private part, then it must override a function declared in
-- the visible part.
+ function Is_A_Primitive
+ (Typ : Entity_Id;
+ Subp : Entity_Id) return Boolean;
+ -- Typ is either the return type of function Subp or the type of one
+ -- of its formals; determine if Subp is a primitive of type Typ.
+
+ function Visible_Part_Type (T : Entity_Id) return Boolean;
+ -- Returns true if T is declared in the visible part of the current
+ -- package scope; otherwise returns false. Assumes that T is declared
+ -- in a package.
+
---------------------------------------
-- Add_Or_Replace_Untagged_Primitive --
---------------------------------------
@@ -11529,7 +11535,9 @@ package body Sem_Ch6 is
-- operation. That's illegal in the tagged case
-- (but not if the private type is untagged).
- if T = Base_Type (Etype (S)) then
+ if T = Base_Type (Etype (S))
+ and then Has_Controlling_Result (S)
+ then
Error_Msg_N
("private function with controlling result must"
& " override visible-part function", S);
@@ -11542,6 +11550,7 @@ package body Sem_Ch6 is
elsif Ekind (Etype (S)) = E_Anonymous_Access_Type
and then T = Base_Type (Designated_Type (Etype (S)))
+ and then Has_Controlling_Result (S)
and then Ada_Version >= Ada_2012
then
Error_Msg_N
@@ -11558,6 +11567,58 @@ package body Sem_Ch6 is
end if;
end Check_Private_Overriding;
+ --------------------
+ -- Is_A_Primitive --
+ --------------------
+
+ function Is_A_Primitive
+ (Typ : Entity_Id;
+ Subp : Entity_Id) return Boolean is
+ begin
+ if Scope (Typ) /= Current_Scope
+ or else Is_Class_Wide_Type (Typ)
+ or else Is_Generic_Type (Typ)
+ then
+ return False;
+
+ -- Untagged type primitive
+
+ elsif not Is_Tagged_Type (Typ) then
+ return True;
+
+ -- Primitive of a tagged type without the First_Controlling_Param
+ -- aspect.
+
+ elsif not Has_First_Controlling_Parameter_Aspect (Typ) then
+ return True;
+
+ -- Non-overriding primitive of a tagged type with the
+ -- First_Controlling_Parameter aspect
+
+ elsif No (Overridden_Operation (Subp)) then
+ return Present (First_Formal (Subp))
+ and then Etype (First_Formal (Subp)) = Typ;
+
+ -- Primitive of a tagged type with the First_Controlling_Parameter
+ -- aspect, overriding an inherited primitive of a tagged type
+ -- without this aspect.
+
+ else
+ if Ekind (Subp) = E_Function
+ and then Has_Controlling_Result (Overridden_Operation (Subp))
+ then
+ return True;
+
+ elsif Is_Dispatching_Operation
+ (Overridden_Operation (Subp))
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_A_Primitive;
+
-----------------------
-- Visible_Part_Type --
-----------------------
@@ -11630,10 +11691,7 @@ package body Sem_Ch6 is
B_Typ := Base_Type (F_Typ);
- if Scope (B_Typ) = Current_Scope
- and then not Is_Class_Wide_Type (B_Typ)
- and then not Is_Generic_Type (B_Typ)
- then
+ if Is_A_Primitive (B_Typ, S) then
Is_Primitive := True;
Set_Has_Primitive_Operations (B_Typ);
Set_Is_Primitive (S);
@@ -11673,10 +11731,7 @@ package body Sem_Ch6 is
B_Typ := Base_Type (B_Typ);
end if;
- if Scope (B_Typ) = Current_Scope
- and then not Is_Class_Wide_Type (B_Typ)
- and then not Is_Generic_Type (B_Typ)
- then
+ if Is_A_Primitive (B_Typ, S) then
Is_Primitive := True;
Set_Is_Primitive (S);
Set_Has_Primitive_Operations (B_Typ);
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index 391cbeb02a9..d52264a0278 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -3648,6 +3648,14 @@ package body Sem_Ch9 is
Freeze_Before (N, Etype (Iface));
+ -- Implicit inheritance of attribute
+
+ if not Has_First_Controlling_Parameter_Aspect (T)
+ and then Has_First_Controlling_Parameter_Aspect (Iface_Typ)
+ then
+ Set_Has_First_Controlling_Parameter_Aspect (T);
+ end if;
+
if Nkind (N) = N_Protected_Type_Declaration then
-- Ada 2005 (AI-345): Protected types can only implement
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index 3c1c49f7064..203e9141624 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -305,7 +305,36 @@ package body Sem_Disp is
Formal := First_Formal (Subp);
while Present (Formal) loop
- Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
+ Ctrl_Type := Empty;
+
+ -- Common Ada case
+
+ if not Has_First_Controlling_Parameter_Aspect (Typ) then
+ Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
+
+ -- Type with the First_Controlling_Parameter aspect: for overriding
+ -- primitives of a parent type that lacks this aspect, we cannot be
+ -- more restrictive than the overridden primitive. This also applies
+ -- to renamings of dispatching primitives. Dispatching operators can
+ -- have one or two controlling parameters, as long as one of them is
+ -- the first one, and none of the parameters have the same type as
+ -- the operator's result type.
+
+ -- Internal subprograms added by the frontend bypass the restrictions
+ -- of First_Controlling_Parameter aspect.
+
+ elsif Formal = First_Formal (Subp)
+ or else Is_Internal (Subp)
+ or else Present (Overridden_Operation (Subp))
+ or else
+ (Present (Alias (Subp))
+ and then Is_Dispatching_Operation (Ultimate_Alias (Subp)))
+ or else
+ (Ekind (Subp) = E_Function
+ and then Is_Operator_Name (Chars (Subp)))
+ then
+ Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp);
+ end if;
if Present (Ctrl_Type) then
@@ -390,7 +419,24 @@ package body Sem_Disp is
Next_Formal (Formal);
end loop;
- if Ekind (Subp) in E_Function | E_Generic_Function then
+ -- Functions overriding parent type primitives that lack the aspect
+ -- First_Controlling_Param cannot be more restrictive than the
+ -- overridden function. This also applies to renamings of dispatching
+ -- primitives. Internal subprograms added by the frontend bypass these
+ -- restrictions.
+
+ if Ekind (Subp) in E_Function | E_Generic_Function
+ and then (not Has_First_Controlling_Parameter_Aspect (Typ)
+ or else Is_Internal (Subp)
+ or else
+ (Present (Overridden_Operation (Subp))
+ and then
+ Has_Controlling_Result (Overridden_Operation (Subp)))
+ or else
+ (Present (Alias (Subp))
+ and then
+ Has_Controlling_Result (Ultimate_Alias (Subp))))
+ then
Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp);
if Present (Ctrl_Type) then
@@ -1345,8 +1391,10 @@ package body Sem_Disp is
Typ := Etype (Subp);
end if;
- -- The following should be better commented, especially since
- -- we just added several new conditions here ???
+ -- Report warning on non dispatching primitives of interface
+ -- type Typ; this warning is disabled when the type has the
+ -- aspect First_Controlling_Parameter because we will report
+ -- an error when the interface type is frozen.
if Comes_From_Source (Subp)
and then Is_Interface (Typ)
@@ -1354,6 +1402,7 @@ package body Sem_Disp is
and then not Is_Derived_Type (Typ)
and then not Is_Generic_Type (Typ)
and then not In_Instance
+ and then not Has_First_Controlling_Parameter_Aspect (Typ)
then
Error_Msg_N ("??declaration of& is too late!", Subp);
Error_Msg_NE
@@ -1772,6 +1821,37 @@ package body Sem_Disp is
-- cascaded errors.
elsif not Error_Posted (Subp) then
+
+ -- When aspect First_Controlling_Parameter applies, check if the
+ -- subprogram is a primitive. Internal subprograms added by the
+ -- frontend bypass its restrictions.
+
+ if Has_First_Controlling_Parameter_Aspect (Tagged_Type)
+ and then not Is_Internal (Subp)
+ and then not
+ (Present (Overridden_Operation (Subp))
+ and then
+ Is_Dispatching_Operation (Overridden_Operation (Subp)))
+ and then not
+ (Present (Alias (Subp))
+ and then
+ Is_Dispatching_Operation (Ultimate_Alias (Subp)))
+ and then (No (First_Formal (Subp))
+ or else not
+ Is_Controlling_Formal (First_Formal (Subp)))
+ then
+ if Warn_On_Non_Dispatching_Primitives then
+ Error_Msg_NE
+ ("?_j?not a dispatching primitive of tagged type&",
+ Subp, Tagged_Type);
+ Error_Msg_NE
+ ("\?_j?disallowed by 'First_'Controlling_'Parameter on &",
+ Subp, Tagged_Type);
+ end if;
+
+ return;
+ end if;
+
Add_Dispatching_Operation (Tagged_Type, Subp);
end if;
@@ -2287,6 +2367,55 @@ package body Sem_Disp is
---------------------------
function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is
+
+ function Has_Predefined_Dispatching_Operation_Name return Boolean;
+ -- Determines if Subp has the name of a predefined dispatching
+ -- operation.
+
+ -----------------------------------------------
+ -- Has_Predefined_Dispatching_Operation_Name --
+ -----------------------------------------------
+
+ function Has_Predefined_Dispatching_Operation_Name return Boolean is
+ TSS_Name : TSS_Name_Type;
+
+ begin
+ Get_Name_String (Chars (Subp));
+
+ if Name_Len > TSS_Name_Type'Last then
+ TSS_Name :=
+ TSS_Name_Type
+ (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
+
+ if Chars (Subp) in Name_uAssign
+ | Name_uSize
+ | Name_Op_Eq
+ or else TSS_Name = TSS_Deep_Adjust
+ or else TSS_Name = TSS_Deep_Finalize
+ or else TSS_Name = TSS_Stream_Input
+ or else TSS_Name = TSS_Stream_Output
+ or else TSS_Name = TSS_Stream_Read
+ or else TSS_Name = TSS_Stream_Write
+ or else TSS_Name = TSS_Put_Image
+
+ -- Name of predefined interface type primitives
+
+ or else Chars (Subp) in Name_uDisp_Asynchronous_Select
+ | Name_uDisp_Conditional_Select
+ | Name_uDisp_Get_Prim_Op_Kind
+ | Name_uDisp_Get_Task_Id
+ | Name_uDisp_Requeue
+ | Name_uDisp_Timed_Select
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Has_Predefined_Dispatching_Operation_Name;
+
+ -- Local variables
+
A_Formal : Entity_Id;
Formal : Entity_Id;
Ctrl_Type : Entity_Id;
@@ -2343,7 +2472,25 @@ package body Sem_Disp is
-- The subprogram may also be dispatching on result
if Present (Etype (Subp)) then
- return Check_Controlling_Type (Etype (Subp), Subp);
+ if Is_Tagged_Type (Etype (Subp))
+ and then Has_First_Controlling_Parameter_Aspect (Etype (Subp))
+ then
+ if Present (Overridden_Operation (Subp))
+ and then Has_Controlling_Result (Overridden_Operation (Subp))
+ then
+ return Check_Controlling_Type (Etype (Subp), Subp);
+
+ -- Internal subprograms added by the frontend bypass the
+ -- restrictions of First_Controlling_Parameter aspect.
+
+ elsif Is_Internal (Subp)
+ and then Has_Predefined_Dispatching_Operation_Name
+ then
+ return Check_Controlling_Type (Etype (Subp), Subp);
+ end if;
+ else
+ return Check_Controlling_Type (Etype (Subp), Subp);
+ end if;
end if;
end if;
@@ -2444,6 +2591,8 @@ package body Sem_Disp is
(Tagged_Type : Entity_Id;
Iface_Prim : Entity_Id) return Entity_Id
is
+ Is_FCP_Type : constant Boolean :=
+ Has_First_Controlling_Parameter_Aspect (Tagged_Type);
E : Entity_Id;
El : Elmt_Id;
@@ -2462,9 +2611,30 @@ package body Sem_Disp is
while Present (E) loop
if Is_Subprogram (E)
and then Is_Dispatching_Operation (E)
- and then Is_Interface_Conformant (Tagged_Type, Iface_Prim, E)
then
- return E;
+ -- For overriding primitives of parent or interface types that
+ -- do not have the aspect First_Controlling_Parameter, we must
+ -- temporarily unset this attribute to check conformance.
+
+ if Ekind (E) = E_Function
+ and then Is_FCP_Type
+ and then Present (Overridden_Operation (E))
+ and then Has_Controlling_Result (Overridden_Operation (E))
+ then
+ Set_Has_First_Controlling_Parameter_Aspect (Tagged_Type, False);
+
+ if Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then
+ Set_Has_First_Controlling_Parameter_Aspect
+ (Tagged_Type, Is_FCP_Type);
+ return E;
+ end if;
+
+ Set_Has_First_Controlling_Parameter_Aspect
+ (Tagged_Type, Is_FCP_Type);
+
+ elsif Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then
+ return E;
+ end if;
end if;
E := Homonym (E);
@@ -2501,7 +2671,28 @@ package body Sem_Disp is
-- Check if E covers the interface primitive (includes case in
-- which E is an inherited private primitive).
- if Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then
+ -- For overriding primitives of parent or interface types that
+ -- do not have the aspect First_Controlling_Parameter, we must
+ -- temporarily unset this attribute to check conformance.
+
+ if Present (Overridden_Operation (E))
+ and then Is_FCP_Type
+ and then not
+ Has_First_Controlling_Parameter_Aspect
+ (Find_Dispatching_Type (Overridden_Operation (E)))
+ then
+ Set_Has_First_Controlling_Parameter_Aspect (Tagged_Type, False);
+
+ if Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then
+ Set_Has_First_Controlling_Parameter_Aspect
+ (Tagged_Type, Is_FCP_Type);
+ return E;
+ end if;
+
+ Set_Has_First_Controlling_Parameter_Aspect
+ (Tagged_Type, Is_FCP_Type);
+
+ elsif Is_Interface_Conformant (Tagged_Type, Iface_Prim, E) then
return E;
end if;
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 3a0572c5a00..ce18ddca338 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -17756,6 +17756,91 @@ package body Sem_Prag is
end if;
end Finalize_Storage;
+ ----------------------------------------
+ -- Pragma_First_Controlling_Parameter --
+ ----------------------------------------
+
+ when Pragma_First_Controlling_Parameter => First_Ctrl_Param : declare
+ Arg : Node_Id;
+ E : Entity_Id := Empty;
+
+ begin
+ if not Core_Extensions_Allowed then
+ return;
+ end if;
+
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+
+ Arg := Get_Pragma_Arg (Arg1);
+
+ if Nkind (Arg) = N_Identifier then
+ Analyze (Arg);
+ E := Entity (Arg);
+ end if;
+
+ if No (E)
+ or else not Is_Type (E)
+ or else not (Is_Tagged_Type (E)
+ or else Is_Concurrent_Type (E))
+ then
+ Error_Pragma
+ ("pragma% must specify tagged type or concurrent type");
+ end if;
+
+ -- Check use of the pragma on private types
+
+ if Has_Private_Declaration (E) then
+ declare
+ Prev_Id : constant Entity_Id :=
+ Incomplete_Or_Partial_View (E);
+ begin
+ if Is_Tagged_Type (Prev_Id) then
+ if Has_First_Controlling_Parameter_Aspect (Prev_Id) then
+ Error_Pragma
+ ("pragma already specified in private declaration");
+ else
+ Error_Msg_N
+ ("hidden 'First_'Controlling_'Parameter tagged type"
+ & " not allowed", N);
+ end if;
+
+ -- No action needed if the partial view is not tagged. For
+ -- example:
+
+ -- package Example is
+ -- type Private_Type is private;
+ -- private
+ -- type Private_Type is new ... with null record
+ -- with First_Controlling_Parameter; -- Legal
+ -- end;
+
+ else
+ null;
+ end if;
+ end;
+ end if;
+
+ -- The corresponding record type of concurrent types will not be
+ -- a tagged type when it does not implement some interface type.
+
+ if Is_Concurrent_Type (E)
+ and then Present (Parent (E))
+ and then No (Interface_List (Parent (E)))
+ then
+ if Warn_On_Non_Dispatching_Primitives then
+ Error_Msg_N
+ ("?_j?'First_'Controlling_'Parameter has no effect", N);
+ Error_Msg_NE
+ ("?_j?because & does not implement interface types",
+ N, E);
+ end if;
+
+ else
+ Set_Has_First_Controlling_Parameter_Aspect (E);
+ end if;
+ end First_Ctrl_Param;
+
-----------
-- Ghost --
-----------
@@ -32790,6 +32875,7 @@ package body Sem_Prag is
Pragma_Fast_Math => 0,
Pragma_Favor_Top_Level => 0,
Pragma_Finalize_Storage_Only => 0,
+ Pragma_First_Controlling_Parameter => 0,
Pragma_Ghost => 0,
Pragma_Global => -1,
Pragma_GNAT_Annotate => 93,
diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
index 557e0454870..48a16038f38 100644
--- a/gcc/ada/sem_prag.ads
+++ b/gcc/ada/sem_prag.ads
@@ -64,6 +64,7 @@ package Sem_Prag is
Pragma_Export => True,
Pragma_Extensions_Visible => True,
Pragma_Favor_Top_Level => True,
+ Pragma_First_Controlling_Parameter => True,
Pragma_Ghost => True,
Pragma_Global => True,
Pragma_GNAT_Annotate => True,
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 3ed4d3a6caa..12a14c8b396 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -567,6 +567,7 @@ package Snames is
Name_Extensions_Visible : constant Name_Id := N + $; -- GNAT
Name_External : constant Name_Id := N + $; -- GNAT
Name_Finalize_Storage_Only : constant Name_Id := N + $; -- GNAT
+ Name_First_Controlling_Parameter : constant Name_Id := N + $;
Name_Ghost : constant Name_Id := N + $; -- GNAT
Name_Global : constant Name_Id := N + $; -- GNAT
Name_Ident : constant Name_Id := N + $; -- GNAT
@@ -1870,6 +1871,7 @@ package Snames is
Pragma_Extensions_Visible,
Pragma_External,
Pragma_Finalize_Storage_Only,
+ Pragma_First_Controlling_Parameter,
Pragma_Ghost,
Pragma_Global,
Pragma_Ident,
diff --git a/gcc/ada/warnsw.adb b/gcc/ada/warnsw.adb
index 4c6934df950..ea7e94c4114 100644
--- a/gcc/ada/warnsw.adb
+++ b/gcc/ada/warnsw.adb
@@ -92,12 +92,13 @@ package body Warnsw is
'z' => X.Warn_On_Size_Alignment),
'_' =>
- ('b' | 'd' | 'e' | 'f' | 'g' | 'h' | 'i' | 'j' | 'k' | 'l' | 'm' |
+ ('b' | 'd' | 'e' | 'f' | 'g' | 'h' | 'i' | 'k' | 'l' | 'm' |
'n' | 'o' | 't' | 'u' | 'v' | 'w' | 'x' | 'y' | 'z' =>
No_Such_Warning,
'a' => X.Warn_On_Anonymous_Allocators,
'c' => X.Warn_On_Unknown_Compile_Time_Warning,
+ 'j' => X.Warn_On_Non_Dispatching_Primitives,
'p' => X.Warn_On_Pedantic_Checks,
'q' => X.Warn_On_Ignored_Equality,
'r' => X.Warn_On_Component_Order,
@@ -190,6 +191,7 @@ package body Warnsw is
-- These warnings are removed from the -gnatwa set
Implementation_Unit_Warnings := False;
+ Warn_On_Non_Dispatching_Primitives := False;
Warn_On_Non_Local_Exception := False;
No_Warn_On_Non_Local_Exception := True;
Warn_On_Reverse_Bit_Order := False;
diff --git a/gcc/ada/warnsw.ads b/gcc/ada/warnsw.ads
index 5dab97070c9..10ec8a5700b 100644
--- a/gcc/ada/warnsw.ads
+++ b/gcc/ada/warnsw.ads
@@ -75,6 +75,7 @@ package Warnsw is
Warn_On_Late_Primitives,
Warn_On_Modified_Unread,
Warn_On_No_Value_Assigned,
+ Warn_On_Non_Dispatching_Primitives,
Warn_On_Non_Local_Exception,
No_Warn_On_Non_Local_Exception,
Warn_On_Object_Renames_Function,
@@ -159,6 +160,7 @@ package Warnsw is
Warn_On_Ineffective_Predicate_Test |
Warn_On_Late_Primitives |
Warn_On_Modified_Unread |
+ Warn_On_Non_Dispatching_Primitives |
Warn_On_Non_Local_Exception |
No_Warn_On_Non_Local_Exception |
Warn_On_Object_Renames_Function |
@@ -357,6 +359,11 @@ package Warnsw is
-- suppress such warnings. The default is that such warnings are enabled.
-- Modified by use of -gnatwv/V.
+ Warn_On_Non_Dispatching_Primitives : Boolean renames F
(X.Warn_On_Non_Dispatching_Primitives);
+ -- Set to True to generate warnings for non dispatching primitives of
tagged
+ -- types that have aspect/pragma First_Controlling_Parameter set to True.
+ -- This is turned on by -gnatw_j and turned off by -gnatw_J
+
Warn_On_Non_Local_Exception : Boolean renames F
(X.Warn_On_Non_Local_Exception);
-- Set to True to generate warnings for non-local exception raises and also
-- handlers that can never handle a local raise. This warning is only ever
--
2.45.2
