Skip to content

R
riscv-gcc-1
Commit ce4a6e84 by Robert Dewar Committed by Arnaud Charlet
Options

fe.h: Remove global Optimize_Alignment flag, no longer used 

2008-04-08  Robert Dewar  <dewar@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>
	    Javier Miranda  <miranda@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* fe.h: Remove global Optimize_Alignment flag, no longer used

	* layout.adb: Test Optimize_Alignment flags rather than global switch

	* lib.ads, lib.adb: New OA_Setting field in library record

	* lib-load.adb: New OA_Setting field in library record

	* lib-writ.ads, lib-writ.adb (Collect_Withs, Write_With_Lines): Place
	units mentioned in limited_with_ clauses in the ali file, with an
	'Y' marker.
	New Ox fields in U line

	* opt.adb: New flag Optimize_Alignment_Local
	(Check_Policy_List[_Config]): New flags

	* opt.ads (Invalid_Value_Used): New flag
	New switch Optimize_Alignment_Local
	(Warn_On_Parameter_Order): New flag
	(Check_Policy_List[_Config]): New flags

	* ali.ads, ali.adb: Add indicator 'Y' to mark mark the presence of
	limited_with clauses.
	New data structures for Optimize_Alignment

	* bcheck.adb (Check_Consistent_Restriction_No_Default_Initialization):
	New procedure
	(Check_Consistent_Optimize_Alignment): Rework for new structure
	(Check_Consistent_Restrictions): Fix incorrect error message

	sem_ch10.adb (Decorate_Tagged_Type): Set the Parent field of a newly
	created class-wide type (to the Parent field of the specific type).
	(Install_Siblings): Handle properly private_with_clauses on subprogram
	bodies and on generic units.
	(Analyze_With_Clause, Install_Limited_Withed_Unit): Guard against an
	illegal limited_with_clause that names a non-existent package.
	(Check_Body_Required): Determine whether a unit named a limited_with
	clause needs a body.
	(Analyze_Context): A limited_with_clause is illegal on a unit_renaming.
	Capture Optimize_Alignment settings to set new OA_Setting field in
	library record.
	(Build_Limited_Views): Include task and protected type declarations.

	* sem_ch3.ads, sem_ch3.adb (Analyze_Object_Declaration): Handle the
	case of a possible constant redeclaration where the current object is
	an entry index constant.
	(Analyze_Object_Declaration): Generate an error in case of CPP
	class-wide object initialization.
	(Analyze_Object_Declaration): Add extra information on warnings for
	declaration of unconstrained objects.
	(Access_Type_Declaration): Set Associated_Final_Chain to Empty, to avoid
	conflicts with the setting of Stored_Constraint in the case where the
	access type entity has already been created as an E_Incomplete_Type due
	to a limited with clause.
	Use new Is_Standard_Character_Type predicate
	(Analyze_Object_Declaration): Apply access_constant check only after
	expression has been resolved, given that it may be overloaded with
	several access types.
	(Constant_Redeclaration): Additional legality checks for deferred
	constant declarations tha involve anonymous access types and/or null
	exclusion indicators.
	(Analyze_Type_Declaration): Set Optimize_Alignment flags
	(Analyze_Subtype_Declaration): Ditto
	(Analyze_Object_Declaration): Ditto
	(Analyze_Object_Declaration): Don't count tasks in generics
	Change name In_Default_Expression      => In_Spec_Expression
	Change name Analyze_Per_Use_Expression => Preanalyze_Spec_Expression
	Change name Pre_Analyze_And_Resolve    => Preanalyze_And_Resolve
	(Process_Discriminants): Additional check for illegal use of default
	expressions in access discriminant specifications in a type that is not
	explicitly limited.
	(Check_Abstract_Overriding): If an inherited function dispaches on an
	access result, it must be overridden, even if the type is a null
	extension.
	(Derive_Subprogram): The formals of the derived subprogram have the
	names and defaults of the parent subprogram, even if the type is
	obtained from the actual subprogram.
	(Derive_Subprogram): In the presence of interfaces, a formal of an
	inherited operation has the derived type not only if it descends from
	the type of the formal of the parent operation, but also if it
	implements it. This is relevant for the renamings created for the
	primitive operations of the actual for a formal derived type.
	(Is_Progenitor): New predicate, to determine whether the type of a
	formal in the parent operation must be replaced by the derived type.

	* sem_util.ads, sem_util.adb (Has_Overriding_Initialize): Make
	predicate recursive to handle components that have a user-defined
	Initialize procedure. Handle controlled derived types whose ancestor
	has a user-defined Initialize procedured.
	(Note_Possible_Modification): Add Sure parameter, generate warning if
	sure modification of constant
	Use new Is_Standard_Character_Type predicate
	(Find_Parameter_Type): when determining whether a protected operation
	implements an interface operation, retrieve the type of the formal from
	the entity when the formal is an access parameter or an
	anonymous-access-to-subprogram.
	Move Copy_Parameter_List to sem_util, for use when building stubbed
	subprogram bodies.
	(Has_Access_Values): Tagged types now return False
	(Within_HSS_Or_If): New procedure
	(Set_Optimize_Alignment_Flags): New procedure
	Change name In_Default_Expression      => In_Spec_Expression
	Change name Analyze_Per_Use_Expression => Preanalyze_Spec_Expression
	Change name Pre_Analyze_And_Resolve    => Preanalyze_And_Resolve

