[Ada] New pragma Default_Scalar_Storage_Order
Arnaud Charlet
charlet@adacore.com
Tue Jul 29 14:02:00 GMT 2014
Normally the default scalar storage order is the native order of the
target. This pragma, which can be either a configuration pragma, or
appear in a package spec or declarative part, can provide a default
value that overrides this normal default. If used in a package spec
or declarative part, it applies to the following declarations of
array and record types in that package spec or declarative part.
The following example shows the pragma in action:
1. pragma Default_Scalar_Storage_Order
2. (High_Order_First);
3. with System; use System;
4. package DSSO1 is
5. type H1 is record
6. -- High from config pragma
7. a : Integer;
8. end record;
9. for H1 use record
10. a at 0 range 0 .. 31;
11. end record;
12.
13. type L2 is record
14. -- Low from explicit setting
15. a : Integer;
16. end record;
17. for L2 use record
18. a at 0 range 0 .. 31;
19. end record;
20. for L2'Scalar_Storage_Order
21. use Low_Order_First;
22.
23. type L2a is new L2;
24. -- Low (inherited from explicit)
25.
26. package Inner is
27. type H3 is record
28. -- High from outer config pragma
29. a : Integer;
30. end record;
31. for H3 use record
32. a at 0 range 0 .. 31;
33. end record;
34.
35. pragma Default_Scalar_Storage_Order
36. (Low_Order_First);
37.
38. type L4 is record
39. -- Low from inner default
40. a : Integer;
41. end record;
42. for L4 use record
43. a at 0 range 0 .. 31;
44. end record;
45. end Inner;
46.
47. type H4a is new Inner.L4;
48. -- High from config pragma
49. -- No inheritance of default setting
50.
51. type H5 is record
52. -- High from config pragma
53. a : Integer;
54. end record;
55. for H5 use record
56. a at 0 range 0 .. 31;
57. end record;
58. end DSSO1;
If this is compiled with -gnatR and we select the lines that mention
scalar storage order, we get:
for H1'Scalar_Storage_Order use System.High_Order_First;
for L2'Scalar_Storage_Order use System.Low_Order_First;
for L2A'Scalar_Storage_Order use System.Low_Order_First;
for INNER.H3'Scalar_Storage_Order use System.High_Order_First;
for INNER.L4'Scalar_Storage_Order use System.Low_Order_First;
for H4A'Scalar_Storage_Order use System.High_Order_First;
for H5'Scalar_Storage_Order use System.High_Order_First;
If the pragma is used in a configuration pragmas file, then the
binder will require that all units, including all run-time library
units, be compiled the same way (with a pragma in a configuration
pragma file with matching order). Given the following file:
1. with DSSO1;
2. procedure DSSOm is
3. type R is record
4. N : Integer;
5. end record;
6. for R use record
7. N at 0 range 0 .. 31;
8. end record;
9. begin
10. null;
11. end;
If we compile DSSom with a configuration file containing a
pragma specifying Low_Order_First, and then compile DSSO1
with a configuration file containing a pragma specifying
High_Order_First, and then do a bind operation, we get
something like (exactly list of run-time files may vary):
error: files not compiled with same Default_Scalar_Storage_Order
files compiled with High_Order_First
dssom.adb
files compiled with Low_Order_First
dsso1.ads
files compiled with no Default_Scalar_Storage_Order
s-stalib.adb
system.ads
s-memory.adb
ada.ads
a-except.adb
a-elchha.adb
s-soflin.adb
s-parame.adb
s-secsta.adb
s-stoele.adb
s-stache.adb
s-exctab.adb
s-except.adb
s-excmac.ads
s-excdeb.adb
s-imgint.adb
interfac.ads
s-assert.adb
s-traceb.adb
s-wchcon.adb
s-wchstw.adb
s-wchcnv.adb
s-wchjis.adb
s-traent.adb
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-29 Robert Dewar <dewar@adacore.com>
* ali.adb (Initialize_ALI): Initialize SSO_Default_Specified
(Scan_ALI): Set SSO_Default in ALIs_Record (Scan_ALI): Set
SSO_Default_Specified.
* ali.ads (ALIs_Record): Add field SSO_Default
(SSO_Default_Specified): New global switch.
* bcheck.adb (Check_Consistent_SSO_Default): New procedure
(Check_Configuration_Consistency): Call this procedure
* einfo.adb (SSO_Set_High_By_Default): New
function (SSO_Set_Low_By_Default): New function
(Set_SSO_Set_High_By_Default): New procedure
(Set_SSO_Set_Low_By_Default): New procedure (Write_Entity_Flags):
List new flags
* einfo.ads (SSO_Set_Low_By_Default): New flag
(SSO_Set_High_By_Default): New flag
* freeze.adb (Set_SSO_From_Default): New procedure
(Freeze_Array_Type): Call Set_SSO_From_Default
(Freeze_Record_Type): Call Set_SSO_From_Default
* gnat_rm.texi: Document pragma Default_Scalar_Storage_Order
* lib-writ.adb (Write_ALI): Set OL/OH in P line as needed
* lib-writ.ads: Add OL/OH parameters to P line
* opt.adb: Set Default_SSO, Default_SSO_Config as appropriate
* opt.ads (Default_SSO): New global switch (Default_SSO_Config):
New global switch
* repinfo.adb (List_Scalar_Storage_Order): List SSO when it is
set by default using pragma Default_Scalar_Storage_Order.
* sem.ads (Scope_Stack_Entry): Add component Save_Default_SSO
* sem_ch13.adb (Inherit_Delayed_Rep_Aspects):
Clear SSO defaults when explicit SSO is inherited.
(Analyze_Attribute_Definition_Clause): Clear SSO defaults when
explicit SSO is specified.
(Inherit_Aspects_At_Freeze_Point):
Clear SSO default when inheriting SSO.
* sem_ch3.adb (Set_Default_SSO): New procedure
(Analyze_Private_Extension_Declaration): Set defualt SSO
(Array_Type_Declaration): ditto (Build_Derived_Array_Type): ditto
(Build_Derived_Private_Type): ditto (Build_Derived_Record_Type):
ditto (Build_Derived_Type): ditto (Make_Class_Wide_Type): ditto
(Record_Type_Declaration): ditto
* sem_ch8.adb (Pop_Scope): Restore Default_SSO (Push_Scope):
Save Default_SSO
* sem_prag.adb (Analyze_Pragma, case
Default_Scalar_Storage_Order): Set Default_SSO
-------------- next part --------------
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 213160)
+++ sem_ch3.adb (working copy)
@@ -699,6 +699,11 @@
-- scalar range. Subt provides the parent subtype to be used to analyze,
-- resolve, and check the given range.
+ procedure Set_Default_SSO (T : Entity_Id);
+ -- T is the entity for an array or record being declared. This procedure
+ -- sets the flags SSO_Set_Low_By_Default/SSO_Set_High_By_Default according
+ -- to the setting of Opt.Default_SSO.
+
procedure Signed_Integer_Type_Declaration (T : Entity_Id; Def : Node_Id);
-- Create a new signed integer entity, and apply the constraint to obtain
-- the required first named subtype of this type.
@@ -846,8 +851,7 @@
Set_Ekind
(Anon_Type, E_Anonymous_Access_Protected_Subprogram_Type);
else
- Set_Ekind
- (Anon_Type, E_Anonymous_Access_Subprogram_Type);
+ Set_Ekind (Anon_Type, E_Anonymous_Access_Subprogram_Type);
end if;
Set_Can_Use_Internal_Rep
@@ -4176,6 +4180,7 @@
Set_Scope (T, Current_Scope);
Set_Ekind (T, E_Record_Type_With_Private);
Init_Size_Align (T);
+ Set_Default_SSO (T);
Set_Etype (T, Parent_Base);
Set_Has_Task (T, Has_Task (Parent_Base));
@@ -5154,6 +5159,7 @@
Set_Etype (Implicit_Base, Implicit_Base);
Set_Scope (Implicit_Base, Current_Scope);
Set_Has_Delayed_Freeze (Implicit_Base);
+ Set_Default_SSO (Implicit_Base);
-- The constrained array type is a subtype of the unconstrained one
@@ -5201,6 +5207,7 @@
Is_Controlled (Element_Type));
Set_Finalize_Storage_Only (T, Finalize_Storage_Only
(Element_Type));
+ Set_Default_SSO (T);
end if;
-- Common attributes for both cases
@@ -5680,8 +5687,8 @@
if Nkind (Indic) /= N_Subtype_Indication then
Make_Implicit_Base;
- Set_Ekind (Derived_Type, Ekind (Parent_Type));
- Set_Etype (Derived_Type, Implicit_Base);
+ Set_Ekind (Derived_Type, Ekind (Parent_Type));
+ Set_Etype (Derived_Type, Implicit_Base);
Copy_Array_Subtype_Attributes (Derived_Type, Parent_Type);
else
@@ -6582,6 +6589,7 @@
Set_Ekind (Full_Der, E_Record_Type);
Set_Is_Underlying_Record_View (Full_Der);
+ Set_Default_SSO (Full_Der);
Analyze (Decl);
@@ -7496,6 +7504,7 @@
if Private_Extension then
Type_Def := N;
Set_Ekind (Derived_Type, E_Record_Type_With_Private);
+ Set_Default_SSO (Derived_Type);
else
Type_Def := Type_Definition (N);
@@ -7509,6 +7518,7 @@
if Present (Record_Extension_Part (Type_Def)) then
Set_Ekind (Derived_Type, E_Record_Type);
+ Set_Default_SSO (Derived_Type);
-- Create internal access types for components with anonymous
-- access types.
@@ -7819,7 +7829,6 @@
else
declare
GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type);
-
begin
if Present (GB)
and then GB /= Enclosing_Generic_Body (Parent_Base)
@@ -8472,6 +8481,15 @@
Set_Convention (Derived_Type, Convention (Parent_Base));
+ -- Set SSO default for record or array type
+
+ if (Is_Array_Type (Derived_Type)
+ or else Is_Record_Type (Derived_Type))
+ and then Is_Base_Type (Derived_Type)
+ then
+ Set_Default_SSO (Derived_Type);
+ end if;
+
-- Propagate invariant information. The new type has invariants if
-- they are inherited from the parent type, and these invariants can
-- be further inherited, so both flags are set.
@@ -17087,6 +17105,7 @@
Set_Is_Abstract_Type (CW_Type, False);
Set_Is_Constrained (CW_Type, False);
Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T));
+ Set_Default_SSO (CW_Type);
if Ekind (T) = E_Class_Wide_Subtype then
Set_Etype (CW_Type, Etype (Base_Type (T)));
@@ -20056,6 +20075,7 @@
Init_Size_Align (T);
Set_Interfaces (T, No_Elist);
Set_Stored_Constraint (T, No_Elist);
+ Set_Default_SSO (T);
-- Normal case
@@ -20422,6 +20442,24 @@
end Set_Completion_Referenced;
---------------------
+ -- Set_Default_SSO --
+ ---------------------
+
+ procedure Set_Default_SSO (T : Entity_Id) is
+ begin
+ case Opt.Default_SSO is
+ when ' ' =>
+ null;
+ when 'L' =>
+ Set_SSO_Set_Low_By_Default (T, True);
+ when 'H' =>
+ Set_SSO_Set_High_By_Default (T, True);
+ when others =>
+ raise Program_Error;
+ end case;
+ end Set_Default_SSO;
+
+ ---------------------
-- Set_Fixed_Range --
---------------------
Index: gnat_rm.texi
===================================================================
--- gnat_rm.texi (revision 213160)
+++ gnat_rm.texi (working copy)
@@ -140,6 +140,7 @@
* Pragma CPU::
* Pragma Debug::
* Pragma Debug_Policy::
+* Pragma Default_Scalar_Storage_Order::
* Pragma Default_Storage_Pool::
* Pragma Depends::
* Pragma Detect_Blocking::
@@ -990,6 +991,7 @@
* Pragma CPU::
* Pragma Debug::
* Pragma Debug_Policy::
+* Pragma Default_Scalar_Storage_Order::
* Pragma Default_Storage_Pool::
* Pragma Depends::
* Pragma Detect_Blocking::
@@ -2507,8 +2509,79 @@
with a first argument of @code{Debug}. It is retained for historical
compatibility reasons.
+@node Pragma Default_Scalar_Storage_Order
+@unnumberedsec Pragma Default_Scalar_Storage_Order
+@cindex Default_Scalar_Storage_Order
+@cindex Scalar_Storage_Order
+@findex Default_Scalar_Storage_Order
+@noindent
+Syntax:
+
+@smallexample @c ada
+pragma Default_Scalar_Storage_Order (High_Order_First | Low_Order_First);
+@end smallexample
+
+@noindent
+Normally if no explicit @code{Scalar_Storage_Order} is given for a record
+type or array type, then the scalar storage order defaults to the ordinary
+default for the target. But this default may be overridden using this pragma.
+The pragma may appear as a configuration pragma, or locally within a package
+spec or declarative part. In the latter case, it applies to all subsequent
+types declared within that package spec or declarative part.
+
+If this pragma is used as a configuration pragma which appears within a
+configuration pragma file (as opposed to appearing explicitly at the start
+of a single unit), then the binder will require that all units in a partition
+be compiled in a similar manner, including all units in the run-time that
+are included in the partition.
+
+The following example shows the use of this pragma:
+
+@smallexample @c ada
+pragma Default_Scalar_Storage_Order (High_Order_First);
+with System; use System;
+package DSSO1 is
+ type H1 is record
+ a : Integer;
+ end record;
+
+ type L2 is record
+ a : Integer;
+ end record;
+ for L2'Scalar_Storage_Order use Low_Order_First;
+
+ type L2a is new L2;
+
+ package Inner is
+ type H3 is record
+ a : Integer;
+ end record;
+
+ pragma Default_Scalar_Storage_Order (Low_Order_First);
+
+ type L4 is record
+ a : Integer;
+ end record;
+ end Inner;
+
+ type H4a is new Inner.L4;
+
+ type H5 is record
+ a : Integer;
+ end record;
+end DSSO1;
+@end smallexample
+
+@noindent
+In this example record types L.. have @code{Low_Order_First} scalar
+storage order, and record types H.. have @code{High_Order_First}.
+Note that in the case of @code{H4a}, the order is not inherited
+from the parent type. Only an explicitly set @code{Scalar_Storage_Order}
+gets inherited on type derivation.
+
@node Pragma Default_Storage_Pool
@unnumberedsec Pragma Default_Storage_Pool
+@cindex Default_Storage_Pool
@findex Default_Storage_Pool
@noindent
Syntax:
@@ -9306,7 +9379,9 @@
@noindent
For every array or record type @var{S}, the representation attribute
@code{Scalar_Storage_Order} denotes the order in which storage elements
-that make up scalar components are ordered within S:
+that make up scalar components are ordered within S. The value given must
+be a static expression of type System.Bit_Order. The following is an example
+of the use of this feature:
@smallexample @c ada
-- Component type definitions
@@ -9340,6 +9415,7 @@
-- the former is used.
@end smallexample
+@noindent
Other properties are as for standard representation attribute @code{Bit_Order},
as defined by Ada RM 13.5.3(4). The default is @code{System.Default_Bit_Order}.
@@ -9349,10 +9425,12 @@
clause is not confirming, then the type's @code{Bit_Order} shall be
specified explicitly and set to the same value.
-For a record extension, the derived type shall have the same scalar storage
-order as the parent type.
+Derived types inherit an explicitly set scalar storage order from their parent
+types. This may be overridden for the derived type by giving an explicit scalar
+storage order for the derived type. For a record extension, the derived type
+must have the same scalar storage order as the parent type.
-If a component of @var{S} is of a record or array type, then that type shall
+If a component of @var{S} is of a record or array type, then that type must
also have a @code{Scalar_Storage_Order} attribute definition clause.
A component of a record or array type that is a packed array, or that
@@ -9392,6 +9470,11 @@
@end itemize
+If no scalar storage order is specified for a type (either directly, or by
+inheritance in the case of a derived type), then the default is normally
+the native ordering of the target, but this default can be overridden using
+pragma @code{Default_Scalar_Storage_Order}.
+
@node Attribute Simple_Storage_Pool
@unnumberedsec Attribute Simple_Storage_Pool
@cindex Storage pool, simple
Index: lib-writ.adb
===================================================================
--- lib-writ.adb (revision 213159)
+++ lib-writ.adb (working copy)
@@ -1159,6 +1159,11 @@
Write_Info_Str (" NS");
end if;
+ if Default_SSO_Config /= ' ' then
+ Write_Info_Str (" O");
+ Write_Info_Char (Default_SSO_Config);
+ end if;
+
if Sec_Stack_Used then
Write_Info_Str (" SS");
end if;
Index: lib-writ.ads
===================================================================
--- lib-writ.ads (revision 213156)
+++ lib-writ.ads (working copy)
@@ -220,6 +220,12 @@
-- NS Normalize_Scalars pragma in effect for all units in
-- this file.
+ -- OH Pragma Default_Scalar_Storage_Order (High_Order_First) is
+ -- present in a configuration pragma file that applies.
+
+ -- OL Pragma Default_Scalar_Storage_Order (Low_Order_First) is
+ -- present in a configuration pragma file that applies.
+
-- Qx A valid Queueing_Policy pragma applies to all the units
-- in this file, where x is the first character (upper case)
-- of the policy name (e.g. 'P' for Priority_Queueing).
Index: einfo.adb
===================================================================
--- einfo.adb (revision 213163)
+++ einfo.adb (working copy)
@@ -564,13 +564,13 @@
-- Stores_Attribute_Old_Prefix Flag270
-- (Has_Protected) Flag271
+ -- (SSO_Set_Low_By_Default) Flag272
+ -- (SSO_Set_Low_By_Default) Flag273
-- (unused) Flag1
-- (unused) Flag2
-- (unused) Flag3
- -- (unused) Flag272
- -- (unused) Flag273
-- (unused) Flag274
-- (unused) Flag275
-- (unused) Flag276
@@ -2972,6 +2972,18 @@
return Node19 (Id);
end Spec_Entity;
+ function SSO_Set_High_By_Default (Id : E) return B is
+ begin
+ pragma Assert (Is_Record_Type (Id) or else Is_Array_Type (Id));
+ return Flag273 (Base_Type (Id));
+ end SSO_Set_High_By_Default;
+
+ function SSO_Set_Low_By_Default (Id : E) return B is
+ begin
+ pragma Assert (Is_Record_Type (Id) or else Is_Array_Type (Id));
+ return Flag272 (Base_Type (Id));
+ end SSO_Set_Low_By_Default;
+
function Static_Discrete_Predicate (Id : E) return S is
begin
pragma Assert (Is_Discrete_Type (Id));
@@ -5768,6 +5780,22 @@
Set_Node19 (Id, V);
end Set_Spec_Entity;
+ procedure Set_SSO_Set_High_By_Default (Id : E; V : B := True) is
+ begin
+ pragma Assert
+ (Is_Base_Type (Id)
+ and then (Is_Record_Type (Id) or else Is_Array_Type (Id)));
+ Set_Flag273 (Id, V);
+ end Set_SSO_Set_High_By_Default;
+
+ procedure Set_SSO_Set_Low_By_Default (Id : E; V : B := True) is
+ begin
+ pragma Assert
+ (Is_Base_Type (Id)
+ and then (Is_Record_Type (Id) or else Is_Array_Type (Id)));
+ Set_Flag272 (Id, V);
+ end Set_SSO_Set_Low_By_Default;
+
procedure Set_Static_Discrete_Predicate (Id : E; V : S) is
begin
pragma Assert (Is_Discrete_Type (Id) and then Has_Predicates (Id));
@@ -8448,6 +8476,8 @@
W ("Size_Known_At_Compile_Time", Flag92 (Id));
W ("SPARK_Aux_Pragma_Inherited", Flag266 (Id));
W ("SPARK_Pragma_Inherited", Flag265 (Id));
+ W ("SSO_Set_High_By_Default", Flag273 (Id));
+ W ("SSO_Set_Low_By_Default", Flag272 (Id));
W ("Static_Elaboration_Desired", Flag77 (Id));
W ("Stores_Attribute_Old_Prefix", Flag270 (Id));
W ("Strict_Alignment", Flag145 (Id));
Index: einfo.ads
===================================================================
--- einfo.ads (revision 213162)
+++ einfo.ads (working copy)
@@ -3897,6 +3897,16 @@
-- case where there is a separate spec, where this field references
-- the corresponding parameter entities in the spec.
+-- SSO_Set_High_By_Default (Flag273) [base type only]
+-- Defined for record and array types. Set in the base type if a pragma
+-- Default_Scalar_Storage_Order (High_Order_First) was active at the time
+-- the record or array was declared and therefore applies to it.
+
+-- SSO_Set_Low_By_Default (Flag272) [base type only]
+-- Defined for record and array types. Set in the base type if a pragma
+-- Default_Scalar_Storage_Order (High_Order_First) was active at the time
+-- the record or array was declared and therefore applies to it.
+
-- Static_Discrete_Predicate (List25)
-- Defined in discrete types/subtypes with static predicates (with the
-- two flags Has_Predicates and Has_Static_Predicate set). Set if the
@@ -5367,6 +5377,8 @@
-- Has_Pragma_Pack (Flag121) (impl base type only)
-- Is_Constrained (Flag12)
-- Reverse_Storage_Order (Flag93) (base type only)
+ -- SSO_Set_High_By_Default (Flag273) (base type only)
+ -- SSO_Set_Low_By_Default (Flag272) (base type only)
-- Next_Index (synth)
-- Number_Dimensions (synth)
-- (plus type attributes)
@@ -5392,6 +5404,8 @@
-- First_Entity (Node17)
-- Equivalent_Type (Node18) (always Empty for type)
-- Last_Entity (Node20)
+ -- SSO_Set_High_By_Default (Flag273) (base type only)
+ -- SSO_Set_Low_By_Default (Flag272) (base type only)
-- First_Component (synth)
-- First_Component_Or_Discriminant (synth)
-- (plus type attributes)
@@ -6023,6 +6037,8 @@
-- OK_To_Reorder_Components (Flag239) (base type only)
-- Reverse_Bit_Order (Flag164) (base type only)
-- Reverse_Storage_Order (Flag93) (base type only)
+ -- SSO_Set_High_By_Default (Flag273) (base type only)
+ -- SSO_Set_Low_By_Default (Flag272) (base type only)
-- First_Component (synth)
-- First_Component_Or_Discriminant (synth)
-- (plus type attributes)
@@ -6049,6 +6065,8 @@
-- OK_To_Reorder_Components (Flag239) (base type only)
-- Reverse_Bit_Order (Flag164) (base type only)
-- Reverse_Storage_Order (Flag93) (base type only)
+ -- SSO_Set_High_By_Default (Flag273) (base type only)
+ -- SSO_Set_Low_By_Default (Flag272) (base type only)
-- First_Component (synth)
-- First_Component_Or_Discriminant (synth)
-- (plus type attributes)
@@ -6073,6 +6091,8 @@
-- Component_Type (Node20) (base type only)
-- Static_Real_Or_String_Predicate (Node25)
-- Is_Constrained (Flag12)
+ -- SSO_Set_High_By_Default (Flag273) (base type only)
+ -- SSO_Set_Low_By_Default (Flag272) (base type only)
-- Next_Index (synth)
-- Number_Dimensions (synth)
-- (plus type attributes)
@@ -6812,6 +6832,8 @@
function SPARK_Pragma (Id : E) return N;
function SPARK_Pragma_Inherited (Id : E) return B;
function Spec_Entity (Id : E) return E;
+ function SSO_Set_High_By_Default (Id : E) return B;
+ function SSO_Set_Low_By_Default (Id : E) return B;
function Static_Elaboration_Desired (Id : E) return B;
function Static_Initialization (Id : E) return N;
function Static_Discrete_Predicate (Id : E) return S;
@@ -7447,6 +7469,8 @@
procedure Set_SPARK_Pragma (Id : E; V : N);
procedure Set_SPARK_Pragma_Inherited (Id : E; V : B := True);
procedure Set_Spec_Entity (Id : E; V : E);
+ procedure Set_SSO_Set_High_By_Default (Id : E; V : B := True);
+ procedure Set_SSO_Set_Low_By_Default (Id : E; V : B := True);
procedure Set_Static_Elaboration_Desired (Id : E; V : B);
procedure Set_Static_Initialization (Id : E; V : N);
procedure Set_Static_Discrete_Predicate (Id : E; V : S);
@@ -8232,6 +8256,8 @@
pragma Inline (SPARK_Pragma);
pragma Inline (SPARK_Pragma_Inherited);
pragma Inline (Spec_Entity);
+ pragma Inline (SSO_Set_High_By_Default);
+ pragma Inline (SSO_Set_Low_By_Default);
pragma Inline (Static_Elaboration_Desired);
pragma Inline (Static_Initialization);
pragma Inline (Static_Discrete_Predicate);
@@ -8666,6 +8692,8 @@
pragma Inline (Set_SPARK_Pragma);
pragma Inline (Set_SPARK_Pragma_Inherited);
pragma Inline (Set_Spec_Entity);
+ pragma Inline (Set_SSO_Set_High_By_Default);
+ pragma Inline (Set_SSO_Set_Low_By_Default);
pragma Inline (Set_Static_Elaboration_Desired);
pragma Inline (Set_Static_Initialization);
pragma Inline (Set_Static_Discrete_Predicate);
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 213160)
+++ sem_prag.adb (working copy)
@@ -13176,7 +13176,10 @@
-- pragma Default_Scalar_Storage_Order
-- (High_Order_First | Low_Order_First);
- when Pragma_Default_Scalar_Storage_Order =>
+ when Pragma_Default_Scalar_Storage_Order => DSSO : declare
+ Default : Character;
+
+ begin
GNAT_Pragma;
Check_Arg_Count (1);
@@ -13189,8 +13192,28 @@
Check_No_Identifiers;
Check_Arg_Is_One_Of
- (Arg1, Name_Low_Order_First, Name_High_Order_First);
+ (Arg1, Name_High_Order_First, Name_Low_Order_First);
+ Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
+ Default := Fold_Upper (Name_Buffer (1));
+ if not Support_Nondefault_SSO_On_Target
+ and then (Ttypes.Bytes_Big_Endian /= (Default = 'H'))
+ then
+ if Warn_On_Unrecognized_Pragma then
+ Error_Msg_N
+ ("non-default Scalar_Storage_Order not supported "
+ & "on target?g?", N);
+ Error_Msg_N
+ ("\pragma Default_Scalar_Storage_Order ignored?g?", N);
+ end if;
+
+ -- Here set the specified default
+
+ else
+ Opt.Default_SSO := Default;
+ end if;
+ end DSSO;
+
--------------------------
-- Default_Storage_Pool --
--------------------------
Index: sem.ads
===================================================================
--- sem.ads (revision 213160)
+++ sem.ads (working copy)
@@ -486,6 +486,9 @@
Save_SPARK_Mode_Pragma : Node_Id;
-- Setting of SPARK_Mode_Pragma on entry to restore on exit
+ Save_Default_SSO : Character;
+ -- Setting of Default_SSO on entry to restore on exit
+
Save_Uneval_Old : Character;
-- Setting of Uneval_Old on entry to restore on exit
Index: freeze.adb
===================================================================
--- freeze.adb (revision 213165)
+++ freeze.adb (working copy)
@@ -180,6 +180,14 @@
-- the flag if Debug_Info_Off is set. This procedure also ensures that
-- subsidiary entities have the flag set as required.
+ procedure Set_SSO_From_Default (T : Entity_Id);
+ -- T is a record or array type that is being frozen. If it is a base type,
+ -- and if SSO_Set_Low/High_By_Default is set, then Reverse_Storage order
+ -- will be set appropriately. Note that an explicit occurrence of aspect
+ -- Scalar_Storage_Order or an explicit setting of this aspect with an
+ -- attribute definition clause occurs, then these two flags are reset in
+ -- any case, so call will have no effect.
+
procedure Undelay_Type (T : Entity_Id);
-- T is a type of a component that we know to be an Itype. We don't want
-- this to have a Freeze_Node, so ensure it doesn't. Do the same for any
@@ -2074,8 +2082,12 @@
-- Processing that is done only for base types
- if Ekind (Arr) = E_Array_Type then
+ if Ekind (Arr) = E_Array_Type then -- what about E_String_Type ???
+ -- Deal with default setting of reverse storage order
+
+ Set_SSO_From_Default (Arr);
+
-- Propagate flags for component type
if Is_Controlled (Component_Type (Arr))
@@ -3091,6 +3103,12 @@
end loop;
end;
+ -- Deal with default setting of reverse storage order
+
+ Set_SSO_From_Default (Rec);
+
+ -- Now deal with reverse storage order/bit order issues
+
if Present (SSO_ADC) then
-- Check compatibility of Scalar_Storage_Order with Bit_Order, if
@@ -4692,12 +4710,11 @@
then
Freeze_Record_Type (E);
- -- For a concurrent type, freeze corresponding record type. This
- -- does not correspond to any specific rule in the RM, but the
- -- record type is essentially part of the concurrent type.
- -- Freeze as well all local entities. This includes record types
- -- created for entry parameter blocks, and whatever local entities
- -- may appear in the private part.
+ -- For a concurrent type, freeze corresponding record type. This does
+ -- not correspond to any specific rule in the RM, but the record type
+ -- is essentially part of the concurrent type. Also freeze all local
+ -- entities. This includes record types created for entry parameter
+ -- blocks and whatever local entities may appear in the private part.
elsif Is_Concurrent_Type (E) then
if Present (Corresponding_Record_Type (E)) then
@@ -7174,6 +7191,29 @@
end if;
end Set_Component_Alignment_If_Not_Set;
+ --------------------------
+ -- Set_SSO_From_Default --
+ --------------------------
+
+ procedure Set_SSO_From_Default (T : Entity_Id) is
+ begin
+ if (Is_Record_Type (T) or else Is_Array_Type (T))
+ and then Is_Base_Type (T)
+ then
+ if (Bytes_Big_Endian and then SSO_Set_Low_By_Default (T))
+ or else
+ ((not Bytes_Big_Endian) and then SSO_Set_High_By_Default (T))
+ then
+ -- If flags cause reverse storage order, then set the result. Note
+ -- that we would have ignored the pragma setting the non default
+ -- storage order in any case, hence the assertion at this point.
+
+ pragma Assert (Support_Nondefault_SSO_On_Target);
+ Set_Reverse_Storage_Order (T);
+ end if;
+ end if;
+ end Set_SSO_From_Default;
+
------------------
-- Undelay_Type --
------------------
Index: repinfo.adb
===================================================================
--- repinfo.adb (revision 213156)
+++ repinfo.adb (working copy)
@@ -1092,10 +1092,14 @@
-- Start of processing for List_Scalar_Storage_Order
begin
- if Has_Rep_Item (Ent, Name_Scalar_Storage_Order) then
+ -- List info if set explicitly or by use of Default_Scalar_Storage_Order
- -- For a record type with explicitly specified scalar storage order,
- -- also display explicit Bit_Order.
+ if Has_Rep_Item (Ent, Name_Scalar_Storage_Order)
+ or else SSO_Set_Low_By_Default (Ent)
+ or else SSO_Set_High_By_Default (Ent)
+ then
+ -- For a record type with specified scalar storage order, also
+ -- display explicit Bit_Order.
if Is_Record_Type (Ent) then
List_Attr ("Bit_Order");
Index: ali.adb
===================================================================
--- ali.adb (revision 213156)
+++ ali.adb (working copy)
@@ -115,6 +115,7 @@
Normalize_Scalars_Specified := False;
Partition_Elaboration_Policy_Specified := ' ';
Queuing_Policy_Specified := ' ';
+ SSO_Default_Specified := False;
Static_Elaboration_Model_Used := False;
Task_Dispatching_Policy_Specified := ' ';
Unreserve_All_Interrupts_Specified := False;
@@ -892,6 +893,7 @@
Restrictions => No_Restrictions,
SAL_Interface => False,
Sfile => No_File,
+ SSO_Default => ' ',
Task_Dispatching_Policy => ' ',
Time_Slice_Value => -1,
WC_Encoding => 'b',
@@ -1131,6 +1133,19 @@
Fatal_Error_Ignore;
end if;
+ -- Processing for OH/OL
+
+ elsif C = 'O' then
+ C := Getc;
+
+ if C = 'L' or else C = 'H' then
+ ALIs.Table (Id).SSO_Default := C;
+ SSO_Default_Specified := True;
+
+ else
+ Fatal_Error_Ignore;
+ end if;
+
-- Processing for Qx
elsif C = 'Q' then
Index: ali.ads
===================================================================
--- ali.ads (revision 213156)
+++ ali.ads (working copy)
@@ -188,6 +188,12 @@
-- Set to True if file was compiled with Normalize_Scalars. Not set if
-- 'P' appears in Ignore_Lines.
+ SSO_Default : Character;
+ -- Set to 'H' or 'L' if file was compiled with a configuration pragma
+ -- file containing Default_Scalar_Storage_Order (High/Low_Order_First).
+ -- Set to ' ' if neither pragma was present. Not set if 'P' appears in
+ -- Ignore_Lines.
+
Unit_Exception_Table : Boolean;
-- Set to True if unit exception table pointer generated. Not set if 'P'
-- appears in Ignore_Lines.
@@ -501,6 +507,11 @@
-- ali files, showing whether a restriction pragma exists anywhere, and
-- accumulating the aggregate knowledge of violations.
+ SSO_Default_Specified : Boolean := False;
+ -- Set to True if at least one ALI file contains an OH/OL flag indicating
+ -- that it was compiled with a configuration pragmas file containing the
+ -- pragma Default_Scalar_Storage_Order (OH/OL present in ALI file P line).
+
Stack_Check_Switch_Set : Boolean := False;
-- Set to True if at least one ALI file contains '-fstack-check' in its
-- argument list.
Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb (revision 213160)
+++ sem_ch8.adb (working copy)
@@ -7533,6 +7533,7 @@
Default_Pool := SST.Save_Default_Storage_Pool;
SPARK_Mode := SST.Save_SPARK_Mode;
SPARK_Mode_Pragma := SST.Save_SPARK_Mode_Pragma;
+ Default_SSO := SST.Save_Default_SSO;
Uneval_Old := SST.Save_Uneval_Old;
if Debug_Flag_W then
@@ -7606,6 +7607,7 @@
SST.Save_Default_Storage_Pool := Default_Pool;
SST.Save_SPARK_Mode := SPARK_Mode;
SST.Save_SPARK_Mode_Pragma := SPARK_Mode_Pragma;
+ SST.Save_Default_SSO := Default_SSO;
SST.Save_Uneval_Old := Uneval_Old;
if Scope_Stack.Last > Scope_Stack.First then
Index: opt.adb
===================================================================
--- opt.adb (revision 213160)
+++ opt.adb (working copy)
@@ -52,6 +52,7 @@
Check_Float_Overflow_Config := Check_Float_Overflow;
Check_Policy_List_Config := Check_Policy_List;
Default_Pool_Config := Default_Pool;
+ Default_SSO_Config := Default_SSO;
Dynamic_Elaboration_Checks_Config := Dynamic_Elaboration_Checks;
Exception_Locations_Suppressed_Config := Exception_Locations_Suppressed;
Extensions_Allowed_Config := Extensions_Allowed;
@@ -90,6 +91,7 @@
Check_Float_Overflow := Save.Check_Float_Overflow;
Check_Policy_List := Save.Check_Policy_List;
Default_Pool := Save.Default_Pool;
+ Default_SSO := Save.Default_SSO;
Dynamic_Elaboration_Checks := Save.Dynamic_Elaboration_Checks;
Exception_Locations_Suppressed := Save.Exception_Locations_Suppressed;
Extensions_Allowed := Save.Extensions_Allowed;
@@ -130,6 +132,7 @@
Save.Check_Float_Overflow := Check_Float_Overflow;
Save.Check_Policy_List := Check_Policy_List;
Save.Default_Pool := Default_Pool;
+ Save.Default_SSO := Default_SSO;
Save.Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks;
Save.Exception_Locations_Suppressed := Exception_Locations_Suppressed;
Save.Extensions_Allowed := Extensions_Allowed;
@@ -190,6 +193,7 @@
Assertions_Enabled := Assertions_Enabled_Config;
Assume_No_Invalid_Values := Assume_No_Invalid_Values_Config;
Check_Policy_List := Check_Policy_List_Config;
+ Default_SSO := Default_SSO_Config;
SPARK_Mode := SPARK_Mode_Config;
SPARK_Mode_Pragma := SPARK_Mode_Pragma_Config;
else
@@ -210,6 +214,7 @@
Assume_No_Invalid_Values := Assume_No_Invalid_Values_Config;
Check_Float_Overflow := Check_Float_Overflow_Config;
Check_Policy_List := Check_Policy_List_Config;
+ Default_SSO := Default_SSO_Config;
Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks_Config;
Extensions_Allowed := Extensions_Allowed_Config;
External_Name_Exp_Casing := External_Name_Exp_Casing_Config;
Index: opt.ads
===================================================================
--- opt.ads (revision 213160)
+++ opt.ads (working copy)
@@ -418,17 +418,26 @@
-- to trigger the activation of the remote debugging interface.
-- Is this still true ???
+ Default_Exit_Status : Int := 0;
+ -- GNATBIND
+ -- Set the default exit status value. Set by the -Xnnn switch for the
+ -- binder.
+
Debug_Generated_Code : Boolean := False;
-- GNAT
-- Set True (-gnatD switch) to debug generated expanded code instead
-- of the original source code. Causes debugging information to be
-- written with respect to the generated code file that is written.
- Default_Exit_Status : Int := 0;
- -- GNATBIND
- -- Set the default exit status value. Set by the -Xnnn switch for the
- -- binder.
-
+ Default_Pool : Node_Id := Empty;
+ -- GNAT
+ -- Used to record the storage pool name (or null literal) that is the
+ -- argument of an applicable pragma Default_Storage_Pool.
+ -- Empty: No pragma Default_Storage_Pool applies.
+ -- N_Null node: "pragma Default_Storage_Pool (null);" applies.
+ -- otherwise: "pragma Default_Storage_Pool (X);" applies, and
+ -- this points to the name X.
+ -- Push_Scope and Pop_Scope in Sem_Ch8 save and restore this value.
Default_Stack_Size : Int := -1;
-- GNATBIND
-- Set to default primary stack size in units of bytes. Set by
@@ -442,15 +451,11 @@
-- default was set by the binder, and that the default should be the
-- initial value of System.Secondary_Stack.Default_Secondary_Stack_Size.
- Default_Pool : Node_Id := Empty;
+ Default_SSO : Character := ' ';
-- GNAT
- -- Used to record the storage pool name (or null literal) that is the
- -- argument of an applicable pragma Default_Storage_Pool.
- -- Empty: No pragma Default_Storage_Pool applies.
- -- N_Null node: "pragma Default_Storage_Pool (null);" applies.
- -- otherwise: "pragma Default_Storage_Pool (X);" applies, and
- -- this points to the name X.
- -- Push_Scope and Pop_Scope in Sem_Ch8 save and restore this value.
+ -- Set if a pragma Default_Scalar_Storage_Order has been given. The value
+ -- of ' ' indicates that no default has been set, otherwise the value is
+ -- either 'H' for High_Order_First or 'L' for Lower_Order_First.
Detect_Blocking : Boolean := False;
-- GNAT
@@ -1809,7 +1814,8 @@
-- These are settings that are used to establish the mode at the start of
-- each unit. The values defined below can be affected either by command
-- line switches, or by the use of appropriate configuration pragmas in a
- -- configuration pragma file.
+ -- configuration pragma file (but NOT by a local use of a configuration
+ -- pragma in a single file).
Ada_Version_Config : Ada_Version_Type;
-- GNAT
@@ -1863,6 +1869,12 @@
-- Same as Default_Pool above, except this is only for Default_Storage_Pool
-- pragmas that are configuration pragmas.
+ Default_SSO_Config : Character := ' ';
+ -- GNAT
+ -- Set if a pragma Default_Scalar_Storage_Order appears as a configuration
+ -- pragma. A value of ' ' means that no pragma was given, otherwise the
+ -- value is 'H' for High_Order_First or 'L' for Low_Order_First.
+
Dynamic_Elaboration_Checks_Config : Boolean := False;
-- GNAT
-- Set True for dynamic elaboration checking mode, as set by the -gnatE
@@ -2116,6 +2128,7 @@
Check_Float_Overflow : Boolean;
Check_Policy_List : Node_Id;
Default_Pool : Node_Id;
+ Default_SSO : Character;
Dynamic_Elaboration_Checks : Boolean;
Exception_Locations_Suppressed : Boolean;
Extensions_Allowed : Boolean;
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 213162)
+++ sem_ch13.adb (working copy)
@@ -932,6 +932,12 @@
and then Reverse_Storage_Order (P)
then
Set_Reverse_Storage_Order (Base_Type (E));
+
+ -- Clear default SSO indications, since the aspect
+ -- overrides the default.
+
+ Set_SSO_Set_Low_By_Default (Base_Type (E), False);
+ Set_SSO_Set_High_By_Default (Base_Type (E), False);
end if;
-- Small
@@ -3272,6 +3278,18 @@
Typ := Etype (F);
+ -- If the attribute specification comes from an aspect
+ -- specification for a class-wide stream, the parameter
+ -- must be a class-wide type of the entity to which the
+ -- aspect applies.
+
+ if From_Aspect_Specification (N)
+ and then Class_Present (Parent (N))
+ and then Is_Class_Wide_Type (Typ)
+ then
+ Typ := Etype (Typ);
+ end if;
+
else
Typ := Etype (Subp);
end if;
@@ -4758,6 +4776,12 @@
& "not supported on target", Expr);
end if;
end if;
+
+ -- Clear SSO default indications since explicit setting of the
+ -- order overrides the defaults.
+
+ Set_SSO_Set_Low_By_Default (Base_Type (U_Ent), False);
+ Set_SSO_Set_High_By_Default (Base_Type (U_Ent), False);
end if;
end Scalar_Storage_Order;
@@ -10311,6 +10335,12 @@
Set_Reverse_Storage_Order (Bas_Typ,
Reverse_Storage_Order (Entity (Name
(Get_Rep_Item (Typ, Name_Scalar_Storage_Order)))));
+
+ -- Clear default SSO indications, since the inherited aspect
+ -- which was set explicitly overrides the default.
+
+ Set_SSO_Set_Low_By_Default (Bas_Typ, False);
+ Set_SSO_Set_High_By_Default (Bas_Typ, False);
end if;
end if;
end;
Index: bcheck.adb
===================================================================
--- bcheck.adb (revision 213156)
+++ bcheck.adb (working copy)
@@ -56,6 +56,7 @@
procedure Check_Consistent_Queuing_Policy;
procedure Check_Consistent_Restrictions;
procedure Check_Consistent_Restriction_No_Default_Initialization;
+ procedure Check_Consistent_SSO_Default;
procedure Check_Consistent_Zero_Cost_Exception_Handling;
procedure Consistency_Error_Msg (Msg : String);
@@ -88,6 +89,10 @@
Check_Consistent_Partition_Elaboration_Policy;
end if;
+ if SSO_Default_Specified then
+ Check_Consistent_SSO_Default;
+ end if;
+
if Zero_Cost_Exceptions_Specified then
Check_Consistent_Zero_Cost_Exception_Handling;
end if;
@@ -1108,6 +1113,73 @@
end loop;
end Check_Consistent_Restriction_No_Default_Initialization;
+ ----------------------------------
+ -- Check_Consistent_SSO_Default --
+ ----------------------------------
+
+ procedure Check_Consistent_SSO_Default is
+ Default : Character;
+
+ begin
+ Default := ALIs.Table (ALIs.First).SSO_Default;
+
+ -- Check all entries match the default above from the first entry
+
+ for A1 in ALIs.First + 1 .. ALIs.Last loop
+ if ALIs.Table (A1).SSO_Default /= Default then
+ Default := '?';
+ exit;
+ end if;
+ end loop;
+
+ -- All match, return
+
+ if Default /= '?' then
+ return;
+ end if;
+
+ -- Here we have a mismatch
+
+ Consistency_Error_Msg
+ ("files not compiled with same Default_Scalar_Storage_Order");
+
+ Write_Eol;
+ Write_Str ("files compiled with High_Order_First");
+ Write_Eol;
+
+ for A1 in ALIs.First .. ALIs.Last loop
+ if ALIs.Table (A1).SSO_Default = 'H' then
+ Write_Str (" ");
+ Write_Name (ALIs.Table (A1).Sfile);
+ Write_Eol;
+ end if;
+ end loop;
+
+ Write_Eol;
+ Write_Str ("files compiled with Low_Order_First");
+ Write_Eol;
+
+ for A1 in ALIs.First .. ALIs.Last loop
+ if ALIs.Table (A1).SSO_Default = 'L' then
+ Write_Str (" ");
+ Write_Name (ALIs.Table (A1).Sfile);
+ Write_Eol;
+ end if;
+ end loop;
+
+ Write_Eol;
+ Write_Str ("files compiled with no Default_Scalar_Storage_Order");
+ Write_Eol;
+
+ for A1 in ALIs.First .. ALIs.Last loop
+ if ALIs.Table (A1).SSO_Default = ' ' then
+ Write_Str (" ");
+ Write_Name (ALIs.Table (A1).Sfile);
+ Write_Eol;
+ end if;
+ end loop;
+ end Check_Consistent_SSO_Default;
+
---------------------------------------------------
-- Check_Consistent_Zero_Cost_Exception_Handling --
---------------------------------------------------
More information about the Gcc-patches
mailing list