+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
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;
Restrictions => No_Restrictions,
SAL_Interface => False,
Sfile => No_File,
+ SSO_Default => ' ',
Task_Dispatching_Policy => ' ',
Time_Slice_Value => -1,
WC_Encoding => 'b',
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
-- 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.
-- 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.
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);
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;
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 --
---------------------------------------------------
-- 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
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));
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));
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));
-- 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
-- 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)
-- 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)
-- 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)
-- 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)
-- 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)
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;
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);
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);
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);
-- 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
-- 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
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
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
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 --
------------------
* Pragma CPU::
* Pragma Debug::
* Pragma Debug_Policy::
+* Pragma Default_Scalar_Storage_Order::
* Pragma Default_Storage_Pool::
* Pragma Depends::
* Pragma Detect_Blocking::
* Pragma CPU::
* Pragma Debug::
* Pragma Debug_Policy::
+* Pragma Default_Scalar_Storage_Order::
* Pragma Default_Storage_Pool::
* Pragma Depends::
* Pragma Detect_Blocking::
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:
@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
-- 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}.
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
@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
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;
-- 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).
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;
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;
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;
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
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;
-- 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
-- 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
-- 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
-- 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
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;
-- 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");
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
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
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;
& "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;
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;
-- 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.
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
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));
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
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
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
Set_Ekind (Full_Der, E_Record_Type);
Set_Is_Underlying_Record_View (Full_Der);
+ Set_Default_SSO (Full_Der);
Analyze (Decl);
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);
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.
else
declare
GB : constant Node_Id := Enclosing_Generic_Body (Derived_Type);
-
begin
if Present (GB)
and then GB /= Enclosing_Generic_Body (Parent_Base)
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.
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)));
Init_Size_Align (T);
Set_Interfaces (T, No_Elist);
Set_Stored_Constraint (T, No_Elist);
+ Set_Default_SSO (T);
-- Normal case
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 --
---------------------
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);
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
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
-- 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);
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 --
projects / gcc.git / commitdiff