mirrors/gcc
0
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2025-01-07 11:33:45 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

adaint.h, [...]: Minor reformatting & code reorganization

Browse Source 
2009-07-28  Robert Dewar  <dewar@adacore.com>

	* adaint.h, einfo.ads, prj.adb, sem_util.adb, makeutl.ads,
	makeutl.adb: Minor reformatting & code reorganization
	* sem_ch3.adb: Minor reformatting.
	Fix spelling error (constraint for constrain) in error msg.

From-SVN: r150162
This commit is contained in:
Robert Dewar 2009-07-28 15:08:57 +00:00 committed by Arnaud Charlet
parent 74efe9f06d
commit 8d12c865d7
8 changed files with 92 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gcc/ada/ChangeLog
View File

@ -1,3 +1,10 @@
2009-07-28 Robert Dewar <dewar@adacore.com>
* adaint.h, einfo.ads, prj.adb, sem_util.adb, makeutl.ads,
makeutl.adb: Minor reformatting & code reorganization
* sem_ch3.adb: Minor reformatting.
Fix spelling error (constraint for constrain) in error msg.
2009-07-28 Emmanuel Briot <briot@adacore.com>
* make.adb, makeutl.adb, makeutl.ads (Project_Tree): Duplicates the

7
gcc/ada/adaint.h
View File

@ -43,10 +43,9 @@
#define Encoding_8bits 1 /* Standard 8bits, CP_ACP on Windows. */
#define Encoding_Unspecified 2 /* Based on GNAT_CODE_PAGE env variable. */
/* Large file support. It is unclear what portable mechanism we can
use to determine at compile time what support the system offers for
large files. For now we just list the platforms we have manually
tested. */
/* Large file support. It is unclear what portable mechanism we can use to
determine at compile time what support the system offers for large files.
For now we just list the platforms we have manually tested. */
#if defined (__GLIBC__) || defined (sun) || defined (__sgi)
#define GNAT_FOPEN fopen64

2
gcc/ada/einfo.ads
View File

@ -3192,7 +3192,7 @@ package Einfo is
-- the case of an appearance of a simple variable that is not a renaming
-- as the left side of an assignment in which case Referenced_As_LHS is
-- set instead, or a similar appearance as an out parameter actual, in
-- which case As_Out_Parameter_Parameter is set.
-- which case Referenced_As_Out_Parameter is set.
-- Referenced_As_LHS (Flag36):
-- Present in all entities. This flag is set instead of Referenced if a

29
gcc/ada/makeutl.adb
View File

