From 49d413972612664513ab9b69934359563616b846 Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Mon, 20 Oct 2014 14:24:15 +0000 Subject: [PATCH] gnat_rm.texi: Document No_Tagged_Streams pragma and aspect. 2014-10-20 Robert Dewar * gnat_rm.texi: Document No_Tagged_Streams pragma and aspect. * snames.ads-tmpl: Add entry for pragma No_Tagged_Streams. * aspects.ads, aspects.adb: Add aspect No_Tagged_Streams. * einfo.adb (No_Tagged_Streams_Pragma): New field. * einfo.ads: Minor reformatting (reorder entries). (No_Tagged_Streams_Pragma): New field. * exp_ch3.adb: Minor comment update. * opt.ads (No_Tagged_Streams): New variable. * par-prag.adb: Add dummy entry for pragma No_Tagged_Streams. * sem.ads (Save_No_Tagged_Streams): New field in scope record. * sem_attr.adb (Check_Stream_Attribute): Check stream ops prohibited by No_Tagged_Streams. * sem_ch3.adb (Analyze_Full_Type_Declaration): Set No_Tagged_Streams_Pragma. (Analyze_Subtype_Declaration): ditto. (Build_Derived_Record_Type): ditto. (Record_Type_Declaration): ditto. * sem_ch8.adb (Pop_Scope): Restore No_Tagged_Streams. (Push_Scope): Save No_Tagged_Streams. * sem_prag.adb (Analyze_Pragma, case No_Tagged_Streams): Implement new pragma. From-SVN: r216476 --- gcc/ada/ChangeLog | 24 ++++++++++++++ gcc/ada/aspects.adb | 1 + gcc/ada/aspects.ads | 3 ++ gcc/ada/einfo.adb | 16 ++++++++++ gcc/ada/einfo.ads | 58 +++++++++++++++++++-------------- gcc/ada/exp_ch3.adb | 7 ++-- gcc/ada/gnat_rm.texi | 47 +++++++++++++++++++++++++++ gcc/ada/opt.ads | 5 +++ gcc/ada/par-prag.adb | 1 + gcc/ada/sem.ads | 3 ++ gcc/ada/sem_attr.adb | 11 +++++++ gcc/ada/sem_ch3.adb | 71 +++++++++++++++++++++++++++++++---------- gcc/ada/sem_ch8.adb | 2 ++ gcc/ada/sem_prag.adb | 53 ++++++++++++++++++++++++++++++ gcc/ada/snames.ads-tmpl | 2 ++ 15 files changed, 262 insertions(+), 42 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3939bafd830..e1e6b137d14 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,27 @@ +2014-10-20 Robert Dewar + + * gnat_rm.texi: Document No_Tagged_Streams pragma and aspect. + * snames.ads-tmpl: Add entry for pragma No_Tagged_Streams. + * aspects.ads, aspects.adb: Add aspect No_Tagged_Streams. + * einfo.adb (No_Tagged_Streams_Pragma): New field. + * einfo.ads: Minor reformatting (reorder entries). + (No_Tagged_Streams_Pragma): New field. + * exp_ch3.adb: Minor comment update. + * opt.ads (No_Tagged_Streams): New variable. + * par-prag.adb: Add dummy entry for pragma No_Tagged_Streams. + * sem.ads (Save_No_Tagged_Streams): New field in scope record. + * sem_attr.adb (Check_Stream_Attribute): Check stream ops + prohibited by No_Tagged_Streams. + * sem_ch3.adb (Analyze_Full_Type_Declaration): Set + No_Tagged_Streams_Pragma. + (Analyze_Subtype_Declaration): ditto. + (Build_Derived_Record_Type): ditto. + (Record_Type_Declaration): ditto. + * sem_ch8.adb (Pop_Scope): Restore No_Tagged_Streams. + (Push_Scope): Save No_Tagged_Streams. + * sem_prag.adb (Analyze_Pragma, case No_Tagged_Streams): Implement new + pragma. + 2014-10-20 Robert Dewar * sem_ch3.adb, prj-proc.adb, sem_ch4.adb, prj-env.adb, lib.ads, diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 472f95700b3..ecac9ff2941 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -546,6 +546,7 @@ package body Aspects is Aspect_Machine_Radix => Aspect_Machine_Radix, Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All, Aspect_No_Return => Aspect_No_Return, + Aspect_No_Tagged_Streams => Aspect_No_Tagged_Streams, Aspect_Obsolescent => Aspect_Obsolescent, Aspect_Object_Size => Aspect_Object_Size, Aspect_Output => Aspect_Output, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 60b64740889..173c66db173 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -180,6 +180,7 @@ package Aspects is Aspect_Interrupt_Handler, Aspect_Lock_Free, -- GNAT Aspect_No_Return, + Aspect_No_Tagged_Streams, -- GNAT Aspect_Pack, Aspect_Persistent_BSS, -- GNAT Aspect_Preelaborable_Initialization, @@ -432,6 +433,7 @@ package Aspects is Aspect_Machine_Radix => Name_Machine_Radix, Aspect_No_Elaboration_Code_All => Name_No_Elaboration_Code_All, Aspect_No_Return => Name_No_Return, + Aspect_No_Tagged_Streams => Name_No_Tagged_Streams, Aspect_Object_Size => Name_Object_Size, Aspect_Obsolescent => Name_Obsolescent, Aspect_Output => Name_Output, @@ -691,6 +693,7 @@ package Aspects is Aspect_Initial_Condition => Never_Delay, Aspect_Initializes => Never_Delay, Aspect_No_Elaboration_Code_All => Never_Delay, + Aspect_No_Tagged_Streams => Never_Delay, Aspect_Obsolescent => Never_Delay, Aspect_Part_Of => Never_Delay, Aspect_Refined_Depends => Never_Delay, diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 6aa7c48a429..18cac0f9b4b 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -251,6 +251,7 @@ package body Einfo is -- Thunk_Entity Node31 -- SPARK_Pragma Node32 + -- No_Tagged_Streams_Pragma Node32 -- Linker_Section_Pragma Node33 -- SPARK_Aux_Pragma Node33 @@ -2594,6 +2595,12 @@ package body Einfo is return Flag136 (Base_Type (Id)); end No_Strict_Aliasing; + function No_Tagged_Streams_Pragma (Id : E) return N is + begin + pragma Assert (Is_Tagged_Type (Id)); + return Node32 (Id); + end No_Tagged_Streams_Pragma; + function Non_Binary_Modulus (Id : E) return B is begin pragma Assert (Is_Type (Id)); @@ -5419,6 +5426,12 @@ package body Einfo is Set_Flag136 (Id, V); end Set_No_Strict_Aliasing; + procedure Set_No_Tagged_Streams_Pragma (Id : E; V : E) is + begin + pragma Assert (Is_Tagged_Type (Id)); + Set_Node32 (Id, V); + end Set_No_Tagged_Streams_Pragma; + procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is begin pragma Assert (Is_Type (Id) and then Is_Base_Type (Id)); @@ -9742,6 +9755,9 @@ package body Einfo is E_Subprogram_Body => Write_Str ("SPARK_Pragma"); + when Type_Kind => + Write_Str ("No_Tagged_Streams_Pragma"); + when others => Write_Str ("Field32??"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index d680c774382..9c2c53c7858 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3361,20 +3361,6 @@ package Einfo is -- Empty if applied to the last literal. This is actually a synonym -- for Next, but its use is preferred in this context. --- Non_Binary_Modulus (Flag58) [base type only] --- Defined in all subtype and type entities. Set for modular integer --- types if the modulus value is other than a power of 2. - --- Non_Limited_View (Node17) --- Defined in abstract states and incomplete types that act as shadow --- entities created when analysing a limited with clause (Ada 2005: --- AI-50217). Points to the defining entity of the original declaration. - --- Nonzero_Is_True (Flag162) [base type only] --- Defined in enumeration types. Set if any non-zero value is to be --- interpreted as true. Currently this is set for derived Boolean --- types which have a convention of C, C++ or Fortran. - -- No_Dynamic_Predicate_On_Actual (Flag276) -- Defined in discrete types. Set for generic formal types that are used -- in loops and quantified expressions. The corresponing actual cannot @@ -3396,6 +3382,35 @@ package Einfo is -- Defined in all entities. Always false except in the case of procedures -- and generic procedures for which a pragma No_Return is given. +-- No_Strict_Aliasing (Flag136) [base type only] +-- Defined in access types. Set to direct the backend to avoid any +-- optimizations based on an assumption about the aliasing status of +-- objects designated by the access type. For the case of the gcc +-- backend, the effect is as though all references to objects of +-- the type were compiled with -fno-strict-aliasing. This flag is +-- set if an unchecked conversion with the access type as a target +-- type occurs in the same source unit as the declaration of the +-- access type, or if an explicit pragma No_Strict_Aliasing applies. + +-- No_Tagged_Streams_Pragma (Node32) +-- Present in all subtype and type entities. Set for tagged types and +-- subtypes (i.e. entities with Is_Tagged_Type set True) if a valid +-- pragma/aspect applies to the type. + +-- Non_Binary_Modulus (Flag58) [base type only] +-- Defined in all subtype and type entities. Set for modular integer +-- types if the modulus value is other than a power of 2. + +-- Non_Limited_View (Node17) +-- Defined in abstract states and incomplete types that act as shadow +-- entities created when analysing a limited with clause (Ada 2005: +-- AI-50217). Points to the defining entity of the original declaration. + +-- Nonzero_Is_True (Flag162) [base type only] +-- Defined in enumeration types. Set if any non-zero value is to be +-- interpreted as true. Currently this is set for derived Boolean +-- types which have a convention of C, C++ or Fortran. + -- Normalized_First_Bit (Uint8) -- Defined in components and discriminants. Indicates the normalized -- value of First_Bit for the component, i.e. the offset within the @@ -3419,16 +3434,6 @@ package Einfo is -- the maximum size such records (needed for allocation purposes when -- there are default discriminants, and also for the 'Size value). --- No_Strict_Aliasing (Flag136) [base type only] --- Defined in access types. Set to direct the backend to avoid any --- optimizations based on an assumption about the aliasing status of --- objects designated by the access type. For the case of the gcc --- backend, the effect is as though all references to objects of --- the type were compiled with -fno-strict-aliasing. This flag is --- set if an unchecked conversion with the access type as a target --- type occurs in the same source unit as the declaration of the --- access type, or if an explicit pragma No_Strict_Aliasing applies. - -- Number_Dimensions (synthesized) -- Applies to array types and subtypes. Returns the number of dimensions -- of the array type or subtype as a value of type Pos. @@ -5261,6 +5266,7 @@ package Einfo is -- Current_Use_Clause (Node27) -- Subprograms_For_Type (Node29) -- Derived_Type_Link (Node31) + -- No_Tagged_Streams_Pragma (Node32) -- Linker_Section_Pragma (Node33) -- Depends_On_Private (Flag14) @@ -6814,6 +6820,7 @@ package Einfo is function No_Predicate_On_Actual (Id : E) return B; function No_Return (Id : E) return B; function No_Strict_Aliasing (Id : E) return B; + function No_Tagged_Streams_Pragma (Id : E) return N; function Non_Binary_Modulus (Id : E) return B; function Non_Limited_View (Id : E) return E; function Nonzero_Is_True (Id : E) return B; @@ -7458,6 +7465,7 @@ package Einfo is procedure Set_No_Predicate_On_Actual (Id : E; V : B := True); procedure Set_No_Return (Id : E; V : B := True); procedure Set_No_Strict_Aliasing (Id : E; V : B := True); + procedure Set_No_Tagged_Streams_Pragma (Id : E; V : N); procedure Set_Non_Binary_Modulus (Id : E; V : B := True); procedure Set_Non_Limited_View (Id : E; V : E); procedure Set_Nonzero_Is_True (Id : E; V : B := True); @@ -8251,6 +8259,7 @@ package Einfo is pragma Inline (No_Predicate_On_Actual); pragma Inline (No_Return); pragma Inline (No_Strict_Aliasing); + pragma Inline (No_Tagged_Streams_Pragma); pragma Inline (Non_Binary_Modulus); pragma Inline (Non_Limited_View); pragma Inline (Nonzero_Is_True); @@ -8693,6 +8702,7 @@ package Einfo is pragma Inline (Set_No_Predicate_On_Actual); pragma Inline (Set_No_Return); pragma Inline (Set_No_Strict_Aliasing); + pragma Inline (Set_No_Tagged_Streams_Pragma); pragma Inline (Set_Non_Binary_Modulus); pragma Inline (Set_Non_Limited_View); pragma Inline (Set_Nonzero_Is_True); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 330e168425a..3aecc9ba370 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -378,7 +378,7 @@ package body Exp_Ch3 is -- type. The rules for inheritance of stream attributes by type extensions -- are enforced by this function. Furthermore, various restrictions prevent -- the generation of these operations, as a useful optimization or for - -- certification purposes. + -- certification purposes and to save unnecessary generated code. -------------------------- -- Adjust_Discriminants -- @@ -10008,7 +10008,9 @@ package body Exp_Ch3 is -- Bodies for Dispatching stream IO routines. We need these only for -- non-limited types (in the limited case there is no dispatching). - -- We also skip them if dispatching or finalization are not available. + -- We also skip them if dispatching or finalization are not available + -- or if stream operations are prohibited by restriction No_Streams or + -- from use of pragma/aspect No_Tagged_Streams. if Stream_Operation_OK (Tag_Typ, TSS_Stream_Read) and then No (TSS (Tag_Typ, TSS_Stream_Read)) @@ -10309,6 +10311,7 @@ package body Exp_Ch3 is or else Is_Synchronized_Interface (Typ))) and then not Restriction_Active (No_Streams) and then not Restriction_Active (No_Dispatch) + and then No (No_Tagged_Streams_Pragma (Typ)) and then not No_Run_Time_Mode and then RTE_Available (RE_Tag) and then No (Type_Without_Stream_Operation (Typ)) diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 44230c22c3d..425791f7fca 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -209,6 +209,7 @@ Implementation Defined Pragmas * Pragma No_Return:: * Pragma No_Run_Time:: * Pragma No_Strict_Aliasing :: +* Pragma No_Tagged_Streams:: * Pragma Normalize_Scalars:: * Pragma Obsolescent:: * Pragma Optimize_Alignment:: @@ -313,6 +314,7 @@ Implementation Defined Aspects * Aspect Iterable:: * Aspect Linker_Section:: * Aspect No_Elaboration_Code_All:: +* Aspect No_Tagged_Streams:: * Aspect Object_Size:: * Aspect Obsolescent:: * Aspect Part_Of:: @@ -1081,6 +1083,7 @@ consideration, the use of these pragmas should be minimized. * Pragma No_Return:: * Pragma No_Run_Time:: * Pragma No_Strict_Aliasing:: +* Pragma No_Tagged_Streams:: * Pragma Normalize_Scalars:: * Pragma Obsolescent:: * Pragma Optimize_Alignment:: @@ -4778,6 +4781,41 @@ Aliasing,,, gnat_ugn, @value{EDITION} User's Guide}. This pragma currently has no effects on access to unconstrained array types. +@node Pragma No_Tagged_Streams +@unnumberedsec Pragma No_Tagged_Streams +@findex No_Tagged_Streams +@noindent +Syntax: + +@smallexample @c ada +pragma No_Tagged_Streams; +pragma No_Tagged_Streams [([Entity =>] tagged_type_LOCAL_NAME)]; +@end smallexample + +@noindent +Normally when a tagged type is introduced using a full type declaration, +part of the processing includes generating stream access routines to be +used by stream attributes referencing the type (or one of its subtypes +or derived types). This can involve the generation of significant amounts +of code which is wasted space if stream routines are not needed for the +type in question. + +The @code{No_Tagged_Streams} pragma causes the generation of these stream +routines to be skipped, and any attempt to use stream operations on +types subject to this pragma will be statically rejected as illegal. + +There are two forms of the pragma. The form with no arguments must appear +in a declarative sequence or in the declarations of a package spec. This +pragma affects all subsequent root tagged types declared in the declaration +sequence, and specifies that no stream routines be generated. The form with +an argument (for which there is also a corresponding aspect) specifies a +single root tagged type for which stream routines are not to be generated. + +Once the pragma has been given for a particular root tagged type, all subtypes +and derived types of this type inherit the pragma automatically, so the effect +applies to a complete hierarchy (this is necessary to deal with the class-wide +dispatching versions of the stream routines). + @node Pragma Normalize_Scalars @unnumberedsec Pragma Normalize_Scalars @findex Normalize_Scalars @@ -8110,6 +8148,7 @@ or attribute definition clause. * Aspect Linker_Section:: * Aspect Lock_Free:: * Aspect No_Elaboration_Code_All:: +* Aspect No_Tagged_Streams:: * Aspect Object_Size:: * Aspect Obsolescent:: * Aspect Part_Of:: @@ -8388,6 +8427,14 @@ This boolean aspect is equivalent to pragma @code{Lock_Free}. This aspect is equivalent to a @code{pragma No_Elaboration_Code_All} statement for a program unit. +@node Aspect No_Tagged_Streams +@unnumberedsec Aspect No_Tagged_Streams +@findex No_Tagged_Streams +@noindent +This aspect is equivalent to a @code{pragma No_Tagged_Streams} with an +argument specifying a root tagged type (thus this aspect can only be +applied to such a type). + @node Aspect Object_Size @unnumberedsec Aspect Object_Size @findex Object_Size diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 79c4d0658d7..7706827f8f5 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1077,6 +1077,11 @@ package Opt is -- GNAT -- Set True if pragma No_Strict_Aliasing with no parameters encountered. + No_Tagged_Streams : Node_Id := Empty; + -- GNAT + -- If a pragma No_Tagged_Streams is active for the current scope, this + -- points to the corresponding pragma. + Normalize_Scalars : Boolean := False; -- GNAT, GNATBIND -- Set True if a pragma Normalize_Scalars applies to the current unit. diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 128ff227837..a9fc33d59b0 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1262,6 +1262,7 @@ begin Pragma_No_Return | Pragma_No_Run_Time | Pragma_No_Strict_Aliasing | + Pragma_No_Tagged_Streams | Pragma_Normalize_Scalars | Pragma_Obsolescent | Pragma_Ordered | diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index e82905ea974..22da2233005 100644 --- a/gcc/ada/sem.ads +++ b/gcc/ada/sem.ads @@ -492,6 +492,9 @@ package Sem is Save_SPARK_Mode_Pragma : Node_Id; -- Setting of SPARK_Mode_Pragma on entry to restore on exit + Save_No_Tagged_Streams : Node_Id; + -- Setting of No_Tagged_Streams to restore on exit + Save_Default_SSO : Character; -- Setting of Default_SSO on entry to restore on exit diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index ca1deebf12f..d0c3f0d3716 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1909,6 +1909,17 @@ package body Sem_Attr is end if; end if; + -- Check for no stream operations allowed from No_Tagged_Streams + + if Is_Tagged_Type (P_Type) + and then Present (No_Tagged_Streams_Pragma (P_Type)) + then + Error_Msg_Sloc := Sloc (No_Tagged_Streams_Pragma (P_Type)); + Error_Msg_NE + ("no stream operations for & (No_Tagged_Streams #)", N, P_Type); + return; + end if; + -- Check restriction violations -- First check the No_Streams restriction, which prohibits the use diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 911198f325e..b81d3636433 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2554,7 +2554,8 @@ package body Sem_Ch3 is -- imported through a LIMITED WITH clause, it appears as incomplete -- but has no full view. - if Ekind (Prev) = E_Incomplete_Type and then Present (Full_View (Prev)) + if Ekind (Prev) = E_Incomplete_Type + and then Present (Full_View (Prev)) then T := Full_View (Prev); Set_Incomplete_View (N, Parent (Prev)); @@ -2847,7 +2848,8 @@ package body Sem_Ch3 is -- incomplete types. if Tagged_Present (N) then - Set_Is_Tagged_Type (T); + Set_Is_Tagged_Type (T, True); + Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams); Make_Class_Wide_Type (T); Set_Direct_Primitive_Operations (T, New_Elmt_List); end if; @@ -2879,6 +2881,7 @@ package body Sem_Ch3 is begin Set_Is_Tagged_Type (T); + Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams); Set_Is_Limited_Record (T, Limited_Present (Def) or else Task_Present (Def) @@ -4663,6 +4666,8 @@ package body Sem_Ch3 is Set_Is_Tagged_Type (Id, True); Set_Has_Unknown_Discriminants (Id, True); + Set_No_Tagged_Streams_Pragma + (Id, No_Tagged_Streams_Pragma (T)); if Ekind (T) = E_Class_Wide_Subtype then Set_Equivalent_Type (Id, Equivalent_Type (T)); @@ -4699,7 +4704,9 @@ package body Sem_Ch3 is end if; if Is_Tagged_Type (T) then - Set_Is_Tagged_Type (Id); + Set_Is_Tagged_Type (Id, True); + Set_No_Tagged_Streams_Pragma + (Id, No_Tagged_Streams_Pragma (T)); Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); Set_Direct_Primitive_Operations (Id, Direct_Primitive_Operations (T)); @@ -4728,6 +4735,8 @@ package body Sem_Ch3 is if Is_Tagged_Type (T) then Set_Is_Tagged_Type (Id); + Set_No_Tagged_Streams_Pragma (Id, + No_Tagged_Streams_Pragma (T)); Set_Is_Abstract_Type (Id, Is_Abstract_Type (T)); Set_Class_Wide_Type (Id, Class_Wide_Type (T)); Set_Direct_Primitive_Operations (Id, @@ -4808,6 +4817,11 @@ package body Sem_Ch3 is Set_Is_Tagged_Type (Id, Is_Tagged_Type (T)); Set_Last_Entity (Id, Last_Entity (T)); + if Is_Tagged_Type (T) then + Set_No_Tagged_Streams_Pragma + (Id, No_Tagged_Streams_Pragma (T)); + end if; + if Has_Discriminants (T) then Set_Discriminant_Constraint (Id, Discriminant_Constraint (T)); @@ -4824,6 +4838,11 @@ package body Sem_Ch3 is Set_Is_Tagged_Type (Id, Is_Tagged_Type (T)); Set_Private_Dependents (Id, New_Elmt_List); + if Is_Tagged_Type (Id) then + Set_No_Tagged_Streams_Pragma + (Id, No_Tagged_Streams_Pragma (T)); + end if; + -- Ada 2005 (AI-412): Decorate an incomplete subtype of an -- incomplete type visible through a limited with clause. @@ -8262,11 +8281,16 @@ package body Sem_Ch3 is -- Fields inherited from the Parent_Type Set_Has_Specified_Layout - (Derived_Type, Has_Specified_Layout (Parent_Type)); + (Derived_Type, Has_Specified_Layout (Parent_Type)); Set_Is_Limited_Composite - (Derived_Type, Is_Limited_Composite (Parent_Type)); + (Derived_Type, Is_Limited_Composite (Parent_Type)); Set_Is_Private_Composite - (Derived_Type, Is_Private_Composite (Parent_Type)); + (Derived_Type, Is_Private_Composite (Parent_Type)); + + if Is_Tagged_Type (Parent_Type) then + Set_No_Tagged_Streams_Pragma + (Derived_Type, No_Tagged_Streams_Pragma (Parent_Type)); + end if; -- Fields inherited from the Parent_Base @@ -8287,7 +8311,6 @@ package body Sem_Ch3 is -- Fields inherited from the Parent_Base for record types if Is_Record_Type (Derived_Type) then - declare Parent_Full : Entity_Id; @@ -8619,6 +8642,11 @@ package body Sem_Ch3 is Set_Is_Controlled (Derived_Type, Is_Controlled (Parent_Type)); Set_Is_Tagged_Type (Derived_Type, Is_Tagged_Type (Parent_Type)); + if Is_Tagged_Type (Derived_Type) then + Set_No_Tagged_Streams_Pragma + (Derived_Type, No_Tagged_Streams_Pragma (Parent_Type)); + end if; + -- If the parent has primitive routines, set the derived type link if Has_Primitive_Operations (Parent_Type) then @@ -8629,7 +8657,7 @@ package body Sem_Ch3 is -- type may be set in the private part, and not propagated to the -- subtype until later, so we obtain the convention from the base type. - Set_Convention (Derived_Type, Convention (Parent_Base)); + Set_Convention (Derived_Type, Convention (Parent_Base)); -- Set SSO default for record or array type @@ -9272,6 +9300,7 @@ package body Sem_Ch3 is if Is_Tagged_Type (T) then Set_Is_Tagged_Type (Def_Id); + Set_No_Tagged_Streams_Pragma (Def_Id, No_Tagged_Streams_Pragma (T)); Make_Class_Wide_Type (Def_Id); end if; @@ -11437,8 +11466,10 @@ package body Sem_Ch3 is if Is_Tagged_Type (Full_Base) then Set_Is_Tagged_Type (Full); - Set_Direct_Primitive_Operations (Full, - Direct_Primitive_Operations (Full_Base)); + Set_Direct_Primitive_Operations + (Full, Direct_Primitive_Operations (Full_Base)); + Set_No_Tagged_Streams_Pragma + (Full, No_Tagged_Streams_Pragma (Full_Base)); -- Inherit class_wide type of full_base in case the partial view was -- not tagged. Otherwise it has already been created when the private @@ -13265,8 +13296,10 @@ package body Sem_Ch3 is Conditional_Delay (Full, Priv); if Is_Tagged_Type (Full) then - Set_Direct_Primitive_Operations (Full, - Direct_Primitive_Operations (Priv)); + Set_Direct_Primitive_Operations + (Full, Direct_Primitive_Operations (Priv)); + Set_No_Tagged_Streams_Pragma + (Full, No_Tagged_Streams_Pragma (Priv)); if Is_Base_Type (Priv) then Set_Class_Wide_Type (Full, Class_Wide_Type (Priv)); @@ -17637,11 +17670,13 @@ package body Sem_Ch3 is Set_Default_SSO (CW_Type); if Ekind (T) = E_Class_Wide_Subtype then - Set_Etype (CW_Type, Etype (Base_Type (T))); + Set_Etype (CW_Type, Etype (Base_Type (T))); else - Set_Etype (CW_Type, T); + Set_Etype (CW_Type, T); end if; + Set_No_Tagged_Streams_Pragma (CW_Type, No_Tagged_Streams); + -- If this is the class_wide type of a constrained subtype, it does -- not have discriminants. @@ -20527,8 +20562,12 @@ package body Sem_Ch3 is Tagged_Present (Def) or else (Serious_Errors_Detected > 0 and then Is_Tagged_Type (T)); - Set_Is_Tagged_Type (T, Is_Tagged); - Set_Is_Limited_Record (T, Limited_Present (Def)); + Set_Is_Limited_Record (T, Limited_Present (Def)); + + if Is_Tagged then + Set_Is_Tagged_Type (T, True); + Set_No_Tagged_Streams_Pragma (T, No_Tagged_Streams); + end if; -- Type is abstract if full declaration carries keyword, or if -- previous partial view did. diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 655f38bf6f4..798564c23c0 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -7851,6 +7851,7 @@ package body Sem_Ch8 is Local_Suppress_Stack_Top := SST.Save_Local_Suppress_Stack_Top; Check_Policy_List := SST.Save_Check_Policy_List; Default_Pool := SST.Save_Default_Storage_Pool; + No_Tagged_Streams := SST.Save_No_Tagged_Streams; SPARK_Mode := SST.Save_SPARK_Mode; SPARK_Mode_Pragma := SST.Save_SPARK_Mode_Pragma; Default_SSO := SST.Save_Default_SSO; @@ -7925,6 +7926,7 @@ package body Sem_Ch8 is SST.Save_Local_Suppress_Stack_Top := Local_Suppress_Stack_Top; SST.Save_Check_Policy_List := Check_Policy_List; SST.Save_Default_Storage_Pool := Default_Pool; + SST.Save_No_Tagged_Streams := No_Tagged_Streams; SST.Save_SPARK_Mode := SPARK_Mode; SST.Save_SPARK_Mode_Pragma := SPARK_Mode_Pragma; SST.Save_Default_SSO := Default_SSO; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 32a3cf3a5e1..ea028abf064 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -16542,6 +16542,58 @@ package body Sem_Prag is Set_Restriction (Max_Tasks, N, 0); Set_Restriction (No_Tasking, N); + ----------------------- + -- No_Tagged_Streams -- + ----------------------- + + -- pragma No_Tagged_Streams; + -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME); + + when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare + E_Id : Node_Id; + E : Entity_Id; + + begin + GNAT_Pragma; + Check_At_Most_N_Arguments (1); + + -- One argument case + + if Arg_Count = 1 then + Check_Optional_Identifier (Arg1, Name_Entity); + Check_Arg_Is_Local_Name (Arg1); + E_Id := Get_Pragma_Arg (Arg1); + + if Etype (E_Id) = Any_Type then + return; + end if; + + E := Entity (E_Id); + + Check_Duplicate_Pragma (E); + + if not Is_Tagged_Type (E) or else Is_Derived_Type (E) then + Error_Pragma_Arg + ("argument for pragma% must be root tagged type", Arg1); + end if; + + if Rep_Item_Too_Early (E, N) + or else + Rep_Item_Too_Late (E, N) + then + return; + else + Set_No_Tagged_Streams_Pragma (E, N); + end if; + + -- Zero argument case + + else + Check_Is_In_Decl_Part_Or_Package_Spec; + No_Tagged_Streams := N; + end if; + end No_Tagged_Strms; + ------------------------ -- No_Strict_Aliasing -- ------------------------ @@ -24906,6 +24958,7 @@ package body Sem_Prag is Pragma_No_Inline => 0, Pragma_No_Run_Time => -1, Pragma_No_Strict_Aliasing => -1, + Pragma_No_Tagged_Streams => 0, Pragma_Normalize_Scalars => 0, Pragma_Obsolescent => 0, Pragma_Optimize => 0, diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index cdc82531c43..cd68f11376c 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -408,6 +408,7 @@ package Snames is Name_Loop_Optimize : constant Name_Id := N + $; -- GNAT Name_No_Run_Time : constant Name_Id := N + $; -- GNAT Name_No_Strict_Aliasing : constant Name_Id := N + $; -- GNAT + Name_No_Tagged_Streams : constant Name_Id := N + $; -- GNAT Name_Normalize_Scalars : constant Name_Id := N + $; Name_Optimize_Alignment : constant Name_Id := N + $; -- GNAT Name_Overflow_Mode : constant Name_Id := N + $; -- GNAT @@ -1749,6 +1750,7 @@ package Snames is Pragma_Loop_Optimize, Pragma_No_Run_Time, Pragma_No_Strict_Aliasing, + Pragma_No_Tagged_Streams, Pragma_Normalize_Scalars, Pragma_Optimize_Alignment, Pragma_Overflow_Mode, -- 2.30.2