From 29f2d76c65e175e18305b92f56be40c2266e9c78 Mon Sep 17 00:00:00 2001 From: Steve Baird Date: Tue, 18 Aug 2020 13:51:37 -0700 Subject: [PATCH] [Ada] Implement AI12-0030: Stream attribute availability gcc/ada/ * sem_util.ads, sem_util.adb: Declare and implement a new predicate, Derivation_Too_Early_To_Inherit. This function indicates whether a given derived type fails to inherit a given streaming-related attribute from its parent type because the declaration of the derived type precedes the corresponding attribute_definition_clause of the parent. * exp_tss.adb (Find_Inherited_TSS): Call Derivation_Too_Early_To_Inherit instead of unconditionally assuming that a parent type's streaming attribute is available for inheritance by an immediate descendant type. * sem_attr.adb (Stream_Attribute_Available): Call Derivation_Too_Early_To_Inherit instead of unconditionally assuming that a parent type's streaming attribute is available for inheritance by an immediate descendant type. * exp_attr.adb (Default_Streaming_Unavailable): A new predicate; given a type, indicates whether predefined (as opposed to user-defined) streaming operations for the type should be implemented by raising Program_Error. (Expand_N_Attribute_Reference): For each of the 4 streaming-related attributes (i.e., Read, Write, Input, Output), after determining that no user-defined implementation is available (including a Stream_Convert pragma), call Default_Streaming_Unavailable; if that call returns True, then implement the streaming operation as "raise Program_Error;". --- gcc/ada/exp_attr.adb | 72 ++++++++++++++++++++++++++++++++++++++++++++ gcc/ada/exp_tss.adb | 8 ++++- gcc/ada/sem_attr.adb | 14 ++++++--- gcc/ada/sem_util.adb | 66 ++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_util.ads | 8 +++++ 5 files changed, 163 insertions(+), 5 deletions(-) diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 301479d8855..d3468d5e58f 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -136,6 +136,12 @@ package body Exp_Attr is -- special-case code that shuffles partial and full views in the middle -- of semantic analysis and expansion. + function Default_Streaming_Unavailable (Typ : Entity_Id) return Boolean; + -- + -- In most cases, references to unavailable streaming attributes + -- are rejected at compile time. In some obscure cases involving + -- generics and formal derived types, the problem is dealt with at runtime. + procedure Expand_Access_To_Protected_Op (N : Node_Id; Pref : Node_Id; @@ -926,6 +932,24 @@ package body Exp_Attr is end if; end Compile_Stream_Body_In_Scope; + ----------------------------------- + -- Default_Streaming_Unavailable -- + ----------------------------------- + + function Default_Streaming_Unavailable (Typ : Entity_Id) return Boolean is + Btyp : constant Entity_Id := Implementation_Base_Type (Typ); + begin + if Is_Immutably_Limited_Type (Btyp) + and then not Is_Tagged_Type (Btyp) + and then not (Ekind (Btyp) = E_Record_Type + and then Present (Corresponding_Concurrent_Type (Btyp))) + then + pragma Assert (In_Instance_Body); + return True; + end if; + return False; + end Default_Streaming_Unavailable; + ----------------------------------- -- Expand_Access_To_Protected_Op -- ----------------------------------- @@ -3954,6 +3978,18 @@ package body Exp_Attr is Analyze_And_Resolve (N, B_Type); return; + -- Limited types + + elsif Default_Streaming_Unavailable (U_Type) then + -- Do the same thing here as is done above in the + -- case where a No_Streams restriction is active. + + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Stream_Operation_Not_Allowed)); + Set_Etype (N, B_Type); + return; + -- Elementary types elsif Is_Elementary_Type (U_Type) then @@ -5074,6 +5110,18 @@ package body Exp_Attr is Analyze (N); return; + -- Limited types + + elsif Default_Streaming_Unavailable (U_Type) then + -- Do the same thing here as is done above in the + -- case where a No_Streams restriction is active. + + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Stream_Operation_Not_Allowed)); + Set_Etype (N, Standard_Void_Type); + return; + -- For elementary types, we call the W_xxx routine directly. Note -- that the effect of Write and Output is identical for the case -- of an elementary type (there are no discriminants or bounds). @@ -5907,6 +5955,18 @@ package body Exp_Attr is Analyze (N); return; + -- Limited types + + elsif Default_Streaming_Unavailable (U_Type) then + -- Do the same thing here as is done above in the + -- case where a No_Streams restriction is active. + + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Stream_Operation_Not_Allowed)); + Set_Etype (N, B_Type); + return; + -- For elementary types, we call the I_xxx routine using the first -- parameter and then assign the result into the second parameter. -- We set Assignment_OK to deal with the conversion case. @@ -7516,6 +7576,18 @@ package body Exp_Attr is Analyze (N); return; + -- Limited types + + elsif Default_Streaming_Unavailable (U_Type) then + -- Do the same thing here as is done above in the + -- case where a No_Streams restriction is active. + + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Stream_Operation_Not_Allowed)); + Set_Etype (N, U_Type); + return; + -- For elementary types, we call the W_xxx routine directly elsif Is_Elementary_Type (U_Type) then diff --git a/gcc/ada/exp_tss.adb b/gcc/ada/exp_tss.adb index b640843c2c3..40943fb9971 100644 --- a/gcc/ada/exp_tss.adb +++ b/gcc/ada/exp_tss.adb @@ -164,7 +164,13 @@ package body Exp_Tss is -- If Typ is a derived type, it may inherit attributes from an ancestor if No (Proc) and then Is_Derived_Type (Btyp) then - Proc := Find_Inherited_TSS (Etype (Btyp), Nam); + if not Derivation_Too_Early_To_Inherit (Btyp, Nam) then + Proc := Find_Inherited_TSS (Etype (Btyp), Nam); + elsif Is_Derived_Type (Etype (Btyp)) then + -- Skip one link in the derivation chain + Proc := Find_Inherited_TSS + (Etype (Base_Type (Etype (Btyp))), Nam); + end if; end if; -- If nothing else, use the TSS of the root type diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index db34caef7de..c80cc06804d 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -12409,11 +12409,17 @@ package body Sem_Attr is -- applies to an ancestor type. while Etype (Etyp) /= Etyp loop - Etyp := Etype (Etyp); + declare + Derived_Type : constant Entity_Id := Etyp; + begin + Etyp := Etype (Etyp); - if Has_Stream_Attribute_Definition (Etyp, Nam) then - return True; - end if; + if Has_Stream_Attribute_Definition (Etyp, Nam) then + if not Derivation_Too_Early_To_Inherit (Derived_Type, Nam) then + return True; + end if; + end if; + end; end loop; if Ada_Version < Ada_2005 then diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1115dfc2b05..30c537643f7 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -50,6 +50,7 @@ with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Aux; use Sem_Aux; with Sem_Attr; use Sem_Attr; +with Sem_Cat; use Sem_Cat; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; with Sem_Disp; use Sem_Disp; @@ -7288,6 +7289,71 @@ package body Sem_Util is return Denotes_Discriminant (L) or else Denotes_Discriminant (H); end Depends_On_Discriminant; + ------------------------------------- + -- Derivation_Too_Early_To_Inherit -- + ------------------------------------- + + function Derivation_Too_Early_To_Inherit + (Typ : Entity_Id; Streaming_Op : TSS_Name_Type) return Boolean is + Btyp : constant Entity_Id := Implementation_Base_Type (Typ); + Parent_Type : Entity_Id; + begin + if Is_Derived_Type (Btyp) then + Parent_Type := Implementation_Base_Type (Etype (Btyp)); + pragma Assert (Parent_Type /= Btyp); + if Has_Stream_Attribute_Definition + (Parent_Type, Streaming_Op) + and then In_Same_Extended_Unit (Btyp, Parent_Type) + and then Instantiation (Get_Source_File_Index (Sloc (Btyp))) = + Instantiation (Get_Source_File_Index (Sloc (Parent_Type))) + then + declare + -- ??? Avoid code duplication here with + -- Sem_Cat.Has_Stream_Attribute_Definition by introducing a + -- new function to be called from both places? + + Rep_Item : Node_Id := First_Rep_Item (Parent_Type); + Real_Rep : Node_Id; + Found : Boolean := False; + begin + while Present (Rep_Item) loop + Real_Rep := Rep_Item; + + if Nkind (Rep_Item) = N_Aspect_Specification then + Real_Rep := Aspect_Rep_Item (Rep_Item); + end if; + + if Nkind (Real_Rep) = N_Attribute_Definition_Clause then + case Chars (Real_Rep) is + when Name_Read => + Found := Streaming_Op = TSS_Stream_Read; + + when Name_Write => + Found := Streaming_Op = TSS_Stream_Write; + + when Name_Input => + Found := Streaming_Op = TSS_Stream_Input; + + when Name_Output => + Found := Streaming_Op = TSS_Stream_Output; + + when others => + null; + end case; + end if; + + if Found then + return Earlier_In_Extended_Unit (Btyp, Real_Rep); + end if; + + Next_Rep_Item (Rep_Item); + end loop; + end; + end if; + end if; + return False; + end Derivation_Too_Early_To_Inherit; + ------------------------- -- Designate_Same_Unit -- ------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index fdc4797bf65..bcc7fd7271a 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -665,6 +665,14 @@ package Sem_Util is -- indication or a scalar subtype where one of the bounds is a -- discriminant. + function Derivation_Too_Early_To_Inherit + (Typ : Entity_Id; Streaming_Op : TSS_Name_Type) return Boolean; + -- Returns True if Typ is a derived type, the given Streaming_Op + -- (one of Read, Write, Input, or Output) is explicitly specified + -- for Typ's parent type, and that attribute specification is *not* + -- inherited by Typ because the declaration of Typ precedes that + -- of the attribute specification. + function Designate_Same_Unit (Name1 : Node_Id; Name2 : Node_Id) return Boolean; -- 2.30.2