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,
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
-- 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;
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;
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;
-- 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
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 --
-------------------------------------
-- --
-- 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- --
-- 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
-- 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
-- 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
-- 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.
-- 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
-- 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.
-- 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
-- --
-- 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- --
-- 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.
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;
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
-- 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;
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
-- 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);
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;
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 "
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 "
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 "
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 "
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
Next_Formal (Formal);
end loop;
-
end Process_Default_Expressions;
----------------------------------------
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 --
------------------
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;
-- --
-- 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- --
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
Sem_Ch8.Initialize;
Fname.UF.Initialize;
Checks.Initialize;
+ Sem_Warn.Initialize;
-- Create package Standard
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).
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;
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);
-- 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;
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;
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;
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;
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;
-- 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)
-- 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
--
-- 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 --
-- -----------------------
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;
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;
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;
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;
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;
-- --
-- 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- --
-- 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
-- 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
-- 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
-- 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
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;
-- --
-- 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- --
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;
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
-- 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 " &
Pragma_No_Strict_Aliasing |
Pragma_Normalize_Scalars |
Pragma_Optimize |
+ Pragma_Optimize_Alignment |
Pragma_Pack |
Pragma_Passive |
Pragma_Preelaborable_Initialization |
-- --
-- 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- --
with Tbuild; use Tbuild;
with Ttypes;
with Uintp; use Uintp;
+with Uname; use Uname;
with Urealp; use Urealp;
with Validsw; use Validsw;
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;
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,
-- 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);
-- 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;
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);
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;
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;
-- 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
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;
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;
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;
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
-- 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);
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;
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;
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));
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;
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);
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);
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));
-- Here to start processing for recognized pragma
- Prag_Id := Get_Pragma_Id (Chars (N));
+ Prag_Id := Get_Pragma_Id (Pname);
-- Preset arguments
-- 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)
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
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;
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;
-- 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
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 --
----------
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;
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;
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;
-------------------------
Pragma_Normalize_Scalars => -1,
Pragma_Obsolescent => 0,
Pragma_Optimize => -1,
+ Pragma_Optimize_Alignment => -1,
Pragma_Pack => 0,
Pragma_Page => -1,
Pragma_Passive => -1,
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 =>
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;
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,
OSDN Git Service
