RM 6.3.1 (8) specifies that the operations inherited by a generic formal
tagged derived type with unknown discriminants have convention Intrinsic.
As a consequence, attribute 'Access cannot be applied to suvh an operation.
This rule also makes it impossible to override an inherited operation of a
type derived from such a formal type (a not uncommon usage), so in fact it
probably needs to be relaxed. The straightforward solution adopted here is to
say that the primitives of a type derived from such a formal type take their
convention from the primitive operation of the ultimate non-generic ancestor.
Compiling no_access.adb in ada 2005 mode must be rejected with the message:
no_access.adb:22:12: prefix of "Access" attribute cannot be intrinsic
---
procedure No_Access is
package P is
type Root is tagged null record;
procedure Proc (X : Root);
end P;
package body P is
procedure Proc (X : Root) is begin null; end;
end P;
generic
type Formal (<>) is new P.Root with private;
Value : Formal;
package G is
procedure Rien;
end G;
package body G is
procedure Rien is
begin
-- attribute reference is illegal because inherited Proc is intrinsic
if Proc'access = null then null; end if;
end;
Thing : Formal := Value;
begin
Proc (Thing);
end G;
begin
null;
end;
---
Tested on x86_64-pc-linux-gnu, committed on trunk
2013-01-02 Ed Schonberg <schonb...@adacore.com>
* sem_ch3.adb (Derive_Subprogram): Enforce RM 6.3.1 (8):
if the derived type is a tagged generic formal type with
unknown discriminants, the inherited operation has convention
Intrinsic. As such, the 'Access attribute cannot be applied to it.
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 194776)
+++ sem_ch3.adb (working copy)
@@ -13320,8 +13320,29 @@
-- of the parent subprogram (a requirement of AI-117). Derived
-- subprograms of untagged types simply get convention Ada by default.
+ -- If the derived type is a tagged generic formal type with unknown
+ -- discriminants, its convention is intrinsic (RM 6.3.1 (8)).
+
+ -- However, if the type is derived from a generic formal, the further
+ -- inherited subprogram has the convention of the non-generic ancestor.
+ -- Otherwise there would be no way to override the operation.
+ -- (This is subject to forthcoming ARG discussions).
+
if Is_Tagged_Type (Derived_Type) then
- Set_Convention (New_Subp, Convention (Parent_Subp));
+ if Is_Generic_Type (Derived_Type)
+ and then Has_Unknown_Discriminants (Derived_Type)
+ then
+ Set_Convention (New_Subp, Convention_Intrinsic);
+
+ else
+ if Is_Generic_Type (Parent_Type)
+ and then Has_Unknown_Discriminants (Parent_Type)
+ then
+ Set_Convention (New_Subp, Convention (Alias (Parent_Subp)));
+ else
+ Set_Convention (New_Subp, Convention (Parent_Subp));
+ end if;
+ end if;
end if;
-- Predefined controlled operations retain their name even if the parent
@@ -13333,9 +13354,9 @@
if Is_Controlled (Parent_Type)
and then
- (Chars (Parent_Subp) = Name_Initialize
- or else Chars (Parent_Subp) = Name_Adjust
- or else Chars (Parent_Subp) = Name_Finalize)
+ (Chars (Parent_Subp) = Name_Initialize or else
+ Chars (Parent_Subp) = Name_Adjust or else
+ Chars (Parent_Subp) = Name_Finalize)
and then Is_Hidden (Parent_Subp)
and then not Is_Visibly_Controlled (Parent_Type)
then
@@ -13377,14 +13398,14 @@
elsif Ada_Version >= Ada_2005
and then (Is_Abstract_Subprogram (Alias (New_Subp))
or else (Is_Tagged_Type (Derived_Type)
- and then Etype (New_Subp) = Derived_Type
- and then not Is_Null_Extension (Derived_Type))
+ and then Etype (New_Subp) = Derived_Type
+ and then not Is_Null_Extension (Derived_Type))
or else (Is_Tagged_Type (Derived_Type)
- and then Ekind (Etype (New_Subp)) =
+ and then Ekind (Etype (New_Subp)) =
E_Anonymous_Access_Type
- and then Designated_Type (Etype (New_Subp)) =
- Derived_Type
- and then not Is_Null_Extension (Derived_Type)))
+ and then Designated_Type (Etype (New_Subp)) =
+ Derived_Type
+ and then not Is_Null_Extension (Derived_Type)))
and then No (Actual_Subp)
then
if not Is_Tagged_Type (Derived_Type)
@@ -13509,9 +13530,7 @@
-- an incomplete type whose full-view is derived type
E := First_Entity (Scope (Derived_Type));
- while Present (E)
- and then E /= Derived_Type
- loop
+ while Present (E) and then E /= Derived_Type loop
if Ekind (E) = E_Incomplete_Type
and then Present (Full_View (E))
and then Full_View (E) = Derived_Type
@@ -13648,8 +13667,7 @@
if not Is_Tagged_Type (Derived_Type)
or else (not Has_Interfaces (Derived_Type)
and then not (Present (Generic_Actual)
- and then
- Has_Interfaces (Generic_Actual)))
+ and then Has_Interfaces (Generic_Actual)))
then
Elmt := First_Elmt (Op_List);
while Present (Elmt) loop
@@ -13673,9 +13691,10 @@
else
pragma Assert (No (Node (Act_Elmt))
or else (Primitive_Names_Match (Subp, Node (Act_Elmt))
- and then
- Type_Conformant (Subp, Node (Act_Elmt),
- Skip_Controlling_Formals => True)));
+ and then
+ Type_Conformant
+ (Subp, Node (Act_Elmt),
+ Skip_Controlling_Formals => True)));
Derive_Subprogram
(New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt));
@@ -14722,9 +14741,7 @@
-- Set Discard_Names if configuration pragma set, or if there is
-- a parameterless pragma in the current declarative region
- if Global_Discard_Names
- or else Discard_Names (Scope (T))
- then
+ if Global_Discard_Names or else Discard_Names (Scope (T)) then
Set_Discard_Names (T);
end if;