@ -162,12 +162,14 @@ package body Makeutl is
function Check_Source_Info_In_ALI (The_ALI : ALI_Id) return Boolean is
Unit_Name : Name_Id;
begin
U_Chk :
for U in ALIs.Table (The_ALI).First_Unit
.. ALIs.Table (The_ALI).Last_Unit
-- Loop through units
for U in ALIs.Table (The_ALI).First_Unit ..
ALIs.Table (The_ALI).Last_Unit
loop
-- Check if the file name is one of the source of the unit.
-- Check if the file name is one of the source of the unit
Get_Name_String (Units.Table (U).Uname);
Name_Len := Name_Len - 2;
@ -177,12 +179,12 @@ package body Makeutl is
return False;
end if;
-- Do the same check for each of the withed units
-- Loop to do same check for each of the withed units
W_Check :
for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop
declare
WR : ALI.With_Record renames Withs.Table (W);
begin
if WR.Sfile /= No_File then
Get_Name_String (WR.Uname);
@ -194,21 +196,22 @@ package body Makeutl is
end if;
end if;
end;
end loop W_Check;
end loop U_Chk;
end loop;
end loop;
-- Check also the subunits
-- Loop to check subunits
D_Check :
for D in ALIs.Table (The_ALI).First_Sdep
.. ALIs.Table (The_ALI).Last_Sdep
for D in ALIs.Table (The_ALI).First_Sdep ..
ALIs.Table (The_ALI).Last_Sdep
loop
declare
SD : Sdep_Record renames Sdep.Table (D);
begin
Unit_Name := SD.Subunit_Name;
if Unit_Name /= No_Name then
-- For separates, the file is no longer associated with the
-- unit ("proc-sep.adb" is not associated with unit "proc.sep".
-- So we need to check whether the source file still exists in
@ -240,7 +243,7 @@ package body Makeutl is
end if;
end if;
end;
end loop D_Check;
end loop;
return True;
end Check_Source_Info_In_ALI;

50
gcc/ada/makeutl.ads
View File

@ -36,8 +36,8 @@ package Makeutl is
type Fail_Proc is access procedure (S : String);
Do_Fail : Fail_Proc := Osint.Fail'Access;
-- Failing procedure called from procedure Test_If_Relative_Path below.
-- May be redirected.
-- Failing procedure called from procedure Test_If_Relative_Path below. May
-- be redirected.
Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data;
-- The project tree
@ -74,14 +74,14 @@ package Makeutl is
function File_Not_A_Source_Of
(Uname : Name_Id;
Sfile : File_Name_Type) return Boolean;
-- Check that file name Sfile is one of the source of unit Uname.
-- Returns True if the unit is in one of the project file, but the file
-- name is not one of its source. Returns False otherwise.
-- Check that file name Sfile is one of the source of unit Uname. Returns
-- True if the unit is in one of the project file, but the file name is not
-- one of its source. Returns False otherwise.
function Check_Source_Info_In_ALI (The_ALI : ALI.ALI_Id) return Boolean;
-- Check whether all file references in ALI are still valid (ie the source
-- files are still associated with the same units).
-- Return True if everything is still valid
-- Check whether all file references in ALI are still valid (ie the
-- source files are still associated with the same units). Return True
-- if everything is still valid
function Is_External_Assignment (Argv : String) return Boolean;
-- Verify that an external assignment switch is syntactically correct
@ -92,9 +92,10 @@ package Makeutl is
-- -X"name=other value"
--
-- Assumptions: 'First = 1, Argv (1 .. 2) = "-X"
-- When this function returns True, the external assignment has
-- been entered by a call to Prj.Ext.Add, so that in a project
-- file, External ("name") will return "value".
--
-- When this function returns True, the external assignment has been
-- entered by a call to Prj.Ext.Add, so that in a project file, External
-- ("name") will return "value".
procedure Verbose_Msg
(N1 : Name_Id;
@ -114,6 +115,7 @@ package Makeutl is
-- at least equal to Minimum_Verbosity, then print Prefix to standard
-- output followed by N1 and S1. If N2 /= No_Name then N2 is printed after
-- S1. S2 is printed last. Both N1 and N2 are printed in quotation marks.
-- The two forms differ only in taking Name_Id or File_name_Type arguments.
function Linker_Options_Switches
(Project : Project_Id;
@ -127,8 +129,8 @@ package Makeutl is
-- files exist and that they belong to a project file.
function Unit_Index_Of (ALI_File : File_Name_Type) return Int;
-- Find the index of a unit in a source file. Return zero if the file
-- is not a multi-unit source file.
-- Find the index of a unit in a source file. Return zero if the file is
-- not a multi-unit source file.
package Mains is
@ -149,8 +151,8 @@ package Makeutl is
-- Reset the index to the beginning of the table
function Next_Main return String;
-- Increase the index and return the next main.
-- If table is exhausted, return an empty string.
-- Increase the index and return the next main. If table is exhausted,
-- return an empty string.
function Get_Location return Source_Ptr;
-- Get the location of the current main
@ -170,12 +172,12 @@ package Makeutl is
Including_L_Switch : Boolean := True;
Including_Non_Switch : Boolean := True;
Including_RTS : Boolean := False);
-- Test if Switch is a relative search path switch.
-- If it is, fail if Parent is the empty string, otherwise prepend the path
-- with Parent. This subprogram is only called when using project files.
-- For gnatbind switches, Including_L_Switch is False, because the
-- argument of the -L switch is not a path. If Including_RTS is True,
-- process also switches --RTS=.
-- Test if Switch is a relative search path switch. If it is, fail if
-- Parent is the empty string, otherwise prepend the path with Parent.
-- This subprogram is only called when using project files. For gnatbind
-- switches, Including_L_Switch is False, because the argument of the -L
-- switch is not a path. If Including_RTS is True, process also switches
-- --RTS=.
function Path_Or_File_Name (Path : Path_Name_Type) return String;
-- Returns a file name if -df is used, otherwise return a path name
@ -185,9 +187,9 @@ package Makeutl is
----------------------
procedure Mark (Source_File : File_Name_Type; Index : Int := 0);
-- Mark a unit, identified by its source file and, when Index is not 0,
-- the index of the unit in the source file. Marking is used to signal
-- that the unit has already been inserted in the Q.
-- Mark a unit, identified by its source file and, when Index is not 0, the
-- index of the unit in the source file. Marking is used to signal that the
-- unit has already been inserted in the Q.
function Is_Marked
(Source_File : File_Name_Type;

4
gcc/ada/prj.adb
View File

@ -1053,6 +1053,7 @@ package body Prj is
-----------------------------------
procedure Compute_All_Imported_Projects (Project : Project_Id) is
procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean);
-- Recursively add the projects imported by project Project, but not
-- those that are extended.
@ -1070,6 +1071,7 @@ package body Prj is
-- A project is not importing itself
Prj2 := Ultimate_Extending_Project_Of (Prj);
if Project /= Prj2 then
-- Check that the project is not already in the list. We know the
@ -1081,6 +1083,7 @@ package body Prj is
if List.Project = Prj2 then
return;
end if;
List := List.Next;
end loop;
@ -1095,6 +1098,7 @@ package body Prj is
procedure For_All_Projects is
new For_Every_Project_Imported (Boolean, Recursive_Add);
Dummy : Boolean := False;
begin

75
gcc/ada/sem_ch3.adb
View File

@ -4826,20 +4826,21 @@ package body Sem_Ch3 is
Parent_Type : Entity_Id;
Derived_Type : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Loc : constant Source_Ptr := Sloc (N);
Corr_Record : constant Entity_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
Corr_Record : constant Entity_Id
:= Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
Corr_Decl : Node_Id;
Corr_Decl_Needed : Boolean;
-- If the derived type has fewer discriminants than its parent,
-- the corresponding record is also a derived type, in order to
-- account for the bound discriminants. We create a full type
-- declaration for it in this case.
-- If the derived type has fewer discriminants than its parent, the
-- corresponding record is also a derived type, in order to account for
-- the bound discriminants. We create a full type declaration for it in
-- this case.
Constraint_Present : constant Boolean
:= Nkind (Subtype_Indication (Type_Definition (N)))
= N_Subtype_Indication;
Constraint_Present : constant Boolean :=
Nkind (Subtype_Indication (Type_Definition (N))) =
N_Subtype_Indication;
D_Constraint : Node_Id;
New_Constraint : Elist_Id;
@ -4867,8 +4868,9 @@ package body Sem_Ch3 is
-- The new type has fewer discriminants, so we need to create a new
-- corresponding record, which is derived from the corresponding
-- record of the parent, and has a stored constraint that
-- captures the values of the discriminant constraints.
-- record of the parent, and has a stored constraint that captures
-- the values of the discriminant constraints.
-- The type declaration for the derived corresponding record has
-- the same discriminant part and constraints as the current
-- declaration. Copy the unanalyzed tree to build declaration.
@ -4980,15 +4982,13 @@ package body Sem_Ch3 is
while Present (D_Constraint) loop
if Nkind (D_Constraint) /= N_Discriminant_Association then
-- Positional constraint. If it is a reference to a
-- new discriminant, it constrains the corresponding
-- old one.
-- Positional constraint. If it is a reference to a new
-- discriminant, it constrains the corresponding old one.
if Nkind (D_Constraint) = N_Identifier then
New_Disc := First_Discriminant (Derived_Type);
while Present (New_Disc) loop
exit when
Chars (New_Disc) = Chars (D_Constraint);
exit when Chars (New_Disc) = Chars (D_Constraint);
Next_Discriminant (New_Disc);
end loop;
@ -4999,12 +4999,12 @@ package body Sem_Ch3 is
Next_Discriminant (Old_Disc);
-- if this is a named constraint, search by name for the
-- old discriminants constrained by the new one.
-- if this is a named constraint, search by name for the old
-- discriminants constrained by the new one.
elsif Nkind (Expression (D_Constraint)) = N_Identifier then
-- Find new discriminant with that name.
-- Find new discriminant with that name
New_Disc := First_Discriminant (Derived_Type);
while Present (New_Disc) loop
@ -5015,20 +5015,17 @@ package body Sem_Ch3 is
if Present (New_Disc) then
-- Verify that the new discriminant renames
-- some discriminant of the parent type, and
-- associate the new discriminant with an old
-- one that it renames (may be more than one).
-- Verify that new discriminant renames some discriminant
-- of the parent type, and associate the new discriminant
-- with one or more old ones that it renames.
declare
Selector : Node_Id;
begin
Selector := First (Selector_Names (D_Constraint));
while Present (Selector) loop
Old_Disc := First_Discriminant (Parent_Type);
while Present (Old_Disc) loop
exit when Chars (Old_Disc) = Chars (Selector);
Next_Discriminant (Old_Disc);
@ -5037,7 +5034,6 @@ package body Sem_Ch3 is
if Present (Old_Disc) then
Set_Corresponding_Discriminant
(New_Disc, Old_Disc);
end if;
Next (Selector);
@ -5049,21 +5045,20 @@ package body Sem_Ch3 is
Next (D_Constraint);
end loop;
New_Disc := First_Discriminant (Derived_Type);
New_Disc := First_Discriminant (Derived_Type);
while Present (New_Disc) loop
if No (Corresponding_Discriminant (New_Disc)) then
Error_Msg_NE
("new discriminant& must constraint old one",
N, New_Disc);
("new discriminant& must constrain old one", N, New_Disc);
elsif not
Subtypes_Statically_Compatible (
Etype (New_Disc),
Etype (Corresponding_Discriminant (New_Disc)))
Subtypes_Statically_Compatible
(Etype (New_Disc),
Etype (Corresponding_Discriminant (New_Disc)))
then
Error_Msg_NE
("& not statically compatible with parent discriminant",
N, New_Disc);
end if;
Next_Discriminant (New_Disc);
@ -5072,22 +5067,20 @@ package body Sem_Ch3 is
elsif Present (Discriminant_Specifications (N)) then
Error_Msg_N
("missing discriminant constraint in untagged derivation",
N);
("missing discriminant constraint in untagged derivation", N);
end if;
-- The entity chain of the derived type includes the new
-- discriminants but shares operations with the parent.
-- The entity chain of the derived type includes the new discriminants
-- but shares operations with the parent.
if Present (Discriminant_Specifications (N)) then
Old_Disc := First_Discriminant (Parent_Type);
while Present (Old_Disc) loop
if No (Next_Entity (Old_Disc))
or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant
then
Set_Next_Entity (Last_Entity (Derived_Type),
Next_Entity (Old_Disc));
Set_Next_Entity
(Last_Entity (Derived_Type), Next_Entity (Old_Disc));
exit;
end if;

5
gcc/ada/sem_util.adb
View File

@ -10448,10 +10448,7 @@ package body Sem_Util is
begin
-- Deal with indexed or selected component where prefix is modified
if Nkind (N) = N_Indexed_Component
or else
Nkind (N) = N_Selected_Component
then
if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
Pref := Prefix (N);
-- If prefix is access type, then it is the designated object that is