+2017-09-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * ali.ads (ALIs_Record): Add No_Component_Reordering component.
+ (No_Component_Reordering_Specified): New switch.
+ * ali.adb (Initialize_ALI): Set No_Component_Reordering_Specified.
+ (Scan_ALI): Set No_Component_Reordering and deal with NC marker.
+ * bcheck.adb (Check_Consistent_No_Component_Reordering):
+ New check.
+ (Check_Configuration_Consistency): Invoke it.
+ * debug.adb (d.r): Toggle the effect of the switch.
+ (d.v): Change to no-op.
+ * einfo.ads (Has_Complex_Representation):
+ Restrict to record types.
+ (No_Reordering): New alias for Flag239.
+ (OK_To_Reorder_Components): Delete.
+ (No_Reordering): Declare.
+ (Set_No_Reordering): Likewise.
+ (OK_To_Reorder_Components): Delete.
+ (Set_OK_To_Reorder_Components): Likewise.
+ * einfo.adb (Has_Complex_Representation): Expect record types.
+ (No_Reordering): New function.
+ (OK_To_Reorder_Components): Delete.
+ (Set_Has_Complex_Representation): Expect base record types.
+ (Set_No_Reordering): New procedure.
+ (Set_OK_To_Reorder_Components): Delete.
+ (Write_Entity_Flags): Adjust to above change.
+ * fe.h (Debug_Flag_Dot_R): New macro and declaration.
+ * freeze.adb (Freeze_Record_Type): Remove conditional code setting
+ OK_To_Reorder_Components on record types with convention Ada.
+ * lib-writ.adb (Write_ALI): Deal with NC marker.
+ * opt.ads (No_Component_Reordering): New flag.
+ (No_Component_Reordering_Config): Likewise.
+ (Config_Switches_Type): Add No_Component_Reordering component.
+ * opt.adb (Register_Opt_Config_Switches): Copy
+ No_Component_Reordering onto No_Component_Reordering_Config.
+ (Restore_Opt_Config_Switches): Restore No_Component_Reordering.
+ (Save_Opt_Config_Switches): Save No_Component_Reordering.
+ (Set_Opt_Config_Switches): Set No_Component_Reordering.
+ * par-prag.adb (Prag): Deal with Pragma_No_Component_Reordering.
+ * sem_ch3.adb (Analyze_Private_Extension_Declaration): Also set the
+ No_Reordering flag from the default.
+ (Build_Derived_Private_Type): Likewise.
+ (Build_Derived_Record_Type): Likewise. Then inherit it
+ for untagged types and clean up handling of similar flags.
+ (Record_Type_Declaration): Likewise.
+ * sem_ch13.adb (Same_Representation): Deal with No_Reordering and
+ remove redundant test on Is_Tagged_Type.
+ * sem_prag.adb (Analyze_Pragma): Handle No_Component_Reordering.
+ (Sig_Flags): Likewise.
+ * snames.ads-tmpl (Name_No_Component_Reordering): New name.
+ (Pragma_Id): Add Pragma_No_Component_Reordering value.
+ * warnsw.adb (Set_GNAT_Mode_Warnings): Enable -gnatw.q as well.
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Record_Type>:
+ Copy the layout of the parent type only if the No_Reordering
+ settings match.
+ (components_to_record): Reorder record types with
+ convention Ada by default unless No_Reordering is set or -gnatd.r
+ is specified and do not warn if No_Reordering is set in GNAT mode.
+
+2017-09-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Check_Previous_Null_Procedure):
+ new predicate to reject declarations that can be completions,
+ when there is a visible prior homograph that is a null procedure.
+ * sem_ch6.adb (Analyze_Null_Procedure): use it.
+ * sem_ch8.adb (Analyze_Subprogram_Renaming): ditto.
+
+2017-09-06 Thomas Quinot <quinot@adacore.com>
+
+ * s-regpat.adb (Compile.Parse_Literal): Fix handling of literal
+ run of 253 characters or more.
+
2017-09-06 Ed Schonberg <schonberg@adacore.com>
* einfo.adb (Designated_Type): Use Is_Incomplete_Type to handle
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Locking_Policy_Specified := ' ';
No_Normalize_Scalars_Specified := False;
No_Object_Specified := False;
+ No_Component_Reordering_Specified := False;
GNATprove_Mode_Specified := False;
Normalize_Scalars_Specified := False;
Partition_Elaboration_Policy_Specified := ' ';
Main_Priority => -1,
Main_CPU => -1,
Main_Program => None,
+ No_Component_Reordering => False,
No_Object => False,
Normalize_Scalars => False,
Ofile_Full_Name => Full_Object_File_Name,
elsif C = 'N' then
C := Getc;
+ -- Processing for NC
+
+ if C = 'C' then
+ ALIs.Table (Id).No_Component_Reordering := True;
+ No_Component_Reordering_Specified := True;
+
-- Processing for NO
- if C = 'O' then
+ elsif C = 'O' then
ALIs.Table (Id).No_Object := True;
No_Object_Specified := True;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- signalled by GP appearing on the P line. Not set if 'P' appears in
-- Ignore_Lines.
+ No_Component_Reordering : Boolean;
+ -- Set to True if file was compiled with a configuration pragma file
+ -- containing pragma No_Component_Reordering. Not set if 'P' appears
+ -- in Ignore_Lines.
+
No_Object : Boolean;
-- Set to True if no object file generated. Not set if 'P' appears in
-- Ignore_Lines.
-- Set to False by Initialize_ALI. Set to True if an ali file indicates
-- that the file was compiled without normalize scalars.
+ No_Component_Reordering_Specified : Boolean := False;
+ -- Set to False by Initialize_ALI. Set to True if an ali file contains
+ -- the No_Component_Reordering flag.
+
No_Object_Specified : Boolean := False;
-- Set to False by Initialize_ALI. Set to True if an ali file contains
-- the No_Object flag.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Check_Consistent_Dynamic_Elaboration_Checking;
procedure Check_Consistent_Interrupt_States;
procedure Check_Consistent_Locking_Policy;
+ procedure Check_Consistent_No_Component_Reordering;
procedure Check_Consistent_Normalize_Scalars;
procedure Check_Consistent_Optimize_Alignment;
procedure Check_Consistent_Partition_Elaboration_Policy;
Check_Consistent_Locking_Policy;
end if;
+ if No_Component_Reordering_Specified then
+ Check_Consistent_No_Component_Reordering;
+ end if;
+
if Partition_Elaboration_Policy_Specified /= ' ' then
Check_Consistent_Partition_Elaboration_Policy;
end if;
end loop Find_Policy;
end Check_Consistent_Locking_Policy;
+ ----------------------------------------------
+ -- Check_Consistent_No_Component_Reordering --
+ ----------------------------------------------
+
+ -- This routine checks for a consistent No_Component_Reordering setting.
+ -- Note that internal units are excluded from this check, since we don't
+ -- in any case allow the pragma to affect types in internal units, and
+ -- there is thus no requirement to recompile the run-time with the setting.
+
+ procedure Check_Consistent_No_Component_Reordering is
+ OK : Boolean := True;
+ begin
+ -- Check that all entries have No_Component_Reordering set
+
+ for A1 in ALIs.First .. ALIs.Last loop
+ if not Is_Internal_File_Name (ALIs.Table (A1).Sfile)
+ and then not ALIs.Table (A1).No_Component_Reordering
+ then
+ OK := False;
+ exit;
+ end if;
+ end loop;
+
+ -- All do, return
+
+ if OK then
+ return;
+ end if;
+
+ -- Here we have an inconsistency
+
+ Consistency_Error_Msg
+ ("some but not all files compiled with No_Component_Reordering");
+
+ Write_Eol;
+ Write_Str ("files compiled with No_Component_Reordering");
+ Write_Eol;
+
+ for A1 in ALIs.First .. ALIs.Last loop
+ if not Is_Internal_File_Name (ALIs.Table (A1).Sfile)
+ and then ALIs.Table (A1).No_Component_Reordering
+ then
+ Write_Str (" ");
+ Write_Name (ALIs.Table (A1).Sfile);
+ Write_Eol;
+ end if;
+ end loop;
+
+ Write_Eol;
+ Write_Str ("files compiled without No_Component_Reordering");
+ Write_Eol;
+
+ for A1 in ALIs.First .. ALIs.Last loop
+ if not Is_Internal_File_Name (ALIs.Table (A1).Sfile)
+ and then not ALIs.Table (A1).No_Component_Reordering
+ then
+ Write_Str (" ");
+ Write_Name (ALIs.Table (A1).Sfile);
+ Write_Eol;
+ end if;
+ end loop;
+ end Check_Consistent_No_Component_Reordering;
+
----------------------------------------
-- Check_Consistent_Normalize_Scalars --
----------------------------------------
-- d.o Conservative elaboration order for indirect calls
-- d.p Use original Ada 95 semantics for Bit_Order (disable AI95-0133)
-- d.q Suppress optimizations on imported 'in'
- -- d.r Enable OK_To_Reorder_Components in non-variant records
+ -- d.r Disable reordering of components in record types
-- d.s Strict secondary stack management
-- d.t Disable static allocation of library level dispatch tables
-- d.u Enable Modify_Tree_For_C (update tree for c)
- -- d.v Enable OK_To_Reorder_Components in variant records
+ -- d.v
-- d.w Do not check for infinite loops
-- d.x No exception handlers
-- d.y
-- optimizations. This option should not be used; the correct solution
-- is to declare the parameter 'in out'.
- -- d.r Forces the flag OK_To_Reorder_Components to be set in all record
- -- base types that have no discriminants.
+ -- d.r Do not reorder components in record types.
-- d.s The compiler no longer attempts to optimize the calls to secondary
-- stack management routines SS_Mark and SS_Release. As a result, each
-- d.u Sets Modify_Tree_For_C mode in which tree is modified to make it
-- easier to generate code using a C compiler.
- -- d.v Forces the flag OK_To_Reorder_Components to be set in all record
- -- base types that have at least one discriminant (v = variant).
-
-- d.w This flag turns off the scanning of loops to detect possible
-- infinite loops.
-- Warnings_Off_Used Flag236
-- Warnings_Off_Used_Unmodified Flag237
-- Warnings_Off_Used_Unreferenced Flag238
- -- OK_To_Reorder_Components Flag239
+ -- No_Reordering Flag239
-- Has_Expanded_Contract Flag240
-- Optimize_Alignment_Space Flag241
function Has_Complex_Representation (Id : E) return B is
begin
- pragma Assert (Is_Type (Id));
+ pragma Assert (Is_Record_Type (Id));
return Flag140 (Implementation_Base_Type (Id));
end Has_Complex_Representation;
return Flag275 (Id);
end No_Predicate_On_Actual;
+ function No_Reordering (Id : E) return B is
+ begin
+ pragma Assert (Is_Record_Type (Id));
+ return Flag239 (Implementation_Base_Type (Id));
+ end No_Reordering;
+
function No_Return (Id : E) return B is
begin
return Flag113 (Id);
return Flag247 (Id);
end OK_To_Rename;
- function OK_To_Reorder_Components (Id : E) return B is
- begin
- pragma Assert (Is_Record_Type (Id));
- return Flag239 (Base_Type (Id));
- end OK_To_Reorder_Components;
-
function Optimize_Alignment_Space (Id : E) return B is
begin
pragma Assert
procedure Set_Has_Complex_Representation (Id : E; V : B := True) is
begin
- pragma Assert (Ekind (Id) = E_Record_Type);
+ pragma Assert (Is_Record_Type (Id) and then Is_Base_Type (Id));
Set_Flag140 (Id, V);
end Set_Has_Complex_Representation;
Set_Flag275 (Id, V);
end Set_No_Predicate_On_Actual;
+ procedure Set_No_Reordering (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Record_Type (Id) and then Is_Base_Type (Id));
+ Set_Flag239 (Id, V);
+ end Set_No_Reordering;
+
procedure Set_No_Return (Id : E; V : B := True) is
begin
pragma Assert
Set_Flag247 (Id, V);
end Set_OK_To_Rename;
- procedure Set_OK_To_Reorder_Components (Id : E; V : B := True) is
- begin
- pragma Assert
- (Is_Record_Type (Id) and then Is_Base_Type (Id));
- Set_Flag239 (Id, V);
- end Set_OK_To_Reorder_Components;
-
procedure Set_Optimize_Alignment_Space (Id : E; V : B := True) is
begin
pragma Assert
W ("No_Dynamic_Predicate_On_actual", Flag276 (Id));
W ("No_Pool_Assigned", Flag131 (Id));
W ("No_Predicate_On_actual", Flag275 (Id));
+ W ("No_Reordering", Flag239 (Id));
W ("No_Return", Flag113 (Id));
W ("No_Strict_Aliasing", Flag136 (Id));
W ("Non_Binary_Modulus", Flag58 (Id));
W ("Nonzero_Is_True", Flag162 (Id));
W ("OK_To_Rename", Flag247 (Id));
- W ("OK_To_Reorder_Components", Flag239 (Id));
W ("Optimize_Alignment_Space", Flag241 (Id));
W ("Optimize_Alignment_Time", Flag242 (Id));
W ("Overlays_Constant", Flag243 (Id));
-- the package body).
-- Has_Complex_Representation (Flag140) [implementation base type only]
--- Defined in all type entities. Set only for a record base type to
--- which a valid pragma Complex_Representation applies.
+-- Defined in record types. Set only for a base type to which a valid
+-- pragma Complex_Representation applies.
-- Has_Component_Size_Clause (Flag68) [implementation base type only]
-- Defined in all type entities. Set if a component size clause is
-- in the spec of a generic package, in constructs that forbid discrete
-- types with predicates.
+-- No_Reordering (Flag239) [implementation base type only]
+-- Defined in record types. Set only for a base type to which a valid
+-- pragma No_Component_Reordering applies.
+
-- No_Return (Flag113)
-- Defined in all entities. Always false except in the case of procedures
-- and generic procedures for which a pragma No_Return is given.
-- is only worth setting this flag for composites, since for primitive
-- types, it is cheaper to do the copy.
--- OK_To_Reorder_Components (Flag239) [base type only]
--- Defined in record types. Set if the backend is permitted to reorder
--- the components. If not set, the record must be laid out in the order
--- in which the components are declared textually. Currently this flag
--- can only be set by debug switches.
-
-- Optimize_Alignment_Space (Flag241)
-- Defined in type, subtype, variable, and constant entities. This
-- flag records that the type or object is to be layed out in a manner
-- Uses_Lock_Free (Flag188)
-- Defined in protected type entities. Set to True when the Lock Free
--- implementation is used for the protected type. This implemenatation is
+-- implementation is used for the protected type. This implementation is
-- based on atomic transactions and doesn't require anymore the use of
-- Protection object (see System.Tasking.Protected_Objects).
-- Is_Controlled (Flag42) (base type only)
-- Is_Interface (Flag186)
-- Is_Limited_Interface (Flag197)
- -- OK_To_Reorder_Components (Flag239) (base type only)
+ -- No_Reordering (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)
-- Is_Controlled (Flag42) (base type only)
-- Is_Interface (Flag186)
-- Is_Limited_Interface (Flag197)
- -- OK_To_Reorder_Components (Flag239) (base type only)
+ -- No_Reordering (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)
function No_Dynamic_Predicate_On_Actual (Id : E) return B;
function No_Pool_Assigned (Id : E) return B;
function No_Predicate_On_Actual (Id : E) return B;
+ function No_Reordering (Id : E) return B;
function No_Return (Id : E) return B;
function No_Strict_Aliasing (Id : E) return B;
function No_Tagged_Streams_Pragma (Id : E) return N;
function Normalized_Position (Id : E) return U;
function Normalized_Position_Max (Id : E) return U;
function OK_To_Rename (Id : E) return B;
- function OK_To_Reorder_Components (Id : E) return B;
function Optimize_Alignment_Space (Id : E) return B;
function Optimize_Alignment_Time (Id : E) return B;
function Original_Access_Type (Id : E) return E;
procedure Set_No_Dynamic_Predicate_On_Actual (Id : E; V : B := True);
procedure Set_No_Pool_Assigned (Id : E; V : B := True);
procedure Set_No_Predicate_On_Actual (Id : E; V : B := True);
+ procedure Set_No_Reordering (Id : E; V : B := True);
procedure Set_No_Return (Id : E; V : B := True);
procedure Set_No_Strict_Aliasing (Id : E; V : B := True);
procedure Set_No_Tagged_Streams_Pragma (Id : E; V : N);
procedure Set_Normalized_Position (Id : E; V : U);
procedure Set_Normalized_Position_Max (Id : E; V : U);
procedure Set_OK_To_Rename (Id : E; V : B := True);
- procedure Set_OK_To_Reorder_Components (Id : E; V : B := True);
procedure Set_Optimize_Alignment_Space (Id : E; V : B := True);
procedure Set_Optimize_Alignment_Time (Id : E; V : B := True);
procedure Set_Original_Access_Type (Id : E; V : E);
pragma Inline (No_Dynamic_Predicate_On_Actual);
pragma Inline (No_Pool_Assigned);
pragma Inline (No_Predicate_On_Actual);
+ pragma Inline (No_Reordering);
pragma Inline (No_Return);
pragma Inline (No_Strict_Aliasing);
pragma Inline (No_Tagged_Streams_Pragma);
pragma Inline (Normalized_Position);
pragma Inline (Normalized_Position_Max);
pragma Inline (OK_To_Rename);
- pragma Inline (OK_To_Reorder_Components);
pragma Inline (Optimize_Alignment_Space);
pragma Inline (Optimize_Alignment_Time);
pragma Inline (Original_Access_Type);
pragma Inline (Set_No_Dynamic_Predicate_On_Actual);
pragma Inline (Set_No_Pool_Assigned);
pragma Inline (Set_No_Predicate_On_Actual);
+ pragma Inline (Set_No_Reordering);
pragma Inline (Set_No_Return);
pragma Inline (Set_No_Strict_Aliasing);
pragma Inline (Set_No_Tagged_Streams_Pragma);
pragma Inline (Set_Normalized_Position);
pragma Inline (Set_Normalized_Position_Max);
pragma Inline (Set_OK_To_Rename);
- pragma Inline (Set_OK_To_Reorder_Components);
pragma Inline (Set_Optimize_Alignment_Space);
pragma Inline (Set_Optimize_Alignment_Time);
pragma Inline (Set_Original_Access_Type);
/* debug: */
-#define Debug_Flag_NN debug__debug_flag_nn
+#define Debug_Flag_Dot_R debug__debug_flag_dot_r
+#define Debug_Flag_NN debug__debug_flag_nn
+extern Boolean Debug_Flag_Dot_R;
extern Boolean Debug_Flag_NN;
/* einfo: */
end if;
end;
- -- Set OK_To_Reorder_Components depending on debug flags
-
- if Is_Base_Type (Rec) and then Convention (Rec) = Convention_Ada then
- if (Has_Discriminants (Rec) and then Debug_Flag_Dot_V)
- or else
- (not Has_Discriminants (Rec) and then Debug_Flag_Dot_R)
- then
- Set_OK_To_Reorder_Components (Rec);
- end if;
- end if;
-
-- Check for useless pragma Pack when all components placed. We only
-- do this check for record types, not subtypes, since a subtype may
-- have all its components placed, and it still makes perfectly good
Addr : Inet_Addr_Type (Family);
Port : Port_Type;
end record;
+ pragma No_Component_Reordering (Sock_Addr_Type);
-- Socket addresses fully define a socket connection with protocol family,
-- an Internet address and a port. No_Sock_Addr provides a special value
-- for uninitialized socket addresses.
&& Stored_Constraint (gnat_entity) != No_Elist
&& (gnat_parent_type = Underlying_Type (Etype (gnat_entity)))
&& Is_Record_Type (gnat_parent_type)
- && !Is_Unchecked_Union (gnat_parent_type))
+ && !Is_Unchecked_Union (gnat_parent_type)
+ && No_Reordering (gnat_entity) == No_Reordering (gnat_parent_type))
{
tree gnu_parent_type
= TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_parent_type));
}
/* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they do,
- pull them out and put them onto the appropriate list. We have to do it
- in a separate pass since we want to handle the discriminants but can't
- play with them until we've used them in debugging data above.
+ pull them out and put them onto the appropriate list.
Similarly, pull out the fields with zero size and no rep clause, as they
would otherwise modify the layout and thus very likely run afoul of the
different kinds of fields and issue a warning if some of them would be
(or are being) reordered by the reordering mechanism.
- Finally, pull out the fields whose size is not a multiple of a byte, so
- that they don't cause the regular fields to be misaligned. As this can
- only happen in packed record types, the alignment is capped to the byte.
-
- ??? If we reorder them, debugging information will be wrong but there is
- nothing that can be done about this at the moment. */
- const bool do_reorder = OK_To_Reorder_Components (gnat_record_type);
+ ??? If we reorder fields, the debugging information will be affected and
+ the debugger print fields in a different order from the source code. */
+ const bool do_reorder
+ = (Convention (gnat_record_type) == Convention_Ada
+ && !No_Reordering (gnat_record_type)
+ && !debug__debug_flag_dot_r);
const bool w_reorder
- = Warn_On_Questionable_Layout
- && (Convention (gnat_record_type) == Convention_Ada);
+ = (Convention (gnat_record_type) == Convention_Ada
+ && Warn_On_Questionable_Layout
+ && !(No_Reordering (gnat_record_type) && GNAT_Mode));
const bool in_variant = (p_gnu_rep_list != NULL);
tree gnu_zero_list = NULL_TREE;
tree gnu_self_list = NULL_TREE;
Write_Info_Char (Partition_Elaboration_Policy);
end if;
+ if No_Component_Reordering_Config then
+ Write_Info_Str (" NC");
+ end if;
+
if not Object then
Write_Info_Str (" NO");
end if;
External_Name_Imp_Casing_Config := External_Name_Imp_Casing;
Fast_Math_Config := Fast_Math;
Initialize_Scalars_Config := Initialize_Scalars;
+ No_Component_Reordering_Config := No_Component_Reordering;
Optimize_Alignment_Config := Optimize_Alignment;
Persistent_BSS_Mode_Config := Persistent_BSS_Mode;
Polling_Required_Config := Polling_Required;
External_Name_Imp_Casing := Save.External_Name_Imp_Casing;
Fast_Math := Save.Fast_Math;
Initialize_Scalars := Save.Initialize_Scalars;
+ No_Component_Reordering := Save.No_Component_Reordering;
Optimize_Alignment := Save.Optimize_Alignment;
Optimize_Alignment_Local := Save.Optimize_Alignment_Local;
Persistent_BSS_Mode := Save.Persistent_BSS_Mode;
Save.External_Name_Imp_Casing := External_Name_Imp_Casing;
Save.Fast_Math := Fast_Math;
Save.Initialize_Scalars := Initialize_Scalars;
+ Save.No_Component_Reordering := No_Component_Reordering;
Save.Optimize_Alignment := Optimize_Alignment;
Save.Optimize_Alignment_Local := Optimize_Alignment_Local;
Save.Persistent_BSS_Mode := Persistent_BSS_Mode;
Extensions_Allowed := True;
External_Name_Exp_Casing := As_Is;
External_Name_Imp_Casing := Lowercase;
+ No_Component_Reordering := False;
Optimize_Alignment := 'O';
Optimize_Alignment_Local := True;
Persistent_BSS_Mode := False;
External_Name_Imp_Casing := External_Name_Imp_Casing_Config;
Fast_Math := Fast_Math_Config;
Initialize_Scalars := Initialize_Scalars_Config;
+ No_Component_Reordering := No_Component_Reordering_Config;
Optimize_Alignment := Optimize_Alignment_Config;
Optimize_Alignment_Local := False;
Persistent_BSS_Mode := Persistent_BSS_Mode_Config;
-- GNATNAME
-- Do not create backup copies of project files. Set by switch --no-backup.
+ No_Component_Reordering : Boolean := False;
+ -- GNAT
+ -- Set True if pragma No_Component_Reordering with no parameter encountered
+
No_Deletion : Boolean := False;
-- GNATPREP
-- Set by preprocessor switch -a. Do not eliminate any source text. Implies
-- This switch is not set when the pragma appears ahead of a given
-- unit, so it does not affect the compilation of other units.
+ No_Component_Reordering_Config : Boolean;
+ -- GNAT
+ -- This is the value of the configuration switch that is set by the
+ -- pragma No_Component_Reordering when it appears in the gnat.adc file.
+ -- This flag is used to set the initial value of No_Component_Reordering
+ -- at the start of each compilation unit, except that it is always set
+ -- False for predefined units.
+
No_Exit_Message : Boolean := False;
-- GNATMAKE, GPRBUILD
-- Set with switch --no-exit-message. When True, if there are compilation
procedure Save_Opt_Config_Switches (Save : out Config_Switches_Type);
-- This procedure saves the current values of the switches which are
- -- initialized from the above Config values, and then resets these switches
- -- according to the Config value settings.
+ -- initialized from the above Config values.
procedure Set_Opt_Config_Switches
(Internal_Unit : Boolean;
External_Name_Imp_Casing : External_Casing_Type;
Fast_Math : Boolean;
Initialize_Scalars : Boolean;
+ No_Component_Reordering : Boolean;
Normalize_Scalars : Boolean;
Optimize_Alignment : Character;
Optimize_Alignment_Local : Boolean;
| Pragma_Max_Queue_Length
| Pragma_Memory_Size
| Pragma_No_Body
+ | Pragma_No_Component_Reordering
| Pragma_No_Elaboration_Code_All
| Pragma_No_Heap_Finalization
| Pragma_No_Inline
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
type Attribute_Data (Name_Length : Attribute_Name_Length := 1) is record
Name : String (1 .. Name_Length);
+ pragma Warnings (Off, Name); -- Reorder it instead???
-- The name of the attribute
Attr_Kind : Defined_Attribute_Kind;
-- B o d y --
-- --
-- Copyright (C) 1986 by University of Toronto. --
--- Copyright (C) 1999-2016, AdaCore --
+-- Copyright (C) 1999-2017, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Case_Emit (C);
end case;
- exit Parse_Loop when Emit_Ptr - Length_Ptr = 254;
-
Parse_Pos := Parse_Pos + 1;
-
- exit Parse_Loop when Parse_Pos > Parse_End;
+ exit Parse_Loop when Parse_Pos > Parse_End
+ or else Emit_Ptr - Length_Ptr = 254;
end loop Parse_Loop;
-- Is the string followed by a '*+?{' operator ? If yes, and if there
return True;
end if;
- -- Tagged types never have differing representations
+ -- Tagged types always have the same representation, because it is not
+ -- possible to specify different representations for common fields.
if Is_Tagged_Type (T1) then
return True;
end if;
end if;
+ -- For records, representations are different if reorderings differ
+
+ if Is_Record_Type (T1)
+ and then Is_Record_Type (T2)
+ and then No_Reordering (T1) /= No_Reordering (T2)
+ then
+ return False;
+ end if;
+
-- Types definitely have same representation if neither has non-standard
-- representation since default representations are always consistent.
-- If only one has non-standard representation, and the other does not,
if Is_Array_Type (T1) then
return Component_Size (T1) = Component_Size (T2);
- -- Tagged types always have the same representation, because it is not
- -- possible to specify different representations for common fields.
-
- elsif Is_Tagged_Type (T1) then
- return True;
-
-- Case of record types
elsif Is_Record_Type (T1) then
Set_Ekind (T, E_Record_Type_With_Private);
Init_Size_Align (T);
Set_Default_SSO (T);
+ Set_No_Reordering (T, No_Component_Reordering);
Set_Etype (T, Parent_Base);
Propagate_Concurrent_Flags (T, Parent_Base);
Set_Ekind (Full_Der, E_Record_Type);
Set_Is_Underlying_Record_View (Full_Der);
Set_Default_SSO (Full_Der);
+ Set_No_Reordering (Full_Der, No_Component_Reordering);
Analyze (Decl);
Type_Def := N;
Set_Ekind (Derived_Type, E_Record_Type_With_Private);
Set_Default_SSO (Derived_Type);
+ Set_No_Reordering (Derived_Type, No_Component_Reordering);
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);
+ Set_No_Reordering (Derived_Type, No_Component_Reordering);
-- Create internal access types for components with anonymous
-- access types.
Set_Has_Primitive_Operations
(Derived_Type, Has_Primitive_Operations (Parent_Base));
- -- Fields inherited from the Parent_Base in the non-private case
+ -- Set fields for private derived types
- if Ekind (Derived_Type) = E_Record_Type then
- Set_Has_Complex_Representation
- (Derived_Type, Has_Complex_Representation (Parent_Base));
+ if Is_Private_Type (Derived_Type) then
+ Set_Depends_On_Private (Derived_Type, True);
+ Set_Private_Dependents (Derived_Type, New_Elmt_List);
end if;
- -- Fields inherited from the Parent_Base for record types
+ -- Inherit fields for non-private types. If this is the completion of a
+ -- derivation from a private type, the parent itself is private and the
+ -- attributes come from its full view, which must be present.
if Is_Record_Type (Derived_Type) then
declare
Parent_Full : Entity_Id;
begin
- -- Ekind (Parent_Base) is not necessarily E_Record_Type since
- -- Parent_Base can be a private type or private extension. Go
- -- to the full view here to get the E_Record_Type specific flags.
-
- if Present (Full_View (Parent_Base)) then
+ if Is_Private_Type (Parent_Base)
+ and then not Is_Record_Type (Parent_Base)
+ then
Parent_Full := Full_View (Parent_Base);
else
Parent_Full := Parent_Base;
end if;
- Set_OK_To_Reorder_Components
- (Derived_Type, OK_To_Reorder_Components (Parent_Full));
- end;
- end if;
-
- -- Set fields for private derived types
-
- if Is_Private_Type (Derived_Type) then
- Set_Depends_On_Private (Derived_Type, True);
- Set_Private_Dependents (Derived_Type, New_Elmt_List);
-
- -- Inherit fields from non private record types. If this is the
- -- completion of a derivation from a private type, the parent itself
- -- is private, and the attributes come from its full view, which must
- -- be present.
-
- else
- if Is_Private_Type (Parent_Base)
- and then not Is_Record_Type (Parent_Base)
- then
Set_Component_Alignment
- (Derived_Type, Component_Alignment (Full_View (Parent_Base)));
+ (Derived_Type, Component_Alignment (Parent_Full));
Set_C_Pass_By_Copy
- (Derived_Type, C_Pass_By_Copy (Full_View (Parent_Base)));
- else
- Set_Component_Alignment
- (Derived_Type, Component_Alignment (Parent_Base));
- Set_C_Pass_By_Copy
- (Derived_Type, C_Pass_By_Copy (Parent_Base));
- end if;
+ (Derived_Type, C_Pass_By_Copy (Parent_Full));
+ Set_Has_Complex_Representation
+ (Derived_Type, Has_Complex_Representation (Parent_Full));
+
+ -- For untagged types, inherit the layout by default to avoid
+ -- costly changes of representation for type conversions.
+
+ if not Is_Tagged then
+ Set_Is_Packed (Derived_Type, Is_Packed (Parent_Full));
+ Set_No_Reordering (Derived_Type, No_Reordering (Parent_Full));
+ end if;
+ end;
end if;
-- Set fields for tagged types
end if;
end;
end if;
-
- else
- Set_Is_Packed (Derived_Type, Is_Packed (Parent_Base));
- Set_Has_Non_Standard_Rep
- (Derived_Type, Has_Non_Standard_Rep (Parent_Base));
end if;
-- STEP 4: Inherit components from the parent base and constrain them.
Set_Interfaces (T, No_Elist);
Set_Stored_Constraint (T, No_Elist);
Set_Default_SSO (T);
+ Set_No_Reordering (T, No_Component_Reordering);
-- Normal case
-- there are various error checks that are applied on this body
-- when it is analyzed (e.g. correct aspect placement).
- if Has_Completion (Prev) then
+ if Has_Completion (Prev)
+ then
Error_Msg_Sloc := Sloc (Prev);
Error_Msg_NE ("duplicate body for & declared#", N, Prev);
end if;
+ Check_Previous_Null_Procedure (N, Prev);
+
Is_Completion := True;
Rewrite (N, Null_Body);
Analyze (N);
if Present (Rename_Spec) then
+ Check_Previous_Null_Procedure (N, Rename_Spec);
+
-- Renaming declaration is the completion of the declaration of
-- Rename_Spec. We build an actual body for it at the freezing point.
if Etype (E_Id) = Any_Type then
return;
- else
- E := Entity (E_Id);
end if;
+ E := Entity (E_Id);
+
-- A pragma that applies to a Ghost entity becomes Ghost for
-- the purposes of legality checks and removal of ignored
-- Ghost code.
Opt.No_Elab_Code_All_Pragma := N;
end if;
+ -----------------------------
+ -- No_Component_Reordering --
+ -----------------------------
+
+ -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
+
+ when Pragma_No_Component_Reordering => No_Comp_Reordering : declare
+ E : Entity_Id;
+ E_Id : Node_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_At_Most_N_Arguments (1);
+
+ if Arg_Count = 0 then
+ Check_Valid_Configuration_Pragma;
+ Opt.No_Component_Reordering := True;
+
+ else
+ Check_Optional_Identifier (Arg2, Name_Entity);
+ Check_Arg_Is_Local_Name (Arg1);
+ E_Id := Get_Pragma_Arg (Arg1);
+
+ if Etype (E_Id) = Any_Type then
+ return;
+ end if;
+
+ E := Entity (E_Id);
+
+ if not Is_Record_Type (E) then
+ Error_Pragma_Arg ("pragma% requires record type", Arg1);
+ end if;
+
+ Set_No_Reordering (Base_Type (E));
+ end if;
+ end No_Comp_Reordering;
+
--------------------------
-- No_Heap_Finalization --
--------------------------
-- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
when Pragma_No_Strict_Aliasing => No_Strict_Aliasing : declare
- E_Id : Entity_Id;
+ E : Entity_Id;
+ E_Id : Node_Id;
begin
GNAT_Pragma;
else
Check_Optional_Identifier (Arg2, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
- E_Id := Entity (Get_Pragma_Arg (Arg1));
+ E_Id := Get_Pragma_Arg (Arg1);
- if E_Id = Any_Type then
+ if Etype (E_Id) = Any_Type then
return;
- elsif No (E_Id) or else not Is_Access_Type (E_Id) then
+ end if;
+
+ E := Entity (E_Id);
+
+ if not Is_Access_Type (E) then
Error_Pragma_Arg ("pragma% requires access type", Arg1);
end if;
- Set_No_Strict_Aliasing (Implementation_Base_Type (E_Id));
+ Set_No_Strict_Aliasing (Base_Type (E));
end if;
end No_Strict_Aliasing;
Check_Arg_Is_Local_Name (Arg1);
E_Id := Get_Pragma_Arg (Arg1);
- if Error_Posted (E_Id) then
+ if Etype (E_Id) = Any_Type then
return;
end if;
-- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
when Pragma_Universal_Aliasing => Universal_Alias : declare
- E_Id : Entity_Id;
+ E : Entity_Id;
+ E_Id : Node_Id;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg2, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
- E_Id := Entity (Get_Pragma_Arg (Arg1));
+ E_Id := Get_Pragma_Arg (Arg1);
- if E_Id = Any_Type then
+ if Etype (E_Id) = Any_Type then
return;
- elsif No (E_Id) or else not Is_Type (E_Id) then
+ end if;
+
+ E := Entity (E_Id);
+
+ if not Is_Type (E) then
Error_Pragma_Arg ("pragma% requires type", Arg1);
end if;
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Ghost_Pragma (N, E_Id);
- Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
- Record_Rep_Item (E_Id, N);
+ Mark_Ghost_Pragma (N, E);
+ Set_Universal_Aliasing (Base_Type (E));
+ Record_Rep_Item (E, N);
end Universal_Alias;
--------------------
Pragma_Memory_Size => 0,
Pragma_No_Return => 0,
Pragma_No_Body => 0,
+ Pragma_No_Component_Reordering => -1,
Pragma_No_Elaboration_Code_All => 0,
Pragma_No_Heap_Finalization => 0,
Pragma_No_Inline => 0,
end if;
end Cannot_Raise_Constraint_Error;
+ ------------------------------------
+ -- Check_Previous_Null_Procedure --
+ ------------------------------------
+
+ procedure Check_Previous_Null_Procedure
+ (Decl : Node_Id;
+ Prev : Entity_Id)
+ is
+ begin
+ if Ekind (Prev) = E_Procedure
+ and then Nkind (Parent (Prev)) = N_Procedure_Specification
+ and then Null_Present (Parent (Prev))
+ then
+ Error_Msg_Sloc := Sloc (Prev);
+ Error_Msg_N
+ ("declaration cannot complete previous null procedure#", Decl);
+ end if;
+ end Check_Previous_Null_Procedure;
+
-----------------------------
-- Check_Part_Of_Reference --
-----------------------------
-- N is one of the statement forms that is a potentially blocking
-- operation. If it appears within a protected action, emit warning.
+ procedure Check_Previous_Null_Procedure
+ (Decl : Node_Id;
+ Prev : Entity_Id);
+ -- A null procedure or a subprogram renaming can complete a previous
+ -- declaration, unless that previous declaration is itself a null
+ -- procedure. This must be treated specially because the analysis of
+ -- the null procedure leaves the corresponding entity as having no
+ -- completion, because its completion is provided by a generated body
+ -- inserted after all other declarations.
+
procedure Check_Result_And_Post_State (Subp_Id : Entity_Id);
-- Determine whether the contract of subprogram Subp_Id mentions attribute
-- 'Result and it contains an expression that evaluates differently in pre-
Name_Interrupt_State : constant Name_Id := N + $; -- GNAT
Name_License : constant Name_Id := N + $; -- GNAT
Name_Locking_Policy : constant Name_Id := N + $;
+ Name_No_Component_Reordering : constant Name_Id := N + $; -- GNAT
Name_No_Heap_Finalization : constant Name_Id := N + $; -- GNAT
Name_No_Run_Time : constant Name_Id := N + $; -- GNAT
Name_No_Strict_Aliasing : constant Name_Id := N + $; -- GNAT
Pragma_Interrupt_State,
Pragma_License,
Pragma_Locking_Policy,
+ Pragma_No_Component_Reordering,
Pragma_No_Heap_Finalization,
Pragma_No_Run_Time,
Pragma_No_Strict_Aliasing,
-- These warnings are added to the -gnatwa set
Address_Clause_Overlay_Warnings := True;
+ Warn_On_Questionable_Layout := True;
Warn_On_Overridden_Size := True;
-- These warnings are removed from the -gnatwa set
projects / gcc.git / commitdiff