From: Gary Dismukes <dismu...@adacore.com>
This set of changes fixes various issues with the handling of inheritance
of nonoverridable aspects (such as for Aggregate, and the indexing and
iterator aspects, among others), plus improves some of the error reporting
related to those. The prior implementation incorrectly handled types
derived from container types with respect to such aspect inheritance,
not properly inheriting the parent type's aspects, leading to rejection
of legal constructs (such as container aggregates for the derived type).
Also, various errors were incorrect (such as stating the wrong aspect)
or unclear.
In the case of types with indexing aspects, the resolution of indexed
names for such types involved locating the eligible indexing functions
anew with the analysis of each indexed name, which was both inefficient
and wrong in some cases. That is addressed by locating the functions once,
when the aspects are resolved, rather doing the location of those in two
places, which is a maintenance hazard and could result in inconsistent
resolution.
Note that this completes work originally undertaken by Ed Schonberg
that was also worked on by Steve Baird.
gcc/ada/ChangeLog:
* diagnostics-constructors.adb
(Make_Default_Iterator_Not_Primitive_Error):
Revise message to match message change made in sem_ch13.adb.
* freeze.adb (Freeze_Record_Type): Output appropriate aspect name in
error message, using Get_Name_String.
(Freeze_Entity): For derived types, call Analyze_Aspects_At_Freeze_Point
on the parent type, and call Inherit_Nonoverridable_Aspects on the type
(for both parent type and any progenitor types). Add with_clause for
System.Case_Util.
* gen_il-fields.ads: Add Aspect_Subprograms to type Opt_Field_Enum.
* gen_il-gen-gen_nodes.adb: Add field Aspect_Subprograms to
N_Aspect_Specification nodes.
* sem_ch4.adb (Try_Container_Indexing): Remove Find_Indexing_Operations
and the code calling it. Add new function Indexing_Interpretations for
retrieving the eligible indexing functions from the appropriate aspect's
Aspect_Subprograms list and call that instead of Find_Value_Of_Aspect.
* sem_ch7.adb (Analyze_Package_Specification): In loop over entities,
call Analyze_Aspects_At_Freeze_Point for types that have delayed
aspects.
* sem_ch13.ads (Analyze_Aspects_At_Freeze_Point): Add
Nonoverridable_Only
formal to restrict processing to nonoverridable aspects.
(Check_Function_For_Indexing_Aspect): New exported procedure renamed
from Check_One_Function and moved to library level.
* sem_ch13.adb (Analyze_Aspects_At_Freeze_Point): Test new formal
Nonoverridable_Only formal to skip processing of aspects that are not
nonoverridable when the formal is True. Skip the processing for
Aspect_Full_Access_Only when Nonoverridable_Only is True. Call
Check_Indexing_Functions in the case of indexing aspects (procedure
moved from Analyze_Attribute_Definition_Clause to top level).
(Analyze_Aspect_Specifications): Locate closest ancestor type with an
explicit matching aspect to determine the aspect spec to reference in
the error about a nonoverridable aspect not confirming an inherited
aspect (skipping intermediate derived parents). Ensures that we retain
existing errors flagged on explicit ancestor aspects rather than
implicit inherited ones. Change names of variables Parent_Type and
Inherited_Aspect to Ancestor_Type and Ancestor_Aspect respectively
for clarity.
(Analyze_Attribute_Definition_Clause): Move nested subprograms
Check_Iterator_Functions and Check_Primitive_Function to top level
of package. Move Check_Indexing_Functions (and its nested subprograms)
from here to within Analyze_Aspects_At_Freeze_Point (adding some
formal parameters and adjusting the code appropriately, and no longer
call it from this procedure).
(Is_CW_Or_Access_To_CW): Add test for the parent type having the
indexing aspect for proper setting of Aspect_Specification_Is_Inherited.
Delete "???" comment.
(Look_Through_Anon_Access): Remove unneeded tests of Is_Access_Constant
and Name_Constant_Indexing, which lead to wrong messages in some cases.
(Check_Function_For_Indexing_Aspect): Procedure renamed from
Check_One_Function and moved to library level (was nested within
Check_Indexing_Functions), plus added formals (including Valid, to
check result). Move scope test to beginning, to immediately exclude
subprograms not declared immediately within the same scope as the type.
Improve several error messages. Add error checking for Constant_Indexing
functions. Append the function entity to the Aspect_Subprograms list of
the aspect specification. Move code for checking for nonconfirming
index aspects and for checking for illegal indexing aspects on full
views to Check_Indexing_Functions.
(Check_Indexing_Functions): Move procedure Illegal_Indexing from
here to within Check_Function_For_Indexing_Aspect. Add a comment
to the loop over interpretations about the checking being done as
legality rules rather than resolution rules, plus a note referencing
AI22-0084. Check for nonconfirming indexing aspects and illegal
indexing aspects on full views here rather than in Check_One_Function
(now named Check_Function_For_Indexing_Aspect). Remove function
Check_One_Function (moved to library level and renamed), and call
Check_Function_For_Indexing_Aspect instead.
(Check_Inherited_Indexing): Improve spec comment. Remove nested function
Same_Chars, and replace call Same_Chars with call to Sem_Util.Same_Name.
Replace call to Illegal_Indexing with call to Error_Msg_NE.
(Check_One_Function): Unnested from Check_Indexing_Functions, rename
to Check_Function_For_Indexing_Aspect, move body to library level,
and move declaration to Sem_Ch13 spec.
(Analyze_Attribute_Definition_Clause, case Attribute_Default_Iterator):
Improve error message related to tagged-type requirement. Suppress call
to Check_Iterator_Functions for attribute definition clauses associated
with inherited aspects. Remove error checking that is redundant with
checking done in Check_Iterator_Functions.
(Check_Aspect_At_Freeze_Point, case Attribute_Default_Iterator): Call
Check_Iterator_Functions (only if the aspect is not Comes_From_Source).
(Check_Iterator_Functions): Procedure unnested from
Analyze_Attribute_Definition_Clause. Add formals Typ and Expr.
Error messages corrected to say "aspect Default_Iterator" instead of
"aspect Iterator".
(Valid_Default_Iterator): Improve error message to say "must be
a local primitive or class-wide function" instead of "must be
a primitive function".
(Check_Primitive_Function): Unnested from
Analyze_Attribute_Definition_Clause.
Add formal Ent.
(Rep_Item_Too_Late): Return False when an attribute_definition_clause
is not Comes_From_Source, since it was generated by the compiler (such
as for an inherited aspect).
(Resolve_Aspect_Aggregate): Capture implementation base type.
(Valid_Empty): Use implementation base types for result type comparison.
(Valid_Add_Named): Use impl base types for comparison of formal's type.
(Valid_Add_Unnamed): Use impl base types for comparison of formal's
type.
(Valid_New_Indexed): Use impl base types for result type comparison.
(Validate_Literal_Aspect): Return immediately when aspect does not have
Comes_From_Source True (no point in validating inherited aspects).
* sem_res.adb (Has_Applicable_User_Defined_Literal): Remove Base_Type
comparison and always call Corresponding_Op_Of_Derived_Type for derived
types. Add "???" comment about issue with wrapper functions (and
indicate that it would be nice to eliminate the call to
Corresponding_Primitive_Op).
* sem_util.ads (Inherit_Nonoverridable_Aspects): New procedure.
(Corresponding_Op_Of_Derived_Type): Update spec comment to indicate
return of Ancestor_Op and name changed from Corresponding_Primitive_Op.
* sem_util.adb (Check_Inherited_Nonoverridable_Aspects): Fix name in
header comment.
(Corresponding_Op_Of_Derived_Type): Move declaration of Typ down with
other local variables. Remove Assert that doesn't apply in some cases.
Simply return Ancestor_Op when it isn't a primitive (it can be a
class-wide op). Function name changed from Corresponding_Primitive_Op.
(Find_Untagged_Type_Of): Add test of Is_Type (E) as a guard for checking
Direct_Primitive_Operations. Remove Assert (False), and return Empty
when the primitive is not found.
(Profile_Matches_Ancestor): Change comparisons to use implementation
base types of the operations' formal and result types. Add tests for
interface ancestors. Revise "???" comment.
(Is_Confirming): Simplify name-matching test to use the names associated
with the aspects rather than going to the N_Attribute_Definition_Clause
nodes (may facilitate elimination of those clauses at some point).
(Inherit_Nonoverridable_Aspects): New procedure to traverse the
aspects of a derived type's parent type and create inherited versions
of the parent type's nonoverridable aspects, identifying the appropriate
subprograms for each such inherited aspect.
(Inherit_Nonoverridable_Aspect): New procedure nested in
Inherit_Nonoverridable_Aspects to inherit individual nonoverridable
aspects. Identifies the corresponding subprogram(s) associated with
an inherited nonoverridable aspect. In the case of indexing aspects,
new eligible indexing functions of the type are also identified here,
and the entities of all of the identified subprograms are appended to
the aspect's Aspect_Subprograms Elist. Add a "???" comment about this.
* sinfo.ads: Add documentation for the new Aspect_Subprograms field.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/diagnostics-constructors.adb | 2 +-
gcc/ada/freeze.adb | 42 +-
gcc/ada/gen_il-fields.ads | 1 +
gcc/ada/gen_il-gen-gen_nodes.adb | 1 +
gcc/ada/sem_ch13.adb | 1452 +++++++++++++++-----------
gcc/ada/sem_ch13.ads | 21 +-
gcc/ada/sem_ch4.adb | 289 +----
gcc/ada/sem_ch7.adb | 8 +
gcc/ada/sem_res.adb | 13 +-
gcc/ada/sem_util.adb | 373 ++++++-
gcc/ada/sem_util.ads | 22 +-
gcc/ada/sinfo.ads | 6 +
12 files changed, 1305 insertions(+), 925 deletions(-)
diff --git a/gcc/ada/diagnostics-constructors.adb
b/gcc/ada/diagnostics-constructors.adb
index ce130cceaa2..d94119662e5 100644
--- a/gcc/ada/diagnostics-constructors.adb
+++ b/gcc/ada/diagnostics-constructors.adb
@@ -49,7 +49,7 @@ package body Diagnostics.Constructors is
(Msg =>
"default iterator defined " &
Sloc_To_String (Subp, Sloc (Expr)) &
- " must be a primitive function",
+ " must be a local primitive or class-wide function",
Locations =>
(1 => Primary_Labeled_Span (Subp)))));
end Make_Default_Iterator_Not_Primitive_Error;
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index c36f626cc8c..fe74c97f261 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -6020,9 +6020,15 @@ package body Freeze is
then
null;
else
- Error_Msg_N
- ("Iterator_Element requires indexing aspect",
- Iterator_Aspect);
+ if Get_Aspect_Id (Iterator_Aspect) = Aspect_Iterator_Element
+ then
+ Error_Msg_N ("Iterator_Element requires indexing aspect",
+ Iterator_Aspect);
+
+ else
+ Error_Msg_N ("Default_Iterator requires indexing aspect",
+ Iterator_Aspect);
+ end if;
end if;
end if;
end;
@@ -6665,6 +6671,36 @@ package body Freeze is
end;
end if;
+ if Is_Derived_Type (E) and then Is_First_Subtype (E) then
+
+ -- If a derived type's parent type is not already frozen and has
+ -- delayed aspects, analyze the parent type's aspects at this point,
+ -- so that the following call to update the type's inherited aspects
+ -- will be effective.
+
+ if not Is_Frozen (Etype (E))
+ and then Has_Delayed_Aspects (Etype (E))
+ then
+ Analyze_Aspects_At_Freeze_Point (Etype (E));
+ Set_Has_Delayed_Aspects (Etype (E), False);
+ end if;
+
+ -- Identify the various subprograms associated with any inherited
+ -- nonoverridable aspects at this point rather than allowing them
+ -- to be resolved during analysis.
+
+ Inherit_Nonoverridable_Aspects (E, Etype (E));
+
+ declare
+ Iface : Node_Id := First (Abstract_Interface_List (E));
+ begin
+ while Present (Iface) loop
+ Inherit_Nonoverridable_Aspects (E, Entity (Iface));
+ Next (Iface);
+ end loop;
+ end;
+ end if;
+
if Has_Delayed_Aspects (E) then
Analyze_Aspects_At_Freeze_Point (E);
end if;
diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads
index 34ae14260ae..b2a498003d8 100644
--- a/gcc/ada/gen_il-fields.ads
+++ b/gcc/ada/gen_il-fields.ads
@@ -77,6 +77,7 @@ package Gen_IL.Fields is
Aspect_On_Partial_View,
Aspect_Rep_Item,
Aspect_Specifications,
+ Aspect_Subprograms,
Assignment_OK,
Attribute_Name,
At_End_Proc,
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index b322f3ca81c..461195b5e34 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -1257,6 +1257,7 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sy (Class_Present, Flag),
Sm (Aspect_On_Partial_View, Flag),
Sm (Aspect_Rep_Item, Node_Id),
+ Sm (Aspect_Subprograms, Elist_Id),
Sm (Entity_Or_Associated_Node, Node_Id), -- just Entity
Sm (Expression_Copy, Node_Id),
Sm (Is_Boolean_Aspect, Flag),
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index a5db33676ae..f425048222e 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -169,10 +169,20 @@ package body Sem_Ch13 is
-- node N for the given type (entity) of the aspect does not appear too
-- late according to the rules in RM 13.1(9) and 13.1(10).
+ procedure Check_Iterator_Functions (Typ : Entity_Id; Expr : Node_Id);
+ -- Check that there is a single function in the type's Default_Iterator
+ -- aspect that has the proper type structure. Expr is the name given in
+ -- the aspect specification.
+
procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id);
-- Called if both Storage_Pool and Storage_Size attribute definition
-- clauses (SP and SS) are present for entity Ent. Issue error message.
+ function Check_Primitive_Function
+ (Subp : Entity_Id; Ent : Entity_Id) return Boolean;
+ -- Common legality checks for primitive-denoting aspects. Checks that
+ -- Subp is a primitive subprogram of the type Ent.
+
procedure Freeze_Entity_Checks (N : Node_Id);
-- Called from Analyze_Freeze_Entity and Analyze_Generic_Freeze Entity
-- to generate appropriate semantic checks that are delayed until this
@@ -971,11 +981,19 @@ package body Sem_Ch13 is
-- Analyze_Aspects_At_Freeze_Point --
-------------------------------------
- procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id) is
+ procedure Analyze_Aspects_At_Freeze_Point
+ (E : Entity_Id;
+ Nonoverridable_Only : Boolean := False)
+ is
procedure Analyze_Aspect_Default_Value (ASN : Node_Id);
-- This routine analyzes an Aspect_Default_[Component_]Value denoted by
-- the aspect specification node ASN.
+ procedure Check_Indexing_Functions (ASN : Node_Id);
+ -- Check that the function in a Constant_Indexing or Variable_Indexing
+ -- aspect has the proper profile. If the name is overloaded, check that
+ -- some interpretation is legal.
+
procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id);
-- Given an aspect specification node ASN whose expression is an
-- optional Boolean, this routines creates the corresponding pragma
@@ -1001,6 +1019,184 @@ package body Sem_Ch13 is
Check_Aspect_Too_Late (ASN);
end Analyze_Aspect_Default_Value;
+ ------------------------------
+ -- Check_Indexing_Functions --
+ ------------------------------
+
+ procedure Check_Indexing_Functions (ASN : Node_Id) is
+ Aspect : constant Aspect_Id := Get_Aspect_Id (ASN);
+ Expr : constant Node_Id := Expression (ASN);
+
+ Indexing_Found : Boolean := False;
+
+ procedure Check_Inherited_Indexing;
+ -- For a derived type, check that the specification of an indexing
+ -- aspect can only be confirming (i.e., that it uses the same name
+ -- as the parent type's aspect).
+ --
+ -- AI12-0160: The uses of Constant_Indexing and Variable_Indexing
+ -- aspects have to be the same for all descendants of an indexable
+ -- container type.
+
+ ------------------------------
+ -- Check_Inherited_Indexing --
+ ------------------------------
+
+ procedure Check_Inherited_Indexing is
+ Inherited : Node_Id;
+ Other_Indexing : Node_Id;
+
+ begin
+ if Aspect = Aspect_Constant_Indexing then
+ Inherited :=
+ Find_Aspect (Etype (E), Aspect_Constant_Indexing);
+ Other_Indexing :=
+ Find_Aspect (Etype (E), Aspect_Variable_Indexing);
+
+ else pragma Assert (Aspect = Aspect_Variable_Indexing);
+ Inherited :=
+ Find_Aspect (Etype (E), Aspect_Variable_Indexing);
+ Other_Indexing :=
+ Find_Aspect (Etype (E), Aspect_Constant_Indexing);
+ end if;
+
+ if Present (Inherited) then
+
+ -- Check if this is a confirming specification. The name
+ -- may be overloaded between the parent operation and the
+ -- inherited one, so we check that the Chars fields match.
+
+ if Same_Name (Expression (Inherited), Expression (ASN)) then
+ Indexing_Found := True;
+
+ -- Indicate the operation that must be overridden, rather than
+ -- redefining the indexing aspect.
+
+ else
+ Error_Msg_NE
+ ("overriding of inherited indexing aspect" &
+ " must be confirming", ASN, E);
+ Error_Msg_NE
+ ("\\override & instead",
+ ASN, Entity (Expression (Inherited)));
+ end if;
+
+ -- If not inherited and the parent has another indexing function
+ -- this is illegal, because it leads to inconsistent results in
+ -- class-wide calls.
+
+ elsif Present (Other_Indexing) then
+ Error_Msg_N
+ ("cannot specify one indexing aspect for derived type"
+ & " if the other indexing aspect is specified for the"
+ & " parent and this aspect is not", ASN);
+ end if;
+ end Check_Inherited_Indexing;
+
+ -- Start of processing for Check_Indexing_Functions
+
+ begin
+ -- If the aspect specification was effectively inherited from the
+ -- parent type (so constructed anew by analysis), then no point
+ -- in validating.
+
+ if not Comes_From_Source (ASN) then
+ return;
+ end if;
+
+ if not Is_Overloaded (Expr) then
+ Check_Function_For_Indexing_Aspect
+ (ASN, E, Entity (Expr), Valid => Indexing_Found);
+
+ else
+ declare
+ I : Interp_Index;
+ It : Interp;
+ Valid : Boolean;
+
+ begin
+ Get_First_Interp (Expr, I, It);
+ while Present (It.Nam) loop
+
+ -- Check that each interpretation is a function valid for
+ -- use as an indexing function. (Note that the rules for
+ -- indexing aspects are to be treated as legality rules,
+ -- as per AI22-0084. If this is ever changed to treat these
+ -- as resolution rules, then we'll have to keep track of
+ -- whether there are further interpretations to be tested,
+ -- and condition the error reporting within Illegal_Indexing
+ -- on that.)
+
+ if Is_Overloadable (It.Nam) then
+ Check_Function_For_Indexing_Aspect
+ (ASN, E, It.Nam, Valid);
+ Indexing_Found := Indexing_Found or Valid;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+ end;
+ end if;
+
+ if not Indexing_Found and then not Error_Posted (ASN) then
+ Error_Msg_NE
+ ("indexing aspect requires a local function that applies to "
+ & "type&", Expr, E);
+ end if;
+
+ -- ??? Is Is_Derived_Type the right test here? A derived type's
+ -- ancestor might or might not have the aspect specified, and
+ -- the derived type itself might or might not have an explicit
+ -- aspect specification (as opposed to an aspect specification
+ -- implicitly introduced by the compiler). So lots of cases to
+ -- consider.
+
+ if Is_Derived_Type (E)
+ -- See comment re this debug flag in exp_ch5.adb
+ and then not Debug_Flag_Dot_XX
+ then
+ Check_Inherited_Indexing;
+ end if;
+
+ -- If partial declaration exists, verify that it is not tagged.
+
+ if Ekind (Current_Scope) = E_Package
+ and then Has_Private_Declaration (E)
+ and then
+ List_Containing (Parent (E)) =
+ Private_Declarations
+ (Specification (Unit_Declaration_Node (Current_Scope)))
+ then
+ declare
+ Decl : Node_Id;
+
+ begin
+ Decl :=
+ First (Visible_Declarations
+ (Specification
+ (Unit_Declaration_Node (Current_Scope))));
+
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Private_Type_Declaration
+ and then E = Full_View (Defining_Identifier (Decl))
+ and then Tagged_Present (Decl)
+ and then No (Aspect_Specifications (Decl))
+ -- Don't complain about compiler-generated
+ -- confirming specifications for inherited aspects.
+ and then Comes_From_Source (ASN)
+ then
+ Error_Msg_NE
+ ("indexing aspect cannot be specified on full view "
+ & "if partial view is tagged", ASN, E);
+ return;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end;
+ end if;
+ end Check_Indexing_Functions;
+
-------------------------------------
-- Make_Pragma_From_Boolean_Aspect --
-------------------------------------
@@ -1139,9 +1335,14 @@ package body Sem_Ch13 is
-- package it may be frozen from an object declaration in the enclosing
-- scope, so install the package declarations to complete the analysis
-- of the aspects, if any. If the package itself is frozen the type will
- -- have been frozen as well.
+ -- have been frozen as well. We don't do this in the case where formal
+ -- Nonoverridable_Only is True, because that formal is only passed True
+ -- at the ends of certain declaration lists (like visible-part lists),
+ -- not when this procedure is called at arbitrary freeze points.
- if not Scope_Within_Or_Same (Current_Scope, Scope (E)) then
+ if not Nonoverridable_Only
+ and then not Scope_Within_Or_Same (Current_Scope, Scope (E))
+ then
if Is_Type (E) and then From_Nested_Package (E) then
declare
Pack : constant Entity_Id := Scope (E);
@@ -1180,6 +1381,16 @@ package body Sem_Ch13 is
if Is_Delayed_Aspect (ASN) then
A_Id := Get_Aspect_Id (ASN);
+ -- When Nonoverridable_Only is True (such as at the end of
+ -- a visible part), we only want to process aspects that are
+ -- nonoverridable, and skip others.
+
+ if Nonoverridable_Only
+ and then A_Id not in Nonoverridable_Aspect_Id
+ then
+ goto Skip_Aspect;
+ end if;
+
case A_Id is
-- For aspects whose expression is an optional Boolean, make
@@ -1250,6 +1461,11 @@ package body Sem_Ch13 is
Error_Msg_NE
("aspect must be fully defined before & is frozen",
ASN, E);
+
+ elsif A_Id in Aspect_Constant_Indexing
+ | Aspect_Variable_Indexing
+ then
+ Check_Indexing_Functions (ASN);
end if;
when Aspect_Integer_Literal
@@ -1294,6 +1510,24 @@ package body Sem_Ch13 is
ASN);
end if;
+ -- Inherited nonoverridable aspect: analysis will
+ -- verify that it is consistent.
+
+ -- If the aspect is not Comes_From_Source, then it's
+ -- an inherited aspect, in which case the aspect's
+ -- operations have already been set and there's no need
+ -- to resolve it.
+
+ -- Does this test of Is_Derived_Type make sense here,
+ -- and is the call to Resolve_Aspect_Aggregate even
+ -- needed here??? (It's called other places.)
+
+ if Is_Derived_Type (E)
+ and then Comes_From_Source (ASN)
+ then
+ Resolve_Aspect_Aggregate (E, Expression (ASN));
+ end if;
+
when Aspect_Finalizable =>
Validate_Finalizable_Aspect (E, ASN);
@@ -1309,27 +1543,34 @@ package body Sem_Ch13 is
end if;
end if;
+ <<Skip_Aspect>>
Next_Rep_Item (ASN);
end loop;
- -- Make a second pass for a Full_Access_Only entry, see above why
+ if not Nonoverridable_Only then
+ -- Make a second pass for a Full_Access_Only entry, see above why
- ASN := First_Rep_Item (E);
- while Present (ASN) loop
- if Nkind (ASN) = N_Aspect_Specification then
- exit when Entity (ASN) /= E;
+ ASN := First_Rep_Item (E);
+ while Present (ASN) loop
+ if Nkind (ASN) = N_Aspect_Specification then
+ exit when Entity (ASN) /= E;
- if Get_Aspect_Id (ASN) = Aspect_Full_Access_Only then
- Make_Pragma_From_Boolean_Aspect (ASN);
- Ritem := Aspect_Rep_Item (ASN);
- if Present (Ritem) then
- Analyze (Ritem);
+ if Get_Aspect_Id (ASN) = Aspect_Full_Access_Only then
+ Make_Pragma_From_Boolean_Aspect (ASN);
+ Ritem := Aspect_Rep_Item (ASN);
+ if Present (Ritem) then
+ Analyze (Ritem);
+ end if;
end if;
end if;
- end if;
- Next_Rep_Item (ASN);
- end loop;
+ Next_Rep_Item (ASN);
+ end loop;
+ end if;
+
+ -- Would be nice to have a comment explaining what this is about. ???
+ -- Also, it's not clear whether this should be done in the case where
+ -- Nonoverridable_Only is True.
if In_Instance
and then E /= Base_Type (E)
@@ -4797,30 +5038,45 @@ package body Sem_Ch13 is
and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition
and then not In_Instance_Body
then
+ -- Locate the nearest ancestor type that has an explicit aspect
+ -- corresponding to E's aspect, and flag an error on that if
+ -- E's aspect does not confirm the aspect inherited from the
+ -- ancestor.
+
-- In order to locate the parent type we must go first to its
-- base type because the frontend introduces an implicit base
-- type even if there is no constraint attached to it, since
-- this is closer to the Ada semantics.
declare
- Parent_Type : constant Entity_Id :=
- Etype (Base_Type (E));
- Inherited_Aspect : constant Node_Id :=
- Find_Aspect (Parent_Type, A_Id);
+ Ancestor_Type : Entity_Id := Etype (Base_Type (E));
+ Ancestor_Aspect : Node_Id := Find_Aspect
+ (Ancestor_Type, A_Id);
begin
- if Present (Inherited_Aspect)
- and then not Is_Confirming
- (A_Id, Inherited_Aspect, Aspect)
- then
- Error_Msg_Name_1 := Aspect_Names (A_Id);
- Error_Msg_Sloc := Sloc (Inherited_Aspect);
+ while Present (Ancestor_Aspect) loop
+ if Comes_From_Source (Ancestor_Aspect)
+ and then
+ not Is_Confirming (A_Id, Ancestor_Aspect, Aspect)
+ then
+ Error_Msg_Name_1 := Aspect_Names (A_Id);
+ Error_Msg_Sloc := Sloc (Ancestor_Aspect);
- Error_Msg_N
- ("overriding aspect specification for "
- & "nonoverridable aspect % does not confirm "
- & "aspect specification inherited from #",
- Aspect);
- end if;
+ Error_Msg_N
+ ("overriding aspect specification for "
+ & "nonoverridable aspect % does not confirm "
+ & "aspect specification inherited from #",
+ Aspect);
+
+ exit;
+ end if;
+
+ if not Is_Derived_Type (Ancestor_Type) then
+ exit;
+ end if;
+
+ Ancestor_Type := Etype (Base_Type (Ancestor_Type));
+ Ancestor_Aspect := Find_Aspect (Ancestor_Type, A_Id);
+ end loop;
end;
end if;
@@ -5058,18 +5314,6 @@ package body Sem_Ch13 is
-- and Value_Size are considered to conflict, but for compatibility,
-- this is merely a warning.
- procedure Check_Indexing_Functions;
- -- Check that the function in Constant_Indexing or Variable_Indexing
- -- attribute has the proper type structure. If the name is overloaded,
- -- check that some interpretation is legal.
-
- procedure Check_Iterator_Functions;
- -- Check that there is a single function in Default_Iterator attribute
- -- that has the proper type structure.
-
- function Check_Primitive_Function (Subp : Entity_Id) return Boolean;
- -- Common legality check for the previous two
-
-----------------------------------
-- Analyze_Put_Image_TSS_Definition --
-----------------------------------
@@ -5432,533 +5676,6 @@ package body Sem_Ch13 is
end if;
end Analyze_Stream_TSS_Definition;
- ------------------------------
- -- Check_Indexing_Functions --
- ------------------------------
-
- procedure Check_Indexing_Functions is
- Indexing_Found : Boolean := False;
-
- procedure Check_Inherited_Indexing;
- -- For a derived type, check that for a derived type, a specification
- -- of an indexing aspect can only be confirming, i.e. uses the same
- -- name as in the parent type.
- -- AI12-0160: Verify that an indexing cannot be specified for
- -- a derived type unless it is specified for the parent.
-
- procedure Check_One_Function (Subp : Entity_Id);
- -- Check one possible interpretation. Sets Indexing_Found True if a
- -- legal indexing function is found.
-
- procedure Illegal_Indexing (Msg : String);
- -- Diagnose illegal indexing function if not overloaded. In the
- -- overloaded case indicate that no legal interpretation exists.
-
- ------------------------------
- -- Check_Inherited_Indexing --
- ------------------------------
-
- procedure Check_Inherited_Indexing is
- Inherited : Node_Id;
- Other_Indexing : Node_Id;
-
- begin
- if Attr = Name_Constant_Indexing then
- Inherited :=
- Find_Aspect (Etype (Ent), Aspect_Constant_Indexing);
- Other_Indexing :=
- Find_Aspect (Etype (Ent), Aspect_Variable_Indexing);
-
- else pragma Assert (Attr = Name_Variable_Indexing);
- Inherited :=
- Find_Aspect (Etype (Ent), Aspect_Variable_Indexing);
- Other_Indexing :=
- Find_Aspect (Etype (Ent), Aspect_Constant_Indexing);
- end if;
-
- if Present (Inherited) then
- if Debug_Flag_Dot_XX then
- null;
-
- -- OK if current attribute_definition_clause is expansion of
- -- inherited aspect.
-
- elsif Aspect_Rep_Item (Inherited) = N then
- null;
-
- -- Check if this is a confirming specification. The name
- -- may be overloaded between the parent operation and the
- -- inherited one, so we check that the Chars fields match.
-
- elsif Is_Entity_Name (Expression (Inherited))
- and then Chars (Entity (Expression (Inherited))) =
- Chars (Entity (Expression (N)))
- then
- Indexing_Found := True;
-
- -- Indicate the operation that must be overridden, rather than
- -- redefining the indexing aspect.
-
- else
- Illegal_Indexing
- ("indexing function already inherited from parent type");
- Error_Msg_NE
- ("!override & instead",
- N, Entity (Expression (Inherited)));
- end if;
-
- -- If not inherited and the parent has another indexing function
- -- this is illegal, because it leads to inconsistent results in
- -- class-wide calls.
-
- elsif Present (Other_Indexing) then
- Error_Msg_N
- ("cannot specify indexing operation on derived type"
- & " if not specified for parent", N);
- end if;
- end Check_Inherited_Indexing;
-
- ------------------------
- -- Check_One_Function --
- ------------------------
-
- procedure Check_One_Function (Subp : Entity_Id) is
- Default_Element : Node_Id;
- Ret_Type : constant Entity_Id := Etype (Subp);
-
- begin
- if not Is_Overloadable (Subp) then
- Illegal_Indexing ("illegal indexing function for type&");
- return;
-
- elsif Scope (Subp) /= Scope (Ent) then
- if Nkind (Expr) = N_Expanded_Name then
-
- -- Indexing function can't be declared elsewhere
-
- Illegal_Indexing
- ("indexing function must be declared"
- & " in scope of type&");
- end if;
-
- if Is_Derived_Type (Ent) then
- Check_Inherited_Indexing;
- end if;
-
- return;
-
- elsif No (First_Formal (Subp)) then
- Illegal_Indexing
- ("Indexing requires a function that applies to type&");
- return;
-
- elsif No (Next_Formal (First_Formal (Subp))) then
- Illegal_Indexing
- ("indexing function must have at least two parameters");
- return;
-
- elsif Is_Derived_Type (Ent) then
- Check_Inherited_Indexing;
- end if;
-
- if not Check_Primitive_Function (Subp) then
- Illegal_Indexing
- ("Indexing aspect requires a function that applies to type&");
- return;
- end if;
-
- -- If partial declaration exists, verify that it is not tagged.
-
- if Ekind (Current_Scope) = E_Package
- and then Has_Private_Declaration (Ent)
- and then From_Aspect_Specification (N)
- and then
- List_Containing (Parent (Ent)) =
- Private_Declarations
- (Specification (Unit_Declaration_Node (Current_Scope)))
- and then Nkind (N) = N_Attribute_Definition_Clause
- then
- declare
- Decl : Node_Id;
-
- begin
- Decl :=
- First (Visible_Declarations
- (Specification
- (Unit_Declaration_Node (Current_Scope))));
-
- while Present (Decl) loop
- if Nkind (Decl) = N_Private_Type_Declaration
- and then Ent = Full_View (Defining_Identifier (Decl))
- and then Tagged_Present (Decl)
- and then No (Aspect_Specifications (Decl))
- then
- Illegal_Indexing
- ("Indexing aspect cannot be specified on full view "
- & "if partial view is tagged");
- return;
- end if;
-
- Next (Decl);
- end loop;
- end;
- end if;
-
- -- An indexing function must return either the default element of
- -- the container, or a reference type. For variable indexing it
- -- must be the latter.
-
- Default_Element :=
- Find_Value_Of_Aspect
- (Etype (First_Formal (Subp)), Aspect_Iterator_Element);
-
- if Present (Default_Element) then
- Analyze (Default_Element);
- end if;
-
- -- For variable_indexing the return type must be a reference type
-
- if Attr = Name_Variable_Indexing then
- if not Has_Implicit_Dereference (Ret_Type) then
- Illegal_Indexing
- ("variable indexing must return a reference type");
- return;
-
- elsif Is_Access_Constant
- (Etype (First_Discriminant (Ret_Type)))
- then
- Illegal_Indexing
- ("variable indexing must return an access to variable");
- return;
- end if;
-
- else
- if Has_Implicit_Dereference (Ret_Type)
- and then not
- Is_Access_Constant
- (Etype (Get_Reference_Discriminant (Ret_Type)))
- then
- Illegal_Indexing
- ("constant indexing must return an access to constant");
- return;
-
- elsif Is_Access_Type (Etype (First_Formal (Subp)))
- and then not Is_Access_Constant (Etype (First_Formal (Subp)))
- then
- Illegal_Indexing
- ("constant indexing must apply to an access to constant");
- return;
- end if;
- end if;
-
- -- All checks succeeded
-
- Indexing_Found := True;
- end Check_One_Function;
-
- -----------------------
- -- Illegal_Indexing --
- -----------------------
-
- procedure Illegal_Indexing (Msg : String) is
- begin
- Error_Msg_NE (Msg, N, Ent);
- end Illegal_Indexing;
-
- -- Start of processing for Check_Indexing_Functions
-
- begin
- if In_Instance then
- Check_Inherited_Indexing;
- end if;
-
- Analyze (Expr);
-
- if not Is_Overloaded (Expr) then
- Check_One_Function (Entity (Expr));
-
- else
- declare
- I : Interp_Index;
- It : Interp;
-
- begin
- Indexing_Found := False;
- Get_First_Interp (Expr, I, It);
- while Present (It.Nam) loop
-
- -- Note that analysis will have added the interpretation
- -- that corresponds to the dereference. We only check the
- -- subprogram itself. Ignore homonyms that may come from
- -- derived types in the context.
-
- if Is_Overloadable (It.Nam)
- and then Comes_From_Source (It.Nam)
- then
- Check_One_Function (It.Nam);
- end if;
-
- Get_Next_Interp (I, It);
- end loop;
- end;
- end if;
-
- if not Indexing_Found and then not Error_Posted (N) then
- Error_Msg_NE
- ("aspect Indexing requires a local function that applies to "
- & "type&", Expr, Ent);
- end if;
- end Check_Indexing_Functions;
-
- ------------------------------
- -- Check_Iterator_Functions --
- ------------------------------
-
- procedure Check_Iterator_Functions is
- function Valid_Default_Iterator (Subp : Entity_Id;
- Ref_Node : Node_Id := Empty)
- return Boolean;
- -- Check one possible interpretation for validity. If
- -- Ref_Node is present report errors on violations.
-
- ----------------------------
- -- Valid_Default_Iterator --
- ----------------------------
-
- function Valid_Default_Iterator (Subp : Entity_Id;
- Ref_Node : Node_Id := Empty)
- return Boolean
- is
- Return_Type : constant Entity_Id := Etype (Etype (Subp));
- Return_Node : Node_Id;
- Root_T : constant Entity_Id := Root_Type (Return_Type);
- Formal : Entity_Id;
-
- function Valid_Iterator_Name (E : Entity_Id) return Boolean
- is (Chars (E) in Name_Forward_Iterator | Name_Reversible_Iterator);
-
- function Valid_Iterator_Name (L : Elist_Id) return Boolean;
-
- -------------------------
- -- Valid_Iterator_Name --
- -------------------------
-
- function Valid_Iterator_Name (L : Elist_Id) return Boolean
- is
- Iface_Elmt : Elmt_Id := First_Elmt (L);
- begin
- while Present (Iface_Elmt) loop
- if Valid_Iterator_Name (Node (Iface_Elmt)) then
- return True;
- end if;
- Next_Elmt (Iface_Elmt);
- end loop;
-
- return False;
- end Valid_Iterator_Name;
-
- begin
- if Subp = Any_Id then
- if Present (Ref_Node) then
-
- -- Subp is not resolved and an error will be posted about
- -- it later
-
- Error_Msg_N ("improper function for default iterator!",
- Ref_Node);
- end if;
-
- return False;
- end if;
-
- if not Check_Primitive_Function (Subp) then
- if Present (Ref_Node) then
- if Debug_Flag_Underscore_DD then
- Record_Default_Iterator_Not_Primitive_Error
- (Ref_Node, Subp);
- else
- Error_Msg_N ("improper function for default iterator!",
- Ref_Node);
- Error_Msg_Sloc := Sloc (Subp);
- Error_Msg_NE
- ("\\default iterator defined # "
- & "must be a primitive function",
- Ref_Node, Subp);
- end if;
- end if;
-
- return False;
- end if;
-
- -- The return type must be derived from a type in an instance
- -- of Iterator.Interfaces, and thus its root type must have a
- -- predefined name.
-
- if not Valid_Iterator_Name (Root_T)
- and then not (Has_Interfaces (Return_Type) and then
- Valid_Iterator_Name (Interfaces (Return_Type)))
- then
- if Present (Ref_Node) then
-
- Return_Node := Result_Definition (Parent (Subp));
-
- Error_Msg_N ("improper function for default iterator!",
- Ref_Node);
- Error_Msg_Sloc := Sloc (Return_Node);
- Error_Msg_NE ("\\return type & # "
- & "must inherit from either "
- & "Forward_Iterator or Reversible_Iterator",
- Ref_Node, Return_Node);
- end if;
-
- return False;
- end if;
-
- Formal := First_Formal (Subp);
-
- -- False if any subsequent formal has no default expression
-
- Next_Formal (Formal);
- while Present (Formal) loop
- if No (Expression (Parent (Formal))) then
- if Present (Ref_Node) then
- Error_Msg_N ("improper function for default iterator!",
- Ref_Node);
- Error_Msg_Sloc := Sloc (Formal);
- Error_Msg_NE ("\\formal parameter & # "
- & "must have a default expression",
- Ref_Node, Formal);
- end if;
-
- return False;
- end if;
-
- Next_Formal (Formal);
- end loop;
-
- -- True if all subsequent formals have default expressions
-
- return True;
- end Valid_Default_Iterator;
-
- Ignore : Boolean;
-
- -- Start of processing for Check_Iterator_Functions
-
- begin
- Analyze (Expr);
-
- if not Is_Entity_Name (Expr) then
- Error_Msg_N ("aspect Iterator must be a function name", Expr);
- end if;
-
- if not Is_Overloaded (Expr) then
- if Entity (Expr) /= Any_Id
- and then not Check_Primitive_Function (Entity (Expr))
- then
- Error_Msg_NE
- ("aspect Indexing requires a function that applies to type&",
- Entity (Expr), Ent);
- end if;
-
- -- Flag the default_iterator as well as the denoted function.
-
- Ignore := Valid_Default_Iterator (Entity (Expr), Expr);
-
- else
- declare
- Default : Entity_Id := Empty;
- I : Interp_Index;
- It : Interp;
-
- begin
- Get_First_Interp (Expr, I, It);
- while Present (It.Nam) loop
- if not Check_Primitive_Function (It.Nam)
- or else not Valid_Default_Iterator (It.Nam)
- then
- Remove_Interp (I);
-
- elsif Present (Default) then
-
- -- An explicit one should override an implicit one
-
- if Comes_From_Source (Default) =
- Comes_From_Source (It.Nam)
- then
- Error_Msg_N ("default iterator must be unique", Expr);
- Error_Msg_Sloc := Sloc (Default);
- Error_Msg_N ("\\possible interpretation#", Expr);
- Error_Msg_Sloc := Sloc (It.Nam);
- Error_Msg_N ("\\possible interpretation#", Expr);
-
- elsif Comes_From_Source (It.Nam) then
- Default := It.Nam;
- end if;
- else
- Default := It.Nam;
- end if;
-
- Get_Next_Interp (I, It);
- end loop;
-
- if Present (Default) then
- Set_Entity (Expr, Default);
- Set_Is_Overloaded (Expr, False);
- else
- Error_Msg_N
- ("no interpretation is a valid default iterator!", Expr);
- end if;
- end;
- end if;
- end Check_Iterator_Functions;
-
- -------------------------------
- -- Check_Primitive_Function --
- -------------------------------
-
- function Check_Primitive_Function (Subp : Entity_Id) return Boolean is
- Ctrl : Entity_Id;
-
- begin
- if Ekind (Subp) /= E_Function then
- return False;
- end if;
-
- if No (First_Formal (Subp)) then
- return False;
- else
- Ctrl := Etype (First_Formal (Subp));
- end if;
-
- -- To be a primitive operation subprogram has to be in same scope.
-
- if Scope (Ctrl) /= Scope (Subp) then
- return False;
- end if;
-
- -- Type of formal may be the class-wide type, an access to such,
- -- or an incomplete view.
-
- if Ctrl = Ent
- or else Ctrl = Class_Wide_Type (Ent)
- or else
- (Ekind (Ctrl) = E_Anonymous_Access_Type
- and then (Designated_Type (Ctrl) = Ent
- or else
- Designated_Type (Ctrl) = Class_Wide_Type (Ent)))
- or else
- (Ekind (Ctrl) = E_Incomplete_Type
- and then Full_View (Ctrl) = Ent)
- then
- null;
- else
- return False;
- end if;
-
- return True;
- end Check_Primitive_Function;
-
----------------------
-- Duplicate_Clause --
----------------------
@@ -6745,7 +6462,7 @@ package body Sem_Ch13 is
-----------------------
when Attribute_Constant_Indexing =>
- Check_Indexing_Functions;
+ null;
---------
-- CPU --
@@ -6801,54 +6518,39 @@ package body Sem_Ch13 is
----------------------
when Attribute_Default_Iterator => Default_Iterator : declare
- Func : Entity_Id;
- Typ : Entity_Id;
-
begin
-- If target type is untagged, further checks are irrelevant
if not Is_Tagged_Type (U_Ent) then
Error_Msg_N
- ("aspect Default_Iterator applies to tagged type", Nam);
+ ("aspect Default_Iterator can only apply to a tagged type",
+ Nam);
return;
end if;
- Check_Iterator_Functions;
-
- Analyze (Expr);
-
- if not Is_Entity_Name (Expr)
- or else Ekind (Entity (Expr)) /= E_Function
- then
- Error_Msg_N ("aspect Iterator must be a function", Expr);
- return;
- else
- Func := Entity (Expr);
- end if;
+ declare
+ Parent_Aspect : constant Node_Id :=
+ Find_Aspect (U_Ent, Aspect_Default_Iterator);
+ begin
+ -- If the attribute definition clause comes from an aspect that
+ -- is not Comes_From_Source, then the aspect must be inherited
+ -- from a parent type, in which case the operation has already
+ -- been set properly, and there's no need to do the check.
- -- The type of the first parameter must be T, T'class, or a
- -- corresponding access type (5.5.1 (8/3). If function is
- -- parameterless label type accordingly.
+ if No (Parent_Aspect)
+ or else Comes_From_Source (Parent_Aspect)
+ then
+ Check_Iterator_Functions (Typ => U_Ent, Expr => Expr);
+ end if;
+ end;
- if No (First_Formal (Func)) then
- Typ := Any_Type;
- else
- Typ := Etype (First_Formal (Func));
- end if;
+ Analyze (Expr);
- if Typ = U_Ent
- or else Typ = Class_Wide_Type (U_Ent)
- or else (Is_Access_Type (Typ)
- and then Designated_Type (Typ) = U_Ent)
- or else (Is_Access_Type (Typ)
- and then Designated_Type (Typ) =
- Class_Wide_Type (U_Ent))
+ if not Is_Entity_Name (Expr)
+ or else Ekind (Entity (Expr)) /= E_Function
then
- null;
-
- else
- Error_Msg_NE
- ("Default_Iterator must be a primitive of&", Func, U_Ent);
+ Error_Msg_N ("aspect Iterator must be a function", Expr);
+ return;
end if;
end Default_Iterator;
@@ -7882,7 +7584,7 @@ package body Sem_Ch13 is
-----------------------
when Attribute_Variable_Indexing =>
- Check_Indexing_Functions;
+ null;
-----------
-- Write --
@@ -11403,7 +11105,6 @@ package body Sem_Ch13 is
-- name. Legality rules are checked separately.
when Aspect_Constant_Indexing
- | Aspect_Default_Iterator
| Aspect_Iterator_Element
| Aspect_Variable_Indexing
=>
@@ -11424,6 +11125,18 @@ package body Sem_Ch13 is
Analyze (Expression (ASN));
return;
+ when Aspect_Default_Iterator =>
+
+ -- If the aspect is not Comes_From_Source, then it's an inherited
+ -- aspect, in which case the aspect's operation has already been
+ -- set, and there's no need to call Check_Iterator_Functions.
+
+ if Comes_From_Source (ASN) then
+ Check_Iterator_Functions
+ (Typ => Entity (ASN), Expr => Expression (ASN));
+ end if;
+ return;
+
-- Finalizable, legality checks in Validate_Finalizable_Aspect
when Aspect_Finalizable =>
@@ -11498,7 +11211,18 @@ package body Sem_Ch13 is
return;
when Aspect_Aggregate =>
- Resolve_Aspect_Aggregate (Entity (ASN), Expression (ASN));
+
+ -- If the aspect is not Comes_From_Source, then it's
+ -- an inherited aspect, in which case the aspect's
+ -- operations have already been set and there's no need
+ -- to resolve it.
+
+ -- Is it even necessary to be calling Resolve_Aspect_Aggr here???
+
+ if Comes_From_Source (ASN) then
+ Resolve_Aspect_Aggregate (Entity (ASN), Expression (ASN));
+ end if;
+
return;
when Aspect_Stable_Properties =>
@@ -12057,6 +11781,467 @@ package body Sem_Ch13 is
end if;
end Check_Constant_Address_Clause;
+ ----------------------------------------
+ -- Check_Function_For_Indexing_Aspect --
+ ----------------------------------------
+
+ procedure Check_Function_For_Indexing_Aspect
+ (ASN : Node_Id;
+ Typ : Entity_Id;
+ Subp : Entity_Id;
+ Valid : out Boolean)
+ is
+ Aspect : constant Aspect_Id := Get_Aspect_Id (ASN);
+
+ procedure Illegal_Indexing (Msg : String);
+ -- Report error on illegal candidate for indexing function
+
+ function Is_CW_Or_Access_To_CW
+ (Param_Type : Entity_Id;
+ Specific_Type : Entity_Id) return Boolean;
+ -- Is Param_Type either Specific_Type'Class or an anonymous
+ -- access-to-Specific_Type'Class type?
+
+ function Look_Through_Anon_Access (Typ : Entity_Id) return Entity_Id;
+ -- For an appropriate access type, return designated type;
+ -- otherwise return argument.
+
+ function Subp_Is_Dispatching_Op_Of_Typ
+ (Subp : Entity_Id;
+ Typ : Entity_Id) return Boolean;
+ -- Is subprogram Subp is a dispatching operation of type Typ?
+
+ ----------------------
+ -- Illegal_Indexing --
+ ----------------------
+
+ -- NOTE: If the semantics of indexing aspects are ever changed
+ -- to be treated like resolution rules instead of legality rules,
+ -- then this procedure could be modified to only issue the error
+ -- if an appropriate function has not yet been found and there are
+ -- no further operations yet to be considered as interpretations
+ -- (i.e., return immediately without a message if Indexing_Found
+ -- or no further candidate functions are yet to be considered).
+
+ procedure Illegal_Indexing (Msg : String) is
+ begin
+ Error_Msg_NE (Msg, ASN, Typ);
+ end Illegal_Indexing;
+
+ ---------------------------
+ -- Is_CW_Or_Access_To_CW --
+ ---------------------------
+
+ function Is_CW_Or_Access_To_CW
+ (Param_Type : Entity_Id;
+ Specific_Type : Entity_Id) return Boolean
+ is
+ Typ : constant Entity_Id :=
+ Look_Through_Anon_Access (Param_Type);
+
+ Aspect_Specification_Is_Inherited : constant Boolean :=
+ Is_Derived_Type (Specific_Type)
+ and then Has_Aspect (Etype (Specific_Type), Aspect);
+ begin
+ if not Is_Class_Wide_Type (Typ) then
+ return False;
+ end if;
+
+ declare
+ Specific_1 : constant Entity_Id :=
+ Implementation_Base_Type (Find_Specific_Type (Typ));
+ Specific_2 : constant Entity_Id :=
+ Implementation_Base_Type (Specific_Type);
+ begin
+ if Aspect_Specification_Is_Inherited then
+ return Is_Ancestor (T1 => Specific_1, T2 => Specific_2);
+ else
+ return Specific_1 = Specific_2;
+ end if;
+ end;
+ end Is_CW_Or_Access_To_CW;
+
+ ------------------------------
+ -- Look_Through_Anon_Access --
+ ------------------------------
+
+ function Look_Through_Anon_Access
+ (Typ : Entity_Id) return Entity_Id
+ is
+ Result : Entity_Id := Typ;
+ begin
+ if Is_Anonymous_Access_Type (Typ)
+ and then Is_Access_Object_Type (Typ)
+ then
+ Result := Designated_Type (Typ);
+ end if;
+
+ return Implementation_Base_Type (Result);
+ end Look_Through_Anon_Access;
+
+ -----------------------------------
+ -- Subp_Is_Dispatching_Op_Of_Typ --
+ -----------------------------------
+
+ function Subp_Is_Dispatching_Op_Of_Typ
+ (Subp : Entity_Id; Typ : Entity_Id) return Boolean
+ is
+ Base_Typ : constant Entity_Id :=
+ Implementation_Base_Type (Typ);
+ Dispatching_Type : Entity_Id := Find_Dispatching_Type (Subp);
+ begin
+ if No (Dispatching_Type) then
+ return False;
+ end if;
+ Dispatching_Type := Implementation_Base_Type (Dispatching_Type);
+
+ return Base_Typ = Dispatching_Type
+ and then
+ -- test whether first formal is controlling
+ Base_Typ = Look_Through_Anon_Access
+ (Etype (First_Formal (Subp)));
+ end Subp_Is_Dispatching_Op_Of_Typ;
+
+ -- Local variables
+
+ Ret_Type : constant Entity_Id := Etype (Subp);
+
+ -- Start of processing for Check_Function_For_Indexing_Aspect
+
+ begin
+ Valid := False;
+
+ -- If the subprogram isn't declared in the same scope as the type
+ -- E, then it shouldn't be considered (see AI22-0084 as well as
+ -- RM 4.1.6(2/5-3/5), though the latter are apparently intended
+ -- as legality rules, not resolution rules).
+
+ if Scope (Subp) /= Scope (Typ) then
+ return;
+
+ elsif not Is_Overloadable (Subp) or else No (Ret_Type) then
+ Illegal_Indexing ("illegal indexing function for type&");
+ return;
+
+ elsif No (First_Formal (Subp)) then
+ Illegal_Indexing
+ ("indexing aspect requires a function that applies to type&");
+ return;
+
+ elsif No (Next_Formal (First_Formal (Subp))) then
+ Error_Msg_Sloc := Sloc (Subp);
+ Illegal_Indexing
+ ("at least two parameters required for indexing function "
+ & "defined #");
+ return;
+
+ elsif not Subp_Is_Dispatching_Op_Of_Typ
+ (Subp => Subp, Typ => Typ)
+ and then not Is_CW_Or_Access_To_CW
+ (Param_Type => Etype (First_Formal (Subp)),
+ Specific_Type => Typ)
+ then
+ Illegal_Indexing
+ ("indexing aspect requires function with first formal "
+ & "applying to type& or its class-wide type");
+ return;
+
+ elsif Aspect = Aspect_Constant_Indexing
+ and then Is_Anonymous_Access_Type (Etype (First_Formal (Subp)))
+ and then not Is_Access_Constant (Etype (First_Formal (Subp)))
+ then
+ Illegal_Indexing
+ ("Constant_Indexing must apply to function with "
+ & "access-to-constant formal");
+ return;
+ end if;
+
+ -- For variable_indexing the return type must be a reference type
+
+ if Aspect = Aspect_Variable_Indexing then
+ if not Has_Implicit_Dereference (Ret_Type) then
+ Illegal_Indexing
+ ("function for Variable_Indexing must return "
+ & "a reference type");
+ return;
+
+ elsif Is_Access_Constant
+ (Etype (First_Discriminant (Ret_Type)))
+ then
+ Illegal_Indexing
+ ("function for Variable_Indexing must return an "
+ & "access-to-variable result");
+ return;
+ end if;
+ end if;
+
+ Valid := True;
+
+ -- Add the acceptable subprogram to the indexing aspect's list
+ -- of subprograms.
+
+ declare
+ Subp_List : Elist_Id := Aspect_Subprograms (ASN);
+ begin
+ Append_New_Elmt (Subp, Subp_List);
+ Set_Aspect_Subprograms (ASN, Subp_List);
+ end;
+ end Check_Function_For_Indexing_Aspect;
+
+ ------------------------------
+ -- Check_Iterator_Functions --
+ ------------------------------
+
+ procedure Check_Iterator_Functions (Typ : Entity_Id; Expr : Node_Id) is
+
+ function Valid_Default_Iterator
+ (Subp : Entity_Id;
+ Ref_Node : Node_Id := Empty) return Boolean;
+ -- Check one possible interpretation for validity. If
+ -- Ref_Node is present report errors on violations.
+
+ ----------------------------
+ -- Valid_Default_Iterator --
+ ----------------------------
+
+ function Valid_Default_Iterator
+ (Subp : Entity_Id;
+ Ref_Node : Node_Id := Empty) return Boolean
+ is
+ Return_Type : constant Entity_Id := Etype (Etype (Subp));
+ Return_Node : Node_Id;
+ Root_T : constant Entity_Id := Root_Type (Return_Type);
+ Formal : Entity_Id;
+
+ function Valid_Iterator_Name (E : Entity_Id) return Boolean
+ is (Chars (E) in Name_Forward_Iterator | Name_Reversible_Iterator);
+
+ function Valid_Iterator_Name (L : Elist_Id) return Boolean;
+
+ -------------------------
+ -- Valid_Iterator_Name --
+ -------------------------
+
+ function Valid_Iterator_Name (L : Elist_Id) return Boolean
+ is
+ Iface_Elmt : Elmt_Id := First_Elmt (L);
+ begin
+ while Present (Iface_Elmt) loop
+ if Valid_Iterator_Name (Node (Iface_Elmt)) then
+ return True;
+ end if;
+ Next_Elmt (Iface_Elmt);
+ end loop;
+
+ return False;
+ end Valid_Iterator_Name;
+
+ -- Start of processing for Valid_Default_Iterator
+
+ begin
+ if Subp = Any_Id then
+ if Present (Ref_Node) then
+
+ -- Subp is not resolved and an error will be posted about
+ -- it later
+
+ Error_Msg_N ("improper function for default iterator!",
+ Ref_Node);
+ end if;
+
+ return False;
+ end if;
+
+ if not Check_Primitive_Function (Subp, Typ) then
+ if Present (Ref_Node) then
+ if Debug_Flag_Underscore_DD then
+ Record_Default_Iterator_Not_Primitive_Error
+ (Ref_Node, Subp);
+ else
+ Error_Msg_N ("improper function for default iterator!",
+ Ref_Node);
+ Error_Msg_Sloc := Sloc (Subp);
+ Error_Msg_NE
+ ("\\default iterator defined # "
+ & "must be a local primitive or class-wide function",
+ Ref_Node, Subp);
+ end if;
+ end if;
+
+ return False;
+ end if;
+
+ -- The return type must be derived from a type in an instance
+ -- of Iterator.Interfaces, and thus its root type must have a
+ -- predefined name.
+
+ if not Valid_Iterator_Name (Root_T)
+ and then not (Has_Interfaces (Return_Type) and then
+ Valid_Iterator_Name (Interfaces (Return_Type)))
+ then
+ if Present (Ref_Node) then
+
+ Return_Node := Result_Definition (Parent (Subp));
+
+ Error_Msg_N ("improper function for default iterator!",
+ Ref_Node);
+ Error_Msg_Sloc := Sloc (Return_Node);
+ Error_Msg_NE ("\\return type & # "
+ & "must inherit from either "
+ & "Forward_Iterator or Reversible_Iterator",
+ Ref_Node, Return_Node);
+ end if;
+
+ return False;
+ end if;
+
+ Formal := First_Formal (Subp);
+
+ -- False if any subsequent formal has no default expression
+
+ Next_Formal (Formal);
+ while Present (Formal) loop
+ if No (Expression (Parent (Formal))) then
+ if Present (Ref_Node) then
+ Error_Msg_N ("improper function for default iterator!",
+ Ref_Node);
+ Error_Msg_Sloc := Sloc (Formal);
+ Error_Msg_NE ("\\formal parameter & # "
+ & "must have a default expression",
+ Ref_Node, Formal);
+ end if;
+
+ return False;
+ end if;
+
+ Next_Formal (Formal);
+ end loop;
+
+ -- True if all subsequent formals have default expressions
+
+ return True;
+ end Valid_Default_Iterator;
+
+ Ignore : Boolean;
+
+ -- Start of processing for Check_Iterator_Functions
+
+ begin
+ Analyze (Expr);
+
+ if not Is_Entity_Name (Expr) then
+ Error_Msg_N ("aspect Default_Iterator must be a function name", Expr);
+ end if;
+
+ if not Is_Overloaded (Expr) then
+ if Entity (Expr) /= Any_Id
+ and then not Check_Primitive_Function (Entity (Expr), Typ)
+ then
+ Error_Msg_NE
+ ("aspect Default_Iterator requires a local function applying "
+ & "to type&", Entity (Expr), Typ);
+ end if;
+
+ -- Flag the default_iterator as well as the denoted function.
+
+ Ignore := Valid_Default_Iterator (Entity (Expr), Expr);
+
+ else
+ declare
+ Default : Entity_Id := Empty;
+ I : Interp_Index;
+ It : Interp;
+
+ begin
+ Get_First_Interp (Expr, I, It);
+ while Present (It.Nam) loop
+ if not Check_Primitive_Function (It.Nam, Typ)
+ or else not Valid_Default_Iterator (It.Nam)
+ then
+ Remove_Interp (I);
+
+ elsif Present (Default) then
+
+ -- An explicit one should override an implicit one
+
+ if Comes_From_Source (Default) =
+ Comes_From_Source (It.Nam)
+ then
+ Error_Msg_N ("default iterator must be unique", Expr);
+ Error_Msg_Sloc := Sloc (Default);
+ Error_Msg_N ("\\possible interpretation#", Expr);
+ Error_Msg_Sloc := Sloc (It.Nam);
+ Error_Msg_N ("\\possible interpretation#", Expr);
+
+ elsif Comes_From_Source (It.Nam) then
+ Default := It.Nam;
+ end if;
+ else
+ Default := It.Nam;
+ end if;
+
+ Get_Next_Interp (I, It);
+ end loop;
+
+ if Present (Default) then
+ Set_Entity (Expr, Default);
+ Set_Is_Overloaded (Expr, False);
+ else
+ Error_Msg_N
+ ("no interpretation is a valid default iterator!", Expr);
+ end if;
+ end;
+ end if;
+ end Check_Iterator_Functions;
+
+ -------------------------------
+ -- Check_Primitive_Function --
+ -------------------------------
+
+ function Check_Primitive_Function
+ (Subp : Entity_Id; Ent : Entity_Id) return Boolean
+ is
+ Ctrl : Entity_Id;
+
+ begin
+ if Ekind (Subp) /= E_Function then
+ return False;
+ end if;
+
+ if No (First_Formal (Subp)) then
+ return False;
+ else
+ Ctrl := Etype (First_Formal (Subp));
+ end if;
+
+ -- To be a primitive operation subprogram has to be in same scope.
+
+ if Scope (Ctrl) /= Scope (Subp) then
+ return False;
+ end if;
+
+ -- Type of formal may be the class-wide type, an access to such,
+ -- or an incomplete view.
+
+ if Ctrl = Ent
+ or else Ctrl = Class_Wide_Type (Ent)
+ or else
+ (Ekind (Ctrl) = E_Anonymous_Access_Type
+ and then (Designated_Type (Ctrl) = Ent
+ or else
+ Designated_Type (Ctrl) = Class_Wide_Type (Ent)))
+ or else
+ (Ekind (Ctrl) = E_Incomplete_Type
+ and then Full_View (Ctrl) = Ent)
+ then
+ null;
+ else
+ return False;
+ end if;
+
+ return True;
+ end Check_Primitive_Function;
+
---------------------------
-- Check_Pool_Size_Clash --
---------------------------
@@ -15627,10 +15812,22 @@ package body Sem_Ch13 is
if Nkind (N) in N_Attribute_Definition_Clause | N_Pragma
and then From_Aspect_Specification (N)
then
- Error_Msg_NE
- ("aspect specification causes premature freezing of&", N, T);
- Set_Has_Delayed_Freeze (T, False);
- return True;
+ -- If an attribute_definition_clause or pragma comes from
+ -- an aspect_specification that is not Comes_From_Source (as when
+ -- it's an inherited aspect), then we assume it must be OK, since
+ -- it was generated by the compiler.
+
+ if Present (Parent (N))
+ and then not Comes_From_Source (Parent (N))
+ then
+ return False;
+
+ else
+ Error_Msg_NE
+ ("aspect specification causes premature freezing of&", N, T);
+ Set_Has_Delayed_Freeze (T, False);
+ return True;
+ end if;
end if;
Too_Late;
@@ -16889,6 +17086,8 @@ package body Sem_Ch13 is
(Typ : Entity_Id;
Expr : Node_Id)
is
+ Impl_Typ : constant Entity_Id := Implementation_Base_Type (Typ);
+
function Valid_Empty (E : Entity_Id) return Boolean;
function Valid_Add_Named (E : Entity_Id) return Boolean;
function Valid_Add_Unnamed (E : Entity_Id) return Boolean;
@@ -16924,7 +17123,9 @@ package body Sem_Ch13 is
function Valid_Empty (E : Entity_Id) return Boolean is
begin
- if Etype (E) /= Typ or else Scope (E) /= Scope (Typ) then
+ if Implementation_Base_Type (Etype (E)) /= Impl_Typ
+ or else Scope (E) /= Scope (Typ)
+ then
return False;
elsif Ekind (E) = E_Function then
@@ -16947,7 +17148,8 @@ package body Sem_Ch13 is
if Ekind (E) = E_Procedure
and then Scope (E) = Scope (Typ)
and then Number_Formals (E) = 3
- and then Etype (First_Formal (E)) = Typ
+ and then
+ Implementation_Base_Type (Etype (First_Formal (E))) = Impl_Typ
and then Ekind (First_Formal (E)) = E_In_Out_Parameter
then
F2 := Next_Formal (First_Formal (E));
@@ -16970,21 +17172,22 @@ package body Sem_Ch13 is
return Ekind (E) = E_Procedure
and then Scope (E) = Scope (Typ)
and then Number_Formals (E) = 2
- and then Etype (First_Formal (E)) = Typ
+ and then
+ Implementation_Base_Type (Etype (First_Formal (E))) = Impl_Typ
and then Ekind (First_Formal (E)) = E_In_Out_Parameter
and then
not Is_Limited_Type (Etype (Next_Formal (First_Formal (E))));
end Valid_Add_Unnamed;
-----------------------
- -- Valid_Nmw_Indexed --
+ -- Valid_New_Indexed --
-----------------------
function Valid_New_Indexed (E : Entity_Id) return Boolean is
begin
return Ekind (E) = E_Function
and then Scope (E) = Scope (Typ)
- and then Etype (E) = Typ
+ and then Implementation_Base_Type (Etype (E)) = Impl_Typ
and then Number_Formals (E) = 2
and then Is_Discrete_Type (Etype (First_Formal (E)))
and then Etype (First_Formal (E)) =
@@ -18181,7 +18384,16 @@ package body Sem_Ch13 is
and then not Is_Aliased (Param_Id);
end Matching;
+ -- Start of processing for Validate_Literal_Aspect
+
begin
+ -- If the aspect specification was effectively inherited from the parent
+ -- type (so constructed anew by analysis), then no point in validating.
+
+ if not Comes_From_Source (ASN) then
+ return;
+ end if;
+
if not Is_Type (Typ) then
Error_Msg_N ("aspect can only be specified for a type", ASN);
return;
diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads
index aeacda833d1..f384a9aa39e 100644
--- a/gcc/ada/sem_ch13.ads
+++ b/gcc/ada/sem_ch13.ads
@@ -111,6 +111,19 @@ package Sem_Ch13 is
-- at the point an object with an address clause is frozen, as well as for
-- address clauses for tasks and entries.
+ procedure Check_Function_For_Indexing_Aspect
+ (ASN : Node_Id;
+ Typ : Entity_Id;
+ Subp : Entity_Id;
+ Valid : out Boolean);
+ -- Check Subp to see whether it's a valid function for Typ's indexing
+ -- aspect ASN (as specified by the rules given in RM 4.1.6(1-3)), flagging
+ -- an error if Subp is not an eligible indexing function (unless Subp is
+ -- declared outside the scope of E, in which case it's simply ignored
+ -- rather than considered an error; see AI22-0084). If valid for indexing,
+ -- then Subp is added to ASN's Aspect_Subprograms list, and Valid is set
+ -- to True (otherwise False).
+
procedure Check_Size
(N : Node_Id;
T : Entity_Id;
@@ -311,8 +324,12 @@ package Sem_Ch13 is
-- Quite an awkward approach, but this is an awkard requirement
- procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id);
- -- Analyzes all the delayed aspects for entity E at the freeze point. Note
+ procedure Analyze_Aspects_At_Freeze_Point
+ (E : Entity_Id;
+ Nonoverridable_Only : Boolean := False);
+ -- Analyzes all the delayed aspects for entity E at the freeze point,
+ -- unless Nonoverridable_Only is True, in which case only nonoverridable
+ -- aspects are analyzed (those aspects have special requirements). Note
-- that this does not include dealing with inheriting delayed aspects from
-- the parent or base type in the case where a derived type or a subtype is
-- frozen. Callers should check that Has_Delayed_Aspects (E) is True before
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 70abf7ccc7d..6a3b7c6e0a9 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -8545,14 +8545,11 @@ package body Sem_Ch4 is
-- that if the argument is a parameter association we must match it
-- by name and not by position.
- function Find_Indexing_Operations
+ function Indexing_Interpretations
(T : Entity_Id;
- Nam : Name_Id;
- Is_Constant : Boolean) return Node_Id;
- -- Return a reference to the primitive operation of type T denoted by
- -- name Nam. If the operation is overloaded, the reference carries all
- -- interpretations. Flag Is_Constant should be set when the context is
- -- constant indexing.
+ Aspect_Kind : Aspect_Id) return Node_Id;
+ -- Return a set of interpretations reflecting all of the functions
+ -- associated with an indexing aspect of type T of the given kind.
--------------------------
-- Constant_Indexing_OK --
@@ -8733,224 +8730,53 @@ package body Sem_Ch4 is
end Expr_Matches_In_Formal;
------------------------------
- -- Find_Indexing_Operations --
+ -- Indexing_Interpretations --
------------------------------
- function Find_Indexing_Operations
+ function Indexing_Interpretations
(T : Entity_Id;
- Nam : Name_Id;
- Is_Constant : Boolean) return Node_Id
+ Aspect_Kind : Aspect_Id) return Node_Id
is
- procedure Inspect_Declarations
- (Typ : Entity_Id;
- Ref : in out Node_Id);
- -- Traverse the declarative list where type Typ resides and collect
- -- all suitable interpretations in node Ref.
-
- procedure Inspect_Primitives
- (Typ : Entity_Id;
- Ref : in out Node_Id);
- -- Traverse the list of primitive operations of type Typ and collect
- -- all suitable interpretations in node Ref.
-
- function Is_OK_Candidate
- (Subp_Id : Entity_Id;
- Typ : Entity_Id) return Boolean;
- -- Determine whether subprogram Subp_Id is a suitable indexing
- -- operation for type Typ. To qualify as such, the subprogram must
- -- be a function, have at least two parameters, and the type of the
- -- first parameter must be either Typ, or Typ'Class, or access [to
- -- constant] with designated type Typ or Typ'Class.
-
- procedure Record_Interp (Subp_Id : Entity_Id; Ref : in out Node_Id);
- -- Store subprogram Subp_Id as an interpretation in node Ref
-
- --------------------------
- -- Inspect_Declarations --
- --------------------------
-
- procedure Inspect_Declarations
- (Typ : Entity_Id;
- Ref : in out Node_Id)
- is
- Typ_Decl : constant Node_Id := Declaration_Node (Typ);
- Decl : Node_Id;
- Subp_Id : Entity_Id;
-
- begin
- -- Ensure that the routine is not called with itypes, which lack a
- -- declarative node.
-
- pragma Assert (Present (Typ_Decl));
- pragma Assert (Is_List_Member (Typ_Decl));
-
- Decl := First (List_Containing (Typ_Decl));
- while Present (Decl) loop
- if Nkind (Decl) = N_Subprogram_Declaration then
- Subp_Id := Defining_Entity (Decl);
-
- if Is_OK_Candidate (Subp_Id, Typ) then
- Record_Interp (Subp_Id, Ref);
- end if;
- end if;
-
- Next (Decl);
- end loop;
- end Inspect_Declarations;
-
- ------------------------
- -- Inspect_Primitives --
- ------------------------
-
- procedure Inspect_Primitives
- (Typ : Entity_Id;
- Ref : in out Node_Id)
- is
- Prim_Elmt : Elmt_Id;
- Prim_Id : Entity_Id;
-
- begin
- Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
- while Present (Prim_Elmt) loop
- Prim_Id := Node (Prim_Elmt);
-
- if Is_OK_Candidate (Prim_Id, Typ) then
- Record_Interp (Prim_Id, Ref);
- end if;
-
- Next_Elmt (Prim_Elmt);
- end loop;
- end Inspect_Primitives;
-
- ---------------------
- -- Is_OK_Candidate --
- ---------------------
-
- function Is_OK_Candidate
- (Subp_Id : Entity_Id;
- Typ : Entity_Id) return Boolean
- is
- Formal : Entity_Id;
- Formal_Typ : Entity_Id;
- Param_Typ : Node_Id;
-
- begin
- -- To classify as a suitable candidate, the subprogram must be a
- -- function whose name matches the argument of aspect Constant or
- -- Variable_Indexing.
-
- if Ekind (Subp_Id) = E_Function and then Chars (Subp_Id) = Nam then
- Formal := First_Formal (Subp_Id);
-
- -- The candidate requires at least two parameters
-
- if Present (Formal) and then Present (Next_Formal (Formal)) then
- Formal_Typ := Empty;
- Param_Typ := Parameter_Type (Parent (Formal));
-
- -- Use the designated type when the first parameter is of an
- -- access type.
-
- if Nkind (Param_Typ) = N_Access_Definition
- and then Present (Subtype_Mark (Param_Typ))
- then
- -- When the context is a constant indexing, the access
- -- definition must be access-to-constant. This does not
- -- apply to variable indexing.
-
- if not Is_Constant
- or else Constant_Present (Param_Typ)
- then
- Formal_Typ := Etype (Subtype_Mark (Param_Typ));
- end if;
-
- -- Otherwise use the parameter type
-
- else
- Formal_Typ := Etype (Param_Typ);
- end if;
-
- if Present (Formal_Typ) then
-
- -- Use the specific type when the parameter type is
- -- class-wide.
-
- if Is_Class_Wide_Type (Formal_Typ) then
- Formal_Typ := Etype (Base_Type (Formal_Typ));
- end if;
+ pragma Assert (Aspect_Kind in Aspect_Constant_Indexing
+ | Aspect_Variable_Indexing);
- -- Use the full view when the parameter type is private
- -- or incomplete.
+ Indexing_Aspect : constant Node_Id := Find_Aspect (T, Aspect_Kind);
+ Indexing_Func_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Indexing_Func : Node_Id := Empty;
- if Is_Incomplete_Or_Private_Type (Formal_Typ)
- and then Present (Full_View (Formal_Typ))
- then
- Formal_Typ := Full_View (Formal_Typ);
- end if;
+ begin
+ if No (Indexing_Aspect)
+ -- Protect against the case where there was an error on the aspect
+ or else No (Aspect_Subprograms (Indexing_Aspect))
+ then
+ return Empty;
+ end if;
- -- The type of the first parameter must denote the type
- -- of the container or acts as its ancestor type.
+ Indexing_Func_Elmt :=
+ First_Elmt (Aspect_Subprograms (Indexing_Aspect));
- return
- Formal_Typ = Typ
- or else Is_Ancestor (Formal_Typ, Typ);
- end if;
- end if;
- end if;
+ pragma Assert (Present (Indexing_Func_Elmt));
- return False;
- end Is_OK_Candidate;
+ while Present (Indexing_Func_Elmt) loop
+ Subp_Id := Node (Indexing_Func_Elmt);
- -------------------
- -- Record_Interp --
- -------------------
+ if Present (Indexing_Func) then
+ Add_One_Interp (Indexing_Func, Subp_Id, Etype (Subp_Id));
- procedure Record_Interp (Subp_Id : Entity_Id; Ref : in out Node_Id) is
- begin
- if Present (Ref) then
- Add_One_Interp (Ref, Subp_Id, Etype (Subp_Id));
-
- -- Otherwise this is the first interpretation. Create a reference
- -- where all remaining interpretations will be collected.
+ -- Otherwise this is the first interpretation. Create a
+ -- reference where all remaining interpretations will be
+ -- collected.
else
- Ref := New_Occurrence_Of (Subp_Id, Sloc (T));
+ Indexing_Func := New_Occurrence_Of (Subp_Id, Sloc (N));
end if;
- end Record_Interp;
-
- -- Local variables
-
- Ref : Node_Id;
- Typ : Entity_Id;
- -- Start of processing for Find_Indexing_Operations
-
- begin
- Typ := T;
-
- -- Use the specific type when the parameter type is class-wide
-
- if Is_Class_Wide_Type (Typ) then
- Typ := Root_Type (Typ);
- end if;
-
- Ref := Empty;
- Typ := Underlying_Type (Base_Type (Typ));
-
- Inspect_Primitives (Typ, Ref);
-
- -- Now look for explicit declarations of an indexing operation.
- -- If the type is private the operation may be declared in the
- -- visible part that contains the partial view.
-
- if Is_Private_Type (T) then
- Inspect_Declarations (T, Ref);
- end if;
-
- Inspect_Declarations (Typ, Ref);
+ Next_Elmt (Indexing_Func_Elmt);
+ end loop;
- return Ref;
- end Find_Indexing_Operations;
+ return Indexing_Func;
+ end Indexing_Interpretations;
-- Local variables
@@ -8961,11 +8787,6 @@ package body Sem_Ch4 is
Func_Name : Node_Id;
Indexing : Node_Id;
- Is_Constant_Indexing : Boolean := False;
- -- This flag reflects the nature of the container indexing. Note that
- -- the context may be suited for constant indexing, but the type may
- -- lack a Constant_Indexing annotation.
-
-- Start of processing for Try_Container_Indexing
begin
@@ -8995,13 +8816,13 @@ package body Sem_Ch4 is
Error_Msg_NW (Warn_On_Dereference, "?d?implicit dereference", N);
end if;
- C_Type := Pref_Typ;
+ C_Type := Base_Type (Pref_Typ);
-- If indexing a class-wide container, obtain indexing primitive from
-- specific type.
if Is_Class_Wide_Type (C_Type) then
- C_Type := Etype (Base_Type (C_Type));
+ C_Type := Etype (C_Type);
end if;
-- Check whether the type has a specified indexing aspect
@@ -9009,21 +8830,18 @@ package body Sem_Ch4 is
Func_Name := Empty;
-- The context is suitable for constant indexing, so obtain the name of
- -- the indexing function from aspect Constant_Indexing.
+ -- the indexing functions from aspect Constant_Indexing.
if Constant_Indexing_OK then
Func_Name :=
- Find_Value_Of_Aspect (Pref_Typ, Aspect_Constant_Indexing);
+ Indexing_Interpretations (C_Type, Aspect_Constant_Indexing);
end if;
- if Present (Func_Name) then
- Is_Constant_Indexing := True;
-
-- Otherwise attempt variable indexing
- else
+ if No (Func_Name) then
Func_Name :=
- Find_Value_Of_Aspect (Pref_Typ, Aspect_Variable_Indexing);
+ Indexing_Interpretations (C_Type, Aspect_Variable_Indexing);
end if;
-- The type is not subject to either form of indexing, therefore the
@@ -9045,31 +8863,6 @@ package body Sem_Ch4 is
else
return False;
end if;
-
- -- If the container type is derived from another container type, the
- -- value of the inherited aspect is the Reference operation declared
- -- for the parent type.
-
- -- However, Reference is also a primitive operation of the type, and the
- -- inherited operation has a different signature. We retrieve the right
- -- ones (the function may be overloaded) from the list of primitive
- -- operations of the derived type.
-
- -- Note that predefined containers are typically all derived from one of
- -- the Controlled types. The code below is motivated by containers that
- -- are derived from other types with a Reference aspect.
- -- Note as well that we need to examine the base type, given that
- -- the container object may be a constrained subtype or itype that
- -- does not have an explicit declaration.
-
- elsif Is_Derived_Type (C_Type)
- and then Etype (First_Formal (Entity (Func_Name))) /= Pref_Typ
- then
- Func_Name :=
- Find_Indexing_Operations
- (T => Base_Type (C_Type),
- Nam => Chars (Func_Name),
- Is_Constant => Is_Constant_Indexing);
end if;
Assoc := New_List (Relocate_Node (Prefix));
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index ff64744727a..ce09ca46a1a 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -1732,6 +1732,14 @@ package body Sem_Ch7 is
Error_Msg_N ("no declaration in visible part for incomplete}", E);
end if;
+ -- A type's nonoverridable aspects need to be resolved at the end
+ -- of the enclosing list of declarations, not only at freeze points
+ -- (see 13.1.1 (11/5)). (Perhaps the proc name should be changed???)
+
+ if Is_Type (E) and then Has_Delayed_Aspects (E) then
+ Analyze_Aspects_At_Freeze_Point (E, Nonoverridable_Only => True);
+ end if;
+
Next_Entity (E);
end loop;
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index dffaebfbca6..27309b2e019 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -525,11 +525,16 @@ package body Sem_Res is
Entity (Expression (Find_Aspect (Typ, Lit_Aspect)));
Name := Make_Identifier (Loc, Chars (Callee));
- if Is_Derived_Type (Typ)
- and then Base_Type (Etype (Callee)) /= Base_Type (Typ)
- then
+ -- It seems that we shouldn't need to retrieve the corresponding
+ -- primitive for a derived type at this point, because it should
+ -- have been determined earlier by Inherit_Nonoverridable_Aspects,
+ -- but the wrapper function created for a literal function when the
+ -- type is frozen gets created too late, so we search again at this
+ -- point. Would be nice to find a way to avoid this. ???
+
+ if Is_Derived_Type (Typ) then
Callee :=
- Corresponding_Primitive_Op
+ Corresponding_Op_Of_Derived_Type
(Ancestor_Op => Callee,
Descendant_Type => Base_Type (Typ));
end if;
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 31bfc9e504e..4ef0fa3c3ef 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -3581,9 +3581,9 @@ package body Sem_Util is
end if;
end Check_No_Hidden_State;
- ---------------------------------------------
- -- Check_Nonoverridable_Aspect_Consistency --
- ---------------------------------------------
+ --------------------------------------------
+ -- Check_Inherited_Nonoverridable_Aspects --
+ --------------------------------------------
procedure Check_Inherited_Nonoverridable_Aspects
(Inheritor : Entity_Id;
@@ -6303,11 +6303,11 @@ package body Sem_Util is
end if;
end Corresponding_Generic_Type;
- --------------------------------
- -- Corresponding_Primitive_Op --
- --------------------------------
+ --------------------------------------
+ -- Corresponding_Op_Of_Derived_Type --
+ --------------------------------------
- function Corresponding_Primitive_Op
+ function Corresponding_Op_Of_Derived_Type
(Ancestor_Op : Entity_Id;
Descendant_Type : Entity_Id) return Entity_Id
is
@@ -6329,7 +6329,7 @@ package body Sem_Util is
begin
while Present (E) and then E /= Prim loop
- if not Is_Tagged_Type (E)
+ if Is_Type (E) and then not Is_Tagged_Type (E)
and then Contains (Direct_Primitive_Operations (E), Prim)
then
return E;
@@ -6338,37 +6338,40 @@ package body Sem_Util is
Next_Entity (E);
end loop;
- pragma Assert (False);
+ -- If a primitive is not found, then return Empty, and in that case
+ -- the ancestor subprogram will be returned (which can occur in
+ -- class-wide subprogram cases, which are not primitives).
+
return Empty;
end Find_Untagged_Type_Of;
- Typ : constant Entity_Id :=
- (if Is_Dispatching_Operation (Ancestor_Op)
- then Find_Dispatching_Type (Ancestor_Op)
- else Find_Untagged_Type_Of (Ancestor_Op));
-
------------------------------
-- Profile_Matches_Ancestor --
------------------------------
function Profile_Matches_Ancestor (S : Entity_Id) return Boolean is
- F1 : Entity_Id := First_Formal (Ancestor_Op);
- F2 : Entity_Id := First_Formal (S);
+ F1 : Entity_Id := First_Formal (Ancestor_Op);
+ F2 : Entity_Id := First_Formal (S);
+ Impl_Type_1 : Entity_Id;
+ Impl_Type_2 : Entity_Id;
begin
if Ekind (Ancestor_Op) /= Ekind (S) then
return False;
end if;
- -- ??? This should probably account for anonymous access formals,
- -- but the parent function (Corresponding_Primitive_Op) is currently
- -- only called for user-defined literal functions, which can't have
- -- such formals. But if this is ever used in a more general context
- -- it should be extended to handle such formals (and result types).
+ -- ??? This function should probably be extended to account for
+ -- anonymous access formals and anonymous access result types.
while Present (F1) and then Present (F2) loop
- if Etype (F1) = Etype (F2)
- or else Is_Ancestor (Typ, Etype (F2))
+ Impl_Type_1 := Implementation_Base_Type (Etype (F1));
+ Impl_Type_2 := Implementation_Base_Type (Etype (F2));
+
+ if Impl_Type_1 = Impl_Type_2
+ or else Is_Ancestor (Impl_Type_1, Impl_Type_2)
+ or else (Is_Interface (Impl_Type_1)
+ and then
+ Is_Progenitor (Impl_Type_1, Impl_Type_2))
then
Next_Formal (F1);
Next_Formal (F2);
@@ -6377,22 +6380,40 @@ package body Sem_Util is
end if;
end loop;
+ Impl_Type_1 := Implementation_Base_Type (Etype (Ancestor_Op));
+ Impl_Type_2 := Implementation_Base_Type (Etype (S));
+
return No (F1)
and then No (F2)
- and then (Etype (Ancestor_Op) = Etype (S)
- or else Is_Ancestor (Typ, Etype (S)));
+ and then (Impl_Type_1 = Impl_Type_2
+ or else
+ Is_Ancestor (Impl_Type_1, Impl_Type_2)
+ or else
+ (Is_Interface (Impl_Type_1)
+ and then Is_Progenitor (Impl_Type_1, Impl_Type_2)));
end Profile_Matches_Ancestor;
-- Local variables
Elmt : Elmt_Id;
Subp : Entity_Id;
+ Typ : constant Entity_Id :=
+ (if Is_Dispatching_Operation (Ancestor_Op)
+ then Find_Dispatching_Type (Ancestor_Op)
+ else Find_Untagged_Type_Of (Ancestor_Op));
- -- Start of processing for Corresponding_Primitive_Op
+ -- Start of processing for Corresponding_Op_Of_Derived_Type
begin
- pragma Assert (Is_Ancestor (Typ, Descendant_Type)
- or else Is_Progenitor (Typ, Descendant_Type));
+ -- If Ancestor_Op isn't a primitive of the parent type, then simply
+ -- return it (it can be a nonprimitive class-wide subprogram).
+
+ if No (Typ)
+ or else (not Is_Ancestor (Typ, Descendant_Type)
+ and then not Is_Progenitor (Typ, Descendant_Type))
+ then
+ return Ancestor_Op;
+ end if;
Elmt := First_Elmt (Primitive_Operations (Descendant_Type));
@@ -6432,7 +6453,7 @@ package body Sem_Util is
pragma Assert (False);
return Empty;
- end Corresponding_Primitive_Op;
+ end Corresponding_Op_Of_Derived_Type;
--------------------
-- Current_Entity --
@@ -14511,6 +14532,281 @@ package body Sem_Util is
return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound (Ind)));
end Indexed_Component_Bit_Offset;
+ ------------------------------------
+ -- Inherit_Nonoverridable_Aspects --
+ ------------------------------------
+
+ procedure Inherit_Nonoverridable_Aspects
+ (Typ : Entity_Id; From_Typ : Entity_Id)
+ is
+
+ procedure Inherit_Nonoverridable_Aspect (Item : Node_Id);
+ -- Inherited nonoverridable aspects usually depend on operations of the
+ -- derived type, inherited or overridden. If an aspect is not explicitly
+ -- specified but rather is inherited, then its components (which usually
+ -- denote subprograms) must generally be associated with operations of
+ -- the derived type (with some exceptions, such as inherited class-wide
+ -- operations for indexing aspects). Item is a nonoverridable element
+ -- of From_Typ's Rep_Item list. A new aspect item is created and is
+ -- associated with the appropriate operations of the derived type,
+ -- and that aspect item is inserted at the beginning of Typ's Rep_Item
+ -- list. For an aspect that specifies a subprogram name, this procedure
+ -- also identifies which subprograms are denoted by the derived type's
+ -- inherited aspect (including inherited, overriding, and in some cases
+ -- new subprograms of the derived type).
+
+ -----------------------------------
+ -- Inherit_Nonoverridable_Aspect --
+ -----------------------------------
+
+ procedure Inherit_Nonoverridable_Aspect (Item : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Assoc : Node_Id;
+ New_Item : Node_Id;
+ Item_Aspect_Id : constant Nonoverridable_Aspect_Id :=
+ Get_Aspect_Id (Item);
+
+ begin
+ New_Item := Make_Aspect_Specification (
+ Sloc => Loc,
+ Identifier => Identifier (Item),
+ Expression => New_Copy_Tree (Expression (Item)));
+ Set_Entity (New_Item, Typ);
+
+ -- We are trying here to implement RM 13.1(15.5):
+ -- if the name denotes one or more primitive subprograms of
+ -- the type, the inherited aspect is a name that denotes the
+ -- corresponding primitive subprogram(s) of the derived type;
+
+ case Item_Aspect_Id is
+ when Aspect_Aggregate =>
+ Assoc := First (Component_Associations (Expression (New_Item)));
+
+ -- Replace aggregate operations coming from the aspect of the
+ -- parent type with the corresponding operations of the derived
+ -- type (which can be inherited or overriding).
+
+ while Present (Assoc) loop
+ pragma Assert (Nkind (Expression (Assoc)) = N_Identifier);
+
+ Set_Entity
+ (Expression (Assoc),
+ Corresponding_Op_Of_Derived_Type
+ (Ancestor_Op => Entity (Expression (Assoc)),
+ Descendant_Type => Typ));
+ Next (Assoc);
+ end loop;
+
+ when Aspect_Integer_Literal
+ | Aspect_Real_Literal
+ | Aspect_String_Literal
+ =>
+ Set_Entity
+ (Expression (New_Item),
+ Corresponding_Op_Of_Derived_Type
+ (Ancestor_Op => Entity (Expression (Item)),
+ Descendant_Type => Typ));
+
+ -- Build corresponding attribute definition clause for following
+ -- name-valued aspects (needed later in Is_Confirming).
+
+ when Aspect_Default_Iterator
+ | Aspect_Constant_Indexing
+ | Aspect_Variable_Indexing
+ =>
+ declare
+ Expr_Copy : constant Node_Id :=
+ New_Copy_Tree (Expression (Item));
+
+ Aitem : constant Node_Id :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Occurrence_Of (Typ, Loc),
+ Chars => Chars (Identifier (Item)),
+ Expression => Expr_Copy);
+
+ New_Entity : Entity_Id := Empty;
+ Parent_Indexing_Subps : Elist_Id;
+ New_Indexing_Subps : Elist_Id;
+ Subp_Elmt : Elmt_Id;
+
+ begin
+ Set_Parent (Aitem, New_Item);
+
+ if Nkind (Expr_Copy) in N_Has_Entity
+ and then Present (Entity (Expr_Copy))
+ then
+ if Present (Primitive_Operations (Typ)) then
+
+ -- Indexing aspects allow multiple subprograms
+
+ if Item_Aspect_Id in Aspect_Constant_Indexing
+ | Aspect_Variable_Indexing
+ then
+ Parent_Indexing_Subps := Aspect_Subprograms (Item);
+ Subp_Elmt := First_Elmt (Parent_Indexing_Subps);
+
+ New_Indexing_Subps := No_Elist;
+
+ -- First collect the functions of the derived type
+ -- that correspond to the functions inherited from
+ -- an ancestor type (From_Typ). Note that in some
+ -- cases these may be class-wide functions rather
+ -- than primitives.
+
+ while Present (Subp_Elmt) loop
+ New_Entity := Corresponding_Op_Of_Derived_Type
+ (Ancestor_Op => Node (Subp_Elmt),
+ Descendant_Type => Typ);
+
+ -- Add the corresponding subprogram to the new
+ -- aspect's list of subprograms.
+
+ Append_New_Elmt (New_Entity, New_Indexing_Subps);
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+
+ -- Traverse the primitive operations of the type
+ -- to locate any indexing functions that have been
+ -- added to the type (i.e., that have been neither
+ -- inherited, nor override any of the inherited
+ -- indexing functions).
+
+ -- ??? Note that this doesn't currently account for
+ -- the possibility of added nonprimitive indexing
+ -- functions (class-wide functions of the derived
+ -- type). This presumably would require traversing
+ -- all of the declarations of the immediately
+ -- enclosing declaration list, which perhaps we
+ -- should arguably be doing in any case, rather
+ -- than separately gathering inherited, overriding,
+ -- and new indexing functions (and which might also
+ -- be more efficient). Perhaps this could/should be
+ -- done in Analyze_Aspects_At_Freeze_Point, but
+ -- experimenting with that led to difficulties.
+
+ declare
+ Prim_Ops : constant Elist_Id :=
+ Primitive_Operations (Typ);
+ Prim_Elmt : Elmt_Id := First_Elmt (Prim_Ops);
+ Prim_Id : Entity_Id;
+ Valid_Func : Boolean;
+
+ begin
+ while Present (Prim_Elmt) loop
+ Prim_Id := Node (Prim_Elmt);
+
+ if Chars (Prim_Id) = Chars (Expression (Item))
+ and then
+ not Is_Inherited_Operation (Prim_Id)
+ and then
+ not Is_Overriding_Subprogram (Prim_Id)
+ then
+ -- Verify that the new primitive has
+ -- a correct profile to qualify as an
+ -- indexing function for Typ.
+
+ Check_Function_For_Indexing_Aspect
+ (New_Item, Typ, Prim_Id, Valid_Func);
+
+ if Valid_Func then
+ Append_New_Elmt
+ (Prim_Id, New_Indexing_Subps);
+ end if;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end;
+
+ -- Save new list of indexing functions on aspect
+
+ Set_Aspect_Subprograms
+ (New_Item, New_Indexing_Subps);
+
+ -- Item_Aspect_Id = Aspect_Default_Iterator
+
+ else
+ New_Entity := Corresponding_Op_Of_Derived_Type
+ (Ancestor_Op => Entity (Expr_Copy),
+ Descendant_Type => Typ);
+ end if;
+ end if;
+
+ Set_Entity (Expr_Copy, New_Entity);
+
+ -- We want the Entity attributes of the two expressions
+ -- to agree.
+
+ Set_Entity (Expression (New_Item), Entity (Expr_Copy));
+
+ end if;
+
+ Set_From_Aspect_Specification (Aitem);
+ Set_Is_Delayed_Aspect (Aitem);
+ Set_Aspect_Rep_Item (New_Item, Aitem);
+ Set_Parent (Aitem, New_Item);
+ end;
+
+ -- Nothing special to do for the other nonoverridable aspects
+
+ when Aspect_Implicit_Dereference
+ | Aspect_Iterator_Element
+ | Aspect_Max_Entry_Queue_Length
+ | Aspect_No_Controlled_Parts
+ =>
+ return;
+ end case;
+
+ Set_Expression_Copy (New_Item, New_Copy_Tree (Expression (New_Item)));
+
+ -- Place new aspect spec in list of rep clauses, to ensure
+ -- later resolution.
+
+ Set_Next_Rep_Item (New_Item, First_Rep_Item (Typ));
+ Set_First_Rep_Item (Typ, New_Item);
+ Set_Is_Delayed_Aspect (New_Item);
+ Set_Has_Delayed_Aspects (Typ);
+ end Inherit_Nonoverridable_Aspect;
+
+ -- Local declarations
+
+ Item : Node_Id;
+
+ -- Start of processing for Inherit_Nonoverridable_Aspects
+
+ begin
+ -- Typ may be the full type of a type derived from a private type,
+ -- in which case the full type primitive operations list can be empty.
+ -- In that case its nonoverridable aspects shouldn't be updated, and
+ -- we rely on the private view's aspect having been updated. (It's not
+ -- clear whether this is appropriate handling for these???)
+
+ if Has_Private_Declaration (Typ)
+ and then
+ (No (Direct_Primitive_Operations (Typ))
+ or else Is_Empty_Elmt_List (Direct_Primitive_Operations (Typ)))
+ then
+ return;
+ end if;
+
+ -- Inherit and update any nonoverridable aspects that come from the
+ -- parent type that should refer to inherited or overriding operations.
+
+ Item := First_Rep_Item (From_Typ);
+
+ while Present (Item) loop
+ if Nkind (Item) = N_Aspect_Specification
+ and then Get_Aspect_Id (Item) in Nonoverridable_Aspect_Id
+ and then Entity (Item) = Base_Type (From_Typ)
+ then
+ Inherit_Nonoverridable_Aspect (Item);
+ end if;
+
+ Item := Next_Rep_Item (Item);
+ end loop;
+ end Inherit_Nonoverridable_Aspects;
+
-----------------------------
-- Inherit_Predicate_Flags --
-----------------------------
@@ -15652,6 +15948,9 @@ package body Sem_Util is
raise Program_Error;
end case;
end Names_Match;
+
+ -- Start of processing for Is_Confirming
+
begin
-- allow users to disable "shall be confirming" check, at least for now
if Relaxed_RM_Semantics then
@@ -15668,20 +15967,8 @@ package body Sem_Util is
| Aspect_Iterator_Element
| Aspect_Constant_Indexing
| Aspect_Variable_Indexing =>
- declare
- Item_1 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_1);
- Item_2 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_2);
- begin
- if Nkind (Item_1) /= N_Attribute_Definition_Clause
- or Nkind (Item_2) /= N_Attribute_Definition_Clause
- then
- pragma Assert (Serious_Errors_Detected > 0);
- return True;
- end if;
-
- return Names_Match (Expression (Item_1),
- Expression (Item_2));
- end;
+ return Names_Match (Expression (Aspect_Spec_1),
+ Expression (Aspect_Spec_2));
-- A confirming aspect for Implicit_Dereference on a derived type
-- has already been checked in Analyze_Aspect_Implicit_Dereference,
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 218faf7be20..4e95c71a9e7 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -598,12 +598,16 @@ package Sem_Util is
-- attribute, except in the case of formal private and derived types.
-- Possible optimization???
- function Corresponding_Primitive_Op
+ function Corresponding_Op_Of_Derived_Type
(Ancestor_Op : Entity_Id;
Descendant_Type : Entity_Id) return Entity_Id;
- -- Given a primitive subprogram of a first type and a (distinct)
- -- descendant type of that type, find the corresponding primitive
- -- subprogram of the descendant type.
+ -- Given a subprogram Ancestor_Op associated with an ancestor type,
+ -- and a (distinct) descendant type of that type, find the corresponding
+ -- subprogram entity, if any, of the descendant type and return it.
+ -- Usually this is a primitive subprogram, but if Ancestor_Op is not
+ -- a primitive of the ancestor type (for example, it could be a class-wide
+ -- operation of the ancestor), then this function will simply return
+ -- Ancestor_Op.
function Current_Entity (N : Node_Id) return Entity_Id;
pragma Inline (Current_Entity);
@@ -1698,6 +1702,16 @@ package Sem_Util is
-- either the value is not yet known before back-end processing or it is
-- not known at compile time after back-end processing.
+ procedure Inherit_Nonoverridable_Aspects
+ (Typ : Entity_Id; From_Typ : Entity_Id);
+ -- For each nonoverridable aspect of parent type From_Typ, create an
+ -- inherited aspect for Typ and identify the subprograms that are denoted
+ -- by the inherited aspect, which may be the same subprograms of From_Typ,
+ -- or the corresponding inherited or overriding subprograms of Typ (in the
+ -- case where the parent subprogram is primitive), or even other eligible
+ -- subprograms that have been added to the derived type (such as can occur
+ -- in the case of indexing aspects).
+
procedure Inherit_Predicate_Flags
(Subt, Par : Entity_Id;
Only_Flags : Boolean := False);
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 64f6112018c..a092fdf786d 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -820,6 +820,11 @@ package Sinfo is
-- Present in N_Aspect_Specification nodes. Points to the corresponding
-- pragma/attribute definition node used to process the aspect.
+ -- Aspect_Subprograms
+ -- Present in N_Aspect_Specification nodes. Contains a list of the
+ -- subprograms that the aspect is associated with. Currently only used
+ -- for indexing aspects.
+
-- Assignment_OK
-- This flag is set in a subexpression node for an object, indicating
-- that the associated object can be modified, even if this would not
@@ -7579,6 +7584,7 @@ package Sinfo is
-- Aspect_Rep_Item
-- Expression (set to Empty if none)
-- Entity entity to which the aspect applies
+ -- Aspect_Subprograms (set to No_Elist if no associated subprograms)
-- Next_Rep_Item
-- Class_Present Set if 'Class present
-- Is_Ignored
--
2.43.0
