+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
#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
-- 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
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;
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);
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
end if;
end if;
end;
- end loop D_Check;
+ end loop;
return True;
end Check_Source_Info_In_ALI;
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
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
-- -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;
-- 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;
-- 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
-- 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
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
----------------------
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;
-----------------------------------
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.
-- 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
if List.Project = Prj2 then
return;
end if;
+
List := List.Next;
end loop;
procedure For_All_Projects is
new For_Every_Project_Imported (Boolean, Recursive_Add);
+
Dummy : Boolean := False;
begin
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;
-- 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.
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;
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
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);
if Present (Old_Disc) then
Set_Corresponding_Discriminant
(New_Disc, Old_Disc);
-
end if;
Next (Selector);
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);
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;
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
projects / platform / upstream / gcc.git / commitdiff