From-SVN: r134011
parent 21d27997
Showing with 379 additions and 165 deletions
gcc/ada/ali.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -53,6 +53,7 @@ package body ALI is ...@@ -53,6 +53,7 @@ package body ALI is
'D' => True, -- dependency 'D' => True, -- dependency
'X' => True, -- xref 'X' => True, -- xref
'S' => True, -- specific dispatching 'S' => True, -- specific dispatching
'Y' => True, -- limited_with
others => False); others => False);
-------------------- --------------------
...@@ -772,7 +773,7 @@ package body ALI is ...@@ -772,7 +773,7 @@ package body ALI is
-- Acquire lines to be ignored -- Acquire lines to be ignored
if Read_Xref then if Read_Xref then
Ignore := ('U' | 'W' | 'D' | 'X' => False, others => True); Ignore := ('U' | 'W' | 'Y' | 'D' | 'X' => False, others => True);
-- Read_Lines parameter given -- Read_Lines parameter given
...@@ -818,7 +819,6 @@ package body ALI is ...@@ -818,7 +819,6 @@ package body ALI is
No_Object => False, No_Object => False,
Normalize_Scalars => False, Normalize_Scalars => False,
Ofile_Full_Name => Full_Object_File_Name, Ofile_Full_Name => Full_Object_File_Name,
Optimize_Alignment_Setting => 'O',
Queuing_Policy => ' ', Queuing_Policy => ' ',
Restrictions => No_Restrictions, Restrictions => No_Restrictions,
SAL_Interface => False, SAL_Interface => False,
...@@ -1041,11 +1041,6 @@ package body ALI is ...@@ -1041,11 +1041,6 @@ package body ALI is
Fatal_Error_Ignore; Fatal_Error_Ignore;
end if; end if;
-- Processing for Ox
elsif C = 'O' then
ALIs.Table (Id).Optimize_Alignment_Setting := Getc;
-- Processing for Qx -- Processing for Qx
elsif C = 'Q' then elsif C = 'Q' then
...@@ -1424,6 +1419,7 @@ package body ALI is ...@@ -1424,6 +1419,7 @@ package body ALI is
UL.SAL_Interface := ALIs.Table (Id).SAL_Interface; UL.SAL_Interface := ALIs.Table (Id).SAL_Interface;
UL.Body_Needed_For_SAL := False; UL.Body_Needed_For_SAL := False;
UL.Elaborate_Body_Desirable := False; UL.Elaborate_Body_Desirable := False;
UL.Optimize_Alignment := 'O';
if Debug_Flag_U then if Debug_Flag_U then
Write_Str (" ----> reading unit "); Write_Str (" ----> reading unit ");
...@@ -1626,6 +1622,19 @@ package body ALI is ...@@ -1626,6 +1622,19 @@ package body ALI is
Check_At_End_Of_Field; Check_At_End_Of_Field;
-- OL/OO/OS/OT parameters
elsif C = 'O' then
C := Getc;
if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then
Units.Table (Units.Last).Optimize_Alignment := C;
else
Fatal_Error_Ignore;
end if;
Check_At_End_Of_Field;
-- RC/RT parameters -- RC/RT parameters
elsif C = 'R' then elsif C = 'R' then
...@@ -1678,7 +1687,7 @@ package body ALI is ...@@ -1678,7 +1687,7 @@ package body ALI is
With_Loop : loop With_Loop : loop
Check_Unknown_Line; Check_Unknown_Line;
exit With_Loop when C /= 'W'; exit With_Loop when C /= 'W' and then C /= 'Y';
if Ignore ('W') then if Ignore ('W') then
Skip_Line; Skip_Line;
...@@ -1693,6 +1702,7 @@ package body ALI is ...@@ -1693,6 +1702,7 @@ package body ALI is
Withs.Table (Withs.Last).Elab_Desirable := False; Withs.Table (Withs.Last).Elab_Desirable := False;
Withs.Table (Withs.Last).Elab_All_Desirable := False; Withs.Table (Withs.Last).Elab_All_Desirable := False;
Withs.Table (Withs.Last).SAL_Interface := False; Withs.Table (Withs.Last).SAL_Interface := False;
Withs.Table (Withs.Last).Limited_With := (C = 'Y');
-- Generic case with no object file available -- Generic case with no object file available
......
gcc/ada/ali.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -176,11 +176,6 @@ package ALI is ...@@ -176,11 +176,6 @@ package ALI is
-- Set to True if file was compiled with Normalize_Scalars. Not set if -- Set to True if file was compiled with Normalize_Scalars. Not set if
-- 'P' appears in Ignore_Lines. -- '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; Unit_Exception_Table : Boolean;
-- Set to True if unit exception table pointer generated. Not set if 'P' -- Set to True if unit exception table pointer generated. Not set if 'P'
-- appears in Ignore_Lines. -- appears in Ignore_Lines.
...@@ -358,6 +353,9 @@ package ALI is ...@@ -358,6 +353,9 @@ package ALI is
-- for the body right after the call for the spec, or at least as close -- for the body right after the call for the spec, or at least as close
-- together as possible. -- together as possible.
Optimize_Alignment : Character;
-- Optimize_Alignment setting. Set to L/S/T/O for OL/OS/OT/OO present
end record; end record;
package Units is new Table.Table ( package Units is new Table.Table (
...@@ -539,6 +537,8 @@ package ALI is ...@@ -539,6 +537,8 @@ package ALI is
SAL_Interface : Boolean := False; SAL_Interface : Boolean := False;
-- True if the Unit is an Interface of a Stand-Alone Library -- True if the Unit is an Interface of a Stand-Alone Library
Limited_With : Boolean := False;
-- True if unit is named in a limited_with_clause
end record; end record;
package Withs is new Table.Table ( package Withs is new Table.Table (
...@@ -669,8 +669,8 @@ package ALI is ...@@ -669,8 +669,8 @@ package ALI is
-- Sdep (Source Dependency) Table -- -- Sdep (Source Dependency) Table --
------------------------------------ ------------------------------------
-- Each source dependency (D line) in an ALI file generates an -- Each source dependency (D line) in an ALI file generates an entry in the
-- entry in the Sdep table. -- Sdep table.
-- Note: there will be no entries in this table if 'D' lines are ignored -- Note: there will be no entries in this table if 'D' lines are ignored
...@@ -678,9 +678,9 @@ package ALI is ...@@ -678,9 +678,9 @@ package ALI is
-- Special value indicating no Sdep table entry -- Special value indicating no Sdep table entry
First_Sdep_Entry : Sdep_Id := No_Sdep_Id + 1; First_Sdep_Entry : Sdep_Id := No_Sdep_Id + 1;
-- Id of first Sdep entry for current ali file. This is initialized to -- Id of first Sdep entry for current ali file. This is initialized to the
-- the first Sdep entry in the table, and then incremented appropriately -- first Sdep entry in the table, and then incremented appropriately as
-- as successive ALI files are scanned. -- successive ALI files are scanned.
type Sdep_Record is record type Sdep_Record is record
...@@ -688,24 +688,23 @@ package ALI is ...@@ -688,24 +688,23 @@ package ALI is
-- Name of source file -- Name of source file
Stamp : Time_Stamp_Type; Stamp : Time_Stamp_Type;
-- Time stamp value. Note that this will be all zero characters -- Time stamp value. Note that this will be all zero characters for the
-- for the dummy entries for missing or non-dependent files. -- dummy entries for missing or non-dependent files.
Checksum : Word; Checksum : Word;
-- Checksum value. Note that this will be all zero characters -- Checksum value. Note that this will be all zero characters for the
-- for the dummy entries for missing or non-dependent files -- dummy entries for missing or non-dependent files
Dummy_Entry : Boolean; Dummy_Entry : Boolean;
-- Set True for dummy entries that correspond to missing files -- Set True for dummy entries that correspond to missing files or files
-- or files where no dependency relationship exists. -- where no dependency relationship exists.
Subunit_Name : Name_Id; Subunit_Name : Name_Id;
-- Name_Id for subunit name if present, else No_Name -- Name_Id for subunit name if present, else No_Name
Rfile : File_Name_Type; Rfile : File_Name_Type;
-- Reference file name. Same as Sfile unless a Source_Reference -- Reference file name. Same as Sfile unless a Source_Reference pragma
-- pragma was used, in which case it reflects the name used in -- was used, in which case it reflects the name used in the pragma.
-- the pragma.
Start_Line : Nat; Start_Line : Nat;
-- Starting line number in file. Always 1, unless a Source_Reference -- Starting line number in file. Always 1, unless a Source_Reference
...@@ -726,8 +725,8 @@ package ALI is ...@@ -726,8 +725,8 @@ package ALI is
-- Use of Name Table Info -- -- Use of Name Table Info --
---------------------------- ----------------------------
-- All unit names and file names are entered into the Names table. The -- All unit names and file names are entered into the Names table. The Info
-- Info fields of these entries are used as follows: -- fields of these entries are used as follows:
-- Unit name Info field has Unit_Id of unit table entry -- Unit name Info field has Unit_Id of unit table entry
-- ALI file name Info field has ALI_Id of ALI table entry -- ALI file name Info field has ALI_Id of ALI table entry
...@@ -737,8 +736,8 @@ package ALI is ...@@ -737,8 +736,8 @@ package ALI is
-- Cross-Reference Data -- -- Cross-Reference Data --
-------------------------- --------------------------
-- The following table records cross-reference sections, there is one -- The following table records cross-reference sections, there is one entry
-- entry for each X header line in the ALI file for an xref section. -- for each X header line in the ALI file for an xref section.
-- Note: there will be no entries in this table if 'X' lines are ignored -- Note: there will be no entries in this table if 'X' lines are ignored
......
gcc/ada/bcheck.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -43,7 +43,7 @@ package body Bcheck is ...@@ -43,7 +43,7 @@ package body Bcheck is
----------------------- -----------------------
-- The following checking subprograms make up the parts of the -- The following checking subprograms make up the parts of the
-- configuration consistency check. -- configuration consistency check. See bodies for details of checks.
procedure Check_Consistent_Dispatching_Policy; procedure Check_Consistent_Dispatching_Policy;
procedure Check_Consistent_Dynamic_Elaboration_Checking; procedure Check_Consistent_Dynamic_Elaboration_Checking;
...@@ -54,6 +54,7 @@ package body Bcheck is ...@@ -54,6 +54,7 @@ package body Bcheck is
procedure Check_Consistent_Optimize_Alignment; procedure Check_Consistent_Optimize_Alignment;
procedure Check_Consistent_Queuing_Policy; procedure Check_Consistent_Queuing_Policy;
procedure Check_Consistent_Restrictions; procedure Check_Consistent_Restrictions;
procedure Check_Consistent_Restriction_No_Default_Initialization;
procedure Check_Consistent_Zero_Cost_Exception_Handling; procedure Check_Consistent_Zero_Cost_Exception_Handling;
procedure Consistency_Error_Msg (Msg : String); procedure Consistency_Error_Msg (Msg : String);
...@@ -90,6 +91,7 @@ package body Bcheck is ...@@ -90,6 +91,7 @@ package body Bcheck is
Check_Consistent_Optimize_Alignment; Check_Consistent_Optimize_Alignment;
Check_Consistent_Dynamic_Elaboration_Checking; Check_Consistent_Dynamic_Elaboration_Checking;
Check_Consistent_Restrictions; Check_Consistent_Restrictions;
Check_Consistent_Restriction_No_Default_Initialization;
Check_Consistent_Interrupt_States; Check_Consistent_Interrupt_States;
Check_Consistent_Dispatching_Policy; Check_Consistent_Dispatching_Policy;
end Check_Configuration_Consistency; end Check_Configuration_Consistency;
...@@ -700,34 +702,40 @@ package body Bcheck is ...@@ -700,34 +702,40 @@ package body Bcheck is
-- Check_Consistent_Optimize_Alignment -- -- Check_Consistent_Optimize_Alignment --
----------------------------------------- -----------------------------------------
-- The rule is that all units other than internal units must be compiled -- The rule is that all units which depend on the global default setting
-- with the same setting for Optimize_Alignment. We can exclude internal -- of Optimize_Alignment must be compiled with the same settinng for this
-- units since they are forced to compile with Optimize_Alignment (Off). -- default. Units which specify an explicit local value for this setting
-- are exempt from the consistency rule (this includes all internal units).
procedure Check_Consistent_Optimize_Alignment is procedure Check_Consistent_Optimize_Alignment is
OA_Setting : Character := ' '; OA_Setting : Character := ' ';
-- Reset when we find a non-internal unit -- Reset when we find a unit that depends on the default and does
-- not have a local specification of the Optimize_Alignment setting.
OA_Unit : ALI_Id; OA_Unit : Unit_Id;
-- Id of unit from which OA_Setting was set -- Id of unit from which OA_Setting was set
C : Character;
begin begin
for A in ALIs.First .. ALIs.Last loop for U in First_Unit_Entry .. Units.Last loop
if not Is_Internal_File_Name (ALIs.Table (A).Afile) then C := Units.Table (U).Optimize_Alignment;
if C /= 'L' then
if OA_Setting = ' ' then if OA_Setting = ' ' then
OA_Setting := ALIs.Table (A).Optimize_Alignment_Setting; OA_Setting := C;
OA_Unit := A; OA_Unit := U;
elsif OA_Setting = ALIs.Table (A).Optimize_Alignment_Setting then elsif OA_Setting = C then
null; null;
else else
Error_Msg_File_1 := ALIs.Table (OA_Unit).Sfile; Error_Msg_Unit_1 := Units.Table (OA_Unit).Uname;
Error_Msg_File_2 := ALIs.Table (A).Sfile; Error_Msg_Unit_2 := Units.Table (U).Uname;
Consistency_Error_Msg Consistency_Error_Msg
("{ and { compiled with different " ("$ and $ compiled with different "
& "Optimize_Alignment settings"); & "default Optimize_Alignment settings");
return; return;
end if; end if;
end if; end if;
...@@ -775,10 +783,9 @@ package body Bcheck is ...@@ -775,10 +783,9 @@ package body Bcheck is
-- Check_Consistent_Restrictions -- -- Check_Consistent_Restrictions --
----------------------------------- -----------------------------------
-- The rule is that if a restriction is specified in any unit, -- The rule is that if a restriction is specified in any unit, then all
-- then all units must obey the restriction. The check applies -- units must obey the restriction. The check applies only to restrictions
-- only to restrictions which require partition wide consistency, -- which require partition wide consistency, and not to internal units.
-- and not to internal units.
procedure Check_Consistent_Restrictions is procedure Check_Consistent_Restrictions is
Restriction_File_Output : Boolean; Restriction_File_Output : Boolean;
...@@ -811,7 +818,7 @@ package body Bcheck is ...@@ -811,7 +818,7 @@ package body Bcheck is
declare declare
M1 : constant String := "{ has restriction "; M1 : constant String := "{ has restriction ";
S : constant String := Restriction_Id'Image (R); S : constant String := Restriction_Id'Image (R);
M2 : String (1 .. 200); -- big enough! M2 : String (1 .. 2000); -- big enough!
P : Integer; P : Integer;
begin begin
...@@ -902,7 +909,7 @@ package body Bcheck is ...@@ -902,7 +909,7 @@ package body Bcheck is
(" { (count = at least #)"); (" { (count = at least #)");
else else
Consistency_Error_Msg Consistency_Error_Msg
(" % (count = #)"); (" { (count = #)");
end if; end if;
end if; end if;
end if; end if;
...@@ -950,6 +957,75 @@ package body Bcheck is ...@@ -950,6 +957,75 @@ package body Bcheck is
end loop; end loop;
end Check_Consistent_Restrictions; end Check_Consistent_Restrictions;
------------------------------------------------------------
-- Check_Consistent_Restriction_No_Default_Initialization --
------------------------------------------------------------
-- The Restriction (No_Default_Initialization) has special consistency
-- rules. The rule is that no unit compiled without this restriction
-- that violates the restriction can WITH a unit that is compiled with
-- the restriction.
procedure Check_Consistent_Restriction_No_Default_Initialization is
begin
-- Nothing to do if no one set this restriction
if not Cumulative_Restrictions.Set (No_Default_Initialization) then
return;
end if;
-- Nothing to do if no one violates the restriction
if not Cumulative_Restrictions.Violated (No_Default_Initialization) then
return;
end if;
-- Otherwise we go into a full scan to find possible problems
for U in Units.First .. Units.Last loop
declare
UTE : Unit_Record renames Units.Table (U);
ATE : ALIs_Record renames ALIs.Table (UTE.My_ALI);
begin
if ATE.Restrictions.Violated (No_Default_Initialization) then
for W in UTE.First_With .. UTE.Last_With loop
declare
AFN : constant File_Name_Type := Withs.Table (W).Afile;
begin
-- The file name may not be present for withs of certain
-- generic run-time files. The test can be safely left
-- out in such cases anyway.
if AFN /= No_File then
declare
WAI : constant ALI_Id :=
ALI_Id (Get_Name_Table_Info (AFN));
WTE : ALIs_Record renames ALIs.Table (WAI);
begin
if WTE.Restrictions.Set
(No_Default_Initialization)
then
Error_Msg_Unit_1 := UTE.Uname;
Consistency_Error_Msg
("unit $ compiled without restriction "
& "No_Default_Initialization");
Error_Msg_Unit_1 := Withs.Table (W).Uname;
Consistency_Error_Msg
("withs unit $, compiled with restriction "
& "No_Default_Initialization");
end if;
end;
end if;
end;
end loop;
end if;
end;
end loop;
end Check_Consistent_Restriction_No_Default_Initialization;
--------------------------------------------------- ---------------------------------------------------
-- Check_Consistent_Zero_Cost_Exception_Handling -- -- Check_Consistent_Zero_Cost_Exception_Handling --
--------------------------------------------------- ---------------------------------------------------
...@@ -1056,15 +1132,7 @@ package body Bcheck is ...@@ -1056,15 +1132,7 @@ package body Bcheck is
-- If consistency errors are tolerated, -- If consistency errors are tolerated,
-- output the message as a warning. -- output the message as a warning.
declare Error_Msg ('?' & Msg);
Warning_Msg : String (1 .. Msg'Length + 1);
begin
Warning_Msg (1) := '?';
Warning_Msg (2 .. Warning_Msg'Last) := Msg;
Error_Msg (Warning_Msg);
end;
-- Otherwise the consistency error is a true error -- Otherwise the consistency error is a true error
......
gcc/ada/fe.h
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Header File * * C Header File *
* * * *
* 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 * * 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- * * terms of the GNU General Public License as published by the Free Soft- *
...@@ -46,11 +46,11 @@ extern char Fold_Lower[], Fold_Upper[]; ...@@ -46,11 +46,11 @@ extern char Fold_Lower[], Fold_Upper[];
/* debug: */ /* debug: */
#define Debug_Flag_XX debug__debug_flag_xx
#define Debug_Flag_NN debug__debug_flag_nn #define Debug_Flag_NN debug__debug_flag_nn
#define Debug_Flag_Dot_A debug__debug_flag_dot_a
extern Boolean Debug_Flag_XX;
extern Boolean Debug_Flag_NN; extern Boolean Debug_Flag_NN;
extern Boolean Debug_Flag_Dot_A;
/* einfo: We will be setting Esize for types, Component_Bit_Offset for fields, /* einfo: We will be setting Esize for types, Component_Bit_Offset for fields,
Alignment for types and objects, Component_Size for array types, and Alignment for types and objects, Component_Size for array types, and
......
gcc/ada/layout.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2001-2007, Free Software Foundation, Inc. -- -- Copyright (C) 2001-2008, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -2807,7 +2807,7 @@ package body Layout is ...@@ -2807,7 +2807,7 @@ package body Layout is
-- have an alignment of 1. But don't do anything for atomic records -- have an alignment of 1. But don't do anything for atomic records
-- since we may need higher alignment for indivisible access. -- since we may need higher alignment for indivisible access.
if Optimize_Alignment = 'S' if Optimize_Alignment_Space (E)
and then Is_Record_Type (E) and then Is_Record_Type (E)
and then Is_Packed (E) and then Is_Packed (E)
and then not Is_Atomic (E) and then not Is_Atomic (E)
...@@ -2848,7 +2848,7 @@ package body Layout is ...@@ -2848,7 +2848,7 @@ package body Layout is
-- alignment matches the size, for example, if the size is 17 -- alignment matches the size, for example, if the size is 17
-- bytes then we want an alignment of 1 for the type. -- bytes then we want an alignment of 1 for the type.
elsif Optimize_Alignment = 'S' then elsif Optimize_Alignment_Space (E) then
if Siz mod (8 * System_Storage_Unit) = 0 then if Siz mod (8 * System_Storage_Unit) = 0 then
Align := 8; Align := 8;
elsif Siz mod (4 * System_Storage_Unit) = 0 then elsif Siz mod (4 * System_Storage_Unit) = 0 then
...@@ -2864,7 +2864,7 @@ package body Layout is ...@@ -2864,7 +2864,7 @@ package body Layout is
-- alignment of 4. Note that this matches the old VMS behavior -- alignment of 4. Note that this matches the old VMS behavior
-- in versions of GNAT prior to 6.1.1. -- in versions of GNAT prior to 6.1.1.
elsif Optimize_Alignment = 'T' elsif Optimize_Alignment_Time (E)
and then Siz > System_Storage_Unit and then Siz > System_Storage_Unit
and then Siz <= 8 * System_Storage_Unit and then Siz <= 8 * System_Storage_Unit
then then
...@@ -2902,7 +2902,7 @@ package body Layout is ...@@ -2902,7 +2902,7 @@ package body Layout is
-- since conceivably we may be able to do better. -- since conceivably we may be able to do better.
if Align > System_Word_Size / System_Storage_Unit if Align > System_Word_Size / System_Storage_Unit
and then Optimize_Alignment /= 'T' and then not Optimize_Alignment_Time (E)
then then
Align := System_Word_Size / System_Storage_Unit; Align := System_Word_Size / System_Storage_Unit;
end if; end if;
...@@ -2912,7 +2912,7 @@ package body Layout is ...@@ -2912,7 +2912,7 @@ package body Layout is
-- we have Optimize_Alignment set to Space. Note that that covers -- we have Optimize_Alignment set to Space. Note that that covers
-- the case of packed records, where we already set alignment to 1. -- the case of packed records, where we already set alignment to 1.
if Optimize_Alignment /= 'S' then if not Optimize_Alignment_Space (E) then
declare declare
Comp : Entity_Id; Comp : Entity_Id;
......
gcc/ada/lib-load.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -224,7 +224,8 @@ package body Lib.Load is ...@@ -224,7 +224,8 @@ package body Lib.Load is
Source_Index => No_Source_File, Source_Index => No_Source_File,
Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False), Unit_File_Name => Get_File_Name (Spec_Name, Subunit => False),
Unit_Name => Spec_Name, Unit_Name => Spec_Name,
Version => 0); Version => 0,
OA_Setting => 'O');
Set_Comes_From_Source_Default (Save_CS); Set_Comes_From_Source_Default (Save_CS);
Set_Error_Posted (Cunit_Entity); Set_Error_Posted (Cunit_Entity);
...@@ -327,7 +328,8 @@ package body Lib.Load is ...@@ -327,7 +328,8 @@ package body Lib.Load is
Source_Index => Main_Source_File, Source_Index => Main_Source_File,
Unit_File_Name => Fname, Unit_File_Name => Fname,
Unit_Name => No_Unit_Name, Unit_Name => No_Unit_Name,
Version => Version); Version => Version,
OA_Setting => 'O');
end if; end if;
end Load_Main_Source; end Load_Main_Source;
...@@ -647,7 +649,8 @@ package body Lib.Load is ...@@ -647,7 +649,8 @@ package body Lib.Load is
Source_Index => Src_Ind, Source_Index => Src_Ind,
Unit_File_Name => Fname, Unit_File_Name => Fname,
Unit_Name => Uname_Actual, Unit_Name => Uname_Actual,
Version => Source_Checksum (Src_Ind)); Version => Source_Checksum (Src_Ind),
OA_Setting => 'O');
-- Parse the new unit -- Parse the new unit
......
gcc/ada/lib-writ.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -87,7 +87,8 @@ package body Lib.Writ is ...@@ -87,7 +87,8 @@ package body Lib.Writ is
Munit_Index => 0, Munit_Index => 0,
Serial_Number => 0, Serial_Number => 0,
Version => 0, Version => 0,
Error_Location => No_Location); Error_Location => No_Location,
OA_Setting => 'O');
end Add_Preprocessing_Dependency; end Add_Preprocessing_Dependency;
------------------------------ ------------------------------
...@@ -141,7 +142,8 @@ package body Lib.Writ is ...@@ -141,7 +142,8 @@ package body Lib.Writ is
Munit_Index => 0, Munit_Index => 0,
Serial_Number => 0, Serial_Number => 0,
Version => 0, Version => 0,
Error_Location => No_Location); Error_Location => No_Location,
OA_Setting => 'O');
-- Parse system.ads so that the checksum is set right -- Parse system.ads so that the checksum is set right
-- Style checks are not applied. -- Style checks are not applied.
...@@ -236,28 +238,33 @@ package body Lib.Writ is ...@@ -236,28 +238,33 @@ package body Lib.Writ is
-- Process with clause -- Process with clause
-- Ada 2005 (AI-50217): limited with_clauses do not create -- Ada 2005 (AI-50217): limited with_clauses do not create
-- dependencies -- dependencies, but must be recorded as components of the
-- partition, in case there is no regular with_clause for
-- the unit anywhere else.
if Nkind (Item) = N_With_Clause if Nkind (Item) = N_With_Clause then
and then not (Limited_Present (Item))
then
Unum := Get_Cunit_Unit_Number (Library_Unit (Item)); Unum := Get_Cunit_Unit_Number (Library_Unit (Item));
With_Flags (Unum) := True; With_Flags (Unum) := True;
if Elaborate_Present (Item) then if not Limited_Present (Item) then
Elab_Flags (Unum) := True; if Elaborate_Present (Item) then
end if; Elab_Flags (Unum) := True;
end if;
if Elaborate_All_Present (Item) then if Elaborate_All_Present (Item) then
Elab_All_Flags (Unum) := True; Elab_All_Flags (Unum) := True;
end if; end if;
if Elaborate_All_Desirable (Item) then if Elaborate_All_Desirable (Item) then
Elab_All_Des_Flags (Unum) := True; Elab_All_Des_Flags (Unum) := True;
end if; end if;
if Elaborate_Desirable (Item) then if Elaborate_Desirable (Item) then
Elab_Des_Flags (Unum) := True; Elab_Des_Flags (Unum) := True;
end if;
else
Set_From_With_Type (Cunit_Entity (Unum));
end if; end if;
end if; end if;
...@@ -441,6 +448,9 @@ package body Lib.Writ is ...@@ -441,6 +448,9 @@ package body Lib.Writ is
Write_Info_Str (" NE"); Write_Info_Str (" NE");
end if; end if;
Write_Info_Str (" O");
Write_Info_Char (OA_Setting (Unit_Num));
if Is_Preelaborated (Uent) then if Is_Preelaborated (Uent) then
Write_Info_Str (" PR"); Write_Info_Str (" PR");
end if; end if;
...@@ -512,7 +522,7 @@ package body Lib.Writ is ...@@ -512,7 +522,7 @@ package body Lib.Writ is
end case; end case;
end if; end if;
if Initialize_Scalars then if Initialize_Scalars or else Invalid_Value_Used then
Write_Info_Str (" IS"); Write_Info_Str (" IS");
end if; end if;
...@@ -696,7 +706,14 @@ package body Lib.Writ is ...@@ -696,7 +706,14 @@ package body Lib.Writ is
Uname := Units.Table (Unum).Unit_Name; Uname := Units.Table (Unum).Unit_Name;
Fname := Units.Table (Unum).Unit_File_Name; Fname := Units.Table (Unum).Unit_File_Name;
Write_Info_Initiate ('W'); if Ekind (Cunit_Entity (Unum)) = E_Package
and then From_With_Type (Cunit_Entity (Unum))
then
Write_Info_Initiate ('Y');
else
Write_Info_Initiate ('W');
end if;
Write_Info_Char (' '); Write_Info_Char (' ');
Write_Info_Name (Uname); Write_Info_Name (Uname);
...@@ -750,20 +767,26 @@ package body Lib.Writ is ...@@ -750,20 +767,26 @@ package body Lib.Writ is
Write_With_File_Names (Fname, Munit_Index (Unum)); Write_With_File_Names (Fname, Munit_Index (Unum));
end if; end if;
if Elab_Flags (Unum) then if Ekind (Cunit_Entity (Unum)) = E_Package
Write_Info_Str (" E"); and then From_With_Type (Cunit_Entity (Unum))
end if; then
null;
else
if Elab_Flags (Unum) then
Write_Info_Str (" E");
end if;
if Elab_All_Flags (Unum) then if Elab_All_Flags (Unum) then
Write_Info_Str (" EA"); Write_Info_Str (" EA");
end if; end if;
if Elab_Des_Flags (Unum) then if Elab_Des_Flags (Unum) then
Write_Info_Str (" ED"); Write_Info_Str (" ED");
end if; end if;
if Elab_All_Des_Flags (Unum) then if Elab_All_Des_Flags (Unum) then
Write_Info_Str (" AD"); Write_Info_Str (" AD");
end if;
end if; end if;
end if; end if;
...@@ -971,11 +994,6 @@ package body Lib.Writ is ...@@ -971,11 +994,6 @@ package body Lib.Writ is
Write_Info_Str (" NS"); Write_Info_Str (" NS");
end if; end if;
if Optimize_Alignment /= 'O' then
Write_Info_Str (" O");
Write_Info_Char (Optimize_Alignment);
end if;
if Sec_Stack_Used then if Sec_Stack_Used then
Write_Info_Str (" SS"); Write_Info_Str (" SS");
end if; end if;
......
gcc/ada/lib-writ.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -167,7 +167,7 @@ package Lib.Writ is ...@@ -167,7 +167,7 @@ package Lib.Writ is
-- P <<parameters>> -- P <<parameters>>
-- Indicates various information that applies to the compilation -- Indicates various information that applies to the compilation
-- of the corresponding source unit. Parameters is a sequence of -- of the corresponding source file. Parameters is a sequence of
-- zero or more two letter codes that indicate configuration -- zero or more two letter codes that indicate configuration
-- pragmas and other parameters that apply: -- pragmas and other parameters that apply:
-- --
...@@ -211,10 +211,6 @@ package Lib.Writ is ...@@ -211,10 +211,6 @@ package Lib.Writ is
-- NS Normalize_Scalars pragma in effect for all units in -- 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 -- Qx A valid Queueing_Policy pragma applies to all the units
-- in this file, where x is the first character (upper case) -- in this file, where x is the first character (upper case)
-- of the policy name (e.g. 'P' for Priority_Queueing). -- of the policy name (e.g. 'P' for Priority_Queueing).
...@@ -462,7 +458,8 @@ package Lib.Writ is ...@@ -462,7 +458,8 @@ package Lib.Writ is
-- case usage is detected, or the compiler cannot determine -- case usage is detected, or the compiler cannot determine
-- the style, then no I parameter will appear. -- the style, then no I parameter will appear.
-- --
-- IS Initialize_Scalars pragma applies to this unit -- IS Initialize_Scalars pragma applies to this unit, or else there
-- is at least one use of the Invalid_Value attribute.
-- --
-- KM Unit source uses a style with keywords in mixed case -- KM Unit source uses a style with keywords in mixed case
-- KU (KM) or all upper case (KU). If the standard lower-case -- KU (KM) or all upper case (KU). If the standard lower-case
...@@ -475,6 +472,23 @@ package Lib.Writ is ...@@ -475,6 +472,23 @@ package Lib.Writ is
-- elaboration code is required. Set if N_Compilation_Unit -- elaboration code is required. Set if N_Compilation_Unit
-- node has flag Has_No_Elaboration_Code set. -- node has flag Has_No_Elaboration_Code set.
-- --
-- OL The units in this file are commpiled with a local pragma
-- Optimize_Alignment, so no consistency requirement applies
-- to these units. All internal units have this status since
-- they have an automatic default of Optimize_Alignment (Off).
--
-- OO Optimize_Alignment (Off) is the default setting for all
-- units in this file. All files in the partition that specify
-- a default must specify the same default.
--
-- OS Optimize_Alignment (Space) is the default settinng for all
-- units in this file. All files in the partition that specify
-- a default must specify the same default.
--
-- OT Optimize_Alignment (Time) is the default settinng for all
-- units in this file. All files in the partition that specify
-- a default must specify the same default.
--
-- PK Unit is package, rather than a subprogram -- PK Unit is package, rather than a subprogram
-- --
-- PU Unit has pragma Pure -- PU Unit has pragma Pure
......
gcc/ada/lib.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -145,6 +145,11 @@ package body Lib is ...@@ -145,6 +145,11 @@ package body Lib is
return Units.Table (U).Munit_Index; return Units.Table (U).Munit_Index;
end Munit_Index; end Munit_Index;
function OA_Setting (U : Unit_Number_Type) return Character is
begin
return Units.Table (U).OA_Setting;
end OA_Setting;
function Source_Index (U : Unit_Number_Type) return Source_File_Index is function Source_Index (U : Unit_Number_Type) return Source_File_Index is
begin begin
return Units.Table (U).Source_Index; return Units.Table (U).Source_Index;
...@@ -223,6 +228,11 @@ package body Lib is ...@@ -223,6 +228,11 @@ package body Lib is
Units.Table (U).Main_Priority := P; Units.Table (U).Main_Priority := P;
end Set_Main_Priority; end Set_Main_Priority;
procedure Set_OA_Setting (U : Unit_Number_Type; C : Character) is
begin
Units.Table (U).OA_Setting := C;
end Set_OA_Setting;
procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type) is procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type) is
begin begin
Units.Table (U).Unit_Name := N; Units.Table (U).Unit_Name := N;
......
gcc/ada/lib.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -344,6 +344,10 @@ package Lib is ...@@ -344,6 +344,10 @@ package Lib is
-- that the default priority is to be used (and is also used for -- that the default priority is to be used (and is also used for
-- entries that do not correspond to possible main programs). -- entries that do not correspond to possible main programs).
-- OA_Setting
-- This is a character field containing L if Optimize_Alignment mode
-- was set locally, and O/T/S for Off/Time/Space default if not.
-- Serial_Number -- Serial_Number
-- This field holds a serial number used by New_Internal_Name to -- This field holds a serial number used by New_Internal_Name to
-- generate unique temporary numbers on a unit by unit basis. The -- generate unique temporary numbers on a unit by unit basis. The
...@@ -385,6 +389,7 @@ package Lib is ...@@ -385,6 +389,7 @@ package Lib is
function Loading (U : Unit_Number_Type) return Boolean; function Loading (U : Unit_Number_Type) return Boolean;
function Main_Priority (U : Unit_Number_Type) return Int; function Main_Priority (U : Unit_Number_Type) return Int;
function Munit_Index (U : Unit_Number_Type) return Nat; function Munit_Index (U : Unit_Number_Type) return Nat;
function OA_Setting (U : Unit_Number_Type) return Character;
function Source_Index (U : Unit_Number_Type) return Source_File_Index; function Source_Index (U : Unit_Number_Type) return Source_File_Index;
function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type; function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type;
function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type; function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type;
...@@ -401,6 +406,7 @@ package Lib is ...@@ -401,6 +406,7 @@ package Lib is
procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id); procedure Set_Ident_String (U : Unit_Number_Type; N : Node_Id);
procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True); procedure Set_Loading (U : Unit_Number_Type; B : Boolean := True);
procedure Set_Main_Priority (U : Unit_Number_Type; P : Int); procedure Set_Main_Priority (U : Unit_Number_Type; P : Int);
procedure Set_OA_Setting (U : Unit_Number_Type; C : Character);
procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type); procedure Set_Unit_Name (U : Unit_Number_Type; N : Unit_Name_Type);
-- Set value of named field for given units table entry. Note that we -- Set value of named field for given units table entry. Note that we
-- do not have an entry for each possible field, since some of the fields -- do not have an entry for each possible field, since some of the fields
...@@ -630,6 +636,7 @@ private ...@@ -630,6 +636,7 @@ private
pragma Inline (Loading); pragma Inline (Loading);
pragma Inline (Main_Priority); pragma Inline (Main_Priority);
pragma Inline (Munit_Index); pragma Inline (Munit_Index);
pragma Inline (OA_Setting);
pragma Inline (Set_Cunit); pragma Inline (Set_Cunit);
pragma Inline (Set_Cunit_Entity); pragma Inline (Set_Cunit_Entity);
pragma Inline (Set_Fatal_Error); pragma Inline (Set_Fatal_Error);
...@@ -637,6 +644,7 @@ private ...@@ -637,6 +644,7 @@ private
pragma Inline (Set_Has_RACW); pragma Inline (Set_Has_RACW);
pragma Inline (Set_Loading); pragma Inline (Set_Loading);
pragma Inline (Set_Main_Priority); pragma Inline (Set_Main_Priority);
pragma Inline (Set_OA_Setting);
pragma Inline (Set_Unit_Name); pragma Inline (Set_Unit_Name);
pragma Inline (Source_Index); pragma Inline (Source_Index);
pragma Inline (Unit_File_Name); pragma Inline (Unit_File_Name);
...@@ -662,6 +670,7 @@ private ...@@ -662,6 +670,7 @@ private
Is_Compiler_Unit : Boolean; Is_Compiler_Unit : Boolean;
Dynamic_Elab : Boolean; Dynamic_Elab : Boolean;
Loading : Boolean; Loading : Boolean;
OA_Setting : Character;
end record; end record;
-- The following representation clause ensures that the above record -- The following representation clause ensures that the above record
...@@ -686,11 +695,12 @@ private ...@@ -686,11 +695,12 @@ private
Generate_Code at 53 range 0 .. 7; Generate_Code at 53 range 0 .. 7;
Has_RACW at 54 range 0 .. 7; Has_RACW at 54 range 0 .. 7;
Dynamic_Elab at 55 range 0 .. 7; Dynamic_Elab at 55 range 0 .. 7;
Is_Compiler_Unit at 56 range 0 .. 31; Is_Compiler_Unit at 56 range 0 .. 7;
Loading at 60 range 0 .. 31; OA_Setting at 57 range 0 .. 7;
Loading at 58 range 0 .. 15;
end record; end record;
for Unit_Record'Size use 64 * 8; for Unit_Record'Size use 60 * 8;
-- This ensures that we did not leave out any fields -- This ensures that we did not leave out any fields
package Units is new Table.Table ( package Units is new Table.Table (
......
gcc/ada/opt.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -49,6 +49,7 @@ package body Opt is ...@@ -49,6 +49,7 @@ package body Opt is
Ada_Version_Config := Ada_Version; Ada_Version_Config := Ada_Version;
Ada_Version_Explicit_Config := Ada_Version_Explicit; Ada_Version_Explicit_Config := Ada_Version_Explicit;
Assertions_Enabled_Config := Assertions_Enabled; Assertions_Enabled_Config := Assertions_Enabled;
Check_Policy_List_Config := Check_Policy_List;
Debug_Pragmas_Enabled_Config := Debug_Pragmas_Enabled; Debug_Pragmas_Enabled_Config := Debug_Pragmas_Enabled;
Dynamic_Elaboration_Checks_Config := Dynamic_Elaboration_Checks; Dynamic_Elaboration_Checks_Config := Dynamic_Elaboration_Checks;
Exception_Locations_Suppressed_Config := Exception_Locations_Suppressed; Exception_Locations_Suppressed_Config := Exception_Locations_Suppressed;
...@@ -60,6 +61,12 @@ package body Opt is ...@@ -60,6 +61,12 @@ package body Opt is
Persistent_BSS_Mode_Config := Persistent_BSS_Mode; Persistent_BSS_Mode_Config := Persistent_BSS_Mode;
Polling_Required_Config := Polling_Required; Polling_Required_Config := Polling_Required;
Use_VADS_Size_Config := Use_VADS_Size; Use_VADS_Size_Config := Use_VADS_Size;
-- Reset the indication that Optimize_Alignment was set locally, since
-- if we had a pragma in the config file, it would set this flag True,
-- but that's not a local setting.
Optimize_Alignment_Local := False;
end Register_Opt_Config_Switches; end Register_Opt_Config_Switches;
--------------------------------- ---------------------------------
...@@ -71,6 +78,7 @@ package body Opt is ...@@ -71,6 +78,7 @@ package body Opt is
Ada_Version := Save.Ada_Version; Ada_Version := Save.Ada_Version;
Ada_Version_Explicit := Save.Ada_Version_Explicit; Ada_Version_Explicit := Save.Ada_Version_Explicit;
Assertions_Enabled := Save.Assertions_Enabled; Assertions_Enabled := Save.Assertions_Enabled;
Check_Policy_List := Save.Check_Policy_List;
Debug_Pragmas_Enabled := Save.Debug_Pragmas_Enabled; Debug_Pragmas_Enabled := Save.Debug_Pragmas_Enabled;
Dynamic_Elaboration_Checks := Save.Dynamic_Elaboration_Checks; Dynamic_Elaboration_Checks := Save.Dynamic_Elaboration_Checks;
Exception_Locations_Suppressed := Save.Exception_Locations_Suppressed; Exception_Locations_Suppressed := Save.Exception_Locations_Suppressed;
...@@ -79,6 +87,7 @@ package body Opt is ...@@ -79,6 +87,7 @@ package body Opt is
External_Name_Imp_Casing := Save.External_Name_Imp_Casing; External_Name_Imp_Casing := Save.External_Name_Imp_Casing;
Fast_Math := Save.Fast_Math; Fast_Math := Save.Fast_Math;
Optimize_Alignment := Save.Optimize_Alignment; Optimize_Alignment := Save.Optimize_Alignment;
Optimize_Alignment_Local := Save.Optimize_Alignment_Local;
Persistent_BSS_Mode := Save.Persistent_BSS_Mode; Persistent_BSS_Mode := Save.Persistent_BSS_Mode;
Polling_Required := Save.Polling_Required; Polling_Required := Save.Polling_Required;
Use_VADS_Size := Save.Use_VADS_Size; Use_VADS_Size := Save.Use_VADS_Size;
...@@ -93,6 +102,7 @@ package body Opt is ...@@ -93,6 +102,7 @@ package body Opt is
Save.Ada_Version := Ada_Version; Save.Ada_Version := Ada_Version;
Save.Ada_Version_Explicit := Ada_Version_Explicit; Save.Ada_Version_Explicit := Ada_Version_Explicit;
Save.Assertions_Enabled := Assertions_Enabled; Save.Assertions_Enabled := Assertions_Enabled;
Save.Check_Policy_List := Check_Policy_List;
Save.Debug_Pragmas_Enabled := Debug_Pragmas_Enabled; Save.Debug_Pragmas_Enabled := Debug_Pragmas_Enabled;
Save.Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks; Save.Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks;
Save.Exception_Locations_Suppressed := Exception_Locations_Suppressed; Save.Exception_Locations_Suppressed := Exception_Locations_Suppressed;
...@@ -101,6 +111,7 @@ package body Opt is ...@@ -101,6 +111,7 @@ package body Opt is
Save.External_Name_Imp_Casing := External_Name_Imp_Casing; Save.External_Name_Imp_Casing := External_Name_Imp_Casing;
Save.Fast_Math := Fast_Math; Save.Fast_Math := Fast_Math;
Save.Optimize_Alignment := Optimize_Alignment; Save.Optimize_Alignment := Optimize_Alignment;
Save.Optimize_Alignment_Local := Optimize_Alignment_Local;
Save.Persistent_BSS_Mode := Persistent_BSS_Mode; Save.Persistent_BSS_Mode := Persistent_BSS_Mode;
Save.Polling_Required := Polling_Required; Save.Polling_Required := Polling_Required;
Save.Use_VADS_Size := Use_VADS_Size; Save.Use_VADS_Size := Use_VADS_Size;
...@@ -131,6 +142,7 @@ package body Opt is ...@@ -131,6 +142,7 @@ package body Opt is
Optimize_Alignment := 'O'; Optimize_Alignment := 'O';
Persistent_BSS_Mode := False; Persistent_BSS_Mode := False;
Use_VADS_Size := False; Use_VADS_Size := False;
Optimize_Alignment_Local := True;
-- For an internal unit, assertions/debug pragmas are off unless this -- For an internal unit, assertions/debug pragmas are off unless this
-- is the main unit and they were explicitly enabled. -- is the main unit and they were explicitly enabled.
...@@ -138,26 +150,30 @@ package body Opt is ...@@ -138,26 +150,30 @@ package body Opt is
if Main_Unit then if Main_Unit then
Assertions_Enabled := Assertions_Enabled_Config; Assertions_Enabled := Assertions_Enabled_Config;
Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config; Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config;
Check_Policy_List := Check_Policy_List_Config;
else else
Assertions_Enabled := False; Assertions_Enabled := False;
Debug_Pragmas_Enabled := False; Debug_Pragmas_Enabled := False;
Check_Policy_List := Empty;
end if; end if;
-- Case of non-internal unit -- Case of non-internal unit
else else
Ada_Version := Ada_Version_Config; Ada_Version := Ada_Version_Config;
Ada_Version_Explicit := Ada_Version_Explicit_Config; Ada_Version_Explicit := Ada_Version_Explicit_Config;
Assertions_Enabled := Assertions_Enabled_Config; Assertions_Enabled := Assertions_Enabled_Config;
Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config; Check_Policy_List := Check_Policy_List_Config;
Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks_Config; Debug_Pragmas_Enabled := Debug_Pragmas_Enabled_Config;
Extensions_Allowed := Extensions_Allowed_Config; Dynamic_Elaboration_Checks := Dynamic_Elaboration_Checks_Config;
External_Name_Exp_Casing := External_Name_Exp_Casing_Config; Extensions_Allowed := Extensions_Allowed_Config;
External_Name_Imp_Casing := External_Name_Imp_Casing_Config; External_Name_Exp_Casing := External_Name_Exp_Casing_Config;
Fast_Math := Fast_Math_Config; External_Name_Imp_Casing := External_Name_Imp_Casing_Config;
Optimize_Alignment := Optimize_Alignment_Config; Fast_Math := Fast_Math_Config;
Persistent_BSS_Mode := Persistent_BSS_Mode_Config; Optimize_Alignment := Optimize_Alignment_Config;
Use_VADS_Size := Use_VADS_Size_Config; Optimize_Alignment_Local := False;
Persistent_BSS_Mode := Persistent_BSS_Mode_Config;
Use_VADS_Size := Use_VADS_Size_Config;
end if; end if;
Exception_Locations_Suppressed := Exception_Locations_Suppressed_Config; Exception_Locations_Suppressed := Exception_Locations_Suppressed_Config;
...@@ -192,6 +208,7 @@ package body Opt is ...@@ -192,6 +208,7 @@ package body Opt is
Tree_Read_Int (Assertions_Enabled_Config_Val); Tree_Read_Int (Assertions_Enabled_Config_Val);
Tree_Read_Bool (All_Errors_Mode); Tree_Read_Bool (All_Errors_Mode);
Tree_Read_Bool (Assertions_Enabled); Tree_Read_Bool (Assertions_Enabled);
Tree_Read_Int (Int (Check_Policy_List));
Tree_Read_Bool (Debug_Pragmas_Enabled); Tree_Read_Bool (Debug_Pragmas_Enabled);
Tree_Read_Bool (Enable_Overflow_Checks); Tree_Read_Bool (Enable_Overflow_Checks);
Tree_Read_Bool (Full_List); Tree_Read_Bool (Full_List);
...@@ -256,6 +273,7 @@ package body Opt is ...@@ -256,6 +273,7 @@ package body Opt is
Tree_Write_Int (Boolean'Pos (Assertions_Enabled_Config)); Tree_Write_Int (Boolean'Pos (Assertions_Enabled_Config));
Tree_Write_Bool (All_Errors_Mode); Tree_Write_Bool (All_Errors_Mode);
Tree_Write_Bool (Assertions_Enabled); Tree_Write_Bool (Assertions_Enabled);
Tree_Write_Int (Int (Check_Policy_List));
Tree_Write_Bool (Debug_Pragmas_Enabled); Tree_Write_Bool (Debug_Pragmas_Enabled);
Tree_Write_Bool (Enable_Overflow_Checks); Tree_Write_Bool (Enable_Overflow_Checks);
Tree_Write_Bool (Full_List); Tree_Write_Bool (Full_List);
......
gcc/ada/opt.ads
...@@ -214,6 +214,12 @@ package Opt is ...@@ -214,6 +214,12 @@ package Opt is
-- GNATBIND -- GNATBIND
-- Set to True to do checks only, no output of binder file -- Set to True to do checks only, no output of binder file
Check_Policy_List : Node_Id := Empty;
-- GNAT
-- This points to the list of N_Pragma nodes for Check_Policy pragmas
-- that are linked through the Next_Pragma fields, with the list being
-- terminated by Empty. The order is most recently processed first.
Check_Readonly_Files : Boolean := False; Check_Readonly_Files : Boolean := False;
-- GNATMAKE -- GNATMAKE
-- Set to True to check readonly files during the make process -- Set to True to check readonly files during the make process
...@@ -400,7 +406,7 @@ package Opt is ...@@ -400,7 +406,7 @@ package Opt is
-- message routines generates one line of output as a separate message. -- message routines generates one line of output as a separate message.
-- If it is set to a non-zero value, then continuation lines are folded -- If it is set to a non-zero value, then continuation lines are folded
-- to make a single long message, and then this message is split up into -- to make a single long message, and then this message is split up into
-- multiple lines not exceeding the specified length. Set by -gnatLnnn. -- multiple lines not exceeding the specified length. Set by -gnatj=nn.
Exception_Locations_Suppressed : Boolean := False; Exception_Locations_Suppressed : Boolean := False;
-- GNAT -- GNAT
...@@ -620,6 +626,10 @@ package Opt is ...@@ -620,6 +626,10 @@ package Opt is
-- generate code even in case of unsupported construct, so that the byte -- generate code even in case of unsupported construct, so that the byte
-- code can be used by static analysis tools. -- code can be used by static analysis tools.
Invalid_Value_Used : Boolean := False;
-- GNAT
-- Set True if a valid Invalid_Value attribute is encountered
Follow_Links_For_Files : Boolean := False; Follow_Links_For_Files : Boolean := False;
-- PROJECT MANAGER -- PROJECT MANAGER
-- Set to True (-eL) to process the project files in trusted mode -- Set to True (-eL) to process the project files in trusted mode
...@@ -862,6 +872,14 @@ package Opt is ...@@ -862,6 +872,14 @@ package Opt is
-- Setting of Optimize_Alignment, set to T/S/O for time/space/off. Can -- Setting of Optimize_Alignment, set to T/S/O for time/space/off. Can
-- be modified by use of pragma Optimize_Alignment. -- be modified by use of pragma Optimize_Alignment.
Optimize_Alignment_Local : Boolean := False;
-- Set True if Optimize_Alignment mode is set by a local configuration
-- pragma that overrides the gnat.adc (or other configuration file) default
-- so that the unit is not dependent on the default setting. Also always
-- set True for internal units, since these always have a default setting
-- of Optimize_Alignment (Off) that is enforced (essentially equivalent to
-- them all having such an explicit pragma in each unit).
Original_Operating_Mode : Operating_Mode_Type := Generate_Code; Original_Operating_Mode : Operating_Mode_Type := Generate_Code;
-- GNAT -- GNAT
-- Indicates the original operating mode of the compiler as set by -- Indicates the original operating mode of the compiler as set by
...@@ -870,7 +888,7 @@ package Opt is ...@@ -870,7 +888,7 @@ package Opt is
Optimization_Level : Int; Optimization_Level : Int;
pragma Import (C, Optimization_Level, "optimize"); pragma Import (C, Optimization_Level, "optimize");
-- This constant reflects the optimization level (0,1,2 for -O0,-O1,-O2) -- Constant reflecting the optimization level (0,1,2,3 for -O0,-O1,-O2,-O3)
Output_File_Name_Present : Boolean := False; Output_File_Name_Present : Boolean := False;
-- GNATBIND, GNAT, GNATMAKE, GPRMAKE -- GNATBIND, GNAT, GNATMAKE, GPRMAKE
...@@ -1133,7 +1151,7 @@ package Opt is ...@@ -1133,7 +1151,7 @@ package Opt is
Upper_Half_Encoding : Boolean := False; Upper_Half_Encoding : Boolean := False;
-- GNAT, GNATBIND -- GNAT, GNATBIND
-- Normally set False, indicating that upper half ASCII characters are -- Normally set False, indicating that upper half ISO 8859-1 characters are
-- used in the normal way to represent themselves. If the wide character -- used in the normal way to represent themselves. If the wide character
-- encoding method uses the upper bit for this encoding, then this flag is -- encoding method uses the upper bit for this encoding, then this flag is
-- set True, and upper half characters in the source indicate the start of -- set True, and upper half characters in the source indicate the start of
...@@ -1190,6 +1208,12 @@ package Opt is ...@@ -1190,6 +1208,12 @@ package Opt is
-- including warnings on Ada 2005 obsolescent features used in Ada 2005 -- including warnings on Ada 2005 obsolescent features used in Ada 2005
-- mode. Set False by -gnatwY. -- mode. Set False by -gnatwY.
Warn_On_Parameter_Order : Boolean := False;
-- GNAT
-- Set to True to generate warnings for cases where the argument list for
-- a call is a sequence of identifiers that match the formal identifiers,
-- but are in the wrong order.
Warn_On_Assertion_Failure : Boolean := True; Warn_On_Assertion_Failure : Boolean := True;
-- GNAT -- GNAT
-- Set to True to activate warnings on assertions that can be determined -- Set to True to activate warnings on assertions that can be determined
...@@ -1374,6 +1398,13 @@ package Opt is ...@@ -1374,6 +1398,13 @@ package Opt is
-- mode, as possibly set by the command line switch -gnata, and possibly -- mode, as possibly set by the command line switch -gnata, and possibly
-- modified by the use of the configuration pragma Assertion_Policy. -- modified by the use of the configuration pragma Assertion_Policy.
Check_Policy_List_Config : Node_Id;
-- GNAT
-- This points to the list of N_Pragma nodes for Check_Policy pragmas
-- that are linked through the Next_Pragma fields, with the list being
-- terminated by Empty. The order is most recently processed first. This
-- list includes only those pragmas in configuration pragma files.
Debug_Pragmas_Enabled_Config : Boolean; Debug_Pragmas_Enabled_Config : Boolean;
-- GNAT -- GNAT
-- This is the value of the configuration switch for debug pragmas enabled -- This is the value of the configuration switch for debug pragmas enabled
...@@ -1485,9 +1516,10 @@ package Opt is ...@@ -1485,9 +1516,10 @@ package Opt is
-- call to Save_Opt_Switches. -- call to Save_Opt_Switches.
procedure Register_Opt_Config_Switches; procedure Register_Opt_Config_Switches;
-- This procedure is called after processing the gnat.adc file to record -- This procedure is called after processing the gnat.adc file and other
-- the values of the Config switches, as possibly modified by the use of -- configuration pragma files to record the values of the Config switches,
-- command line switches and configuration pragmas. -- as possibly modified by the use of command line switches and pragmas
-- appearing in these files.
------------------------ ------------------------
-- Other Global Flags -- -- Other Global Flags --
...@@ -1564,6 +1596,7 @@ private ...@@ -1564,6 +1596,7 @@ private
Ada_Version : Ada_Version_Type; Ada_Version : Ada_Version_Type;
Ada_Version_Explicit : Ada_Version_Type; Ada_Version_Explicit : Ada_Version_Type;
Assertions_Enabled : Boolean; Assertions_Enabled : Boolean;
Check_Policy_List : Node_Id;
Debug_Pragmas_Enabled : Boolean; Debug_Pragmas_Enabled : Boolean;
Dynamic_Elaboration_Checks : Boolean; Dynamic_Elaboration_Checks : Boolean;
Exception_Locations_Suppressed : Boolean; Exception_Locations_Suppressed : Boolean;
...@@ -1572,6 +1605,7 @@ private ...@@ -1572,6 +1605,7 @@ private
External_Name_Imp_Casing : External_Casing_Type; External_Name_Imp_Casing : External_Casing_Type;
Fast_Math : Boolean; Fast_Math : Boolean;
Optimize_Alignment : Character; Optimize_Alignment : Character;
Optimize_Alignment_Local : Boolean;
Persistent_BSS_Mode : Boolean; Persistent_BSS_Mode : Boolean;
Polling_Required : Boolean; Polling_Required : Boolean;
Use_VADS_Size : Boolean; Use_VADS_Size : Boolean;
......
gcc/ada/sem_ch3.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -71,14 +71,6 @@ package Sem_Ch3 is ...@@ -71,14 +71,6 @@ package Sem_Ch3 is
procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id); procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id);
-- Analyze an interface declaration or a formal interface declaration -- Analyze an interface declaration or a formal interface declaration
procedure Analyze_Per_Use_Expression (N : Node_Id; T : Entity_Id);
-- Default and per object expressions do not freeze their components,
-- and must be analyzed and resolved accordingly. The analysis is
-- done by calling the Pre_Analyze_And_Resolve routine and setting
-- the global In_Default_Expression flag. See the documentation section
-- entitled "Handling of Default and Per-Object Expressions" in sem.ads
-- for details. N is the expression to be analyzed, T is the expected type.
procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id); procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id);
-- Process an array type declaration. If the array is constrained, we -- Process an array type declaration. If the array is constrained, we
-- create an implicit parent array type, with the same index types and -- create an implicit parent array type, with the same index types and
...@@ -204,6 +196,14 @@ package Sem_Ch3 is ...@@ -204,6 +196,14 @@ package Sem_Ch3 is
-- Always False in Ada 95 mode. Equivalent to OK_For_Limited_Init_In_05 in -- Always False in Ada 95 mode. Equivalent to OK_For_Limited_Init_In_05 in
-- Ada 2005 mode. -- Ada 2005 mode.
procedure Preanalyze_Spec_Expression (N : Node_Id; T : Entity_Id);
-- Default and per object expressions do not freeze their components, and
-- must be analyzed and resolved accordingly. The analysis is done by
-- calling the Preanalyze_And_Resolve routine and setting the global
-- In_Default_Expression flag. See the documentation section entitled
-- "Handling of Default and Per-Object Expressions" in sem.ads for full
-- details. N is the expression to be analyzed, T is the expected type.
procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id); procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id);
-- Process some semantic actions when the full view of a private type is -- Process some semantic actions when the full view of a private type is
-- encountered and analyzed. The first action is to create the full views -- encountered and analyzed. The first action is to create the full views
......
gcc/ada/sem_util.ads
...@@ -139,6 +139,13 @@ package Sem_Util is ...@@ -139,6 +139,13 @@ package Sem_Util is
-- N is one of the statement forms that is a potentially blocking -- N is one of the statement forms that is a potentially blocking
-- operation. If it appears within a protected action, emit warning. -- operation. If it appears within a protected action, emit warning.
procedure Check_Unprotected_Access
(Context : Node_Id;
Expr : Node_Id);
-- Check whether the expression is a pointer to a protected component,
-- and the context is external to the protected operation, to warn against
-- a possible unlocked access to data.
procedure Check_VMS (Construct : Node_Id); procedure Check_VMS (Construct : Node_Id);
-- Check that this the target is OpenVMS, and if so, return with -- Check that this the target is OpenVMS, and if so, return with
-- no effect, otherwise post an error noting this can only be used -- no effect, otherwise post an error noting this can only be used
...@@ -196,6 +203,12 @@ package Sem_Util is ...@@ -196,6 +203,12 @@ package Sem_Util is
-- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag -- Sets the Has_Delayed_Freeze flag of New if the Delayed_Freeze flag
-- of Old is set and Old has no yet been Frozen (i.e. Is_Frozen is false); -- of Old is set and Old has no yet been Frozen (i.e. Is_Frozen is false);
function Copy_Parameter_List (Subp_Id : Entity_Id) return List_Id;
-- Utility to create a parameter profile for a new subprogram spec,
-- when the subprogram has a body that acts as spec. This is done for
-- some cases of inlining, and for private protected ops. Also used
-- to create bodies for stubbed subprograms.
function Current_Entity (N : Node_Id) return Entity_Id; function Current_Entity (N : Node_Id) return Entity_Id;
-- Find the currently visible definition for a given identifier, that is to -- Find the currently visible definition for a given identifier, that is to
-- say the first entry in the visibility chain for the Chars of N. -- say the first entry in the visibility chain for the Chars of N.
...@@ -474,11 +487,13 @@ package Sem_Util is ...@@ -474,11 +487,13 @@ package Sem_Util is
-- declaration. -- declaration.
function Has_Access_Values (T : Entity_Id) return Boolean; function Has_Access_Values (T : Entity_Id) return Boolean;
-- Returns true if type or subtype T is an access type, or has a -- Returns true if type or subtype T is an access type, or has a component
-- component (at any recursive level) that is an access type. This -- (at any recursive level) that is an access type. This is a conservative
-- is a conservative predicate, if it is not known whether or not -- predicate, if it is not known whether or not T contains access values
-- T contains access values (happens for generic formals in some -- (happens for generic formals in some cases), then False is returned.
-- cases), then False is returned. -- Note that tagged types return False. Even though the tag is implemented
-- as an access type internally, this function tests only for access types
-- known to the programmer. See also Has_Tagged_Component.
function Has_Abstract_Interfaces function Has_Abstract_Interfaces
(T : Entity_Id; (T : Entity_Id;
...@@ -527,6 +542,10 @@ package Sem_Util is ...@@ -527,6 +542,10 @@ package Sem_Util is
function Has_Null_Exclusion (N : Node_Id) return Boolean; function Has_Null_Exclusion (N : Node_Id) return Boolean;
-- Determine whether node N has a null exclusion -- Determine whether node N has a null exclusion
function Has_Overriding_Initialize (T : Entity_Id) return Boolean;
-- Predicate to determine whether a controlled type has a user-defined
-- initialize procedure, which makes the type not preelaborable.
function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean; function Has_Preelaborable_Initialization (E : Entity_Id) return Boolean;
-- Return True iff type E has preelaborable initialiation as defined in -- Return True iff type E has preelaborable initialiation as defined in
-- Ada 2005 (see AI-161 for details of the definition of this attribute). -- Ada 2005 (see AI-161 for details of the definition of this attribute).
...@@ -544,8 +563,11 @@ package Sem_Util is ...@@ -544,8 +563,11 @@ package Sem_Util is
-- if there is no underlying type). -- if there is no underlying type).
function Has_Tagged_Component (Typ : Entity_Id) return Boolean; function Has_Tagged_Component (Typ : Entity_Id) return Boolean;
-- Typ must be a composite type (array or record). This function is used -- Returns True if Typ is a composite type (array or record) which is
-- to check if '=' has to be expanded into a bunch component comparaisons. -- either itself a tagged type, or has a component (recursively) which is
-- a tagged type. Returns False for non-composite type, or if no tagged
-- component is present. to check if '=' has to be expanded into a bunch
-- component comparisons.
function In_Instance return Boolean; function In_Instance return Boolean;
-- Returns True if the current scope is within a generic instance -- Returns True if the current scope is within a generic instance
...@@ -801,10 +823,10 @@ package Sem_Util is ...@@ -801,10 +823,10 @@ package Sem_Util is
-- set if you want to clear only the Last_Assignment field (see above). -- set if you want to clear only the Last_Assignment field (see above).
procedure Kill_Size_Check_Code (E : Entity_Id); procedure Kill_Size_Check_Code (E : Entity_Id);
-- Called when an address clause or pragma Import is applied to an -- Called when an address clause or pragma Import is applied to an entity.
-- entity. If the entity is a variable or a constant, and size check -- If the entity is a variable or a constant, and size check code is
-- code is present, this size check code is killed, since the object -- present, this size check code is killed, since the object will not
-- will not be allocated by the program. -- be allocated by the program.
function Known_To_Be_Assigned (N : Node_Id) return Boolean; function Known_To_Be_Assigned (N : Node_Id) return Boolean;
-- The node N is an entity reference. This function determines whether the -- The node N is an entity reference. This function determines whether the
...@@ -900,13 +922,17 @@ package Sem_Util is ...@@ -900,13 +922,17 @@ package Sem_Util is
-- in Success indicates sucess of reordering. For more details, see body. -- in Success indicates sucess of reordering. For more details, see body.
-- Errors are reported only if Report is set to True. -- Errors are reported only if Report is set to True.
procedure Note_Possible_Modification (N : Node_Id); procedure Note_Possible_Modification (N : Node_Id; Sure : Boolean);
-- This routine is called if the sub-expression N maybe the target of -- This routine is called if the sub-expression N maybe the target of
-- an assignment (e.g. it is the left side of an assignment, used as -- an assignment (e.g. it is the left side of an assignment, used as
-- an out parameters, or used as prefixes of access attributes). It -- an out parameters, or used as prefixes of access attributes). It
-- sets May_Be_Modified in the associated entity if there is one, -- sets May_Be_Modified in the associated entity if there is one,
-- taking into account the rule that in the case of renamed objects, -- taking into account the rule that in the case of renamed objects,
-- it is the flag in the renamed object that must be set. -- it is the flag in the renamed object that must be set.
--
-- The parameter Sure is set True if the modification is sure to occur
-- (e.g. target of assignment, or out parameter), and to False if the
-- modification is only potential (e.g. address of entity taken).
function Object_Access_Level (Obj : Node_Id) return Uint; function Object_Access_Level (Obj : Node_Id) return Uint;
-- Return the accessibility level of the view of the object Obj. -- Return the accessibility level of the view of the object Obj.
...@@ -1057,6 +1083,10 @@ package Sem_Util is ...@@ -1057,6 +1083,10 @@ package Sem_Util is
-- parameters are already members of a list, and do not need to be -- parameters are already members of a list, and do not need to be
-- chained separately. See also First_Actual and Next_Actual. -- chained separately. See also First_Actual and Next_Actual.
procedure Set_Optimize_Alignment_Flags (E : Entity_Id);
pragma Inline (Set_Optimize_Alignment_Flags);
-- Sets Optimize_Aliignment_Space/Time flags in E from current settings
procedure Set_Public_Status (Id : Entity_Id); procedure Set_Public_Status (Id : Entity_Id);
-- If an entity (visible or otherwise) is defined in a library -- If an entity (visible or otherwise) is defined in a library
-- package, or a package that is itself public, then this subprogram -- package, or a package that is itself public, then this subprogram
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment