Commit 8d12c865 by Robert Dewar Committed by Arnaud Charlet

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

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
parent 74efe9f0
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> 2009-07-28 Emmanuel Briot <briot@adacore.com>
* make.adb, makeutl.adb, makeutl.ads (Project_Tree): Duplicates the * make.adb, makeutl.adb, makeutl.ads (Project_Tree): Duplicates the
......
...@@ -43,10 +43,9 @@ ...@@ -43,10 +43,9 @@
#define Encoding_8bits 1 /* Standard 8bits, CP_ACP on Windows. */ #define Encoding_8bits 1 /* Standard 8bits, CP_ACP on Windows. */
#define Encoding_Unspecified 2 /* Based on GNAT_CODE_PAGE env variable. */ #define Encoding_Unspecified 2 /* Based on GNAT_CODE_PAGE env variable. */
/* Large file support. It is unclear what portable mechanism we can /* Large file support. It is unclear what portable mechanism we can use to
use to determine at compile time what support the system offers for determine at compile time what support the system offers for large files.
large files. For now we just list the platforms we have manually For now we just list the platforms we have manually tested. */
tested. */
#if defined (__GLIBC__) || defined (sun) || defined (__sgi) #if defined (__GLIBC__) || defined (sun) || defined (__sgi)
#define GNAT_FOPEN fopen64 #define GNAT_FOPEN fopen64
......
...@@ -3192,7 +3192,7 @@ package Einfo is ...@@ -3192,7 +3192,7 @@ package Einfo is
-- the case of an appearance of a simple variable that is not a renaming -- 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 -- 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 -- 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): -- Referenced_As_LHS (Flag36):
-- Present in all entities. This flag is set instead of Referenced if a -- Present in all entities. This flag is set instead of Referenced if a
......
...@@ -162,12 +162,14 @@ package body Makeutl is ...@@ -162,12 +162,14 @@ package body Makeutl is
function Check_Source_Info_In_ALI (The_ALI : ALI_Id) return Boolean is function Check_Source_Info_In_ALI (The_ALI : ALI_Id) return Boolean is
Unit_Name : Name_Id; Unit_Name : Name_Id;
begin begin
U_Chk : -- Loop through units
for U in ALIs.Table (The_ALI).First_Unit
.. ALIs.Table (The_ALI).Last_Unit for U in ALIs.Table (The_ALI).First_Unit ..
ALIs.Table (The_ALI).Last_Unit
loop 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); Get_Name_String (Units.Table (U).Uname);
Name_Len := Name_Len - 2; Name_Len := Name_Len - 2;
...@@ -177,12 +179,12 @@ package body Makeutl is ...@@ -177,12 +179,12 @@ package body Makeutl is
return False; return False;
end if; 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 for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop
declare declare
WR : ALI.With_Record renames Withs.Table (W); WR : ALI.With_Record renames Withs.Table (W);
begin begin
if WR.Sfile /= No_File then if WR.Sfile /= No_File then
Get_Name_String (WR.Uname); Get_Name_String (WR.Uname);
...@@ -194,21 +196,22 @@ package body Makeutl is ...@@ -194,21 +196,22 @@ package body Makeutl is
end if; end if;
end if; end if;
end; end;
end loop W_Check; end loop;
end loop U_Chk; end loop;
-- Check also the subunits -- Loop to check subunits
D_Check : for D in ALIs.Table (The_ALI).First_Sdep ..
for D in ALIs.Table (The_ALI).First_Sdep ALIs.Table (The_ALI).Last_Sdep
.. ALIs.Table (The_ALI).Last_Sdep
loop loop
declare declare
SD : Sdep_Record renames Sdep.Table (D); SD : Sdep_Record renames Sdep.Table (D);
begin begin
Unit_Name := SD.Subunit_Name; Unit_Name := SD.Subunit_Name;
if Unit_Name /= No_Name then if Unit_Name /= No_Name then
-- For separates, the file is no longer associated with the -- For separates, the file is no longer associated with the
-- unit ("proc-sep.adb" is not associated with unit "proc.sep". -- unit ("proc-sep.adb" is not associated with unit "proc.sep".
-- So we need to check whether the source file still exists in -- So we need to check whether the source file still exists in
...@@ -240,7 +243,7 @@ package body Makeutl is ...@@ -240,7 +243,7 @@ package body Makeutl is
end if; end if;
end if; end if;
end; end;
end loop D_Check; end loop;
return True; return True;
end Check_Source_Info_In_ALI; end Check_Source_Info_In_ALI;
......
...@@ -36,8 +36,8 @@ package Makeutl is ...@@ -36,8 +36,8 @@ package Makeutl is
type Fail_Proc is access procedure (S : String); type Fail_Proc is access procedure (S : String);
Do_Fail : Fail_Proc := Osint.Fail'Access; Do_Fail : Fail_Proc := Osint.Fail'Access;
-- Failing procedure called from procedure Test_If_Relative_Path below. -- Failing procedure called from procedure Test_If_Relative_Path below. May
-- May be redirected. -- be redirected.
Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data; Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data;
-- The project tree -- The project tree
...@@ -74,14 +74,14 @@ package Makeutl is ...@@ -74,14 +74,14 @@ package Makeutl is
function File_Not_A_Source_Of function File_Not_A_Source_Of
(Uname : Name_Id; (Uname : Name_Id;
Sfile : File_Name_Type) return Boolean; Sfile : File_Name_Type) return Boolean;
-- Check that file name Sfile is one of the source of unit Uname. -- Check that file name Sfile is one of the source of unit Uname. Returns
-- Returns True if the unit is in one of the project file, but the file -- True if the unit is in one of the project file, but the file name is not
-- name is not one of its source. Returns False otherwise. -- one of its source. Returns False otherwise.
function Check_Source_Info_In_ALI (The_ALI : ALI.ALI_Id) return Boolean; 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 -- Check whether all file references in ALI are still valid (ie the
-- files are still associated with the same units). -- source files are still associated with the same units). Return True
-- Return True if everything is still valid -- if everything is still valid
function Is_External_Assignment (Argv : String) return Boolean; function Is_External_Assignment (Argv : String) return Boolean;
-- Verify that an external assignment switch is syntactically correct -- Verify that an external assignment switch is syntactically correct
...@@ -92,9 +92,10 @@ package Makeutl is ...@@ -92,9 +92,10 @@ package Makeutl is
-- -X"name=other value" -- -X"name=other value"
-- --
-- Assumptions: 'First = 1, Argv (1 .. 2) = "-X" -- 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 -- When this function returns True, the external assignment has been
-- file, External ("name") will return "value". -- entered by a call to Prj.Ext.Add, so that in a project file, External
-- ("name") will return "value".
procedure Verbose_Msg procedure Verbose_Msg
(N1 : Name_Id; (N1 : Name_Id;
...@@ -114,6 +115,7 @@ package Makeutl is ...@@ -114,6 +115,7 @@ package Makeutl is
-- at least equal to Minimum_Verbosity, then print Prefix to standard -- 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 -- 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. -- 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 function Linker_Options_Switches
(Project : Project_Id; (Project : Project_Id;
...@@ -127,8 +129,8 @@ package Makeutl is ...@@ -127,8 +129,8 @@ package Makeutl is
-- files exist and that they belong to a project file. -- files exist and that they belong to a project file.
function Unit_Index_Of (ALI_File : File_Name_Type) return Int; 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 -- Find the index of a unit in a source file. Return zero if the file is
-- is not a multi-unit source file. -- not a multi-unit source file.
package Mains is package Mains is
...@@ -149,8 +151,8 @@ package Makeutl is ...@@ -149,8 +151,8 @@ package Makeutl is
-- Reset the index to the beginning of the table -- Reset the index to the beginning of the table
function Next_Main return String; function Next_Main return String;
-- Increase the index and return the next main. -- Increase the index and return the next main. If table is exhausted,
-- If table is exhausted, return an empty string. -- return an empty string.
function Get_Location return Source_Ptr; function Get_Location return Source_Ptr;
-- Get the location of the current main -- Get the location of the current main
...@@ -170,12 +172,12 @@ package Makeutl is ...@@ -170,12 +172,12 @@ package Makeutl is
Including_L_Switch : Boolean := True; Including_L_Switch : Boolean := True;
Including_Non_Switch : Boolean := True; Including_Non_Switch : Boolean := True;
Including_RTS : Boolean := False); Including_RTS : Boolean := False);
-- Test if Switch is a relative search path switch. -- Test if Switch is a relative search path switch. If it is, fail if
-- If it is, fail if Parent is the empty string, otherwise prepend the path -- Parent is the empty string, otherwise prepend the path with Parent.
-- with Parent. This subprogram is only called when using project files. -- This subprogram is only called when using project files. For gnatbind
-- For gnatbind switches, Including_L_Switch is False, because the -- switches, Including_L_Switch is False, because the argument of the -L
-- argument of the -L switch is not a path. If Including_RTS is True, -- switch is not a path. If Including_RTS is True, process also switches
-- process also switches --RTS=. -- --RTS=.
function Path_Or_File_Name (Path : Path_Name_Type) return String; function Path_Or_File_Name (Path : Path_Name_Type) return String;
-- Returns a file name if -df is used, otherwise return a path name -- Returns a file name if -df is used, otherwise return a path name
...@@ -185,9 +187,9 @@ package Makeutl is ...@@ -185,9 +187,9 @@ package Makeutl is
---------------------- ----------------------
procedure Mark (Source_File : File_Name_Type; Index : Int := 0); procedure Mark (Source_File : File_Name_Type; Index : Int := 0);
-- Mark a unit, identified by its source file and, when Index is not 0, -- Mark a unit, identified by its source file and, when Index is not 0, the
-- the index of the unit in the source file. Marking is used to signal -- index of the unit in the source file. Marking is used to signal that the
-- that the unit has already been inserted in the Q. -- unit has already been inserted in the Q.
function Is_Marked function Is_Marked
(Source_File : File_Name_Type; (Source_File : File_Name_Type;
......
...@@ -1053,6 +1053,7 @@ package body Prj is ...@@ -1053,6 +1053,7 @@ package body Prj is
----------------------------------- -----------------------------------
procedure Compute_All_Imported_Projects (Project : Project_Id) is procedure Compute_All_Imported_Projects (Project : Project_Id) is
procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean); procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean);
-- Recursively add the projects imported by project Project, but not -- Recursively add the projects imported by project Project, but not
-- those that are extended. -- those that are extended.
...@@ -1070,6 +1071,7 @@ package body Prj is ...@@ -1070,6 +1071,7 @@ package body Prj is
-- A project is not importing itself -- A project is not importing itself
Prj2 := Ultimate_Extending_Project_Of (Prj); Prj2 := Ultimate_Extending_Project_Of (Prj);
if Project /= Prj2 then if Project /= Prj2 then
-- Check that the project is not already in the list. We know the -- Check that the project is not already in the list. We know the
...@@ -1081,6 +1083,7 @@ package body Prj is ...@@ -1081,6 +1083,7 @@ package body Prj is
if List.Project = Prj2 then if List.Project = Prj2 then
return; return;
end if; end if;
List := List.Next; List := List.Next;
end loop; end loop;
...@@ -1095,6 +1098,7 @@ package body Prj is ...@@ -1095,6 +1098,7 @@ package body Prj is
procedure For_All_Projects is procedure For_All_Projects is
new For_Every_Project_Imported (Boolean, Recursive_Add); new For_Every_Project_Imported (Boolean, Recursive_Add);
Dummy : Boolean := False; Dummy : Boolean := False;
begin begin
......
...@@ -4826,20 +4826,21 @@ package body Sem_Ch3 is ...@@ -4826,20 +4826,21 @@ package body Sem_Ch3 is
Parent_Type : Entity_Id; Parent_Type : Entity_Id;
Derived_Type : Entity_Id) Derived_Type : Entity_Id)
is 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 : Node_Id;
Corr_Decl_Needed : Boolean; Corr_Decl_Needed : Boolean;
-- If the derived type has fewer discriminants than its parent, -- If the derived type has fewer discriminants than its parent, the
-- the corresponding record is also a derived type, in order to -- corresponding record is also a derived type, in order to account for
-- account for the bound discriminants. We create a full type -- the bound discriminants. We create a full type declaration for it in
-- declaration for it in this case. -- this case.
Constraint_Present : constant Boolean Constraint_Present : constant Boolean :=
:= Nkind (Subtype_Indication (Type_Definition (N))) Nkind (Subtype_Indication (Type_Definition (N))) =
= N_Subtype_Indication; N_Subtype_Indication;
D_Constraint : Node_Id; D_Constraint : Node_Id;
New_Constraint : Elist_Id; New_Constraint : Elist_Id;
...@@ -4867,8 +4868,9 @@ package body Sem_Ch3 is ...@@ -4867,8 +4868,9 @@ package body Sem_Ch3 is
-- The new type has fewer discriminants, so we need to create a new -- The new type has fewer discriminants, so we need to create a new
-- corresponding record, which is derived from the corresponding -- corresponding record, which is derived from the corresponding
-- record of the parent, and has a stored constraint that -- record of the parent, and has a stored constraint that captures
-- captures the values of the discriminant constraints. -- the values of the discriminant constraints.
-- The type declaration for the derived corresponding record has -- The type declaration for the derived corresponding record has
-- the same discriminant part and constraints as the current -- the same discriminant part and constraints as the current
-- declaration. Copy the unanalyzed tree to build declaration. -- declaration. Copy the unanalyzed tree to build declaration.
...@@ -4980,15 +4982,13 @@ package body Sem_Ch3 is ...@@ -4980,15 +4982,13 @@ package body Sem_Ch3 is
while Present (D_Constraint) loop while Present (D_Constraint) loop
if Nkind (D_Constraint) /= N_Discriminant_Association then if Nkind (D_Constraint) /= N_Discriminant_Association then
-- Positional constraint. If it is a reference to a -- Positional constraint. If it is a reference to a new
-- new discriminant, it constrains the corresponding -- discriminant, it constrains the corresponding old one.
-- old one.
if Nkind (D_Constraint) = N_Identifier then if Nkind (D_Constraint) = N_Identifier then
New_Disc := First_Discriminant (Derived_Type); New_Disc := First_Discriminant (Derived_Type);
while Present (New_Disc) loop while Present (New_Disc) loop
exit when exit when Chars (New_Disc) = Chars (D_Constraint);
Chars (New_Disc) = Chars (D_Constraint);
Next_Discriminant (New_Disc); Next_Discriminant (New_Disc);
end loop; end loop;
...@@ -4999,12 +4999,12 @@ package body Sem_Ch3 is ...@@ -4999,12 +4999,12 @@ package body Sem_Ch3 is
Next_Discriminant (Old_Disc); Next_Discriminant (Old_Disc);
-- if this is a named constraint, search by name for the -- if this is a named constraint, search by name for the old
-- old discriminants constrained by the new one. -- discriminants constrained by the new one.
elsif Nkind (Expression (D_Constraint)) = N_Identifier then 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); New_Disc := First_Discriminant (Derived_Type);
while Present (New_Disc) loop while Present (New_Disc) loop
...@@ -5015,20 +5015,17 @@ package body Sem_Ch3 is ...@@ -5015,20 +5015,17 @@ package body Sem_Ch3 is
if Present (New_Disc) then if Present (New_Disc) then
-- Verify that the new discriminant renames -- Verify that new discriminant renames some discriminant
-- some discriminant of the parent type, and -- of the parent type, and associate the new discriminant
-- associate the new discriminant with an old -- with one or more old ones that it renames.
-- one that it renames (may be more than one).
declare declare
Selector : Node_Id; Selector : Node_Id;
begin begin
Selector := First (Selector_Names (D_Constraint)); Selector := First (Selector_Names (D_Constraint));
while Present (Selector) loop while Present (Selector) loop
Old_Disc := First_Discriminant (Parent_Type); Old_Disc := First_Discriminant (Parent_Type);
while Present (Old_Disc) loop while Present (Old_Disc) loop
exit when Chars (Old_Disc) = Chars (Selector); exit when Chars (Old_Disc) = Chars (Selector);
Next_Discriminant (Old_Disc); Next_Discriminant (Old_Disc);
...@@ -5037,7 +5034,6 @@ package body Sem_Ch3 is ...@@ -5037,7 +5034,6 @@ package body Sem_Ch3 is
if Present (Old_Disc) then if Present (Old_Disc) then
Set_Corresponding_Discriminant Set_Corresponding_Discriminant
(New_Disc, Old_Disc); (New_Disc, Old_Disc);
end if; end if;
Next (Selector); Next (Selector);
...@@ -5049,21 +5045,20 @@ package body Sem_Ch3 is ...@@ -5049,21 +5045,20 @@ package body Sem_Ch3 is
Next (D_Constraint); Next (D_Constraint);
end loop; end loop;
New_Disc := First_Discriminant (Derived_Type); New_Disc := First_Discriminant (Derived_Type);
while Present (New_Disc) loop while Present (New_Disc) loop
if No (Corresponding_Discriminant (New_Disc)) then if No (Corresponding_Discriminant (New_Disc)) then
Error_Msg_NE Error_Msg_NE
("new discriminant& must constraint old one", ("new discriminant& must constrain old one", N, New_Disc);
N, New_Disc);
elsif not elsif not
Subtypes_Statically_Compatible ( Subtypes_Statically_Compatible
Etype (New_Disc), (Etype (New_Disc),
Etype (Corresponding_Discriminant (New_Disc))) Etype (Corresponding_Discriminant (New_Disc)))
then then
Error_Msg_NE Error_Msg_NE
("& not statically compatible with parent discriminant", ("& not statically compatible with parent discriminant",
N, New_Disc); N, New_Disc);
end if; end if;
Next_Discriminant (New_Disc); Next_Discriminant (New_Disc);
...@@ -5072,22 +5067,20 @@ package body Sem_Ch3 is ...@@ -5072,22 +5067,20 @@ package body Sem_Ch3 is
elsif Present (Discriminant_Specifications (N)) then elsif Present (Discriminant_Specifications (N)) then
Error_Msg_N Error_Msg_N
("missing discriminant constraint in untagged derivation", ("missing discriminant constraint in untagged derivation", N);
N);
end if; end if;
-- The entity chain of the derived type includes the new -- The entity chain of the derived type includes the new discriminants
-- discriminants but shares operations with the parent. -- but shares operations with the parent.
if Present (Discriminant_Specifications (N)) then if Present (Discriminant_Specifications (N)) then
Old_Disc := First_Discriminant (Parent_Type); Old_Disc := First_Discriminant (Parent_Type);
while Present (Old_Disc) loop while Present (Old_Disc) loop
if No (Next_Entity (Old_Disc)) if No (Next_Entity (Old_Disc))
or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant or else Ekind (Next_Entity (Old_Disc)) /= E_Discriminant
then then
Set_Next_Entity (Last_Entity (Derived_Type), Set_Next_Entity
Next_Entity (Old_Disc)); (Last_Entity (Derived_Type), Next_Entity (Old_Disc));
exit; exit;
end if; end if;
......
...@@ -10448,10 +10448,7 @@ package body Sem_Util is ...@@ -10448,10 +10448,7 @@ package body Sem_Util is
begin begin
-- Deal with indexed or selected component where prefix is modified -- Deal with indexed or selected component where prefix is modified
if Nkind (N) = N_Indexed_Component if Nkind_In (N, N_Indexed_Component, N_Selected_Component) then
or else
Nkind (N) = N_Selected_Component
then
Pref := Prefix (N); Pref := Prefix (N);
-- If prefix is access type, then it is the designated object that is -- If prefix is access type, then it is the designated object that is
......
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