The No_Tagged_Streams pragma (and aspect) provides a method for
selectively inhibiting the generation of stream routines for
tagged types. It can be used either in a form naming a specific
tagged type, or in a sequence of declarations to apply to all
subsequent declarations.
The following tests show the use of the pragma and the rejection
of attempts to use stream operations on affected types.
1. with Ada.Text_IO; use Ada.Text_IO;
2. with Ada.Text_IO.Text_Streams;
3. use Ada.Text_IO.Text_Streams;
4. procedure NTS1 is
5. f : File_Type;
6. type R is tagged null record;
7. pragma No_Tagged_Streams (R);
8. RV : R;
9. begin
10. R'Write (Stream (f), RV);
|
>>> no stream operations for "R"
(No_Tagged_Streams at line 7)
11. end;
1. with Ada.Text_IO; use Ada.Text_IO;
2. with Ada.Text_IO.Text_Streams;
3. use Ada.Text_IO.Text_Streams;
4. procedure NTS2 is
5. pragma No_Tagged_Streams;
6. f : File_Type;
7. type R is tagged null record;
8. RV : R;
9. begin
10. R'Write (Stream (f), RV);
|
>>> no stream operations for "R"
(No_Tagged_Streams at line 5)
11. end;
1. with Ada.Text_IO; use Ada.Text_IO;
2. with Ada.Text_IO.Text_Streams;
3. use Ada.Text_IO.Text_Streams;
4. procedure NTS3 is
5. f : File_Type;
6. pragma No_Tagged_Streams;
7. type R is tagged null record;
8. RV : R;
9. begin
10. R'Write (Stream (f), RV);
|
>>> no stream operations for "R"
(No_Tagged_Streams at line 6)
11. end;
1. package NTS4 is
2. pragma No_Tagged_Streams;
3. type R is tagged null record;
4. end;
1. with Ada.Text_IO; use Ada.Text_IO;
2. with Ada.Text_IO.Text_Streams;
3. use Ada.Text_IO.Text_Streams;
4. with NTS4; use NTS4;
5. procedure NTS4M is
6. f : File_Type;
7. RV : R;
8. begin
9. R'Write (Stream (f), RV);
|
>>> no stream operations for "R"
(No_Tagged_Streams at nts4.ads:2)
10. end;
1. with Ada.Text_IO; use Ada.Text_IO;
2. with Ada.Text_IO.Text_Streams;
3. use Ada.Text_IO.Text_Streams;
4. procedure NTS5 is
5. f : File_Type;
6. type R is tagged null record
7. with No_Tagged_Streams => True;
8. type R1 is new R with
9. record F : Integer; end record;
10. RV : R1;
11. begin
12. R1'Write (Stream (f), RV);
|
>>> no stream operations for "R1"
(No_Tagged_Streams at line 7)
13. end;
The following test shows the rejection of incorrect usage
1. pragma No_Tagged_Streams;
|
>>> pragma "NO_TAGGED_STREAMS" is not in
declarative part or package spec
2. procedure NTS6 is
3. type R is new Integer;
4. pragma No_Tagged_Streams (Entity => R);
|
>>> argument for pragma "NO_TAGGED_STREAMS"
must be root tagged type
5. begin
6. null;
7. end;
2014-10-20 Robert Dewar <de...@adacore.com>
* 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.
Index: aspects.adb
===================================================================
--- aspects.adb (revision 216469)
+++ aspects.adb (working copy)
@@ -546,6 +546,7 @@
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,
Index: aspects.ads
===================================================================
--- aspects.ads (revision 216469)
+++ aspects.ads (working copy)
@@ -180,6 +180,7 @@
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 @@
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 @@
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,
Index: einfo.adb
===================================================================
--- einfo.adb (revision 216469)
+++ einfo.adb (working copy)
@@ -251,6 +251,7 @@
-- Thunk_Entity Node31
-- SPARK_Pragma Node32
+ -- No_Tagged_Streams_Pragma Node32
-- Linker_Section_Pragma Node33
-- SPARK_Aux_Pragma Node33
@@ -2594,6 +2595,12 @@
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 @@
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 @@
E_Subprogram_Body =>
Write_Str ("SPARK_Pragma");
+ when Type_Kind =>
+ Write_Str ("No_Tagged_Streams_Pragma");
+
when others =>
Write_Str ("Field32??");
end case;
Index: einfo.ads
===================================================================
--- einfo.ads (revision 216469)
+++ einfo.ads (working copy)
@@ -3361,20 +3361,6 @@
-- 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 @@
-- 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 @@
-- 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 @@
-- 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 @@
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 @@
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 @@
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 @@
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);
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 216475)
+++ exp_ch3.adb (working copy)
@@ -378,7 +378,7 @@
-- 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 @@
-- 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 @@
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))
Index: gnat_rm.texi
===================================================================
--- gnat_rm.texi (revision 216469)
+++ gnat_rm.texi (working copy)
@@ -209,6 +209,7 @@
* 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 @@
* 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 @@
* 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 @@
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 @@
* 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 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
Index: opt.ads
===================================================================
--- opt.ads (revision 216473)
+++ opt.ads (working copy)
@@ -1077,6 +1077,11 @@
-- 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.
Index: par-prag.adb
===================================================================
--- par-prag.adb (revision 216469)
+++ par-prag.adb (working copy)
@@ -1262,6 +1262,7 @@
Pragma_No_Return |
Pragma_No_Run_Time |
Pragma_No_Strict_Aliasing |
+ Pragma_No_Tagged_Streams |
Pragma_Normalize_Scalars |
Pragma_Obsolescent |
Pragma_Ordered |
Index: sem.ads
===================================================================
--- sem.ads (revision 216469)
+++ sem.ads (working copy)
@@ -492,6 +492,9 @@
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
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 216469)
+++ sem_attr.adb (working copy)
@@ -1909,6 +1909,17 @@
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
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 216475)
+++ sem_ch3.adb (working copy)
@@ -2554,7 +2554,8 @@
-- 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 @@
-- 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 @@
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 @@
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 @@
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 @@
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 @@
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 @@
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,12 +8281,17 @@
-- 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
Set_Has_Controlled_Component
@@ -8287,7 +8311,6 @@
-- 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 @@
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 @@
-- 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 @@
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 @@
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 @@
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 @@
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,9 +20562,13 @@
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.
Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb (revision 216469)
+++ sem_ch8.adb (working copy)
@@ -7851,6 +7851,7 @@
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 @@
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;
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 216469)
+++ sem_prag.adb (working copy)
@@ -16542,6 +16542,58 @@
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 @@
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,
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 216469)
+++ snames.ads-tmpl (working copy)
@@ -408,6 +408,7 @@
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 @@
Pragma_Loop_Optimize,
Pragma_No_Run_Time,
Pragma_No_Strict_Aliasing,
+ Pragma_No_Tagged_Streams,
Pragma_Normalize_Scalars,
Pragma_Optimize_Alignment,
Pragma_Overflow_Mode,
