mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-18 11:20:51 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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

2014-07-29  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Valid_Operator_Definition): Verify that
	all parameter have mode IN. This check must be done here for
	subprogram instantiations that have operator names, because their
	analysis does not follow the same path as that for subprogram
	declarations.

From-SVN: r213167
This commit is contained in:
Arnaud Charlet 2014-07-29 15:16:09 +02:00
parent a08bf2de29
commit 220d1fd9df
19 changed files with 507 additions and 37 deletions

53
gcc/ada/ChangeLog

@ -1,3 +1,56 @@
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
2014-07-29 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Valid_Operator_Definition): Verify that
all parameter have mode IN. This check must be done here for
subprogram instantiations that have operator names, because their
analysis does not follow the same path as that for subprogram
declarations.
2014-07-29 Robert Dewar <dewar@adacore.com>
* freeze.adb (Freeze_Entity, Concurrent_Type case): Add a guard

15
gcc/ada/ali.adb

@ -115,6 +115,7 @@ package body ALI is
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 @@ package body ALI is
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 @@ package body ALI is
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

11
gcc/ada/ali.ads

@ -188,6 +188,12 @@ package ALI is
-- 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 @@ package ALI is
-- 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.

72
gcc/ada/bcheck.adb

@ -56,6 +56,7 @@ package body Bcheck is
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 @@ package body Bcheck is
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 @@ package body Bcheck is
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 --
---------------------------------------------------

34
gcc/ada/einfo.adb

@ -564,13 +564,13 @@ package body Einfo is
-- 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 @@ package body Einfo is
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 @@ package body Einfo is
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 @@ package body Einfo is
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));

28
gcc/ada/einfo.ads

@ -3897,6 +3897,16 @@ package Einfo is
-- 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 @@ package Einfo is
-- 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 @@ package Einfo is
-- 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 @@ package Einfo is
-- 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 @@ package Einfo is
-- 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 @@ package Einfo is
-- 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 @@ package Einfo is
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 @@ package Einfo is
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 @@ package Einfo is
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 @@ package Einfo is
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);

54
gcc/ada/freeze.adb

@ -180,6 +180,14 @@ package body Freeze is
-- 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,7 +2082,11 @@ package body Freeze is
-- 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
@ -3091,6 +3103,12 @@ package body Freeze is
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 @@ package body Freeze is
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 @@ package body Freeze is
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 --
------------------

91
gcc/ada/gnat_rm.texi

@ -140,6 +140,7 @@ Implementation Defined Pragmas
* 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 @@ consideration, the use of these pragmas should be minimized.
* 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 @@ This pragma is equivalent to a corresponding @code{Check_Policy} pragma
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 @@ this attribute.
@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 @@ that make up scalar components are ordered within S:
-- 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 @@ this means that if a @code{Scalar_Storage_Order} attribute definition
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 @@ are relaxed. Instead, the following rules apply:
@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

5
gcc/ada/lib-writ.adb

@ -1159,6 +1159,11 @@ package body Lib.Writ is
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;

6
gcc/ada/lib-writ.ads

@ -220,6 +220,12 @@ package Lib.Writ is
-- 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).

5
gcc/ada/opt.adb

@ -52,6 +52,7 @@ package body Opt is
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 @@ package body Opt is
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 @@ package body Opt is
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 @@ package body Opt is
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 @@ package body Opt is
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;

41
gcc/ada/opt.ads

@ -418,17 +418,26 @@ package Opt is
-- 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 @@ package Opt is
-- 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 @@ package Opt is
-- 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 @@ package Opt is
-- 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 @@ private
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;

10
gcc/ada/repinfo.adb

@ -1092,10 +1092,14 @@ package body Repinfo is
-- 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");

3
gcc/ada/sem.ads

@ -486,6 +486,9 @@ package Sem is
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

30
gcc/ada/sem_ch13.adb

@ -932,6 +932,12 @@ package body Sem_Ch13 is
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 @@ package body Sem_Ch13 is
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 @@ package body Sem_Ch13 is
& "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 @@ package body Sem_Ch13 is
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;

48
gcc/ada/sem_ch3.adb

@ -699,6 +699,11 @@ package body Sem_Ch3 is
-- 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 @@ package body Sem_Ch3 is
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 @@ package body Sem_Ch3 is
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 @@ package body Sem_Ch3 is
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 @@ package body Sem_Ch3 is
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 @@ package body Sem_Ch3 is
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 @@ package body Sem_Ch3 is
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 @@ package body Sem_Ch3 is
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 @@ package body Sem_Ch3 is
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 @@ package body Sem_Ch3 is
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 @@ package body Sem_Ch3 is
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 @@ package body Sem_Ch3 is
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 @@ package body Sem_Ch3 is
Init_Size_Align (T);
Set_Interfaces (T, No_Elist);
Set_Stored_Constraint (T, No_Elist);
Set_Default_SSO (T);
-- Normal case
@ -20421,6 +20441,24 @@ package body Sem_Ch3 is
end if;
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 --
---------------------

9
gcc/ada/sem_ch6.adb

@ -12017,6 +12017,15 @@ package body Sem_Ch6 is
Error_Msg_N
("default values not allowed for operator parameters",
Parent (F));
-- For function instantiations that are operators, we must check
-- separately that the corresponding generic only has in-parameters.
-- For subprogram declarations this is done in Set_Formal_Mode.
-- Such an error could not arise in earlier versions of the language.
elsif Ekind (F) /= E_In_Parameter then
Error_Msg_N
("operators can only have IN parameters", F);
end if;
Next_Formal (F);

2
gcc/ada/sem_ch8.adb

@ -7533,6 +7533,7 @@ package body Sem_Ch8 is
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 @@ package body Sem_Ch8 is
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

27
gcc/ada/sem_prag.adb

@ -13176,7 +13176,10 @@ package body Sem_Prag is
-- 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,7 +13192,27 @@ package body Sem_Prag is
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 --