summaryrefslogtreecommitdiff
path: root/gcc
diff options
context:
space:
mode:
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2008-03-26 07:36:02 +0000
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2008-03-26 07:36:02 +0000
commit2253aba6069113bf4d0356a00a1eb828be807d23 (patch)
tree70dbf93da9aba2214e551ac66d758a30077cf351 /gcc
parent1722baf3c2afd28012e3b87df33d12b4865d8129 (diff)
downloadgcc-2253aba6069113bf4d0356a00a1eb828be807d23.tar.gz
2008-03-26 Robert Dewar <dewar@adacore.com>
* ali.ads, ali.adb (Optimize_Alignment_Setting): New field in ALI record * bcheck.adb (Check_Consistent_Optimize_Alignment): New procedure * debug.adb: Add debug flags d.r and d.v Add debug flag .T (Optimize_Alignment (Time)) Add debug flag .S (Optimize_Alignment (Space)) * freeze.adb (Freeze_Record_Type): Set OK_To_Reorder_Components depending on setting of relevant debug flags. Replace use of Warnings_Off by Has_Warnings_Off (Freeze_Entity): In circuit for warning on suspicious convention actuals, do not give warning if subprogram has same entity as formal type, or if subprogram does not come from source. (Freeze_Entity): Don't reset Is_Packed for fully rep speced record if Optimize_Alignment set to Space. * frontend.adb: Add call to Sem_Warn.Initialize Add call to Sem_Warn.Output_Unused_Warnings_Off_Warnings Reset Optimize_Alignment mode from debug switches .S and .T * layout.adb (Layout_Composite_Object): Rewritten for Optimize_Aligment pragma. * lib-writ.ads, lib-writ.adb: New Ox parameter for Optimize_Alignment mode. * opt.ads, opt.adb: (Optimize_Alignment): New global switch * par-prag.adb (N_Pragma): Chars field removed, use Chars (Pragma_Identifier (.. instead, adjustments throughout to accomodate this change. Add entry for pragma Optimize_Alignment * sem_prag.adb (N_Pragma): Chars field removed, use Chars (Pragma_Identifier (.. instead, adjustments throughout to accomodate this change. (Process_Compile_Time_Warning_Or_Error): Use !! for generated msg (Favor_Top_Level): Use new function Is_Access_Subprogram_Type Add implementation of pragma Optimize_Alignment git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@133549 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
-rw-r--r--gcc/ada/ali.adb6
-rw-r--r--gcc/ada/ali.ads87
-rw-r--r--gcc/ada/bcheck.adb52
-rw-r--r--gcc/ada/debug.adb33
-rw-r--r--gcc/ada/freeze.adb132
-rw-r--r--gcc/ada/frontend.adb16
-rw-r--r--gcc/ada/layout.adb137
-rw-r--r--gcc/ada/lib-writ.adb5
-rw-r--r--gcc/ada/lib-writ.ads26
-rw-r--r--gcc/ada/opt.adb6
-rw-r--r--gcc/ada/opt.ads25
-rw-r--r--gcc/ada/par-prag.adb13
-rw-r--r--gcc/ada/sem_prag.adb168
13 files changed, 446 insertions, 260 deletions
diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb
index 8466ddd91d8..96624d6a835 100644
--- a/gcc/ada/ali.adb
+++ b/gcc/ada/ali.adb
@@ -818,6 +818,7 @@ package body ALI is
No_Object => False,
Normalize_Scalars => False,
Ofile_Full_Name => Full_Object_File_Name,
+ Optimize_Alignment_Setting => 'O',
Queuing_Policy => ' ',
Restrictions => No_Restrictions,
SAL_Interface => False,
@@ -1040,6 +1041,11 @@ package body ALI is
Fatal_Error_Ignore;
end if;
+ -- Processing for Ox
+
+ elsif C = 'O' then
+ ALIs.Table (Id).Optimize_Alignment_Setting := Getc;
+
-- Processing for Qx
elsif C = 'Q' then
diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads
index 94715b31196..90c8e0d50c9 100644
--- a/gcc/ada/ali.ads
+++ b/gcc/ada/ali.ads
@@ -122,82 +122,83 @@ package ALI is
-- Id of last Sdep table entry for this file
Main_Program : Main_Program_Type;
- -- Indicator of whether first unit can be used as main program.
- -- Not set if 'M' appears in Ignore_Lines.
+ -- Indicator of whether first unit can be used as main program. Not set
+ -- if 'M' appears in Ignore_Lines.
Main_Priority : Int;
- -- Indicates priority value if Main_Program field indicates that
- -- this can be a main program. A value of -1 (No_Main_Priority)
- -- indicates that no parameter was found, or no M line was present.
- -- Not set if 'M' appears in Ignore_Lines.
+ -- Indicates priority value if Main_Program field indicates that this
+ -- can be a main program. A value of -1 (No_Main_Priority) indicates
+ -- that no parameter was found, or no M line was present. Not set if
+ -- 'M' appears in Ignore_Lines.
Time_Slice_Value : Int;
-- Indicates value of time slice parameter from T=xxx on main program
- -- line. A value of -1 indicates that no T=xxx parameter was found,
- -- or no M line was present.
- -- Not set if 'M' appears in Ignore_Lines.
+ -- line. A value of -1 indicates that no T=xxx parameter was found, or
+ -- no M line was present. Not set if 'M' appears in Ignore_Lines.
WC_Encoding : Character;
-- Wide character encoding if main procedure. Otherwise not relevant.
-- Not set if 'M' appears in Ignore_Lines.
Locking_Policy : Character;
- -- Indicates locking policy for units in this file. Space means
- -- tasking was not used, or that no Locking_Policy pragma was
- -- present or that this is a language defined unit. Otherwise set
- -- to first character (upper case) of policy name.
- -- Not set if 'P' appears in Ignore_Lines.
+ -- Indicates locking policy for units in this file. Space means tasking
+ -- was not used, or that no Locking_Policy pragma was present or that
+ -- this is a language defined unit. Otherwise set to first character
+ -- (upper case) of policy name. Not set if 'P' appears in Ignore_Lines.
Queuing_Policy : Character;
- -- Indicates queuing policy for units in this file. Space means
- -- tasking was not used, or that no Queuing_Policy pragma was
- -- present or that this is a language defined unit. Otherwise set
- -- to first character (upper case) of policy name.
- -- Not set if 'P' appears in Ignore_Lines.
+ -- Indicates queuing policy for units in this file. Space means tasking
+ -- was not used, or that no Queuing_Policy pragma was present or that
+ -- this is a language defined unit. Otherwise set to first character
+ -- (upper case) of policy name. Not set if 'P' appears in Ignore_Lines.
Task_Dispatching_Policy : Character;
- -- Indicates task dispatching policy for units in this file. Space
- -- means tasking was not used, or that no Task_Dispatching_Policy
- -- pragma was present or that this is a language defined unit.
- -- Otherwise set to first character (upper case) of policy name.
- -- Not set if 'P' appears in Ignore_Lines.
+ -- Indicates task dispatching policy for units in this file. Space means
+ -- tasking was not used, or that no Task_Dispatching_Policy pragma was
+ -- present or that this is a language defined unit. Otherwise set to
+ -- first character (upper case) of policy name. Not set if 'P' appears
+ -- in Ignore_Lines.
Compile_Errors : Boolean;
- -- Set to True if compile errors for unit. Note that No_Object
- -- will always be set as well in this case.
- -- Not set if 'P' appears in Ignore_Lines.
+ -- Set to True if compile errors for unit. Note that No_Object will
+ -- always be set as well in this case. Not set if 'P' appears in
+ -- Ignore_Lines.
Float_Format : Character;
- -- Set to float format (set to I if no float-format given).
- -- Not set if 'P' appears in Ignore_Lines.
+ -- Set to float format (set to I if no float-format given). 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 True if no object file generated. Not set if 'P' appears in
+ -- Ignore_Lines.
Normalize_Scalars : Boolean;
- -- Set to True if file was compiled with Normalize_Scalars.
- -- Not set if 'P' appears in Ignore_Lines.
+ -- Set to True if file was compiled with Normalize_Scalars. Not set if
+ -- 'P' appears in Ignore_Lines.
+
+ Optimize_Alignment_Setting : Character;
+ -- Optimize_Alignment setting. Set to S/T if OS/OT parameters present,
+ -- otherwise set to 'O' (S/T/O = Space/Time/Off). 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.
+ -- Set to True if unit exception table pointer generated. Not set if 'P'
+ -- appears in Ignore_Lines.
Zero_Cost_Exceptions : Boolean;
- -- Set to True if file was compiled with zero cost exceptions.
- -- Not set if 'P' appears in Ignore_Lines.
+ -- Set to True if file was compiled with zero cost exceptions. Not set
+ -- if 'P' appears in Ignore_Lines.
Restrictions : Restrictions_Info;
-- Restrictions information reconstructed from R lines
First_Interrupt_State : Interrupt_State_Id;
Last_Interrupt_State : Interrupt_State_Id'Base;
- -- These point to the first and last entries in the interrupt
- -- state table for this unit. If there are no entries, then
- -- Last_Interrupt_State = First_Interrupt_State - 1 (that's
- -- why the 'Base reference is there, it can be one less than
- -- the lower bound of the subtype).
- -- Not set if 'I' appears in Ignore_Lines
+ -- These point to the first and last entries in the interrupt state
+ -- table for this unit. If no entries, then Last_Interrupt_State =
+ -- First_Interrupt_State - 1 (that's why the 'Base reference is there,
+ -- it can be one less than the lower bound of the subtype). Not set if
+ -- 'I' appears in Ignore_Lines
First_Specific_Dispatching : Priority_Specific_Dispatching_Id;
Last_Specific_Dispatching : Priority_Specific_Dispatching_Id'Base;
diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb
index adab9588cf2..c397cc8dc92 100644
--- a/gcc/ada/bcheck.adb
+++ b/gcc/ada/bcheck.adb
@@ -51,6 +51,7 @@ package body Bcheck is
procedure Check_Consistent_Interrupt_States;
procedure Check_Consistent_Locking_Policy;
procedure Check_Consistent_Normalize_Scalars;
+ procedure Check_Consistent_Optimize_Alignment;
procedure Check_Consistent_Queuing_Policy;
procedure Check_Consistent_Restrictions;
procedure Check_Consistent_Zero_Cost_Exception_Handling;
@@ -86,8 +87,8 @@ package body Bcheck is
end if;
Check_Consistent_Normalize_Scalars;
+ Check_Consistent_Optimize_Alignment;
Check_Consistent_Dynamic_Elaboration_Checking;
-
Check_Consistent_Restrictions;
Check_Consistent_Interrupt_States;
Check_Consistent_Dispatching_Policy;
@@ -657,12 +658,11 @@ package body Bcheck is
-- then all other units in the partition must also be compiled with
-- Normalized_Scalars in effect.
- -- There is some issue as to whether this consistency check is
- -- desirable, it is certainly required at the moment by the RM.
- -- We should keep a watch on the ARG and HRG deliberations here.
- -- GNAT no longer depends on this consistency (it used to do so,
- -- but that has been corrected in the latest version, since the
- -- Initialize_Scalars pragma does not require consistency.
+ -- There is some issue as to whether this consistency check is desirable,
+ -- it is certainly required at the moment by the RM. We should keep a watch
+ -- on the ARG and HRG deliberations here. GNAT no longer depends on this
+ -- consistency (it used to do so, but that is no longer the case, since
+ -- pragma Initialize_Scalars pragma does not require consistency.)
procedure Check_Consistent_Normalize_Scalars is
begin
@@ -696,6 +696,44 @@ package body Bcheck is
end if;
end Check_Consistent_Normalize_Scalars;
+ -----------------------------------------
+ -- Check_Consistent_Optimize_Alignment --
+ -----------------------------------------
+
+ -- The rule is that all units other than internal units must be compiled
+ -- with the same setting for Optimize_Alignment. We can exclude internal
+ -- units since they are forced to compile with Optimize_Alignment (Off).
+
+ procedure Check_Consistent_Optimize_Alignment is
+ OA_Setting : Character := ' ';
+ -- Reset when we find a non-internal unit
+
+ OA_Unit : ALI_Id;
+ -- Id of unit from which OA_Setting was set
+
+ begin
+ for A in ALIs.First .. ALIs.Last loop
+ if not Is_Internal_File_Name (ALIs.Table (A).Afile) then
+ if OA_Setting = ' ' then
+ OA_Setting := ALIs.Table (A).Optimize_Alignment_Setting;
+ OA_Unit := A;
+
+ elsif OA_Setting = ALIs.Table (A).Optimize_Alignment_Setting then
+ null;
+
+ else
+ Error_Msg_File_1 := ALIs.Table (OA_Unit).Sfile;
+ Error_Msg_File_2 := ALIs.Table (A).Sfile;
+
+ Consistency_Error_Msg
+ ("{ and { compiled with different "
+ & "Optimize_Alignment settings");
+ return;
+ end if;
+ end if;
+ end loop;
+ end Check_Consistent_Optimize_Alignment;
+
-------------------------------------
-- Check_Consistent_Queuing_Policy --
-------------------------------------
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index b4ab4c6e7da..48ff50bd737 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
@@ -93,7 +93,7 @@ package body Debug is
-- dY Enable configurable run-time mode
-- dZ Generate listing showing the contents of the dispatch tables
- -- d.a Disable OpenVMS alignment optimization on types
+ -- d.a
-- d.b
-- d.c
-- d.d
@@ -110,11 +110,11 @@ package body Debug is
-- d.o
-- d.p
-- d.q
- -- d.r
+ -- d.r Enable OK_To_Reorder_Components in non-variant records
-- d.s Disable expansion of slice move, use memmove
-- d.t Disable static allocation of library level dispatch tables
-- d.u
- -- d.v
+ -- d.v Enable OK_To_Reorder_Components in variant records
-- d.w Do not check for infinite while loops
-- d.x No exception handlers
-- d.y
@@ -138,8 +138,8 @@ package body Debug is
-- d.P
-- d.Q
-- d.R
- -- d.S
- -- d.T
+ -- d.S Force Optimize_Alignment (Space)
+ -- d.T Force Optimize_Alignment (Time)
-- d.U
-- d.V
-- d.W
@@ -474,33 +474,32 @@ package body Debug is
-- line has an internally generated number used for references between
-- tagged types and primitives. For each primitive the output has the
-- following fields:
+ --
-- - Letter 'P' or letter 's': The former indicates that this
-- primitive will be located in a primary dispatch table. The
-- latter indicates that it will be located in a secondary
-- dispatch table.
+ --
-- - Name of the primitive. In case of predefined Ada primitives
-- the text "(predefined)" is added before the name, and these
-- acronyms are used: SR (Stream_Read), SW (Stream_Write), SI
-- (Stream_Input), SO (Stream_Output), DA (Deep_Adjust), DF
-- (Deep_Finalize). In addition Oeq identifies the equality
-- operator, and "_assign" the assignment.
+ --
-- - If the primitive covers interface types, two extra fields
-- referencing other primitives are generated: "Alias" references
-- the primitive of the tagged type that covers an interface
-- primitive, and "AI_Alias" references the covered interface
-- primitive.
+ --
-- - The expression "at #xx" indicates the slot of the dispatch
-- table occupied by such primitive in its corresponding primary
-- or secondary dispatch table.
+ --
-- - In case of abstract subprograms the text "is abstract" is
-- added at the end of the line.
- -- d.a Disable OpenVMS alignment optimization on types. On OpenVMS,
- -- record types whose size is odd "in between" (e.g. 17 bits) are
- -- over-aligned to the next power of 2 (until 8 bytes). This over
- -- alignment improve generated code and is more consistent with
- -- what Dec Ada does.
-
-- d.f Suppress folding of static expressions. This of course results
-- in seriously non-conforming behavior, but is useful sometimes
-- when tracking down handling of complex expressions.
@@ -520,6 +519,9 @@ package body Debug is
-- main source (this corresponds to a previous behavior of -gnatl and
-- is used for running the ACATS tests).
+ -- d.r Forces the flag OK_To_Reorder_Components to be set in all record
+ -- base types that have no discriminants.
+
-- d.s Normally the compiler expands slice moves into loops if overlap
-- might be possible. This debug flag inhibits that expansion, and
-- the back end is expected to use an appropriate routine to handle
@@ -531,6 +533,9 @@ package body Debug is
-- previous dynamic construction of tables. It is there as a possible
-- work around if we run into trouble with the new implementation.
+ -- 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 while loops to detect possible
-- infinite loops.
@@ -543,6 +548,10 @@ package body Debug is
-- byte code, even in case of unsupported construct, for the sake
-- of static analysis tools.
+ -- d.S Force Optimize_Alignment (Space) mode as the default
+
+ -- d.T Force Optimize_Alignment (Time) mode as the default
+
-- d1 Error messages have node numbers where possible. Normally error
-- messages have only source locations. This option is useful when
-- debugging errors caused by expanded code, where the source location
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index f977e7a0e02..edd52f5b7f0 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
@@ -155,14 +155,8 @@ package body Freeze is
-- setting of Debug_Info_Needed for the entity. This flag is set if
-- the entity comes from source, or if we are in Debug_Generated_Code
-- mode or if the -gnatdV debug flag is set. However, it never sets
- -- the flag if Debug_Info_Off is set.
-
- procedure Set_Debug_Info_Needed (T : Entity_Id);
- -- Sets the Debug_Info_Needed flag on entity T if not already set, and
- -- also on any entities that are needed by T (for an object, the type
- -- of the object is needed, and for a type, the subsidiary types are
- -- needed -- see body for details). Never has any effect on T if the
- -- Debug_Info_Off flag is set.
+ -- the flag if Debug_Info_Off is set. This procedure also ensures that
+ -- subsidiary entities have the flag set as required.
procedure Undelay_Type (T : Entity_Id);
-- T is a type of a component that we know to be an Itype.
@@ -956,12 +950,13 @@ package body Freeze is
procedure Check_Debug_Info_Needed (T : Entity_Id) is
begin
- if Needs_Debug_Info (T) or else Debug_Info_Off (T) then
+ if Debug_Info_Off (T) then
return;
elsif Comes_From_Source (T)
or else Debug_Generated_Code
or else Debug_Flag_VV
+ or else Needs_Debug_Info (T)
then
Set_Debug_Info_Needed (T);
end if;
@@ -1856,7 +1851,7 @@ package body Freeze is
then
declare
Will_Be_Frozen : Boolean := False;
- S : Entity_Id := Scope (Rec);
+ S : Entity_Id;
begin
-- We have a pretty bad kludge here. Suppose Rec is subtype
@@ -1874,6 +1869,7 @@ package body Freeze is
-- do, then mark that Comp'Base will actually be frozen. If
-- so, we merely undelay it.
+ S := Scope (Rec);
while Present (S) loop
if Is_Subprogram (S) then
Will_Be_Frozen := True;
@@ -1994,14 +1990,31 @@ package body Freeze is
end if;
end if;
+ -- Set OK_To_Reorder_Components depending on debug flags
+
+ if Rec = 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
- -- sense to pack other subtypes or the parent type.
+ -- sense to pack other subtypes or the parent type. We do not give
+ -- this warning if Optimize_Alignment is set to Space, since the
+ -- pragma Pack does have an effect in this case (it always resets
+ -- the alignment to one).
if Ekind (Rec) = E_Record_Type
and then Is_Packed (Rec)
and then not Unplaced_Component
+ and then Optimize_Alignment /= 'S'
then
-- Reset packed status. Probably not necessary, but we do it so
-- that there is no chance of the back end doing something strange
@@ -2093,16 +2106,19 @@ package body Freeze is
-- Generate warning for applying C or C++ convention to a record
-- with discriminants. This is suppressed for the unchecked union
- -- case, since the whole point in this case is interface C.
+ -- case, since the whole point in this case is interface C. We also
+ -- do not generate this within instantiations, since we will have
+ -- generated a message on the template.
if Has_Discriminants (E)
and then not Is_Unchecked_Union (E)
- and then not Warnings_Off (E)
- and then not Warnings_Off (Base_Type (E))
and then (Convention (E) = Convention_C
or else
Convention (E) = Convention_CPP)
and then Comes_From_Source (E)
+ and then not In_Instance
+ and then not Has_Warnings_Off (E)
+ and then not Has_Warnings_Off (Base_Type (E))
then
declare
Cprag : constant Node_Id := Get_Rep_Pragma (E, Name_Convention);
@@ -2330,16 +2346,18 @@ package body Freeze is
end if;
-- Check suspicious parameter for C function. These tests
- -- apply only to exported/imported suboprograms.
+ -- apply only to exported/imported subprograms.
if Warn_On_Export_Import
+ and then Comes_From_Source (E)
and then (Convention (E) = Convention_C
or else
Convention (E) = Convention_CPP)
- and then not Warnings_Off (E)
- and then not Warnings_Off (F_Type)
- and then not Warnings_Off (Formal)
and then (Is_Imported (E) or else Is_Exported (E))
+ and then Convention (E) /= Convention (Formal)
+ and then not Has_Warnings_Off (E)
+ and then not Has_Warnings_Off (F_Type)
+ and then not Has_Warnings_Off (Formal)
then
Error_Msg_Qual_Level := 1;
@@ -2482,14 +2500,14 @@ package body Freeze is
and then (Convention (E) = Convention_C
or else
Convention (E) = Convention_CPP)
- and then not Warnings_Off (E)
- and then not Warnings_Off (R_Type)
and then (Is_Imported (E) or else Is_Exported (E))
then
-- Check suspicious return of fat C pointer
if Is_Access_Type (R_Type)
and then Esize (R_Type) > Ttypes.System_Address_Size
+ and then not Has_Warnings_Off (E)
+ and then not Has_Warnings_Off (R_Type)
then
Error_Msg_N
("?return type of& does not "
@@ -2499,6 +2517,8 @@ package body Freeze is
elsif Root_Type (R_Type) = Standard_Boolean
and then Convention (R_Type) = Convention_Ada
+ and then not Has_Warnings_Off (E)
+ and then not Has_Warnings_Off (R_Type)
then
Error_Msg_N
("?return type of & is an 8-bit "
@@ -2512,6 +2532,8 @@ package body Freeze is
Is_Tagged_Type
(Designated_Type (R_Type))))
and then Convention (E) = Convention_C
+ and then not Has_Warnings_Off (E)
+ and then not Has_Warnings_Off (R_Type)
then
Error_Msg_N
("?return type of & does not "
@@ -2521,6 +2543,8 @@ package body Freeze is
elsif Ekind (R_Type) = E_Access_Subprogram_Type
and then not Has_Foreign_Convention (R_Type)
+ and then not Has_Warnings_Off (E)
+ and then not Has_Warnings_Off (R_Type)
then
Error_Msg_N
("?& should return a foreign "
@@ -2537,10 +2561,12 @@ package body Freeze is
and then not Is_Imported (E)
and then Has_Foreign_Convention (E)
and then Warn_On_Export_Import
+ and then not Has_Warnings_Off (E)
+ and then not Has_Warnings_Off (Etype (E))
then
Error_Msg_N
("?foreign convention function& should not " &
- "return unconstrained array", E);
+ "return unconstrained array!", E);
-- Ada 2005 (AI-326): Check wrong use of tagged
-- incomplete type
@@ -5233,7 +5259,6 @@ package body Freeze is
Next_Formal (Formal);
end loop;
-
end Process_Default_Expressions;
----------------------------------------
@@ -5266,65 +5291,6 @@ package body Freeze is
end if;
end Set_Component_Alignment_If_Not_Set;
- ---------------------------
- -- Set_Debug_Info_Needed --
- ---------------------------
-
- procedure Set_Debug_Info_Needed (T : Entity_Id) is
- begin
- if No (T)
- or else Needs_Debug_Info (T)
- or else Debug_Info_Off (T)
- then
- return;
- else
- Set_Needs_Debug_Info (T);
- end if;
-
- if Is_Object (T) then
- Set_Debug_Info_Needed (Etype (T));
-
- elsif Is_Type (T) then
- Set_Debug_Info_Needed (Etype (T));
-
- if Is_Record_Type (T) then
- declare
- Ent : Entity_Id := First_Entity (T);
- begin
- while Present (Ent) loop
- Set_Debug_Info_Needed (Ent);
- Next_Entity (Ent);
- end loop;
- end;
-
- elsif Is_Array_Type (T) then
- Set_Debug_Info_Needed (Component_Type (T));
-
- declare
- Indx : Node_Id := First_Index (T);
- begin
- while Present (Indx) loop
- Set_Debug_Info_Needed (Etype (Indx));
- Indx := Next_Index (Indx);
- end loop;
- end;
-
- if Is_Packed (T) then
- Set_Debug_Info_Needed (Packed_Array_Type (T));
- end if;
-
- elsif Is_Access_Type (T) then
- Set_Debug_Info_Needed (Directly_Designated_Type (T));
-
- elsif Is_Private_Type (T) then
- Set_Debug_Info_Needed (Full_View (T));
-
- elsif Is_Protected_Type (T) then
- Set_Debug_Info_Needed (Corresponding_Record_Type (T));
- end if;
- end if;
- end Set_Debug_Info_Needed;
-
------------------
-- Undelay_Type --
------------------
@@ -5439,7 +5405,7 @@ package body Freeze is
if Present (Decl)
and then Nkind (Decl) = N_Pragma
- and then Chars (Decl) = Name_Import
+ and then Pragma_Name (Decl) = Name_Import
then
return;
end if;
diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb
index dc1d469f0c2..6d01843fb22 100644
--- a/gcc/ada/frontend.adb
+++ b/gcc/ada/frontend.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
@@ -59,8 +59,8 @@ with Tbuild; use Tbuild;
with Types; use Types;
procedure Frontend is
- Config_Pragmas : List_Id;
- -- Gather configuration pragmas
+ Config_Pragmas : List_Id;
+ -- Gather configuration pragmas
begin
-- Carry out package initializations. These are initializations which
@@ -78,6 +78,7 @@ begin
Sem_Ch8.Initialize;
Fname.UF.Initialize;
Checks.Initialize;
+ Sem_Warn.Initialize;
-- Create package Standard
@@ -207,6 +208,14 @@ begin
Fmap.Initialize (Mapping_File_Name.all);
end if;
+ -- Adjust Optimize_Alignment mode from debug switches if necessary
+
+ if Debug_Flag_Dot_SS then
+ Optimize_Alignment := 'S';
+ elsif Debug_Flag_Dot_TT then
+ Optimize_Alignment := 'T';
+ end if;
+
-- We have now processed the command line switches, and the gnat.adc
-- file, so this is the point at which we want to capture the values
-- of the configuration switches (see Opt for further details).
@@ -326,6 +335,7 @@ begin
Sem_Warn.Output_Non_Modifed_In_Out_Warnings;
Sem_Warn.Output_Unreferenced_Messages;
Sem_Warn.Check_Unused_Withs;
+ Sem_Warn.Output_Unused_Warnings_Off_Warnings;
end if;
end if;
diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb
index a3ed7579451..d890012eabe 100644
--- a/gcc/ada/layout.adb
+++ b/gcc/ada/layout.adb
@@ -2794,7 +2794,32 @@ package body Layout is
Align : Nat;
begin
- if Unknown_Alignment (E) then
+ -- If alignment is already set, then nothing to do
+
+ if Known_Alignment (E) then
+ return;
+ end if;
+
+ -- Alignment is not known, see if we can set it, taking into account
+ -- the setting of the Optimize_Alignment mode.
+
+ -- If Optimize_Alignment is set to Space, then packed records always
+ -- have an aligmment of 1. But don't do anything for atomic records
+ -- since we may need higher alignment for indivisible access.
+
+ if Optimize_Alignment = 'S'
+ and then Is_Record_Type (E)
+ and then Is_Packed (E)
+ and then not Is_Atomic (E)
+ then
+ Align := 1;
+
+ -- Not a record, or not packed
+
+ else
+ -- The only other cases we worry about here are where the size is
+ -- staticallly known at compile time.
+
if Known_Static_Esize (E) then
Siz := Esize (E);
@@ -2809,8 +2834,8 @@ package body Layout is
-- Size is known, alignment is not set
- -- Reset alignment to match size if size is exactly 2, 4, or 8
- -- storage units.
+ -- Reset alignment to match size if the known size is exactly 2, 4,
+ -- or 8 storage units.
if Siz = 2 * System_Storage_Unit then
Align := 2;
@@ -2819,54 +2844,75 @@ package body Layout is
elsif Siz = 8 * System_Storage_Unit then
Align := 8;
- -- On VMS, also reset for odd "in between" sizes, e.g. a 17-bit
- -- record is given an alignment of 4. This is more consistent with
- -- what DEC Ada does (-gnatd.a turns this off which can be used to
- -- examine the value of this special transformation).
+ -- If Optimize_Alignment is set to Space, then make sure the
+ -- alignment matches the size, for example, if the size is 17
+ -- bytes then we want an alignment of 1 for the type.
+
+ elsif Optimize_Alignment = 'S' then
+ if Siz mod (8 * System_Storage_Unit) = 0 then
+ Align := 8;
+ elsif Siz mod (4 * System_Storage_Unit) = 0 then
+ Align := 4;
+ elsif Siz mod (2 * System_Storage_Unit) = 0 then
+ Align := 2;
+ else
+ Align := 1;
+ end if;
+
+ -- If Optimize_Alignment is set to Time, then we reset for odd
+ -- "in between sizes", for example a 17 bit record is given an
+ -- alignment of 4. Note that this matches the old VMS behavior
+ -- in versions of GNAT prior to 6.1.1.
- elsif OpenVMS_On_Target
- and then not Debug_Flag_Dot_A
+ elsif Optimize_Alignment = 'T'
and then Siz > System_Storage_Unit
+ and then Siz <= 8 * System_Storage_Unit
then
if Siz <= 2 * System_Storage_Unit then
Align := 2;
elsif Siz <= 4 * System_Storage_Unit then
Align := 4;
- elsif Siz <= 8 * System_Storage_Unit then
+ else -- Siz <= 8 * System_Storage_Unit then
Align := 8;
- else
- return;
end if;
- -- No special alignment fiddling needed
+ -- No special alignment fiddling needed
else
return;
end if;
+ end if;
- -- Here Align is set to the proposed improved alignment
+ -- Here we have Set Align to the proposed improved value. Make sure the
+ -- value set does not exceed Maximum_Alignment for the target.
- if Align > Maximum_Alignment then
- Align := Maximum_Alignment;
- end if;
+ if Align > Maximum_Alignment then
+ Align := Maximum_Alignment;
+ end if;
- -- Further processing for record types only to reduce the alignment
- -- set by the above processing in some specific cases. We do not
- -- do this for atomic records, since we need max alignment there.
+ -- Further processing for record types only to reduce the alignment
+ -- set by the above processing in some specific cases. We do not
+ -- do this for atomic records, since we need max alignment there,
- if Is_Record_Type (E) then
+ if Is_Record_Type (E) and then not Is_Atomic (E) then
- -- For records, there is generally no point in setting alignment
- -- higher than word size since we cannot do better than move by
- -- words in any case
+ -- For records, there is generally no point in setting alignment
+ -- higher than word size since we cannot do better than move by
+ -- words in any case. Omit this if we are optimizing for time,
+ -- since conceivably we may be able to do better.
- if Align > System_Word_Size / System_Storage_Unit then
- Align := System_Word_Size / System_Storage_Unit;
- end if;
+ if Align > System_Word_Size / System_Storage_Unit
+ and then Optimize_Alignment /= 'T'
+ then
+ Align := System_Word_Size / System_Storage_Unit;
+ end if;
- -- Check components. If any component requires a higher
- -- alignment, then we set that higher alignment in any case.
+ -- Check components. If any component requires a higher alignment,
+ -- then we set that higher alignment in any case. Don't do this if
+ -- we have Optimize_Alignment set to Space. Note that that covers
+ -- the case of packed records, where we arleady set alignment to 1.
+ if Optimize_Alignment /= 'S' then
declare
Comp : Entity_Id;
@@ -2878,19 +2924,19 @@ package body Layout is
Calign : constant Uint := Alignment (Etype (Comp));
begin
- -- The cases to worry about are when the alignment
- -- of the component type is larger than the alignment
- -- we have so far, and either there is no component
- -- clause for the alignment, or the length set by
- -- the component clause matches the alignment set.
+ -- The cases to process are when the alignment of the
+ -- component type is larger than the alignment we have
+ -- so far, and either there is no component clause for
+ -- the component, or the length set by the component
+ -- clause matches the length of the component type.
if Calign > Align
and then
(Unknown_Esize (Comp)
- or else (Known_Static_Esize (Comp)
- and then
- Esize (Comp) =
- Calign * System_Storage_Unit))
+ or else (Known_Static_Esize (Comp)
+ and then
+ Esize (Comp) =
+ Calign * System_Storage_Unit))
then
Align := UI_To_Int (Calign);
end if;
@@ -2901,16 +2947,17 @@ package body Layout is
end loop;
end;
end if;
+ end if;
- -- Set chosen alignment
+ -- Set chosen alignment, and increase Esize if necessary to match
+ -- the chosen alignment.
- Set_Alignment (E, UI_From_Int (Align));
+ Set_Alignment (E, UI_From_Int (Align));
- if Known_Static_Esize (E)
- and then Esize (E) < Align * System_Storage_Unit
- then
- Set_Esize (E, UI_From_Int (Align * System_Storage_Unit));
- end if;
+ if Known_Static_Esize (E)
+ and then Esize (E) < Align * System_Storage_Unit
+ then
+ Set_Esize (E, UI_From_Int (Align * System_Storage_Unit));
end if;
end Set_Composite_Alignment;
diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb
index 40d5103e78e..bbc29ef3cd1 100644
--- a/gcc/ada/lib-writ.adb
+++ b/gcc/ada/lib-writ.adb
@@ -971,6 +971,11 @@ package body Lib.Writ is
Write_Info_Str (" NS");
end if;
+ if Optimize_Alignment /= 'O' then
+ Write_Info_Str (" O");
+ Write_Info_Char (Optimize_Alignment);
+ end if;
+
if Sec_Stack_Used then
Write_Info_Str (" SS");
end if;
diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads
index b10d01eef26..ba46bf11831 100644
--- a/gcc/ada/lib-writ.ads
+++ b/gcc/ada/lib-writ.ads
@@ -209,7 +209,11 @@ package Lib.Writ is
-- to all units in the file.
--
-- NS Normalize_Scalars pragma in effect for all units in
- -- this file
+ -- this file.
+ --
+ -- OS Optimize_Alignment (Space) active for all units in this file
+ --
+ -- OT Optimize_Alignment (Time) active for all units in this file
--
-- Qx A valid Queueing_Policy pragma applies to all the units
-- in this file, where x is the first character (upper case)
@@ -498,15 +502,15 @@ package Lib.Writ is
-- W unit-name [source-name lib-name] [E] [EA] [ED] [AD]
--
-- One of these lines is present for each unit that is mentioned in
- -- an explicit with clause by the current unit. The first parameter
- -- is the unit name in internal format. The second parameter is the
- -- file name of the file that must be compiled to compile this unit.
- -- It is usually the file for the body, except for packages
- -- which have no body; for units that need a body, if the source file
- -- for the body cannot be found, the file name of the spec is used
- -- instead. The third parameter is the file name of the library
- -- information file that contains the results of compiling this unit.
- -- The optional modifiers are used as follows:
+ -- an explicit with clause by the current unit. The first parameter is
+ -- the unit name in internal format. The second parameter is the file
+ -- name of the file that must be compiled to compile this unit. It is
+ -- usually the file for the body, except for packages which have no
+ -- body. For units that need a body, if the source file for the body
+ -- cannot be found, the file name of the spec is used instead. The
+ -- third parameter is the file name of the library information file
+ -- that contains the results of compiling this unit. The optional
+ -- modifiers are used as follows:
--
-- E pragma Elaborate applies to this unit
--
@@ -528,6 +532,8 @@ package Lib.Writ is
-- of a generic unit compiled with earlier versions of GNAT which
-- did not generate object or ali files for generics.
+ -- In fact W lines include implicit withs ???
+
-- -----------------------
-- -- L Linker_Options --
-- -----------------------
diff --git a/gcc/ada/opt.adb b/gcc/ada/opt.adb
index df1969b4281..64460f60ff6 100644
--- a/gcc/ada/opt.adb
+++ b/gcc/ada/opt.adb
@@ -56,6 +56,7 @@ package body Opt is
External_Name_Exp_Casing_Config := External_Name_Exp_Casing;
External_Name_Imp_Casing_Config := External_Name_Imp_Casing;
Fast_Math_Config := Fast_Math;
+ Optimize_Alignment_Config := Optimize_Alignment;
Persistent_BSS_Mode_Config := Persistent_BSS_Mode;
Polling_Required_Config := Polling_Required;
Use_VADS_Size_Config := Use_VADS_Size;
@@ -77,6 +78,7 @@ package body Opt is
External_Name_Exp_Casing := Save.External_Name_Exp_Casing;
External_Name_Imp_Casing := Save.External_Name_Imp_Casing;
Fast_Math := Save.Fast_Math;
+ Optimize_Alignment := Save.Optimize_Alignment;
Persistent_BSS_Mode := Save.Persistent_BSS_Mode;
Polling_Required := Save.Polling_Required;
Use_VADS_Size := Save.Use_VADS_Size;
@@ -98,6 +100,7 @@ package body Opt is
Save.External_Name_Exp_Casing := External_Name_Exp_Casing;
Save.External_Name_Imp_Casing := External_Name_Imp_Casing;
Save.Fast_Math := Fast_Math;
+ Save.Optimize_Alignment := Optimize_Alignment;
Save.Persistent_BSS_Mode := Persistent_BSS_Mode;
Save.Polling_Required := Polling_Required;
Save.Use_VADS_Size := Use_VADS_Size;
@@ -125,6 +128,7 @@ package body Opt is
Extensions_Allowed := True;
External_Name_Exp_Casing := As_Is;
External_Name_Imp_Casing := Lowercase;
+ Optimize_Alignment := 'O';
Persistent_BSS_Mode := False;
Use_VADS_Size := False;
@@ -151,12 +155,14 @@ package body Opt is
External_Name_Exp_Casing := External_Name_Exp_Casing_Config;
External_Name_Imp_Casing := External_Name_Imp_Casing_Config;
Fast_Math := Fast_Math_Config;
+ Optimize_Alignment := Optimize_Alignment_Config;
Persistent_BSS_Mode := Persistent_BSS_Mode_Config;
Use_VADS_Size := Use_VADS_Size_Config;
end if;
Exception_Locations_Suppressed := Exception_Locations_Suppressed_Config;
Fast_Math := Fast_Math_Config;
+ Optimize_Alignment := Optimize_Alignment_Config;
Polling_Required := Polling_Required_Config;
end Set_Opt_Config_Switches;
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index decd1cc4609..b795a3c240e 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
@@ -858,6 +858,10 @@ package Opt is
-- error is detected then this flag is reset from Generate_Code to
-- Check_Semantics after generating an error message.
+ Optimize_Alignment : Character := 'O';
+ -- Settinng of Optimize_Alignment, set to T/S/O for time/space/off. Can
+ -- be modified by use of pragma Optimize_Alignment.
+
Original_Operating_Mode : Operating_Mode_Type := Generate_Code;
-- GNAT
-- Indicates the original operating mode of the compiler as set by
@@ -1298,6 +1302,12 @@ package Opt is
-- which have a record representation clause but this component does not
-- have a component clause. The default is that this warning is disabled.
+ Warn_On_Warnings_Off : Boolean := False;
+ -- GNAT
+ -- Set to True to generate warnings for use of Pragma Warnings (Off, ent),
+ -- where either the pragma is never used, or it could be replaced by a
+ -- pragma Unmodified or Unreferenced.
+
type Warning_Mode_Type is (Suppress, Normal, Treat_As_Error);
Warning_Mode : Warning_Mode_Type := Normal;
-- GNAT, GNATBIND
@@ -1338,8 +1348,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 the
- -- gnat.adc file.
+ -- line switches, or by the use of appropriate configuration pragmas in a
+ -- configuration pragma file.
Ada_Version_Config : Ada_Version_Type;
-- GNAT
@@ -1416,6 +1426,14 @@ package Opt is
-- used to set the initial value of Fast_Math at the start of each new
-- compilation unit.
+ Optimize_Alignment_Config : Character;
+ -- GNAT
+ -- This is the value of the configuration switch that controls the
+ -- alignment optimization mode, as set by an Optimize_Alignment pragma.
+ -- It is used to set the initial value of Optimize_Alignment at the start
+ -- of each new compilation unit, except that it is always set to 'O' (off)
+ -- for internal units.
+
Persistent_BSS_Mode_Config : Boolean;
-- GNAT
-- This is the value of the configuration switch that controls whether
@@ -1553,6 +1571,7 @@ private
External_Name_Exp_Casing : External_Casing_Type;
External_Name_Imp_Casing : External_Casing_Type;
Fast_Math : Boolean;
+ Optimize_Alignment : Character;
Persistent_BSS_Mode : Boolean;
Polling_Required : Boolean;
Use_VADS_Size : Boolean;
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index 5f49f9f82bd..973968df199 100644
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
@@ -43,8 +43,8 @@ with System.WCh_Con; use System.WCh_Con;
separate (Par)
function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
- Pragma_Name : constant Name_Id := Chars (Pragma_Node);
- Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pragma_Name);
+ Prag_Name : constant Name_Id := Pragma_Name (Pragma_Node);
+ Prag_Id : constant Pragma_Id := Get_Pragma_Id (Prag_Name);
Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node);
Arg_Count : Nat;
Arg_Node : Node_Id;
@@ -241,10 +241,10 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
end loop;
end Process_Restrictions_Or_Restriction_Warnings;
--- Start if processing for Prag
+-- Start of processing for Prag
begin
- Error_Msg_Name_1 := Pragma_Name;
+ Error_Msg_Name_1 := Prag_Name;
-- Ignore unrecognized pragma. We let Sem post the warning for this, since
-- it is a semantic error, not a syntactic one (we have already checked
@@ -626,7 +626,7 @@ begin
-- Source_File_Name_Project pragmas.
begin
- if Get_Pragma_Id (Pragma_Name) = Pragma_Source_File_Name then
+ if Prag_Id = Pragma_Source_File_Name then
if Project_File_In_Use = In_Use then
Error_Msg
("pragma Source_File_Name cannot be used " &
@@ -1135,6 +1135,7 @@ begin
Pragma_No_Strict_Aliasing |
Pragma_Normalize_Scalars |
Pragma_Optimize |
+ Pragma_Optimize_Alignment |
Pragma_Pack |
Pragma_Passive |
Pragma_Preelaborable_Initialization |
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index f0f31cbb629..251805ddf8e 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
@@ -75,6 +75,7 @@ with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes;
with Uintp; use Uintp;
+with Uname; use Uname;
with Urealp; use Urealp;
with Validsw; use Validsw;
@@ -235,6 +236,7 @@ package body Sem_Prag is
procedure Analyze_Pragma (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ Pname : constant Name_Id := Pragma_Name (N);
Prag_Id : Pragma_Id;
Pragma_Exit : exception;
@@ -502,7 +504,7 @@ package body Sem_Prag is
function Is_Configuration_Pragma return Boolean;
-- Deterermines if the placement of the current pragma is appropriate
- -- for a configuration pragma (precedes the current compilation unit).
+ -- for a configuration pragma.
function Is_In_Context_Clause return Boolean;
-- Returns True if pragma appears within the context clause of a unit,
@@ -715,7 +717,7 @@ package body Sem_Prag is
-- Here we have a real error (non-static expression)
else
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Flag_Non_Static_Expr
("argument for pragma% must be a identifier or " &
"static string expression!", Argx);
@@ -909,7 +911,7 @@ package body Sem_Prag is
-- Finally, we have a real error
else
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Flag_Non_Static_Expr
("argument for pragma% must be a static expression!", Argx);
raise Pragma_Exit;
@@ -962,7 +964,7 @@ package body Sem_Prag is
for K in Names'Range loop
if Chars (Arg) = Names (K) then
if K < Highest_So_Far then
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Error_Msg_N
("parameters out of order for pragma%", Arg);
Error_Msg_Name_1 := Names (K);
@@ -1112,7 +1114,7 @@ package body Sem_Prag is
elsif Present (Parameter_Specifications (Specification (P)))
or else not Is_Compilation_Unit (Defining_Entity (P))
then
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Error_Msg_N
("?pragma% is only effective in main program", N);
end if;
@@ -1239,7 +1241,7 @@ package body Sem_Prag is
begin
if Present (Arg) and then Chars (Arg) /= No_Name then
if Chars (Arg) /= Id then
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Error_Msg_Name_2 := Id;
Error_Msg_N ("pragma% argument expects identifier%", Arg);
raise Pragma_Exit;
@@ -1319,9 +1321,9 @@ package body Sem_Prag is
-- Check_Valid_Configuration_Pragma --
--------------------------------------
- -- A configuration pragma must appear in the context clause of
- -- a compilation unit, at the start of the list (i.e. only other
- -- pragmas may precede it).
+ -- A configuration pragma must appear in the context clause of a
+ -- compilation unit, and only other pragmas may preceed it. Note that
+ -- the test also allows use in a configuration pragma file.
procedure Check_Valid_Configuration_Pragma is
begin
@@ -1500,7 +1502,7 @@ package body Sem_Prag is
procedure Error_Pragma (Msg : String) is
begin
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Error_Msg_N (Msg, N);
raise Pragma_Exit;
end Error_Pragma;
@@ -1511,14 +1513,14 @@ package body Sem_Prag is
procedure Error_Pragma_Arg (Msg : String; Arg : Node_Id) is
begin
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Error_Msg_N (Msg, Get_Pragma_Arg (Arg));
raise Pragma_Exit;
end Error_Pragma_Arg;
procedure Error_Pragma_Arg (Msg1, Msg2 : String; Arg : Node_Id) is
begin
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Error_Msg_N (Msg1, Get_Pragma_Arg (Arg));
Error_Pragma_Arg (Msg2, Arg);
end Error_Pragma_Arg;
@@ -1529,7 +1531,7 @@ package body Sem_Prag is
procedure Error_Pragma_Arg_Ident (Msg : String; Arg : Node_Id) is
begin
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Error_Msg_N (Msg, Arg);
raise Pragma_Exit;
end Error_Pragma_Arg_Ident;
@@ -1717,7 +1719,7 @@ package body Sem_Prag is
end if;
if Index = Names'Last then
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Error_Msg_N ("pragma% does not allow & argument", Arg);
-- Check for possible misspelling
@@ -1792,9 +1794,9 @@ package body Sem_Prag is
-- Is_Configuration_Pragma --
-----------------------------
- -- A configuration pragma must appear in the context clause of
- -- a compilation unit, at the start of the list (i.e. only other
- -- pragmas may precede it).
+ -- A configuration pragma must appear in the context clause of a
+ -- compilation unit, and only other pragmas may precede it. Note that
+ -- the test below also permits use in a configuration pragma file.
function Is_Configuration_Pragma return Boolean is
Lis : constant List_Id := List_Containing (N);
@@ -2029,15 +2031,27 @@ package body Sem_Prag is
Ptr : Nat;
CC : Char_Code;
C : Character;
+ Cent : constant Entity_Id :=
+ Cunit_Entity (Current_Sem_Unit);
+
+ Force : constant Boolean :=
+ Prag_Id = Pragma_Compile_Time_Warning
+ and then
+ Is_Spec_Name (Unit_Name (Current_Sem_Unit))
+ and then (Ekind (Cent) /= E_Package
+ or else not In_Private_Part (Cent));
+ -- Set True if this is the warning case, and we are in the
+ -- visible part of a package spec, or in a subprogram spec,
+ -- in which case we want to force the client to see the
+ -- warning, even though it is not in the main unit.
begin
- Cont := False;
- Ptr := 1;
-
-- Loop through segments of message separated by line
-- feeds. We output these segments as separate messages
-- with continuation marks for all but the first.
+ Cont := False;
+ Ptr := 1;
loop
Error_Msg_Strlen := 0;
@@ -2063,11 +2077,33 @@ package body Sem_Prag is
Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
- if Cont = False then
- Error_Msg_N ("<~", Arg1);
- Cont := True;
+ -- If this is a warning in a spec, then we want clients
+ -- to see the warning, so mark the message with the
+ -- special sequence !! to force the warning. In the case
+ -- of a package spec, we do not force this if we are in
+ -- the private part of the spec.
+
+ if Force then
+ if Cont = False then
+ Error_Msg_N ("<~!!", Arg1);
+ Cont := True;
+ else
+ Error_Msg_N ("\<~!!", Arg1);
+ end if;
+
+ -- Error, rather than warning, or in a body, so we do not
+ -- need to force visibility for client (error will be
+ -- output in any case, and this is the situation in which
+ -- we do not want a client to get a warning, since the
+ -- warning is in the body or the spec private part.
+
else
- Error_Msg_N ("\<~", Arg1);
+ if Cont = False then
+ Error_Msg_N ("<~", Arg1);
+ Cont := True;
+ else
+ Error_Msg_N ("\<~", Arg1);
+ end if;
end if;
exit when Ptr > Len;
@@ -2253,7 +2289,7 @@ package body Sem_Prag is
or else
Ekind (E) = E_Named_Real
then
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Error_Msg_N
("cannot apply pragma% to named constant!",
Get_Pragma_Arg (Arg2));
@@ -2713,8 +2749,9 @@ package body Sem_Prag is
elsif Etype (Def_Id) /= Standard_Void_Type
and then
- (Chars (N) = Name_Export_Procedure
- or else Chars (N) = Name_Import_Procedure)
+ (Pname = Name_Export_Procedure
+ or else
+ Pname = Name_Import_Procedure)
then
Match := False;
@@ -2792,7 +2829,7 @@ package body Sem_Prag is
else
if not Ambiguous then
Ambiguous := True;
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Error_Msg_N
("pragma% does not uniquely identify subprogram!",
N);
@@ -4289,7 +4326,7 @@ package body Sem_Prag is
Error_Msg_NE ("entity& was previously imported", N, E);
end if;
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Error_Msg_N
("\(pragma% applies to all previous entities)", N);
@@ -4525,13 +4562,13 @@ package body Sem_Prag is
begin
-- Deal with unrecognized pragma
- if not Is_Pragma_Name (Chars (N)) then
+ if not Is_Pragma_Name (Pname) then
if Warn_On_Unrecognized_Pragma then
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Error_Msg_N ("?unrecognized pragma%!", Pragma_Identifier (N));
for PN in First_Pragma_Name .. Last_Pragma_Name loop
- if Is_Bad_Spelling_Of (Chars (N), PN) then
+ if Is_Bad_Spelling_Of (Pname, PN) then
Error_Msg_Name_1 := PN;
Error_Msg_N
("\?possible misspelling of %!", Pragma_Identifier (N));
@@ -4545,7 +4582,7 @@ package body Sem_Prag is
-- Here to start processing for recognized pragma
- Prag_Id := Get_Pragma_Id (Chars (N));
+ Prag_Id := Get_Pragma_Id (Pname);
-- Preset arguments
@@ -6647,7 +6684,7 @@ package body Sem_Prag is
-- If it's an access-to-subprogram type (in particular, not a
-- subtype), set the flag on that type.
- if Ekind (Named_Entity) in Access_Subprogram_Type_Kind then
+ if Is_Access_Subprogram_Type (Named_Entity) then
Set_Can_Use_Internal_Rep (Named_Entity, False);
-- Otherwise it's an error (name denotes the wrong sort of entity)
@@ -7419,7 +7456,8 @@ package body Sem_Prag is
if Is_Imported (Def_Id)
and then Present (First_Rep_Item (Def_Id))
and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
- and then Chars (First_Rep_Item (Def_Id)) = Name_Interface
+ and then
+ Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
then
null;
else
@@ -8251,9 +8289,9 @@ package body Sem_Prag is
Nod := Next (N);
while Present (Nod) loop
if Nkind (Nod) = N_Pragma
- and then Chars (Nod) = Name_Main
+ and then Pragma_Name (Nod) = Name_Main
then
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Error_Msg_N ("duplicate pragma% not permitted", Nod);
end if;
@@ -8295,9 +8333,9 @@ package body Sem_Prag is
Nod := Next (N);
while Present (Nod) loop
if Nkind (Nod) = N_Pragma
- and then Chars (Nod) = Name_Main_Storage
+ and then Pragma_Name (Nod) = Name_Main_Storage
then
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Error_Msg_N ("duplicate pragma% not permitted", Nod);
end if;
@@ -8684,7 +8722,7 @@ package body Sem_Prag is
-- Optimize --
--------------
- -- pragma Optimize (Time | Space);
+ -- pragma Optimize (Time | Space | Off);
-- The actual check for optimize is done in Gigi. Note that this
-- pragma does not actually change the optimization setting, it
@@ -8695,6 +8733,33 @@ package body Sem_Prag is
Check_Arg_Count (1);
Check_Arg_Is_One_Of (Arg1, Name_Time, Name_Space, Name_Off);
+ ------------------------
+ -- Optimize_Alignment --
+ ------------------------
+
+ -- pragma Optimize_Alignment (Time | Space | Off);
+
+ when Pragma_Optimize_Alignment =>
+ GNAT_Pragma;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+ Check_Valid_Configuration_Pragma;
+
+ declare
+ Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
+ begin
+ case Nam is
+ when Name_Time =>
+ Opt.Optimize_Alignment := 'T';
+ when Name_Space =>
+ Opt.Optimize_Alignment := 'S';
+ when Name_Off =>
+ Opt.Optimize_Alignment := 'O';
+ when others =>
+ Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
+ end case;
+ end;
+
----------
-- Pack --
----------
@@ -10508,9 +10573,9 @@ package body Sem_Prag is
Nod := Next (N);
while Present (Nod) loop
if Nkind (Nod) = N_Pragma
- and then Chars (Nod) = Name_Time_Slice
+ and then Pragma_Name (Nod) = Name_Time_Slice
then
- Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Name_1 := Pname;
Error_Msg_N ("duplicate pragma% not permitted", Nod);
end if;
@@ -11165,6 +11230,12 @@ package body Sem_Prag is
Set_Warnings_Off
(E, (Chars (Expression (Arg1)) = Name_Off));
+ if Chars (Expression (Arg1)) = Name_Off
+ and then Warn_On_Warnings_Off
+ then
+ Warnings_Off_Pragmas.Append ((N, E));
+ end if;
+
if Is_Enumeration_Type (E) then
declare
Lit : Entity_Id;
@@ -11296,9 +11367,9 @@ package body Sem_Prag is
function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
begin
- return Chars (N) = Name_Interrupt_State
+ return Pragma_Name (N) = Name_Interrupt_State
or else
- Chars (N) = Name_Priority_Specific_Dispatching;
+ Pragma_Name (N) = Name_Priority_Specific_Dispatching;
end Delay_Config_Pragma_Analyze;
-------------------------
@@ -11496,6 +11567,7 @@ package body Sem_Prag is
Pragma_Normalize_Scalars => -1,
Pragma_Obsolescent => 0,
Pragma_Optimize => -1,
+ Pragma_Optimize_Alignment => -1,
Pragma_Pack => 0,
Pragma_Page => -1,
Pragma_Passive => -1,
@@ -11575,7 +11647,7 @@ package body Sem_Prag is
return False;
else
- C := Sig_Flags (Get_Pragma_Id (Chars (Parent (P))));
+ C := Sig_Flags (Get_Pragma_Id (Parent (P)));
case C is
when -1 =>
@@ -11612,7 +11684,7 @@ package body Sem_Prag is
function Is_Pragma_String_Literal (Par : Node_Id) return Boolean is
Pragn : constant Node_Id := Parent (Par);
Assoc : constant List_Id := Pragma_Argument_Associations (Pragn);
- Pname : constant Name_Id := Chars (Pragn);
+ Pname : constant Name_Id := Pragma_Name (Pragn);
Argn : Natural;
N : Node_Id;
@@ -11686,7 +11758,7 @@ package body Sem_Prag is
if Present (PA) then
P := First (PA);
while Present (P) loop
- if Chars (P) = Name_Suppress_All then
+ if Pragma_Name (P) = Name_Suppress_All then
Prepend_To (Context_Items (N),
Make_Pragma (Sloc (P),
Chars => Name_Suppress,
View Lorry Controller Status