From: Robert Dewar Date: Wed, 26 Mar 2008 07:36:02 +0000 (+0100) Subject: ali.ads, ali.adb (Optimize_Alignment_Setting): New field in ALI record X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=1b24ada5aba090c1b641353f94cba86730c99105;p=gcc.git ali.ads, ali.adb (Optimize_Alignment_Setting): New field in ALI record 2008-03-26 Robert Dewar * 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 From-SVN: r133549 --- 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,