-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Debug; use Debug;
with Binderr; use Binderr;
with Lib; use Lib;
-with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
with Osint; use Osint;
-- Get_File_Checksum --
-----------------------
- function Get_File_Checksum (Fname : Name_Id) return Word is
- Full_Name : Name_Id;
+ function Get_File_Checksum (Fname : File_Name_Type) return Word is
+ Full_Name : File_Name_Type;
Source_Index : Source_File_Index;
begin
if Text = null then
if Generic_Separately_Compiled (Withs.Table (W).Sfile) then
- Error_Msg_Name_1 := Afile;
- Error_Msg_Name_2 := Withs.Table (W).Sfile;
- Error_Msg ("% not found, % must be compiled");
+ Error_Msg_File_1 := Afile;
+ Error_Msg_File_2 := Withs.Table (W).Sfile;
+ Error_Msg ("{ not found, { must be compiled");
Set_Name_Table_Info (Afile, Int (No_Unit_Id));
return;
Free (Text);
if ALIs.Table (Idread).Compile_Errors then
- Error_Msg_Name_1 := Withs.Table (W).Sfile;
- Error_Msg ("% had errors, must be fixed, and recompiled");
+ Error_Msg_File_1 := Withs.Table (W).Sfile;
+ Error_Msg ("{ had errors, must be fixed, and recompiled");
Set_Name_Table_Info (Afile, Int (No_Unit_Id));
elsif ALIs.Table (Idread).No_Object then
- Error_Msg_Name_1 := Withs.Table (W).Sfile;
- Error_Msg ("% must be recompiled");
+ Error_Msg_File_1 := Withs.Table (W).Sfile;
+ Error_Msg ("{ must be recompiled");
Set_Name_Table_Info (Afile, Int (No_Unit_Id));
end if;
loop
F := Sdep.Table (D).Sfile;
- if F /= No_Name then
+ if F /= No_File then
-- If this is the first time we are seeing this source file,
-- then make a new entry in the source table.
-- In All_Sources mode, flag error of file not found
if Opt.All_Sources then
- Error_Msg_Name_1 := F;
- Error_Msg ("cannot locate %");
+ Error_Msg_File_1 := F;
+ Error_Msg ("cannot locate {");
end if;
end if;
function Time_Stamp_Mismatch
(A : ALI_Id;
- Read_Only : Boolean := False)
- return File_Name_Type
+ Read_Only : Boolean := False) return File_Name_Type
is
Src : Source_Id;
-- Source file Id for the current Sdep entry
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- be read, scanned, and processed recursively.
procedure Set_Source_Table (A : ALI_Id);
- -- Build source table entry corresponding to the ALI file whose id is A.
+ -- Build source table entry corresponding to the ALI file whose id is A
procedure Set_Source_Table;
- -- Build the entire source table.
+ -- Build the entire source table
function Time_Stamp_Mismatch
(A : ALI_Id;
- Read_Only : Boolean := False)
- return File_Name_Type;
+ Read_Only : Boolean := False) return File_Name_Type;
-- Looks in the Source_Table and checks time stamp mismatches between
-- the sources there and the sources in the Sdep section of ali file whose
-- id is A. If no time stamp mismatches are found No_File is returned.
-- in a false negative, but that is never harmful, it just means
-- that in unusual cases an unnecessary recompilation occurs.
- function Get_File_Checksum (Fname : Name_Id) return Word;
+ function Get_File_Checksum (Fname : File_Name_Type) return Word;
-- Compute checksum for the given file. As far as possible, this circuit
-- computes exactly the same value computed by the compiler, but it does
-- not matter if it gets it wrong in marginal cases, since the only result
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Butil; use Butil;
with Debug; use Debug;
with Fname; use Fname;
-with Namet; use Namet;
with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
function Getc return Character;
-- Get next character, bumping P past the character obtained
+ function Get_File_Name (Lower : Boolean := False) return File_Name_Type;
+ -- Skip blanks, then scan out a file name (name is left in Name_Buffer
+ -- with length in Name_Len, as well as returning a File_Name_Type value.
+ -- If lower is false, the case is unchanged, if Lower is True then the
+ -- result is forced to all lower case for systems where file names are
+ -- not case sensitive. This ensures that gnatbind works correctly
+ -- regardless of the case of the file name on all systems. The scan
+ -- is terminated by a end of line, space or horizontal tab. Any other
+ -- special characters are included in the returned name.
+
function Get_Name
- (Lower : Boolean := False;
- Ignore_Spaces : Boolean := False) return Name_Id;
+ (Ignore_Spaces : Boolean := False;
+ Ignore_Special : Boolean := False)return Name_Id;
-- Skip blanks, then scan out a name (name is left in Name_Buffer with
-- length in Name_Len, as well as being returned in Name_Id form).
-- If Lower is set to True then the Name_Buffer will be converted to
-- all lower case, for systems where file names are not case sensitive.
-- This ensures that gnatbind works correctly regardless of the case
- -- of the file name on all systems. The name is terminated by a either
- -- white space (when Ignore_Spaces is False) or a typeref bracket or
- -- an equal sign except for the special case of an operator name
- -- starting with a double quite which is terminated by another double
- -- quote. This function handles wide characters properly.
+ -- of the file name on all systems. The termination condition depends
+ -- on the settings of Ignore_Spaces and Ignore_Special:
+ --
+ -- If Ignore_Spaces is False (normal case), then scan is terminated
+ -- by the normal end of field condition (EOL, space, horizontal tab)
+ --
+ -- If Ignore_Special is False (normal case), the scan is terminated by
+ -- a typeref bracket or an equal sign except for the special case of
+ -- an operator name starting with a double quite which is terminated
+ -- by another double quote.
+ --
+ -- It is an error to set both Ignore_Spaces and Ignore_Special to True.
+ -- This function handles wide characters properly.
function Get_Nat return Nat;
-- Skip blanks, then scan out an unsigned integer value in Nat range
function Get_Stamp return Time_Stamp_Type;
-- Skip blanks, then scan out a time stamp
+ function Get_Unit_Name return Unit_Name_Type;
+ -- Skip blanks, then scan out a file name (name is left in Name_Buffer
+ -- with length in Name_Len, as well as returning a Unit_Name_Type value.
+ -- The case is unchanged and terminated by a normal end of field.
+
function Nextc return Character;
-- Return current character without modifying pointer P
Write_Name (F);
Write_Str (" is incorrectly formatted");
Write_Eol;
- Write_Str
- ("make sure you are using consistent versions of gcc/gnatbind");
+
+ Write_Str ("make sure you are using consistent versions " &
+
+ -- Split the following line so that it can easily be transformed for
+ -- e.g. JVM/.NET back-ends where the compiler has a different name.
+
+ "of gcc/gnatbind");
+
Write_Eol;
-- Find start of line
end if;
end Fatal_Error_Ignore;
+ -------------------
+ -- Get_File_Name --
+ -------------------
+
+ function Get_File_Name
+ (Lower : Boolean := False) return File_Name_Type
+ is
+ F : Name_Id;
+
+ begin
+ F := Get_Name (Ignore_Special => True);
+
+ -- Convert file name to all lower case if file names are not case
+ -- sensitive. This ensures that we handle names in the canonical
+ -- lower case format, regardless of the actual case.
+
+ if Lower and not File_Names_Case_Sensitive then
+ Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
+ return Name_Find;
+ else
+ return File_Name_Type (F);
+ end if;
+ end Get_File_Name;
+
--------------
-- Get_Name --
--------------
function Get_Name
- (Lower : Boolean := False;
- Ignore_Spaces : Boolean := False) return Name_Id
+ (Ignore_Spaces : Boolean := False;
+ Ignore_Special : Boolean := False) return Name_Id
is
begin
Name_Len := 0;
exit when At_End_Of_Field and not Ignore_Spaces;
- if Name_Buffer (1) = '"' then
- exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"';
+ if not Ignore_Special then
+ if Name_Buffer (1) = '"' then
+ exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"';
- else
- -- Terminate on parens or angle brackets or equal sign
+ else
+ -- Terminate on parens or angle brackets or equal sign
- exit when Nextc = '(' or else Nextc = ')'
- or else Nextc = '{' or else Nextc = '}'
- or else Nextc = '<' or else Nextc = '>'
- or else Nextc = '=';
+ exit when Nextc = '(' or else Nextc = ')'
+ or else Nextc = '{' or else Nextc = '}'
+ or else Nextc = '<' or else Nextc = '>'
+ or else Nextc = '=';
- -- Terminate if left bracket not part of wide char sequence
- -- Note that we only recognize brackets notation so far ???
+ -- Terminate if left bracket not part of wide char sequence
+ -- Note that we only recognize brackets notation so far ???
- exit when Nextc = '[' and then T (P + 1) /= '"';
+ exit when Nextc = '[' and then T (P + 1) /= '"';
- -- Terminate if right bracket not part of wide char sequence
+ -- Terminate if right bracket not part of wide char sequence
- exit when Nextc = ']' and then T (P - 1) /= '"';
+ exit when Nextc = ']' and then T (P - 1) /= '"';
+ end if;
end if;
end loop;
- -- Convert file name to all lower case if file names are not case
- -- sensitive. This ensures that we handle names in the canonical
- -- lower case format, regardless of the actual case.
-
- if Lower and not File_Names_Case_Sensitive then
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- end if;
-
return Name_Find;
end Get_Name;
+ -------------------
+ -- Get_Unit_Name --
+ -------------------
+
+ function Get_Unit_Name return Unit_Name_Type is
+ begin
+ return Unit_Name_Type (Get_Name);
+ end Get_Unit_Name;
+
-------------
-- Get_Nat --
-------------
Queuing_Policy => ' ',
Restrictions => No_Restrictions,
SAL_Interface => False,
- Sfile => No_Name,
+ Sfile => No_File,
Task_Dispatching_Policy => ' ',
Time_Slice_Value => -1,
WC_Encoding => '8',
UL : Unit_Record renames Units.Table (Units.Last);
begin
- UL.Uname := Get_Name;
+ UL.Uname := Get_Unit_Name;
UL.Predefined := Is_Predefined_Unit;
UL.Internal := Is_Internal_Unit;
UL.My_ALI := Id;
- UL.Sfile := Get_Name (Lower => True);
+ UL.Sfile := Get_File_Name (Lower => True);
UL.Pure := False;
UL.Preelab := False;
UL.No_Elab := False;
Checkc (' ');
Skip_Space;
Withs.Increment_Last;
- Withs.Table (Withs.Last).Uname := Get_Name;
+ Withs.Table (Withs.Last).Uname := Get_Unit_Name;
Withs.Table (Withs.Last).Elaborate := False;
Withs.Table (Withs.Last).Elaborate_All := False;
Withs.Table (Withs.Last).Elab_Desirable := False;
-- Normal case
else
- Withs.Table (Withs.Last).Sfile := Get_Name (Lower => True);
- Withs.Table (Withs.Last).Afile := Get_Name;
+ Withs.Table (Withs.Last).Sfile := Get_File_Name
+ (Lower => True);
+ Withs.Table (Withs.Last).Afile := Get_File_Name
+ (Lower => True);
-- Scan out possible E, EA, ED, and AD parameters
True;
end if;
end if;
+
+ else
+ Fatal_Error;
end if;
end loop;
end if;
Checkc (' ');
Skip_Space;
Sdep.Increment_Last;
- Sdep.Table (Sdep.Last).Sfile := Get_Name (Lower => True);
+
+ -- In the following call, Lower is not set to True, this is either
+ -- a bug, or it deserves a special comment as to why this is so???
+
+ Sdep.Table (Sdep.Last).Sfile := Get_File_Name;
+
Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
Sdep.Table (Sdep.Last).Dummy_Entry :=
(Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp);
begin
XS.File_Num := Sdep_Id (Get_Nat + Nat (First_Sdep_Entry) - 1);
- XS.File_Name := Get_Name;
+ XS.File_Name := Get_File_Name;
XS.First_Entity := Xref_Entity.Last + 1;
Current_File_Num := XS.File_Num;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Casing; use Casing;
with Gnatvsn; use Gnatvsn;
+with Namet; use Namet;
with Rident; use Rident;
with Table;
with Types; use Types;
Afile : File_Name_Type;
-- Name of ALI file
- Ofile_Full_Name : Name_Id;
+ Ofile_Full_Name : File_Name_Type;
-- Full name of object file corresponding to the ALI file
Sfile : File_Name_Type;
File_Num : Sdep_Id;
-- Dependency number for file (entry in Sdep.Table)
- File_Name : Name_Id;
+ File_Name : File_Name_Type;
-- Name of file
First_Entity : Nat;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- file containing equivalent definitions for use by gigi.
with Debug; use Debug;
-with Namet; use Namet;
with Nlists; use Nlists;
with Elists; use Elists;
with Output; use Output;
function To_Flag_Word4_Ptr is new
Unchecked_Conversion (Union_Id_Ptr, Flag_Word4_Ptr);
+ -- The following declarations are used to store flags 216-247 in the
+ -- Field12 field of the fifth component of an extended (entity) node.
+
+ type Flag_Word5 is record
+ Flag216 : Boolean;
+ Flag217 : Boolean;
+ Flag218 : Boolean;
+ Flag219 : Boolean;
+ Flag220 : Boolean;
+ Flag221 : Boolean;
+ Flag222 : Boolean;
+ Flag223 : Boolean;
+
+ Flag224 : Boolean;
+ Flag225 : Boolean;
+ Flag226 : Boolean;
+ Flag227 : Boolean;
+ Flag228 : Boolean;
+ Flag229 : Boolean;
+ Flag230 : Boolean;
+
+ -- Note: flags 231-247 not in use yet
+
+ Flag231 : Boolean;
+
+ Flag232 : Boolean;
+ Flag233 : Boolean;
+ Flag234 : Boolean;
+ Flag235 : Boolean;
+ Flag236 : Boolean;
+ Flag237 : Boolean;
+ Flag238 : Boolean;
+ Flag239 : Boolean;
+
+ Flag240 : Boolean;
+ Flag241 : Boolean;
+ Flag242 : Boolean;
+ Flag243 : Boolean;
+ Flag244 : Boolean;
+ Flag245 : Boolean;
+ Flag246 : Boolean;
+ Flag247 : Boolean;
+ end record;
+
+ pragma Pack (Flag_Word5);
+ for Flag_Word5'Size use 32;
+ for Flag_Word5'Alignment use 4;
+
+ type Flag_Word5_Ptr is access all Flag_Word5;
+
+ function To_Flag_Word5 is new
+ Unchecked_Conversion (Union_Id, Flag_Word5);
+
+ function To_Flag_Word5_Ptr is new
+ Unchecked_Conversion (Union_Id_Ptr, Flag_Word5_Ptr);
+
-- Default value used to initialize default nodes. Note that some of the
-- fields get overwritten, and in particular, Nkind always gets reset.
package Orig_Nodes is new Table.Table (
Table_Component_Type => Node_Id,
- Table_Index_Type => Node_Id,
+ Table_Index_Type => Node_Id'Base,
Table_Low_Bound => First_Node_Id,
Table_Initial => Alloc.Orig_Nodes_Initial,
Table_Increment => Alloc.Orig_Nodes_Increment,
-- the copy, since we inserted the original, not the copy.
Nodes.Table (New_Id).Rewrite_Ins := False;
+ pragma Debug (New_Node_Debugging_Output (New_Id));
end if;
return New_Id;
Nodes.Table (Nod).Sloc := New_Sloc;
pragma Debug (New_Node_Debugging_Output (Nod));
- -- If this is a node with a real location and we are generating
- -- source nodes, then reset Current_Error_Node. This is useful
- -- if we bomb during parsing to get a error location for the bomb.
+ -- If this is a node with a real location and we are generating source
+ -- nodes, then reset Current_Error_Node. This is useful if we bomb
+ -- during parsing to get an error location for the bomb.
if Default_Node.Comes_From_Source and then New_Sloc > No_Location then
Current_Error_Node := Nod;
return To_Flag_Word4 (Nodes.Table (N + 4).Field11).Flag215;
end Flag215;
+ function Flag216 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag216;
+ end Flag216;
+
+ function Flag217 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag217;
+ end Flag217;
+
+ function Flag218 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag218;
+ end Flag218;
+
+ function Flag219 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag219;
+ end Flag219;
+
+ function Flag220 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag220;
+ end Flag220;
+
+ function Flag221 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag221;
+ end Flag221;
+
+ function Flag222 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag222;
+ end Flag222;
+
+ function Flag223 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag223;
+ end Flag223;
+
+ function Flag224 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag224;
+ end Flag224;
+
+ function Flag225 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag225;
+ end Flag225;
+
+ function Flag226 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag226;
+ end Flag226;
+
+ function Flag227 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag227;
+ end Flag227;
+
+ function Flag228 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag228;
+ end Flag228;
+
+ function Flag229 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag229;
+ end Flag229;
+
+ function Flag230 (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return To_Flag_Word5 (Nodes.Table (N + 4).Field12).Flag230;
+ end Flag230;
+
procedure Set_Nkind (N : Node_Id; Val : Node_Kind) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
(Nodes.Table (N + 4).Field11'Unrestricted_Access)).Flag215 := Val;
end Set_Flag215;
+ procedure Set_Flag216 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word5_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag216 := Val;
+ end Set_Flag216;
+
+ procedure Set_Flag217 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word5_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag217 := Val;
+ end Set_Flag217;
+
+ procedure Set_Flag218 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word5_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag218 := Val;
+ end Set_Flag218;
+
+ procedure Set_Flag219 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word5_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag219 := Val;
+ end Set_Flag219;
+
+ procedure Set_Flag220 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word5_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag220 := Val;
+ end Set_Flag220;
+
+ procedure Set_Flag221 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word5_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag221 := Val;
+ end Set_Flag221;
+
+ procedure Set_Flag222 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word5_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag222 := Val;
+ end Set_Flag222;
+
+ procedure Set_Flag223 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word5_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag223 := Val;
+ end Set_Flag223;
+
+ procedure Set_Flag224 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word5_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag224 := Val;
+ end Set_Flag224;
+
+ procedure Set_Flag225 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word5_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag225 := Val;
+ end Set_Flag225;
+
+ procedure Set_Flag226 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word5_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag226 := Val;
+ end Set_Flag226;
+
+ procedure Set_Flag227 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word5_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag227 := Val;
+ end Set_Flag227;
+
+ procedure Set_Flag228 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word5_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag228 := Val;
+ end Set_Flag228;
+
+ procedure Set_Flag229 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word5_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag229 := Val;
+ end Set_Flag229;
+
+ procedure Set_Flag230 (N : Node_Id; Val : Boolean) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ To_Flag_Word5_Ptr
+ (Union_Id_Ptr'
+ (Nodes.Table (N + 4).Field12'Unrestricted_Access)).Flag230 := Val;
+ end Set_Flag230;
+
procedure Set_Node1_With_Parent (N : Node_Id; Val : Node_Id) is
begin
pragma Assert (N in Nodes.First .. Nodes.Last);
end Unchecked_Access;
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock is
+ begin
+ Nodes.Locked := False;
+ Orig_Nodes.Locked := False;
+ end Unlock;
+
end Atree;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Alloc;
with Sinfo; use Sinfo;
with Einfo; use Einfo;
+with Namet; use Namet;
with Types; use Types;
with Snames; use Snames;
with System; use System;
-- by the parser. The package Entity_Info defines the semantic information
-- which is added to the tree nodes that represent declared entities (i.e.
-- the information which might typically be described in a separate symbol
--- table structure.
+-- table structure).
-- The front end of the compiler first parses the program and generates a
-- tree that is simply a syntactic representation of the program in abstract
-- show which token is referenced by this pointer.
-- In_List A flag used to indicate if the node is a member
- -- of a node list.
+ -- of a node list.
-- Rewrite_Sub A flag set if the node has been rewritten using
-- the Rewrite procedure. The original value of the
-- the level of parentheses. Up to 3 levels can be
-- accomodated. Anything more than 3 levels is treated
-- as 3 levels (conformance tests that complain about
- -- this are hereby deemed pathological!) Set to zero
+ -- this are hereby deemed pathological!). Set to zero
-- for non-subexpression nodes.
-- Comes_From_Source
-- it will take a bit of fiddling to change that ???
-- Note: the actual usage of FieldN (i.e. whether it contains a Elist_Id,
- -- List_Id, Name_Id, Node_Id, String_Id, Uint or Ureal), depends on the
+ -- List_Id, Name_Id, Node_Id, String_Id, Uint or Ureal) depends on the
-- value in Nkind. Generally the access to this field is always via the
-- functional interface, so the field names ElistN, ListN, NameN, NodeN,
-- StrN, UintN and UrealN are used only in the bodies of the access
-- entity, it is of type Entity_Kind which is defined
-- in package Einfo.
- -- Flag19 197 additional flags
+ -- Flag19 229 additional flags
-- ...
- -- Flag215
+ -- Flag247
-- Convention Entity convention (Convention_Id value)
-------------------------------------
-- A subpackage Atree.Unchecked_Access provides routines for reading and
- -- writing the fields defined above (Field1-27, Node1-27, Flag1-215 etc).
+ -- writing the fields defined above (Field1-27, Node1-27, Flag1-247 etc).
-- These unchecked access routines can be used for untyped traversals.
-- In addition they are used in the implementations of the Sinfo and
-- Einfo packages. These packages both provide logical synonyms for
-- which the parser could not parse correctly, and adding additional
-- semantic information (e.g. making constraint checks explicit). The
-- following subprograms are used for constructing the tree in the first
- -- place, and then for subsequent modifications as required
+ -- place, and then for subsequent modifications as required.
procedure Initialize;
-- Called at the start of compilation to initialize the allocation of
-- Tree_Read is used.
procedure Lock;
- -- Called before the backend is invoked to lock the nodes table
+ -- Called before the back end is invoked to lock the nodes table
+ -- Also called after Unlock to relock???
+
+ procedure Unlock;
+ -- Unlocks nodes table, in cases where the back end needs to modify it
procedure Tree_Read;
-- Initializes internal tables from current tree file using the relevant
function Flag215 (N : Node_Id) return Boolean;
pragma Inline (Flag215);
+ function Flag216 (N : Node_Id) return Boolean;
+ pragma Inline (Flag216);
+
+ function Flag217 (N : Node_Id) return Boolean;
+ pragma Inline (Flag217);
+
+ function Flag218 (N : Node_Id) return Boolean;
+ pragma Inline (Flag218);
+
+ function Flag219 (N : Node_Id) return Boolean;
+ pragma Inline (Flag219);
+
+ function Flag220 (N : Node_Id) return Boolean;
+ pragma Inline (Flag220);
+
+ function Flag221 (N : Node_Id) return Boolean;
+ pragma Inline (Flag221);
+
+ function Flag222 (N : Node_Id) return Boolean;
+ pragma Inline (Flag222);
+
+ function Flag223 (N : Node_Id) return Boolean;
+ pragma Inline (Flag223);
+
+ function Flag224 (N : Node_Id) return Boolean;
+ pragma Inline (Flag224);
+
+ function Flag225 (N : Node_Id) return Boolean;
+ pragma Inline (Flag225);
+
+ function Flag226 (N : Node_Id) return Boolean;
+ pragma Inline (Flag226);
+
+ function Flag227 (N : Node_Id) return Boolean;
+ pragma Inline (Flag227);
+
+ function Flag228 (N : Node_Id) return Boolean;
+ pragma Inline (Flag228);
+
+ function Flag229 (N : Node_Id) return Boolean;
+ pragma Inline (Flag229);
+
+ function Flag230 (N : Node_Id) return Boolean;
+ pragma Inline (Flag230);
+
-- Procedures to set value of indicated field
procedure Set_Nkind (N : Node_Id; Val : Node_Kind);
procedure Set_Flag215 (N : Node_Id; Val : Boolean);
pragma Inline (Set_Flag215);
+ procedure Set_Flag216 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag216);
+
+ procedure Set_Flag217 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag217);
+
+ procedure Set_Flag218 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag218);
+
+ procedure Set_Flag219 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag219);
+
+ procedure Set_Flag220 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag220);
+
+ procedure Set_Flag221 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag221);
+
+ procedure Set_Flag222 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag222);
+
+ procedure Set_Flag223 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag223);
+
+ procedure Set_Flag224 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag224);
+
+ procedure Set_Flag225 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag225);
+
+ procedure Set_Flag226 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag226);
+
+ procedure Set_Flag227 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag227);
+
+ procedure Set_Flag228 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag228);
+
+ procedure Set_Flag229 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag229);
+
+ procedure Set_Flag230 (N : Node_Id; Val : Boolean);
+ pragma Inline (Set_Flag230);
+
-- The following versions of Set_Noden also set the parent
-- pointer of the referenced node if it is non_Empty
-------------------------
-- The nodes of the tree are stored in a table (i.e. an array). In the
- -- case of extended nodes four consecutive components in the array are
+ -- case of extended nodes five consecutive components in the array are
-- used. There are thus two formats for array components. One is used
-- for non-extended nodes, and for the first component of extended
- -- nodes. The other is used for the extension parts (second, third and
- -- fourth components) of an extended node. A variant record structure
- -- is used to distinguish the two formats.
+ -- nodes. The other is used for the extension parts (second, third,
+ -- fourth and fifth components) of an extended node. A variant record
+ -- structure is used to distinguish the two formats.
type Node_Record (Is_Extension : Boolean := False) is record
-- Extension (second component) of extended node
when True =>
+
Field6 : Union_Id;
Field7 : Union_Id;
Field8 : Union_Id;
-- Field6-10 Holds Field24-Field28
-- Field11 Holds Flag184-Flag215
- -- Field12 currently unused, reserved for expansion
+ -- Field12 Holds Flag216-Flag230
end case;
end record;
for Node_Record'Size use 8*32;
for Node_Record'Alignment use 4;
- -- The following defines the extendible array used for the nodes table
- -- Nodes with extensions use two consecutive entries in the array
+ -- The following defines the extendable array used for the nodes table
+ -- Nodes with extensions use five consecutive entries in the array
package Nodes is new Table.Table (
Table_Component_Type => Node_Record,
- Table_Index_Type => Node_Id,
+ Table_Index_Type => Node_Id'Base,
Table_Low_Bound => First_Node_Id,
Table_Initial => Alloc.Nodes_Initial,
Table_Increment => Alloc.Nodes_Increment,
* *
* C Header File *
* *
- * Copyright (C) 1992-2006, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2007, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
Boolean flag215 : 1;
};
+/* Structure used for extra flags in fifth component overlaying Field12 */
+struct Flag_Word5
+{
+ Boolean flag216 : 1;
+ Boolean flag217 : 1;
+ Boolean flag218 : 1;
+ Boolean flag219 : 1;
+ Boolean flag220 : 1;
+ Boolean flag221 : 1;
+ Boolean flag222 : 1;
+ Boolean flag223 : 1;
+
+ Boolean flag224 : 1;
+ Boolean flag225 : 1;
+ Boolean flag226 : 1;
+ Boolean flag227 : 1;
+ Boolean flag228 : 1;
+ Boolean flag229 : 1;
+ Boolean flag230 : 1;
+ Boolean flag231 : 1;
+
+ Boolean flag232 : 1;
+ Boolean flag233 : 1;
+ Boolean flag234 : 1;
+ Boolean flag235 : 1;
+ Boolean flag236 : 1;
+ Boolean flag237 : 1;
+ Boolean flag238 : 1;
+ Boolean flag239 : 1;
+
+ Boolean flag240 : 1;
+ Boolean flag241 : 1;
+ Boolean flag242 : 1;
+ Boolean flag243 : 1;
+ Boolean flag244 : 1;
+ Boolean flag245 : 1;
+ Boolean flag246 : 1;
+ Boolean flag247 : 1;
+};
+
struct Non_Extended
{
Source_Ptr sloc;
Int field12;
struct Flag_Word fw;
struct Flag_Word2 fw2;
+ struct Flag_Word5 fw5;
} U;
};
#define Flag213(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.X.fw4.flag213)
#define Flag214(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.X.fw4.flag214)
#define Flag215(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.X.fw4.flag215)
+#define Flag216(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag216)
+#define Flag217(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag217)
+#define Flag218(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag218)
+#define Flag219(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag219)
+#define Flag220(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag220)
+#define Flag221(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag221)
+#define Flag222(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag222)
+#define Flag223(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag223)
+#define Flag224(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag224)
+#define Flag225(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag225)
+#define Flag226(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag226)
+#define Flag227(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag227)
+#define Flag228(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag228)
+#define Flag229(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag229)
+#define Flag230(N) (Nodes_Ptr[(N) - First_Node_Id + 4].V.EX.U.fw5.flag230)
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Produce an error or a warning message, depending on whether an
-- inconsistent configuration is permitted or not.
- function Same_Unit (U1 : Name_Id; U2 : Name_Id) return Boolean;
+ function Same_Unit (U1 : Unit_Name_Type; U2 : Name_Id) return Boolean;
-- Used to compare two unit names for No_Dependence checks. U1 is in
-- standard unit name format, and U2 is in literal form with periods.
Src : Source_Id;
-- Source file Id for this Sdep entry
- ALI_Path_Id : Name_Id;
+ ALI_Path_Id : File_Name_Type;
begin
-- First, we go through the source table to see if there are any cases
if Sdep.Table (D).Stamp /= Source.Table (Src).Stamp
and then not Source.Table (Src).All_Checksums_Match
then
- Error_Msg_Name_1 := ALIs.Table (A).Sfile;
- Error_Msg_Name_2 := Sdep.Table (D).Sfile;
+ Error_Msg_File_1 := ALIs.Table (A).Sfile;
+ Error_Msg_File_2 := Sdep.Table (D).Sfile;
-- Two styles of message, depending on whether or not
-- the updated file is the one that must be recompiled
- if Error_Msg_Name_1 = Error_Msg_Name_2 then
+ if Error_Msg_File_1 = Error_Msg_File_2 then
if Tolerate_Consistency_Errors then
Error_Msg
- ("?% has been modified and should be recompiled");
+ ("?{ has been modified and should be recompiled");
else
Error_Msg
- ("% has been modified and must be recompiled");
+ ("{ has been modified and must be recompiled");
end if;
else
Osint.Find_File ((ALIs.Table (A).Afile), Osint.Library);
if Osint.Is_Readonly_Library (ALI_Path_Id) then
if Tolerate_Consistency_Errors then
- Error_Msg ("?% should be recompiled");
- Error_Msg_Name_1 := ALI_Path_Id;
- Error_Msg ("?(% is obsolete and read-only)");
-
+ Error_Msg ("?{ should be recompiled");
+ Error_Msg_File_1 := ALI_Path_Id;
+ Error_Msg ("?({ is obsolete and read-only)");
else
- Error_Msg ("% must be compiled");
- Error_Msg_Name_1 := ALI_Path_Id;
- Error_Msg ("(% is obsolete and read-only)");
+ Error_Msg ("{ must be compiled");
+ Error_Msg_File_1 := ALI_Path_Id;
+ Error_Msg ("({ is obsolete and read-only)");
end if;
elsif Tolerate_Consistency_Errors then
("?% should be recompiled (% has been modified)");
else
- Error_Msg ("% must be recompiled (% has been modified)");
+ Error_Msg ("{ must be recompiled ({ has been modified)");
end if;
end if;
if (not Tolerate_Consistency_Errors) and Verbose_Mode then
- declare
- Msg : constant String := "% time stamp ";
- Buf : String (1 .. Msg'Length + Time_Stamp_Length);
-
- begin
- Buf (1 .. Msg'Length) := Msg;
- Buf (Msg'Length + 1 .. Buf'Length) :=
- String (Source.Table (Src).Stamp);
- Error_Msg_Name_1 := Sdep.Table (D).Sfile;
- Error_Msg (Buf);
- end;
+ Error_Msg_File_1 := Sdep.Table (D).Sfile;
+ Error_Msg
+ ("{ time stamp " & String (Source.Table (Src).Stamp));
- declare
- Msg : constant String := " conflicts with % timestamp ";
- Buf : String (1 .. Msg'Length + Time_Stamp_Length);
+ Error_Msg_File_1 := Sdep.Table (D).Sfile;
+ -- Something wrong here, should be different file ???
- begin
- Buf (1 .. Msg'Length) := Msg;
- Buf (Msg'Length + 1 .. Buf'Length) :=
- String (Sdep.Table (D).Stamp);
- Error_Msg_Name_1 := Sdep.Table (D).Sfile;
- Error_Msg (Buf);
- end;
+ Error_Msg
+ (" conflicts with { timestamp " &
+ String (Sdep.Table (D).Stamp));
end if;
-- Exit from the loop through Sdep entries once we find one
and then
ALIs.Table (A2).Task_Dispatching_Policy /= Policy
then
- Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
- Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
+ Error_Msg_File_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_File_2 := ALIs.Table (A2).Sfile;
Consistency_Error_Msg
- ("% and % compiled with different task" &
+ ("{ and { compiled with different task" &
" dispatching policies");
exit Find_Policy;
end if;
-- same partition.
if Task_Dispatching_Policy_Specified /= ' ' then
- Error_Msg_Name_1 := ALIs.Table (F).Sfile;
- Error_Msg_Name_2 :=
+ Error_Msg_File_1 := ALIs.Table (F).Sfile;
+ Error_Msg_File_2 :=
ALIs.Table (TDP_Pragma_Afile).Sfile;
- Error_Msg_Nat_1 := DTK.PSD_Pragma_Line;
+ Error_Msg_Nat_1 := DTK.PSD_Pragma_Line;
Consistency_Error_Msg
- ("Priority_Specific_Dispatching at %:#" &
- " incompatible with Task_Dispatching_Policy at %");
+ ("Priority_Specific_Dispatching at {:#" &
+ " incompatible with Task_Dispatching_Policy at {");
end if;
-- Ceiling_Locking must also be specified for a partition
if ALIs.Table (A).Locking_Policy /= ' '
and then ALIs.Table (A).Locking_Policy /= 'C'
then
- Error_Msg_Name_1 := ALIs.Table (F).Sfile;
- Error_Msg_Name_2 := ALIs.Table (A).Sfile;
+ Error_Msg_File_1 := ALIs.Table (F).Sfile;
+ Error_Msg_File_2 := ALIs.Table (A).Sfile;
Error_Msg_Nat_1 := DTK.PSD_Pragma_Line;
Consistency_Error_Msg
- ("Priority_Specific_Dispatching at %:#" &
- " incompatible with Locking_Policy at %");
+ ("Priority_Specific_Dispatching at {:#" &
+ " incompatible with Locking_Policy at {");
end if;
end loop;
end if;
DTK.Dispatching_Policy
then
- Error_Msg_Name_1 :=
+ Error_Msg_File_1 :=
ALIs.Table (PSD_Table (Prio).Afile).Sfile;
- Error_Msg_Name_2 := ALIs.Table (F).Sfile;
+ Error_Msg_File_2 := ALIs.Table (F).Sfile;
Error_Msg_Nat_1 := PSD_Table (Prio).Loc;
Error_Msg_Nat_2 := DTK.PSD_Pragma_Line;
Consistency_Error_Msg
- ("overlapping priority ranges at %:# and %:#");
+ ("overlapping priority ranges at {:# and {:#");
exit Find_Overlapping;
end if;
-- Issue warning, not one of the safe cases
else
- Error_Msg_Name_1 := UR.Sfile;
+ Error_Msg_File_1 := UR.Sfile;
Error_Msg
- ("?% has dynamic elaboration checks " &
+ ("?{ has dynamic elaboration checks " &
"and with's");
- Error_Msg_Name_1 := WU.Sfile;
+ Error_Msg_File_1 := WU.Sfile;
Error_Msg
- ("? % which has static elaboration " &
+ ("? { which has static elaboration " &
"checks");
Warnings_Detected := Warnings_Detected - 1;
begin
for A2 in A1 + 1 .. ALIs.Last loop
if ALIs.Table (A2).Float_Format /= Format then
- Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
- Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
+ Error_Msg_File_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_File_2 := ALIs.Table (A2).Sfile;
Consistency_Error_Msg
- ("% and % compiled with different " &
+ ("{ and { compiled with different " &
"floating-point representations");
exit Find_Format;
end if;
Loc (Inum) := Lnum;
elsif Istate (Inum) /= Stat then
- Error_Msg_Name_1 := ALIs.Table (Afile (Inum)).Sfile;
- Error_Msg_Name_2 := ALIs.Table (F).Sfile;
+ Error_Msg_File_1 := ALIs.Table (Afile (Inum)).Sfile;
+ Error_Msg_File_2 := ALIs.Table (F).Sfile;
Error_Msg_Nat_1 := Loc (Inum);
Error_Msg_Nat_2 := Lnum;
Consistency_Error_Msg
- ("inconsistent interrupt states at %:# and %:#");
+ ("inconsistent interrupt states at {:# and {:#");
end if;
end loop;
end loop;
if ALIs.Table (A2).Locking_Policy /= ' ' and
ALIs.Table (A2).Locking_Policy /= Policy
then
- Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
- Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
+ Error_Msg_File_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_File_2 := ALIs.Table (A2).Sfile;
Consistency_Error_Msg
- ("% and % compiled with different locking policies");
+ ("{ and { compiled with different locking policies");
exit Find_Policy;
end if;
end loop;
and then
ALIs.Table (A2).Queuing_Policy /= Policy
then
- Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
- Error_Msg_Name_2 := ALIs.Table (A2).Sfile;
+ Error_Msg_File_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_File_2 := ALIs.Table (A2).Sfile;
Consistency_Error_Msg
- ("% and % compiled with different queuing policies");
+ ("{ and { compiled with different queuing policies");
exit Find_Policy;
end if;
end loop;
-- in the case of a parameter restriction).
declare
- M1 : constant String := "% has restriction ";
+ M1 : constant String := "{ has restriction ";
S : constant String := Restriction_Id'Image (R);
M2 : String (1 .. 200); -- big enough!
P : Integer;
P := P + 5;
end if;
- Error_Msg_Name_1 := ALIs.Table (A).Sfile;
+ Error_Msg_File_1 := ALIs.Table (A).Sfile;
Consistency_Error_Msg (M2 (1 .. P - 1));
Consistency_Error_Msg
("but the following files violate this restriction:");
if R in All_Boolean_Restrictions then
Print_Restriction_File (R);
- Error_Msg_Name_1 := T.Sfile;
- Consistency_Error_Msg (" %");
+ Error_Msg_File_1 := T.Sfile;
+ Consistency_Error_Msg (" {");
-- Case of Parameter restriction where violation
-- count exceeds restriction value, print file
Cumulative_Restrictions.Value (R)
then
Print_Restriction_File (R);
- Error_Msg_Name_1 := T.Sfile;
+ Error_Msg_File_1 := T.Sfile;
Error_Msg_Nat_1 := Int (T.Restrictions.Count (R));
if T.Restrictions.Unknown (R) then
Consistency_Error_Msg
- (" % (count = at least #)");
+ (" { (count = at least #)");
else
Consistency_Error_Msg
(" % (count = #)");
for ND in No_Deps.First .. No_Deps.Last loop
declare
- ND_Unit : constant Name_Id := No_Deps.Table (ND).No_Dep_Unit;
+ ND_Unit : constant Name_Id :=
+ No_Deps.Table (ND).No_Dep_Unit;
begin
for J in ALIs.First .. ALIs.Last loop
U : Unit_Record renames Units.Table (K);
begin
for L in U.First_With .. U.Last_With loop
- if Same_Unit (Withs.Table (L).Uname, ND_Unit) then
- Error_Msg_Name_1 := U.Uname;
- Error_Msg_Name_2 := ND_Unit;
+ if Same_Unit
+ (Withs.Table (L).Uname, ND_Unit)
+ then
+ Error_Msg_File_1 := U.Sfile;
+ Error_Msg_Name_1 := ND_Unit;
Consistency_Error_Msg
- ("unit & violates restriction " &
+ ("file { violates restriction " &
"No_Dependence => %");
end if;
end loop;
if ALIs.Table (A1).Zero_Cost_Exceptions /=
ALIs.Table (ALIs.First).Zero_Cost_Exceptions
then
- Error_Msg_Name_1 := ALIs.Table (A1).Sfile;
- Error_Msg_Name_2 := ALIs.Table (ALIs.First).Sfile;
+ Error_Msg_File_1 := ALIs.Table (A1).Sfile;
+ Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile;
- Consistency_Error_Msg ("% and % compiled with different "
+ Consistency_Error_Msg ("{ and { compiled with different "
& "exception handling mechanisms");
end if;
end loop Check_Mechanism;
for K in Boolean loop
if K then
Name_Buffer (Name_Len) := 'b';
-
else
Name_Buffer (Name_Len) := 's';
end if;
declare
- Info : constant Int := Get_Name_Table_Info (Name_Find);
+ Unit : constant Unit_Name_Type := Name_Find;
+ Info : constant Int := Get_Name_Table_Info (Unit);
begin
if Info /= 0 then
or else ALIs.Table (A).Ver (1 .. VL) /=
ALIs.Table (ALIs.First).Ver (1 .. VL)
then
- Error_Msg_Name_1 := ALIs.Table (A).Sfile;
- Error_Msg_Name_2 := ALIs.Table (ALIs.First).Sfile;
+ Error_Msg_File_1 := ALIs.Table (A).Sfile;
+ Error_Msg_File_2 := ALIs.Table (ALIs.First).Sfile;
Consistency_Error_Msg
- ("% and % compiled with different GNAT versions");
+ ("{ and { compiled with different GNAT versions");
end if;
end loop;
end Check_Versions;
-- Same_Unit --
---------------
- function Same_Unit (U1 : Name_Id; U2 : Name_Id) return Boolean is
+ function Same_Unit (U1 : Unit_Name_Type; U2 : Name_Id) return Boolean is
begin
-- Note, the string U1 has a terminating %s or %b, U2 does not
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Elab_Error_Msg (S : Successor_Id);
-- Given a successor link, outputs an error message of the form
- -- "& must be elaborated before & ..." where ... is the reason.
+ -- "$ must be elaborated before $ ..." where ... is the reason.
procedure Gather_Dependencies;
-- Compute dependencies, building the Succ and UNR tables
-- Here we want to generate output
- Error_Msg_Name_1 := Units.Table (SL.Before).Uname;
+ Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
if SL.Elab_Body then
- Error_Msg_Name_2 := Units.Table (Corresponding_Body (SL.After)).Uname;
+ Error_Msg_Unit_2 := Units.Table (Corresponding_Body (SL.After)).Uname;
else
- Error_Msg_Name_2 := Units.Table (SL.After).Uname;
+ Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
end if;
- Error_Msg_Output (" & must be elaborated before &", Info => True);
+ Error_Msg_Output (" $ must be elaborated before $", Info => True);
- Error_Msg_Name_1 := Units.Table (SL.Reason_Unit).Uname;
+ Error_Msg_Unit_1 := Units.Table (SL.Reason_Unit).Uname;
case SL.Reason is
when Withed =>
when Elab =>
Error_Msg_Output
- (" reason: pragma Elaborate in unit &",
+ (" reason: pragma Elaborate in unit $",
Info => True);
when Elab_All =>
Error_Msg_Output
- (" reason: pragma Elaborate_All in unit &",
+ (" reason: pragma Elaborate_All in unit $",
Info => True);
when Elab_All_Desirable =>
Error_Msg_Output
- (" reason: implicit Elaborate_All in unit &",
+ (" reason: implicit Elaborate_All in unit $",
Info => True);
Error_Msg_Output
- (" recompile & with -gnatwl for full details",
+ (" recompile $ with -gnatwl for full details",
Info => True);
when Elab_Desirable =>
Error_Msg_Output
- (" reason: implicit Elaborate in unit &",
+ (" reason: implicit Elaborate in unit $",
Info => True);
Error_Msg_Output
- (" recompile & with -gnatwl for full details",
+ (" recompile $ with -gnatwl for full details",
Info => True);
when Spec_First =>
Write_Elab_All_Chain (S);
if SL.Elab_Body then
- Error_Msg_Name_1 := Units.Table (SL.Before).Uname;
- Error_Msg_Name_2 := Units.Table (SL.After).Uname;
+ Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
+ Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
Error_Msg_Output
- (" & must therefore be elaborated before &",
+ (" $ must therefore be elaborated before $",
True);
- Error_Msg_Name_1 := Units.Table (SL.After).Uname;
+ Error_Msg_Unit_1 := Units.Table (SL.After).Uname;
Error_Msg_Output
- (" (because & has a pragma Elaborate_Body)",
+ (" (because $ has a pragma Elaborate_Body)",
True);
end if;
- Write_Eol;
+ if not Zero_Formatting then
+ Write_Eol;
+ end if;
end Elab_Error_Msg;
---------------------
-- obsolete unit with's a previous (now disappeared) spec.
if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then
- Error_Msg_Name_1 := Units.Table (U).Sfile;
- Error_Msg_Name_2 := Withs.Table (W).Uname;
- Error_Msg ("% depends on & which no longer exists");
+ Error_Msg_File_1 := Units.Table (U).Sfile;
+ Error_Msg_Unit_1 := Withs.Table (W).Uname;
+ Error_Msg ("{ depends on $ which no longer exists");
goto Next_With;
end if;
procedure Write_Dependencies is
begin
- Write_Eol;
- Write_Str
- (" ELABORATION ORDER DEPENDENCIES");
- Write_Eol;
- Write_Eol;
+ if not Zero_Formatting then
+ Write_Eol;
+ Write_Str (" ELABORATION ORDER DEPENDENCIES");
+ Write_Eol;
+ Write_Eol;
+ end if;
Info_Prefix_Suppress := True;
end loop;
Info_Prefix_Suppress := False;
- Write_Eol;
+
+ if not Zero_Formatting then
+ Write_Eol;
+ end if;
end Write_Dependencies;
--------------------------
L := ST.Elab_All_Link;
while L /= No_Elab_All_Link loop
Nam := Elab_All_Entries.Table (L).Needed_By;
- Error_Msg_Name_1 := Nam;
- Error_Msg_Output (" &", Info => True);
+ Error_Msg_Unit_1 := Nam;
+ Error_Msg_Output (" $", Info => True);
Get_Name_String (Nam);
L := Elab_All_Entries.Table (L).Next_Elab;
end loop;
- Error_Msg_Name_1 := After;
- Error_Msg_Output (" &", Info => True);
+ Error_Msg_Unit_1 := After;
+ Error_Msg_Output (" $", Info => True);
end if;
end Write_Elab_All_Chain;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
-with Butil; use Butil;
-with Namet; use Namet;
-with Opt; use Opt;
-with Output; use Output;
+with Butil; use Butil;
+with Opt; use Opt;
+with Output; use Output;
package body Binderr is
----------------------
procedure Error_Msg_Output (Msg : String; Info : Boolean) is
- Use_Second_Name : Boolean := False;
+ Use_Second_File : Boolean := False;
+ Use_Second_Unit : Boolean := False;
Use_Second_Nat : Boolean := False;
+ Warning : Boolean := False;
begin
if Warnings_Detected + Errors_Detected > Maximum_Errors then
return;
end if;
- if Msg (Msg'First) = '?' then
+ -- First, check for warnings
+
+ for J in Msg'Range loop
+ if Msg (J) = '?' then
+ Warning := True;
+ exit;
+ end if;
+ end loop;
+
+ if Warning then
Write_Str ("warning: ");
elsif Info then
if not Info_Prefix_Suppress then
for J in Msg'Range loop
if Msg (J) = '%' then
+ Get_Name_String (Error_Msg_Name_1);
+ Write_Char ('"');
+ Write_Str (Name_Buffer (1 .. Name_Len));
+ Write_Char ('"');
- if Use_Second_Name then
- Get_Name_String (Error_Msg_Name_2);
+ elsif Msg (J) = '{' then
+ if Use_Second_File then
+ Get_Name_String (Error_Msg_File_2);
else
- Use_Second_Name := True;
- Get_Name_String (Error_Msg_Name_1);
+ Use_Second_File := True;
+ Get_Name_String (Error_Msg_File_1);
end if;
Write_Char ('"');
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Char ('"');
- elsif Msg (J) = '&' then
+ elsif Msg (J) = '$' then
Write_Char ('"');
- if Use_Second_Name then
- Write_Unit_Name (Error_Msg_Name_2);
+ if Use_Second_Unit then
+ Write_Unit_Name (Error_Msg_Unit_2);
else
- Use_Second_Name := True;
- Write_Unit_Name (Error_Msg_Name_1);
+ Use_Second_Unit := True;
+ Write_Unit_Name (Error_Msg_Unit_1);
end if;
Write_Char ('"');
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- This package contains the routines to output error messages for the binder
-- and also the routines for handling fatal error conditions in the binder.
+with Namet; use Namet;
with Types; use Types;
package Binderr is
-- appear which cause the error message circuit to modify the given
-- string as follows:
- -- Insertion character % (Percent: insert file name from Names table)
- -- The character % is replaced by the text for the file name specified
- -- by the Name_Id value stored in Error_Msg_Name_1. The name is always
- -- enclosed in quotes. A second % may appear in a single message in
- -- which case it is similarly replaced by the name which is specified
- -- by the Name_Id value stored in Error_Msg_Name_2.
+ -- Insertion character { (Left brace: insert file name from Names table)
+ -- The character { is replaced by the text for the file name specified
+ -- by the File_Name_Type value stored in Error_Msg_File_1. The name is
+ -- always enclosed in quotes. A second % may appear in a single message
+ -- in which case it is similarly replaced by the name which is
+ -- specified by the File_Name_Type value stored in Error_Msg_File_2.
- -- Insertion character & (Ampersand: insert unit name from Names table)
+ -- Insertion character $ (Dollar: insert unit name from Names table)
-- The character & is replaced by the text for the unit name specified
- -- by the Name_Id value stored in Error_Msg_Name_1. The name is always
+ -- by the Name_Id value stored in Error_Msg_Unit_1. The name is always
-- enclosed in quotes. A second & may appear in a single message in
-- which case it is similarly replaced by the name which is specified
- -- by the Name_Id value stored in Error_Msg_Name_2.
+ -- by the Name_Id value stored in Error_Msg_Unit_2.
-- Insertion character # (Pound: insert non-negative number in decimal)
-- The character # is replaced by the contents of Error_Msg_Nat_1
-- passed to the error message routine for insertion sequences described
-- above. The reason these are passed globally is that the insertion
-- mechanism is essentially an untyped one in which the appropriate
- -- variables are set dependingon the specific insertion characters used.
+ -- variables are set depending on the specific insertion characters used.
Error_Msg_Name_1 : Name_Id;
- Error_Msg_Name_2 : Name_Id;
- -- Name_Id values for % insertion characters in message
+ -- Name_Id value for % insertion characters in message
+
+ Error_Msg_File_1 : File_Name_Type;
+ Error_Msg_File_2 : File_Name_Type;
+ -- Name_Id values for { insertion characters in message
+
+ Error_Msg_Unit_1 : Unit_Name_Type;
+ Error_Msg_Unit_2 : Unit_Name_Type;
+ -- Name_Id values for $ insertion characters in message
Error_Msg_Nat_1 : Nat;
Error_Msg_Nat_2 : Nat;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
-with Namet; use Namet;
with Output; use Output;
with Targparm; use Targparm;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
-with Types; use Types;
+with Namet; use Namet;
package Butil is
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- This package contains variables common to error reporting packages
-- including Errout and Prj.Err.
+with Namet; use Namet;
with Types; use Types;
with Uintp; use Uintp;
Error_Msg_Name_3 : Name_Id;
-- Name_Id values for % insertion characters in message
- Error_Msg_Unit_1 : Name_Id;
- Error_Msg_Unit_2 : Name_Id;
- -- Name_Id values for $ insertion characters in message
+ Error_Msg_File_1 : File_Name_Type;
+ Error_Msg_File_2 : File_Name_Type;
+ Error_Msg_File_3 : File_Name_Type;
+ -- File_Name_Type values for { insertion characters in message
+
+ Error_Msg_Unit_1 : Unit_Name_Type;
+ Error_Msg_Unit_2 : Unit_Name_Type;
+ -- Unit_Name_Type values for $ insertion characters in message
Error_Msg_Node_1 : Node_Id;
Error_Msg_Node_2 : Node_Id;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
procedure Set_Msg_Insertion_File_Name is
begin
- if Error_Msg_Name_1 = No_Name then
+ if Error_Msg_File_1 = No_File then
null;
- elsif Error_Msg_Name_1 = Error_Name then
+ elsif Error_Msg_File_1 = Error_File_Name then
Set_Msg_Blank;
Set_Msg_Str ("<error>");
else
Set_Msg_Blank;
- Get_Name_String (Error_Msg_Name_1);
+ Get_Name_String (Error_Msg_File_1);
Set_Msg_Quote;
Set_Msg_Name_Buffer;
Set_Msg_Quote;
end if;
- -- The following assignments ensure that the second and third percent
- -- insertion characters will correspond to the Error_Msg_Name_2 and
- -- Error_Msg_Name_3 as required. We suppress possible validity checks in
- -- case operating in -gnatVa mode, and Error_Msg_Name_2/3 is not needed
- -- and has not been set.
+ -- The following assignments ensure that the second and third {
+ -- insertion characters will correspond to the Error_Msg_File_2 and
+ -- Error_Msg_File_3 values and We suppress possible validity checks in
+ -- case operating in -gnatVa mode, and Error_Msg_File_2 or
+ -- Error_Msg_File_3 is not needed and has not been set.
declare
pragma Suppress (Range_Check);
begin
- Error_Msg_Name_1 := Error_Msg_Name_2;
- Error_Msg_Name_2 := Error_Msg_Name_3;
+ Error_Msg_File_1 := Error_Msg_File_2;
+ Error_Msg_File_2 := Error_Msg_File_3;
end;
end Set_Msg_Insertion_File_Name;
end;
end Set_Msg_Insertion_Name;
+ ------------------------------------
+ -- Set_Msg_Insertion_Name_Literal --
+ ------------------------------------
+
+ procedure Set_Msg_Insertion_Name_Literal is
+ begin
+ if Error_Msg_Name_1 = No_Name then
+ null;
+
+ elsif Error_Msg_Name_1 = Error_Name then
+ Set_Msg_Blank;
+ Set_Msg_Str ("<error>");
+
+ else
+ Set_Msg_Blank;
+ Get_Name_String (Error_Msg_Name_1);
+ Set_Msg_Quote;
+ Set_Msg_Name_Buffer;
+ Set_Msg_Quote;
+ end if;
+
+ -- The following assignments ensure that the second and third % or %%
+ -- insertion characters will correspond to the Error_Msg_Name_2 and
+ -- Error_Msg_Name_3 values and We suppress possible validity checks in
+ -- case operating in -gnatVa mode, and Error_Msg_Name_2 or
+ -- Error_Msg_Name_3 is not needed and has not been set.
+
+ declare
+ pragma Suppress (Range_Check);
+ begin
+ Error_Msg_Name_1 := Error_Msg_Name_2;
+ Error_Msg_Name_2 := Error_Msg_Name_3;
+ end;
+ end Set_Msg_Insertion_Name_Literal;
+
-------------------------------------
-- Set_Msg_Insertion_Reserved_Name --
-------------------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- location to be referenced, and Flag is the location at which the
-- flag is posted (used to determine whether to add "in file xxx")
+ procedure Set_Msg_Insertion_Name_Literal;
+
procedure Set_Msg_Insertion_Name;
-- Handle name insertion (% insertion character)
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Check for insertion character
if C = '%' then
- Set_Msg_Insertion_Name;
+ if P <= Text'Last and then Text (P) = '%' then
+ P := P + 1;
+ Set_Msg_Insertion_Name_Literal;
+ else
+ Set_Msg_Insertion_Name;
+ end if;
elsif C = '$' then
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- and the special characters space, comma, period, colon and semicolon,
-- apostrophe and parentheses. Special insertion characters can also
-- appear which cause the error message circuit to modify the given
- -- string as follows:
-
- -- Ignored insertion characters: the following characters, used as
- -- insertion characters by Errout are ignored: '$', '&', and '}'.
- -- If present in an error message, they are not output and are not
- -- replaced by any text.
-
- -- Insertion character % (Percent: insert name from Names table)
- -- The character % is replaced by the text for the name specified by
- -- the Name_Id value stored in Error_Msg_Name_1. A blank precedes
- -- the name if it is preceded by a non-blank character other than a
- -- left parenthesis. The name is enclosed in quotes unless manual
- -- quotation mode is set. If the Name_Id is set to No_Name, then
- -- no insertion occurs; if the Name_Id is set to Error_Name, then
- -- the string <error> is inserted. A second and third % may appear
- -- in a single message, similarly replaced by the names which are
- -- specified by the Name_Id values stored in Error_Msg_Name_2 and
- -- Error_Msg_Name_3. The names are decoded and cased according to
- -- the current identifier casing mode.
-
- -- Insertion character { (Left brace: insert literally from names table)
- -- The character { is treated similarly to %, except that the
- -- name is output literally as stored in the names table without
- -- adjusting the casing. This can be used for file names and in
- -- other situations where the name string is to be output unchanged.
-
- -- Insertion character * (Asterisk, insert reserved word name)
- -- The insertion character * is treated exactly like % except that
- -- the resulting name is cased according to the default conventions
- -- for reserved words (see package Scans).
-
- -- Insertion character # (Pound: insert line number reference)
- -- The character # is replaced by the string indicating the source
- -- position stored in Error_Msg_Sloc. There are two cases:
- --
- -- for locations in current file: at line nnn:ccc
- -- for locations in other files: at filename:nnn:ccc
- --
- -- By convention, the # insertion character is only used at the end
- -- of an error message, so the above strings only appear as the last
- -- characters of an error message.
-
- -- Insertion character @ (At: insert column number reference)
- -- The character @ is replaced by null if the RM_Column_Check mode is
- -- off (False). If the switch is on (True), then @ is replaced by the
- -- text string " in column nnn" where nnn is the decimal representation
- -- of the column number stored in Error_Msg_Col plus one (the plus one
- -- is because the number is stored 0-origin and displayed 1-origin).
-
- -- Insertion character ^ (Carret: insert integer value)
- -- The character ^ is replaced by the decimal conversion of the Uint
- -- value stored in Error_Msg_Uint_1, with a possible leading minus.
- -- A second ^ may occur in the message, in which case it is replaced
- -- by the decimal conversion of the Uint value in Error_Msg_Uint_2.
-
- -- Insertion character ! (Exclamation: unconditional message)
- -- The character ! appearing as the last character of a message makes
- -- the message unconditional which means that it is output even if it
- -- would normally be suppressed.
-
- -- Insertion character ? (Question: warning message)
- -- The character ? appearing anywhere in a message makes the message
- -- a warning instead of a normal error message, and the text of the
- -- message will be preceded by "Warning:" instead of "Error:" The
- -- handling of warnings if further controlled by the Warning_Mode
- -- option (-w switch), see package Opt for further details, and
- -- also by the current setting from pragma Warnings. This pragma
- -- applies only to warnings issued from the semantic phase (not
- -- the parser), but currently all relevant warnings are posted
- -- by the semantic phase anyway. Messages starting with (style)
- -- are also treated as warning messages.
-
- -- Insertion character A-Z (Upper case letter: Ada reserved word)
- -- If two or more upper case letters appear in the message, they are
- -- taken as an Ada reserved word, and are converted to the default
- -- case for reserved words (see Scans package spec). Surrounding
- -- quotes are added unless manual quotation mode is currently set.
-
- -- Insertion character ` (Backquote: set manual quotation mode)
- -- The backquote character always appears in pairs. Each backquote
- -- of the pair is replaced by a double quote character. In addition,
- -- Any reserved keywords, or name insertions between these backquotes
- -- are not surrounded by the usual automatic double quotes. See the
- -- section below on manual quotation mode for further details.
-
- -- Insertion character ' (Quote: literal character)
- -- Precedes a character which is placed literally into the message.
- -- Used to insert characters into messages that are one of the
- -- insertion characters defined here.
-
- -- Insertion character \ (Backslash: continuation message)
- -- Indicates that the message is a continuation of a message
- -- previously posted. This is used to ensure that such groups
- -- of messages are treated as a unit. The \ character must be
- -- the first character of the message text.
+ -- string. For a full list of these, see the spec of errout.
-----------------------------------------------------
-- Format of Messages and Manual Quotation Control --
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Elists; use Elists;
with Exp_Util; use Exp_Util;
with Lib; use Lib;
-with Namet; use Namet;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Type Support Subprogram (TSS) handling
+with Namet; use Namet;
with Types; use Types;
package Exp_Tss is
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with Namet; use Namet;
-with Opt; use Opt;
-with Osint; use Osint;
-with Output; use Output;
+with Opt; use Opt;
+with Osint; use Osint;
+with Output; use Output;
with Table;
+with Types; use Types;
+
+with System.OS_Lib; use System.OS_Lib;
with Unchecked_Conversion;
-- Hash table to map unit names to file names. Used in conjunction with
-- table File_Mapping above.
+ function Hash (F : File_Name_Type) return Header_Num;
+ -- Function used to compute hash of file name
+
package File_Hash_Table is new GNAT.HTable.Simple_HTable (
Header_Num => Header_Num,
Element => Int,
-- Add_Forbidden_File_Name --
-----------------------------
- procedure Add_Forbidden_File_Name (Name : Name_Id) is
+ procedure Add_Forbidden_File_Name (Name : File_Name_Type) is
begin
Forbidden_Names.Set (Name, True);
end Add_Forbidden_File_Name;
-- Hash --
----------
+ function Hash (F : File_Name_Type) return Header_Num is
+ begin
+ return Header_Num (Int (F) rem Header_Num'Range_Length);
+ end Hash;
+
function Hash (F : Unit_Name_Type) return Header_Num is
begin
return Header_Num (Int (F) rem Header_Num'Range_Length);
Last : Natural := 0;
Uname : Unit_Name_Type;
- Fname : Name_Id;
- Pname : Name_Id;
-
- The_Mapping : Mapping;
+ Fname : File_Name_Type;
+ Pname : File_Name_Type;
- procedure Empty_Tables (Warning : Boolean := True);
+ procedure Empty_Tables;
-- Remove all entries in case of incorrect mapping file
- function Find_Name return Name_Id;
- -- Return Error_Name for "/", otherwise call Name_Find
+ function Find_File_Name return File_Name_Type;
+ -- Return Error_File_Name for "/", otherwise call Name_Find
+ -- What is this about, explanation required ???
+
+ function Find_Unit_Name return Unit_Name_Type;
+ -- Return Error_Unit_Name for "/", otherwise call Name_Find
+ -- Even more mysterious??? function appeared when Find_Name was split
+ -- for the two types, but this routine is definitely called!
procedure Get_Line;
-- Get a line from the mapping file
-- Empty_Tables --
------------------
- procedure Empty_Tables (Warning : Boolean := True) is
+ procedure Empty_Tables is
begin
- if Warning then
- Write_Str ("mapping file """);
- Write_Str (File_Name);
- Write_Line (""" is not taken into account");
- end if;
-
Unit_Hash_Table.Reset;
File_Hash_Table.Reset;
Path_Mapping.Set_Last (0);
Last_In_Table := 0;
end Empty_Tables;
- ---------------
- -- Find_Name --
- ---------------
+ --------------------
+ -- Find_File_Name --
+ --------------------
+
+ -- Why is only / illegal, why not \ on windows ???
- function Find_Name return Name_Id is
+ function Find_File_Name return File_Name_Type is
begin
if Name_Buffer (1 .. Name_Len) = "/" then
- return Error_Name;
-
+ return Error_File_Name;
else
return Name_Find;
end if;
- end Find_Name;
+ end Find_File_Name;
+
+ --------------------
+ -- Find_Unit_Name --
+ --------------------
+
+ function Find_Unit_Name return Unit_Name_Type is
+ begin
+ return Unit_Name_Type (Find_File_Name);
+ -- very odd ???
+ end Find_Unit_Name;
--------------
-- Get_Line --
Write_Line (""" is truncated");
end Report_Truncated;
- -- Start of procedure Initialize
+ -- Start of processing for Initialize
begin
- Empty_Tables (Warning => False);
+ Empty_Tables;
Name_Len := File_Name'Length;
Name_Buffer (1 .. Name_Len) := File_Name;
Read_Source_File (Name_Enter, 0, Hi, Src, Config);
Name_Len := Last - First + 1;
Name_Buffer (1 .. Name_Len) := SP (First .. Last);
- Uname := Find_Name;
+ Uname := Find_Unit_Name;
-- Get the file name
Name_Len := Last - First + 1;
Name_Buffer (1 .. Name_Len) := SP (First .. Last);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Fname := Find_Name;
+ Fname := Find_File_Name;
-- Get the path name
Name_Len := Last - First + 1;
Name_Buffer (1 .. Name_Len) := SP (First .. Last);
- Pname := Find_Name;
+ Pname := Find_File_Name;
-- Check for duplicate entries
if Unit_Hash_Table.Get (Uname) /= No_Entry then
- Write_Str ("warning: duplicate entry """);
- Write_Str (Get_Name_String (Uname));
- Write_Str (""" in mapping file """);
- Write_Str (File_Name);
- Write_Line ("""");
- The_Mapping := File_Mapping.Table (Unit_Hash_Table.Get (Uname));
- Write_Line (Get_Name_String (The_Mapping.Uname));
- Write_Line (Get_Name_String (The_Mapping.Fname));
Empty_Tables;
return;
end if;
if File_Hash_Table.Get (Fname) /= No_Entry then
- Write_Str ("warning: duplicate entry """);
- Write_Str (Get_Name_String (Fname));
- Write_Str (""" in mapping file """);
- Write_Str (File_Name);
- Write_Line ("""");
- The_Mapping := Path_Mapping.Table (File_Hash_Table.Get (Fname));
- Write_Line (Get_Name_String (The_Mapping.Uname));
- Write_Line (Get_Name_String (The_Mapping.Fname));
Empty_Tables;
return;
end if;
-- Record the length of the two mapping tables
Last_In_Table := File_Mapping.Last;
-
end Initialize;
----------------------
begin
if Forbidden_Names.Get (File) then
- return Error_Name;
+ return Error_File_Name;
end if;
Index := File_Hash_Table.Get (File);
-- Remove_Forbidden_File_Name --
--------------------------------
- procedure Remove_Forbidden_File_Name (Name : Name_Id) is
+ procedure Remove_Forbidden_File_Name (Name : File_Name_Type) is
begin
Forbidden_Names.Set (Name, False);
end Remove_Forbidden_File_Name;
end if;
for Unit in Last_In_Table + 1 .. File_Mapping.Last loop
- Put_Line (File_Mapping.Table (Unit).Uname);
- Put_Line (File_Mapping.Table (Unit).Fname);
- Put_Line (Path_Mapping.Table (Unit).Fname);
+ Put_Line (Name_Id (File_Mapping.Table (Unit).Uname));
+ Put_Line (Name_Id (File_Mapping.Table (Unit).Fname));
+ Put_Line (Name_Id (Path_Mapping.Table (Unit).Fname));
end loop;
-- Before closing the file, write the buffer to the file.
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2003, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- This package keeps two mappings: from unit names to file names,
-- and from file names to path names.
-with Types; use Types;
+with Namet; use Namet;
package Fmap is
-- for ASIS, for example) to remove any existing mappings from a previous
-- compilation.
- procedure Add_Forbidden_File_Name (Name : Name_Id);
+ procedure Add_Forbidden_File_Name (Name : File_Name_Type);
-- Indicate that a source file name is forbidden.
-- This is used by gnatmake when there are Locally_Removed_Files in
-- extending projects.
- procedure Remove_Forbidden_File_Name (Name : Name_Id);
+ procedure Remove_Forbidden_File_Name (Name : File_Name_Type);
-- Indicate that a source file name that was forbidden is no longer
-- forbidden. Used by gnatmake when a locally removed file is redefined
-- in another extending project.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with SFN_Scan; use SFN_Scan;
-with Namet; use Namet;
with Osint; use Osint;
+with Types; use Types;
with Unchecked_Conversion;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Debug; use Debug;
with Fmap; use Fmap;
with Krunch;
-with Namet; use Namet;
with Opt; use Opt;
with Osint; use Osint;
with Table;
-- Null or error name means that some previous error occurred
-- This is an unrecoverable error, so signal it.
- if Uname <= Error_Name then
+ if Uname in Error_Unit_Name_Or_No_Unit_Name then
raise Unrecoverable_Error;
end if;
Debug_Flag_4);
end if;
- Fnam := File_Name_Type (Name_Find);
+ Fnam := Name_Find;
-- If we are in the second search of the table, we accept
-- the file name without checking, because we know that
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- to deal with the extra dependencies).
with Casing; use Casing;
+with Types; use Types;
package Fname.UF is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Alloc;
with Hostparm; use Hostparm;
-with Namet; use Namet;
with Table;
+with Types; use Types;
package body Fname is
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- association between source file names and unit names as defined
-- (see package Uname for definition of format of unit names).
-with Types; use Types;
+with Namet; use Namet;
package Fname is
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- at the bottom of the list. They are recognized because they are
-- the only ones without a Unit_Name.
- if Units.Table (T (C1)).Unit_Name = No_Name then
+ if Units.Table (T (C1)).Unit_Name = No_Unit_Name then
return False;
- elsif Units.Table (T (C2)).Unit_Name = No_Name then
+ elsif Units.Table (T (C2)).Unit_Name = No_Unit_Name then
return True;
else
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
------------------------------------------------------------------------------
with Hostparm;
-with Namet; use Namet;
with Osint.C; use Osint.C;
package body Lib.Util is
Info_Buffer_Col := Info_Buffer_Col + Name_Len;
end Write_Info_Name;
+ procedure Write_Info_Name (Name : File_Name_Type) is
+ begin
+ Write_Info_Name (Name_Id (Name));
+ end Write_Info_Name;
+
+ procedure Write_Info_Name (Name : Unit_Name_Type) is
+ begin
+ Write_Info_Name (Name_Id (Name));
+ end Write_Info_Name;
+
--------------------
-- Write_Info_Nat --
--------------------
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-1999 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- Adds image of N to Info_Buffer with no leading or trailing blanks
procedure Write_Info_Name (Name : Name_Id);
- -- Adds characters of Name to Info_Buffer
+ procedure Write_Info_Name (Name : File_Name_Type);
+ procedure Write_Info_Name (Name : Unit_Name_Type);
+ -- Adds characters of Name to Info_Buffer. Note that in all cases, the
+ -- name is written literally from the names table entry without modifying
+ -- the case, using simply Get_Name_String.
procedure Write_Info_Str (Val : String);
-- Adds characters of Val to Info_Buffer surrounded by quotes
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Elists; use Elists;
with Errout; use Errout;
with Lib.Util; use Lib.Util;
-with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
with Restrict; use Restrict;
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Ada.Command_Line; use Ada.Command_Line;
-with Namet; use Namet;
with Osint; use Osint;
with Prj.Ext;
with Prj.Util;
end loop;
if Equal_Pos = Start
- or else Equal_Pos >= Finish
+ or else Equal_Pos > Finish
then
return False;
else
-- --
-- S p e c --
-- --
--- Copyright (C) 2004-2006 Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
+with Namet; use Namet;
with Osint;
with Prj; use Prj;
with Types; use Types;
-- --
-- T e m p l a t e --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- generated automatically in order.
with Atree; use Atree; -- body only
+with Namet; use Namet; -- spec only
with Nlists; use Nlists; -- spec only
with Sinfo; use Sinfo; -- body only
with Snames; use Snames; -- body only
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2006 Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
-with Namet; use Namet;
with Opt; use Opt;
with Targparm; use Targparm;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
-with Fmap; use Fmap;
-with Gnatvsn; use Gnatvsn;
-with Hostparm;
-with Namet; use Namet;
-with Opt; use Opt;
-with Output; use Output;
-with Sdefault; use Sdefault;
-with Table;
-with Targparm; use Targparm;
+with Unchecked_Conversion;
with System.Case_Util; use System.Case_Util;
-with Unchecked_Conversion;
-
with GNAT.HTable;
+with Fmap; use Fmap;
+with Gnatvsn; use Gnatvsn;
+with Hostparm;
+with Opt; use Opt;
+with Output; use Output;
+with Sdefault; use Sdefault;
+with Table;
+with Targparm; use Targparm;
+
package body Osint is
Running_Program : Program_Type := Unspecified;
-------------------------------------
-- This package creates a number of source, ALI and object file names
- -- that are used to locate the actual file and for the purpose of
- -- message construction. These names need not be accessible by Name_Find,
- -- and can be therefore created by using routine Name_Enter. The files in
- -- question are file names with a prefix directory (ie the files not
- -- in the current directory). File names without a prefix directory are
- -- entered with Name_Find because special values might be attached to
- -- the various Info fields of the corresponding name table entry.
+ -- that are used to locate the actual file and for the purpose of message
+ -- construction. These names need not be accessible by Name_Find, and can
+ -- be therefore created by using routine Name_Enter. The files in question
+ -- are file names with a prefix directory (ie the files not in the current
+ -- directory). File names without a prefix directory are entered with
+ -- Name_Find because special values might be attached to the various Info
+ -- fields of the corresponding name table entry.
-----------------------
-- Local Subprograms --
-----------------------
function Append_Suffix_To_File_Name
- (Name : Name_Id;
- Suffix : String) return Name_Id;
+ (Name : File_Name_Type;
+ Suffix : String) return File_Name_Type;
-- Appends Suffix to Name and returns the new name
function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type;
function Executable_Prefix return String_Ptr;
-- Returns the name of the root directory where the executable is stored.
- -- The executable must be located in a directory called "bin", or
- -- under root/lib/gcc-lib/..., or under root/libexec/gcc/... Thus, if
- -- the executable is stored in directory "/foo/bar/bin", this routine
- -- returns "/foo/bar/". Return "" if the location is not recognized
- -- as described above.
+ -- The executable must be located in a directory called "bin", or under
+ -- root/lib/gcc-lib/..., or under root/libexec/gcc/... For example, if
+ -- executable is stored in directory "/foo/bar/bin", this routine returns
+ -- "/foo/bar/". Return "" if location is not recognized as described above.
function Update_Path (Path : String_Ptr) return String_Ptr;
-- Update the specified path to replace the prefix with the location
T : File_Type;
Dir : Natural;
Name : String) return File_Name_Type;
- -- See if the file N whose name is Name exists in directory Dir. Dir is
- -- an index into the Lib_Search_Directories table if T = Library.
- -- Otherwise if T = Source, Dir is an index into the
- -- Src_Search_Directories table. Returns the File_Name_Type of the
- -- full file name if file found, or No_File if not found.
+ -- See if the file N whose name is Name exists in directory Dir. Dir is an
+ -- index into the Lib_Search_Directories table if T = Library. Otherwise
+ -- if T = Source, Dir is an index into the Src_Search_Directories table.
+ -- Returns the File_Name_Type of the full file name if file found, or
+ -- No_File if not found.
function C_String_Length (S : Address) return Integer;
- -- Returns length of a C string. Returns zero for a null address
+ -- Returns length of a C string (zero for a null address)
function To_Path_String_Access
(Path_Addr : Address;
Path_Len : Integer) return String_Access;
- -- Converts a C String to an Ada String. Are we doing this to avoid
- -- withing Interfaces.C.Strings ???
+ -- Converts a C String to an Ada String. Are we doing this to avoid withing
+ -- Interfaces.C.Strings ???
------------------------------
-- Other Local Declarations --
-- End of line character
Number_File_Names : Int := 0;
- -- The total number of file names found on command line and placed in
- -- File_Names.
+ -- Number of file names founde on command line and placed in File_Names
Look_In_Primary_Directory_For_Current_Main : Boolean := False;
- -- When this variable is True, Find_File will only look in
- -- the Primary_Directory for the Current_Main file.
- -- This variable is always True for the compiler.
- -- It is also True for gnatmake, when the soucr name given
- -- on the command line has directory information.
+ -- When this variable is True, Find_File only looks in Primary_Directory
+ -- for the Current_Main file. This variable is always set to True for the
+ -- compiler. It is also True for gnatmake, when the soucr name given on
+ -- the command line has directory information.
Current_Full_Source_Name : File_Name_Type := No_File;
Current_Full_Source_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
Current_Full_Lib_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
Current_Full_Obj_Name : File_Name_Type := No_File;
Current_Full_Obj_Stamp : Time_Stamp_Type := Empty_Time_Stamp;
- -- Respectively full name (with directory info) and time stamp of
- -- the latest source, library and object files opened by Read_Source_File
- -- and Read_Library_Info.
+ -- Respectively full name (with directory info) and time stamp of the
+ -- latest source, library and object files opened by Read_Source_File and
+ -- Read_Library_Info.
------------------
-- Search Paths --
Primary_Directory : constant := 0;
-- This is index in the tables created below for the first directory to
- -- search in for source or library information files. This is the
- -- directory containing the latest main input file (a source file for
- -- the compiler or a library file for the binder).
+ -- search in for source or library information files. This is the directory
+ -- containing the latest main input file (a source file for the compiler or
+ -- a library file for the binder).
package Src_Search_Directories is new Table.Table (
Table_Component_Type => String_Ptr,
- Table_Index_Type => Natural,
+ Table_Index_Type => Integer,
Table_Low_Bound => Primary_Directory,
Table_Initial => 10,
Table_Increment => 100,
package Lib_Search_Directories is new Table.Table (
Table_Component_Type => String_Ptr,
- Table_Index_Type => Natural,
+ Table_Index_Type => Integer,
Table_Low_Bound => Primary_Directory,
Table_Initial => 10,
Table_Increment => 100,
-- efficiency concern when retrieving full file names or time stamps of
-- source files. If the programmer calls Source_File_Data (Cache => True)
-- he is guaranteed that the price to retrieve the full name (ie with
- -- directory info) or time stamp of the file will be payed only once,
- -- the first time the full name is actually searched (or the first time
- -- the time stamp is actually retrieved). This is achieved by employing
- -- a hash table that stores as a key the File_Name_Type of the file and
- -- associates to that File_Name_Type the full file name of the file and its
- -- time stamp.
+ -- directory info) or time stamp of the file will be payed only once, the
+ -- first time the full name is actually searched (or the first time the
+ -- time stamp is actually retrieved). This is achieved by employing a hash
+ -- table that stores as a key the File_Name_Type of the file and associates
+ -- to that File_Name_Type the full file name and time stamp of the file.
File_Cache_Enabled : Boolean := False;
-- Set to true if you want the enable the file data caching mechanism
function Smart_File_Stamp
(N : File_Name_Type;
T : File_Type) return Time_Stamp_Type;
- -- Takes the same parameter as the routine above (N is a file name
- -- without any prefix directory information) and behaves like File_Stamp
- -- except that if File_Cache_Enabled is True this routine looks first in
- -- the hash table to see if the file stamp of the file is already
- -- available.
+ -- Takes the same parameter as the routine above (N is a file name without
+ -- any prefix directory information) and behaves like File_Stamp except
+ -- that if File_Cache_Enabled is True this routine looks first in the hash
+ -- table to see if the file stamp of the file is already available.
-----------------------------
-- Add_Default_Search_Dirs --
Curr := Curr + Actual_Len;
end loop;
- -- We are done with the file, so we close it
+ -- We are done with the file, so we close it (ignore any error on
+ -- the close, since we have successfully read the file).
Close (File_FD, Status);
- -- We ignore any error here, because we have successfully read the
- -- file.
-- Now, we read line by line
First := 1;
Curr := 0;
-
while Curr < Len loop
Ch := S (Curr + 1);
-- For the compiler, if --RTS= was specified, add the runtime
-- directories.
- if RTS_Src_Path_Name /= null and then
- RTS_Lib_Path_Name /= null
+ if RTS_Src_Path_Name /= null
+ and then RTS_Lib_Path_Name /= null
then
Add_Search_Dirs (RTS_Src_Path_Name, Include);
Add_Search_Dirs (RTS_Lib_Path_Name, Objects);
begin
Number_File_Names := Number_File_Names + 1;
- -- As Add_File may be called for mains specified inside
- -- a project file, File_Names may be too short and needs
- -- to be extended.
+ -- As Add_File may be called for mains specified inside a project file,
+ -- File_Names may be too short and needs to be extended.
if Number_File_Names > File_Names'Last then
File_Names := new File_Name_Array'(File_Names.all & File_Names.all);
--------------------------------
function Append_Suffix_To_File_Name
- (Name : Name_Id;
- Suffix : String) return Name_Id
+ (Name : File_Name_Type;
+ Suffix : String) return File_Name_Type
is
begin
Get_Name_String (Name);
function Executable_Name (Name : File_Name_Type) return File_Name_Type is
Exec_Suffix : String_Access;
+
begin
if Name = No_File then
return No_File;
Buffer : String := Name_Buffer (1 .. Name_Len);
begin
- -- Get the file name in canonical case to accept as is
- -- names ending with ".EXE" on VMS and Windows.
+ -- Get the file name in canonical case to accept as is names
+ -- ending with ".EXE" on VMS and Windows.
Canonical_Case_File_Name (Buffer);
- -- If the Executable does not end with the executable
- -- suffix, add it.
+ -- If Executable does not end with the executable suffix, add it
if Buffer'Length <= Exec_Suffix'Length
or else
-----------------------
function Executable_Prefix return String_Ptr is
+
function Get_Install_Dir (Exec : String) return String_Ptr;
-- S is the executable name preceeded by the absolute or relative
-- path, e.g. "c:\usr\bin\gcc.exe" or "..\bin\gcc".
-- directory prefix.
return Get_Install_Dir
- (GNAT.OS_Lib.Locate_Exec_On_Path (Exec_Name.all).all);
+ (System.OS_Lib.Locate_Exec_On_Path (Exec_Name.all).all);
end Executable_Prefix;
------------------
end if;
end File_Stamp;
+ function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is
+ begin
+ return File_Stamp (File_Name_Type (Name));
+ end File_Stamp;
+
---------------
-- Find_File --
---------------
-- If we are looking for a config file, look only in the current
-- directory, i.e. return input argument unchanged. Also look
-- only in the current directory if we are looking for a .dg
- -- file (happens in -gnatD mode)
+ -- file (happens in -gnatD mode).
if T = Config
or else (Debug_Generated_Code
-- corresponding path name
if File /= No_File then
+
-- For locally removed file, Error_Name is returned; then
-- return No_File, indicating the file is not a source.
- if File = Error_Name then
+ if File = Error_File_Name then
return No_File;
else
procedure Find_Program_Name is
Command_Name : String (1 .. Len_Arg (0));
- Cindex1 : Integer := Command_Name'First;
- Cindex2 : Integer := Command_Name'Last;
+ Cindex1 : Integer := Command_Name'First;
+ Cindex2 : Integer := Command_Name'Last;
begin
Fill_Arg (Command_Name'Address, 0);
-- We first verify if there is a directory Include_Search_Dir
-- containing default search directories
- Result_Search_Dir
- := Read_Default_Search_Dirs (Norm_Search_Dir,
- Search_File,
- null);
+ Result_Search_Dir :=
+ Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
Default_Search_Dir :=
new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
Free (Norm_Search_Dir);
Suppress_Options := (others => False);
-- Reserve the first slot in the search paths table. This is the
- -- directory of the main source file or main library file and is
- -- filled in by each call to Next_Main_Source/Next_Main_Lib_File with
- -- the directory specified for this main source or library file. This
- -- is the directory which is searched first by default. This default
- -- search is inhibited by the option -I- for both source and library
- -- files.
+ -- directory of the main source file or main library file and is filled
+ -- in by each call to Next_Main_Source/Next_Main_Lib_File with the
+ -- directory specified for this main source or library file. This is the
+ -- directory which is searched first by default. This default search is
+ -- inhibited by the option -I- for both source and library files.
Src_Search_Directories.Set_Last (Primary_Directory);
Src_Search_Directories.Table (Primary_Directory) := new String'("");
Name_Len := File_Name'Last - Fptr + 1;
Name_Buffer (1 .. Name_Len) := File_Name (Fptr .. File_Name'Last);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Current_Main := File_Name_Type (Name_Find);
+ Current_Main := Name_Find;
-- In the gnatmake case, the main file may have not have the
-- extension. Try ".adb" first then ".ads"
begin
if Strip_Suffix (Orig_Main) = Orig_Main then
- Current_Main := Append_Suffix_To_File_Name (Orig_Main, ".adb");
+ Current_Main :=
+ Append_Suffix_To_File_Name (Orig_Main, ".adb");
if Full_Source_Name (Current_Main) = No_File then
Current_Main :=
Find_Program_Name;
- -- Find the target prefix if any, for the cross compilation case
- -- for instance in "alpha-dec-vxworks-gcc" the target prefix is
+ -- Find the target prefix if any, for the cross compilation case.
+ -- For instance in "alpha-dec-vxworks-gcc" the target prefix is
-- "alpha-dec-vxworks-"
while Name_Len > 0 loop
Prev_Was_Separator := True;
Nb_Relative_Dir := 0;
for J in 1 .. Len loop
- if S (J) in ASCII.NUL .. ASCII.US
- or else S (J) = ' '
- then
+ if S (J) in ASCII.NUL .. ASCII.US or else S (J) = ' ' then
S (J) := Path_Separator;
end if;
if S (J) = Path_Separator then
Prev_Was_Separator := True;
+
else
if Prev_Was_Separator and then Is_Relative (S.all, J) then
Nb_Relative_Dir := Nb_Relative_Dir + 1;
if Current_Full_Obj_Stamp (1) = ' ' then
- -- When the library is readonly, always assume that
- -- the object is consistent.
+ -- When the library is readonly always assume object is consistent
if Is_Readonly_Library (Current_Full_Lib_Name) then
Current_Full_Obj_Stamp := Current_Full_Lib_Stamp;
elsif Fatal_Err then
Get_Name_String (Current_Full_Obj_Name);
Close (Lib_FD, Status);
+
-- No need to check the status, we fail anyway
Fail ("Cannot find: ", Name_Buffer (1 .. Name_Len));
if Current_Full_Source_Name = No_File then
- -- If we were trying to access the main file and we could not
- -- find it we have an error.
+ -- If we were trying to access the main file and we could not find
+ -- it, we have an error.
if N = Current_Main then
Get_Name_String (N);
pragma Import
(C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec");
- C_Host_File : String (1 .. Host_File'Length + 1);
+ C_Host_File : String (1 .. Host_File'Length + 1);
Canonical_File_Addr : Address;
Canonical_File_Len : Integer;
begin
In_String (1 .. In_Length) := Path.all;
In_String (In_Length + 1) := ASCII.NUL;
- Result_Ptr := C_Update_Path (In_String'Address,
- Component_Name'Address);
+ Result_Ptr := C_Update_Path (In_String'Address, Component_Name'Address);
Result_Length := Strlen (Result_Ptr);
Out_String := new String (1 .. Result_Length);
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- This package contains the low level, operating system routines used in the
-- compiler and binder for command line processing and file input output.
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with System; use System;
-with Types; use Types;
+with Namet; use Namet;
+with Types; use Types;
-pragma Elaborate_All (GNAT.OS_Lib);
+with System.OS_Lib; use System.OS_Lib;
+with System; use System;
+
+pragma Elaborate_All (System.OS_Lib);
-- For the call to function Get_Target_Object_Suffix in the private part
package Osint is
-- Same as above, with String parameters
function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type;
- -- Returns the time stamp of file Name. Name should include relative
- -- path information in order to locate it. If the source file cannot be
- -- opened, or Name = No_File, and all blank time stamp is returned (this is
- -- not an error situation).
+ -- Returns the time stamp of file Name. Name should include relative path
+ -- information in order to locate it. If the source file cannot be opened,
+ -- or Name = No_File, and all blank time stamp is returned (this is not an
+ -- error situation).
+
+ function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type;
+ -- Same as above for a path name
type String_Access_List is array (Positive range <>) of String_Access;
-- Deferenced type used to return a list of file specs in
function Full_Source_Name (N : File_Name_Type) return File_Name_Type;
function Source_File_Stamp (N : File_Name_Type) return Time_Stamp_Type;
- -- Returns the full name/time stamp of the source file whose simple name is
- -- N which should not include path information. Note that if the file
+ -- Returns the full name/time stamp of the source file whose simple name
+ -- is N which should not include path information. Note that if the file
-- cannot be located No_File is returned for the first routine and an all
-- blank time stamp is returned for the second (this is not an error
-- situation). The full name includes appropriate directory information.
function Full_Lib_File_Name (N : File_Name_Type) return File_Name_Type;
function Library_File_Stamp (N : File_Name_Type) return Time_Stamp_Type;
- -- Returns the full name/time stamp of library file N. N should not
- -- include path information. Note that if the file cannot be located
- -- No_File is returned for the first routine and an all blank time stamp
- -- is returned for the second (this is not an error situation). The
- -- full name includes the appropriate directory information. The library
- -- file directory lookup penalty is incurred every single time this
- -- routine is called.
+ -- Returns the full name/time stamp of library file N. N should not include
+ -- path information. Note that if the file cannot be located No_File is
+ -- returned for the first routine and an all blank time stamp is returned
+ -- for the second (this is not an error situation). The full name includes
+ -- the appropriate directory information. The library file directory lookup
+ -- penalty is incurred every single time this routine is called.
function Lib_File_Name
(Source_File : File_Name_Type;
-- length in Name_Len), and place the resulting descriptor in Fdesc. Issue
-- message and exit with fatal error if file cannot be created. The Fmode
-- parameter is set to either Text or Binary (for details see description
- -- of GNAT.OS_Lib.Create_File).
+ -- of System.OS_Lib.Create_File).
type Program_Type is (Compiler, Binder, Make, Gnatls, Unspecified);
-- Program currently running
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- If we have no unit name, things are seriously messed up by previous
-- errors, and we should not try to continue compilation.
- if Unit_Name (Cur_Unum) = No_Name then
+ if Unit_Name (Cur_Unum) = No_Unit_Name then
raise Unrecoverable_Error;
end if;
or not Same_File_Name_Except_For_Case
(File_Name, Unit_File_Name (Cur_Unum)))
then
- Error_Msg_Name_1 := File_Name;
+ Error_Msg_File_1 := File_Name;
Error_Msg
("?file name does not match unit name, should be{", Sloc (Curunit));
end if;
and then Expected_Unit (Cur_Unum) /= Unit_Name (Cur_Unum)
then
Loc := Error_Location (Cur_Unum);
- Error_Msg_Name_1 := Unit_File_Name (Cur_Unum);
- Get_Name_String (Error_Msg_Name_1);
+ Error_Msg_File_1 := Unit_File_Name (Cur_Unum);
+ Get_Name_String (Error_Msg_File_1);
-- Check for predefined file case
Name_Buffer (1) = 'g')
then
declare
- Expect_Name : constant Name_Id := Expected_Unit (Cur_Unum);
- Actual_Name : constant Name_Id := Unit_Name (Cur_Unum);
+ Expect_Name : constant Unit_Name_Type := Expected_Unit (Cur_Unum);
+ Actual_Name : constant Unit_Name_Type := Unit_Name (Cur_Unum);
begin
- Error_Msg_Name_1 := Expect_Name;
- Error_Msg ("% is not a predefined library unit!", Loc);
+ Error_Msg_Unit_1 := Expect_Name;
+ Error_Msg ("$$ is not a predefined library unit!", Loc);
-- In the predefined file case, we know the user did not
-- construct their own package, but we got the wrong one.
-- of misspelling of predefined unit names without needing
-- a full list of them.
- -- Before actually issinying the message, we will check that the
+ -- Before actually issuing the message, we will check that the
-- unit name is indeed a plausible misspelling of the one we got.
if Is_Bad_Spelling_Of
(Found => Get_Name_String (Expect_Name),
Expect => Get_Name_String (Actual_Name))
then
- Error_Msg_Name_1 := Actual_Name;
- Error_Msg ("possible misspelling of %!", Loc);
+ Error_Msg_Unit_1 := Actual_Name;
+ Error_Msg ("possible misspelling of $$!", Loc);
end if;
end;
Spec_Name := Get_Parent_Spec_Name (Unit_Name (Cur_Unum));
- if Spec_Name /= No_Name then
+ if Spec_Name /= No_Unit_Name then
Unum :=
Load_Unit
(Load_Name => Spec_Name,
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
-with Namet; use Namet;
with Osint;
with Prj.Com; use Prj.Com;
with System.Case_Util; use System.Case_Util;
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2006, Free Software Foundation, Inc --
+-- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
------------------------------------------------------------------------------
with Err_Vars; use Err_Vars;
-with Namet; use Namet;
with Opt; use Opt;
with Prj.Err; use Prj.Err;
with Prj.Strt; use Prj.Strt;
if not Ignore then
Error_Msg_Name_1 := Token_Name;
- Error_Msg ("undefined attribute {", Token_Ptr);
+ Error_Msg ("undefined attribute %%", Token_Ptr);
end if;
end if;
and then Token_Name /= Name_Of (Package_Declaration, In_Tree)
then
Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree);
- Error_Msg ("expected {", Token_Ptr);
+ Error_Msg ("expected %", Token_Ptr);
end if;
if Token /= Tok_Semicolon then
Current_Package : Project_Node_Id)
is
Expression_Location : Source_Ptr;
- String_Type_Name : Name_Id := No_Name;
- Project_String_Type_Name : Name_Id := No_Name;
- Type_Location : Source_Ptr := No_Location;
- Project_Location : Source_Ptr := No_Location;
- Expression : Project_Node_Id := Empty_Node;
+ String_Type_Name : Name_Id := No_Name;
+ Project_String_Type_Name : Name_Id := No_Name;
+ Type_Location : Source_Ptr := No_Location;
+ Project_Location : Source_Ptr := No_Location;
+ Expression : Project_Node_Id := Empty_Node;
Variable_Name : constant Name_Id := Token_Name;
- OK : Boolean := True;
+ OK : Boolean := True;
begin
Variable :=
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
-with Namet; use Namet;
with Output; use Output;
with Stringt; use Stringt;
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
------------------------------------------------------------------------------
with Csets;
-with Namet; use Namet;
with Opt;
with Output;
with Osint; use Osint;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with GNAT.Regexp; use GNAT.Regexp;
with System.Case_Util; use System.Case_Util;
with System.CRTL;
+with System.Regexp; use System.Regexp;
package body Prj.Makr is
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
------------------------------------------------------------------------------
with Err_Vars; use Err_Vars;
-with Namet; use Namet;
with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
with Snames;
with Table;
-with Ada.Characters.Handling; use Ada.Characters.Handling;
-with Ada.Exceptions; use Ada.Exceptions;
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Ada.Exceptions; use Ada.Exceptions;
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with System.HTable; use System.HTable;
+with System.HTable; use System.HTable;
package body Prj.Part is
Buffer : String_Access;
Buffer_Last : Natural := 0;
- Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator;
+ Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator;
type Extension_Origin is (None, Extending_Simple, Extending_All);
-- Type of parameter From_Extended for procedures Parse_Single_Project and
No_With : constant With_Id := 0;
type With_Record is record
- Path : Name_Id;
+ Path : File_Name_Type;
Location : Source_Ptr;
Limited_With : Boolean;
Node : Project_Node_Id;
-- name of the current project has been extablished.
type Names_And_Id is record
- Path_Name : Name_Id;
- Canonical_Path_Name : Name_Id;
+ Path_Name : Path_Name_Type;
+ Canonical_Path_Name : Path_Name_Type;
Id : Project_Node_Id;
end record;
+ -- Needs a comment ???
package Project_Stack is new Table.Table
(Table_Component_Type => Names_And_Id,
(Context_Clause : With_Id;
In_Tree : Project_Node_Tree_Ref;
Imported_Projects : out Project_Node_Id;
- Project_Directory : Name_Id;
+ Project_Directory : Path_Name_Type;
From_Extended : Extension_Origin;
In_Limited : Boolean;
Packages_To_Check : String_List_Access);
-- Returns the path name of a project file. Returns an empty string
-- if project file cannot be found.
- function Immediate_Directory_Of (Path_Name : Name_Id) return Name_Id;
+ function Immediate_Directory_Of
+ (Path_Name : Path_Name_Type) return Path_Name_Type;
-- Get the directory of the file with the specified path name.
-- This includes the directory separator as the last character.
-- Returns "./" if Path_Name contains no directory separator.
- function Project_Name_From (Path_Name : String) return Name_Id;
+ function Project_Name_From (Path_Name : String) return File_Name_Type;
-- Returns the name of the project that corresponds to its path name.
-- Returns No_Name if the path name is invalid, because the corresponding
-- project name does not have the syntax of an ada identifier.
Virtual_Name_Id : Name_Id;
-- Virtual extending project name id
- Virtual_Path_Id : Name_Id;
+ Virtual_Path_Id : Path_Name_Type;
-- Fake path name of the virtual extending project. The directory is
-- the same directory as the extending all project.
- Virtual_Dir_Id : constant Name_Id :=
+ Virtual_Dir_Id : constant Path_Name_Type :=
Immediate_Directory_Of (Path_Name_Of (Main_Project, In_Tree));
-- The directory of the extending all project
K => Virtual_Name_Id,
E => (Name => Virtual_Name_Id,
Node => Virtual_Project,
- Canonical_Path => No_Name,
+ Canonical_Path => No_Path,
Extended => False));
end Create_Virtual_Extending_Project;
-- Immediate_Directory_Of --
----------------------------
- function Immediate_Directory_Of (Path_Name : Name_Id) return Name_Id is
+ function Immediate_Directory_Of
+ (Path_Name : Path_Name_Type) return Path_Name_Type
+ is
begin
Get_Name_String (Path_Name);
-- Store path and location in table Withs
Current_With :=
- (Path => Token_Name,
+ (Path => File_Name_Type (Token_Name),
Location => Token_Ptr,
Limited_With => Limited_With,
Node => Current_With_Node,
(Context_Clause : With_Id;
In_Tree : Project_Node_Tree_Ref;
Imported_Projects : out Project_Node_Id;
- Project_Directory : Name_Id;
+ Project_Directory : Path_Name_Type;
From_Extended : Extension_Origin;
In_Limited : Boolean;
Packages_To_Check : String_List_Access)
is
- Current_With_Clause : With_Id := Context_Clause;
+ Current_With_Clause : With_Id;
Current_Project : Project_Node_Id := Empty_Node;
Previous_Project : Project_Node_Id := Empty_Node;
begin
Imported_Projects := Empty_Node;
+ Current_With_Clause := Context_Clause;
while Current_With_Clause /= No_With loop
Current_With := Withs.Table (Current_With_Clause);
Current_With_Clause := Current_With.Next;
-- The project file cannot be found
- Error_Msg_Name_1 := Current_With.Path;
-
+ Error_Msg_File_1 := Current_With.Path;
Error_Msg ("unknown project file: {", Current_With.Location);
-- If this is not imported by the main project file,
if Project_Stack.Last > 1 then
for Index in reverse 1 .. Project_Stack.Last loop
- Error_Msg_Name_1 := Project_Stack.Table (Index).Path_Name;
+ Error_Msg_File_1 :=
+ File_Name_Type (Project_Stack.Table (Index).Path_Name);
Error_Msg ("\imported by {", Current_With.Location);
end loop;
end if;
end if;
Set_String_Value_Of
- (Current_Project, In_Tree, Current_With.Path);
+ (Current_Project, In_Tree, Name_Id (Current_With.Path));
Set_Location_Of
(Current_Project, In_Tree, Current_With.Location);
if Limited_With and then Project_Stack.Last > 1 then
declare
- Canonical_Path_Name : Name_Id;
+ Canonical_Path_Name : Path_Name_Type;
begin
Name_Len := Resolved_Path'Length;
In_Limited : Boolean;
Packages_To_Check : String_List_Access)
is
- Normed_Path_Name : Name_Id;
- Canonical_Path_Name : Name_Id;
- Project_Directory : Name_Id;
+ Normed_Path_Name : Path_Name_Type;
+ Canonical_Path_Name : Path_Name_Type;
+ Project_Directory : Path_Name_Type;
Project_Scan_State : Saved_Project_Scan_State;
Source_Index : Source_File_Index;
Extending : Boolean := False;
- Extended_Project : Project_Node_Id := Empty_Node;
+ Extended_Project : Project_Node_Id := Empty_Node;
A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
Tree_Private_Part.Projects_Htable.Get_First
(In_Tree.Projects_HT);
- Name_From_Path : constant Name_Id := Project_Name_From (Path_Name);
+ Name_From_Path : constant File_Name_Type :=
+ Project_Name_From (Path_Name);
Name_Of_Project : Name_Id := No_Name;
Project_Stack.Table (Index).Canonical_Path_Name
then
Error_Msg ("circular dependency detected", Token_Ptr);
- Error_Msg_Name_1 := Normed_Path_Name;
- Error_Msg ("\ { is imported by", Token_Ptr);
+ Error_Msg_File_1 := File_Name_Type (Normed_Path_Name);
+ Error_Msg ("\\ { is imported by", Token_Ptr);
for Current in reverse 1 .. Project_Stack.Last loop
- Error_Msg_Name_1 := Project_Stack.Table (Current).Path_Name;
+ Error_Msg_File_1 :=
+ File_Name_Type (Project_Stack.Table (Current).Path_Name);
if Project_Stack.Table (Current).Canonical_Path_Name /=
Canonical_Path_Name
then
Error_Msg
- ("\ { which itself is imported by", Token_Ptr);
+ ("\\ { which itself is imported by", Token_Ptr);
else
- Error_Msg ("\ {", Token_Ptr);
+ Error_Msg ("\\ {", Token_Ptr);
exit;
end if;
end loop;
Tree.Reset_State;
Scan (In_Tree);
- if Name_From_Path = No_Name then
+ if Name_From_Path = No_File then
-- The project file name is not correct (no or bad extension,
-- or not following Ada identifier's syntax).
- Error_Msg_Name_1 := Canonical_Path_Name;
+ Error_Msg_File_1 := File_Name_Type (Canonical_Path_Name);
Error_Msg ("?{ is not a valid path name for a project file",
Token_Ptr);
end if;
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
declare
- Expected_Name : constant Name_Id := Name_Find;
+ Expected_Name : constant File_Name_Type := Name_Find;
begin
-- Output a warning if the actual name is not the expected name
- if Name_From_Path /= No_Name
+ if Name_From_Path /= No_File
and then Expected_Name /= Name_From_Path
then
- Error_Msg_Name_1 := Expected_Name;
+ Error_Msg_File_1 := Expected_Name;
Error_Msg ("?file name does not match unit name, " &
"should be `{" & Project_File_Extension & "`",
Token_Ptr);
declare
Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
- Tree_Private_Part.Projects_Htable.Get_First
- (In_Tree.Projects_HT);
+ Tree_Private_Part.Projects_Htable.Get_First
+ (In_Tree.Projects_HT);
+
Project_Name : Name_Id := Name_And_Node.Name;
begin
if Project_Name /= No_Name then
Error_Msg_Name_1 := Project_Name;
Error_Msg
- ("duplicate project name {", Location_Of (Project, In_Tree));
- Error_Msg_Name_1 :=
- Path_Name_Of (Name_And_Node.Node, In_Tree);
+ ("duplicate project name %%", Location_Of (Project, In_Tree));
+ Error_Msg_File_1 :=
+ File_Name_Type (Path_Name_Of (Name_And_Node.Node, In_Tree));
Error_Msg
("\already in {", Location_Of (Project, In_Tree));
Expect (Tok_String_Literal, "literal string");
if Token = Tok_String_Literal then
- Set_Extended_Project_Path_Of (Project, In_Tree, Token_Name);
+ Set_Extended_Project_Path_Of
+ (Project, In_Tree, Path_Name_Type (Token_Name));
declare
Original_Path_Name : constant String :=
-- We could not find the project file to extend
- Error_Msg_Name_1 := Token_Name;
-
+ Error_Msg_File_1 := File_Name_Type (Token_Name);
Error_Msg ("unknown project file: {", Token_Ptr);
-- If we are not in the main project file, display the
-- import path.
if Project_Stack.Last > 1 then
- Error_Msg_Name_1 :=
- Project_Stack.Table (Project_Stack.Last).Path_Name;
+ Error_Msg_File_1 :=
+ File_Name_Type
+ (Project_Stack.Table (Project_Stack.Last).Path_Name);
Error_Msg ("\extended by {", Token_Ptr);
for Index in reverse 1 .. Project_Stack.Last - 1 loop
- Error_Msg_Name_1 :=
- Project_Stack.Table (Index).Path_Name;
+ Error_Msg_File_1 :=
+ File_Name_Type
+ (Project_Stack.Table (Index).Path_Name);
Error_Msg ("\imported by {", Token_Ptr);
end loop;
end if;
Imported := Project_Node_Of (With_Clause, In_Tree);
if Is_Extending_All (With_Clause, In_Tree) then
- Error_Msg_Name_1 := Name_Of (Imported, In_Tree);
+ Error_Msg_File_1 :=
+ File_Name_Type (Name_Of (Imported, In_Tree));
Error_Msg ("cannot import extending-all project {",
Token_Ptr);
exit With_Clause_Loop;
Name_Len := Name_Len - 1;
declare
- Parent_Name : constant Name_Id := Name_Find;
+ Parent_Name : constant File_Name_Type := Name_Find;
Parent_Found : Boolean := False;
With_Clause : Project_Node_Id :=
First_With_Clause_Of (Project, In_Tree);
if Extended_Project /= Empty_Node then
Parent_Found :=
- Name_Of (Extended_Project, In_Tree) = Parent_Name;
+ Name_Of (Extended_Project, In_Tree) = Name_Id (Parent_Name);
end if;
-- If the parent project is not the extended project,
while not Parent_Found and then With_Clause /= Empty_Node loop
Parent_Found :=
Name_Of (Project_Node_Of (With_Clause, In_Tree), In_Tree) =
- Parent_Name;
+ Name_Id (Parent_Name);
With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
end loop;
if not Parent_Found then
Error_Msg_Name_1 := Name_Of_Project;
- Error_Msg_Name_2 := Parent_Name;
- Error_Msg ("project { does not import or extend project {",
+ Error_Msg_File_1 := Parent_Name;
+ Error_Msg ("project %% does not import or extend project {",
Location_Of (Project, In_Tree));
end if;
end;
-- Project_Name_From --
-----------------------
- function Project_Name_From (Path_Name : String) return Name_Id is
+ function Project_Name_From (Path_Name : String) return File_Name_Type is
Canonical : String (1 .. Path_Name'Length) := Path_Name;
First : Natural := Canonical'Last;
Last : Natural := First;
-- If the path name is empty, return No_Name to indicate failure
if First = 0 then
- return No_Name;
+ return No_File;
end if;
Canonical_Case_File_Name (Canonical);
else
-- Not the correct extension, return No_Name to indicate failure
- return No_Name;
+ return No_File;
end if;
-- If no dot in the path name, return No_Name to indicate failure
else
- return No_Name;
+ return No_File;
end if;
First := First + 1;
-- If the extension is the file name, return No_Name to indicate failure
if First > Last then
- return No_Name;
+ return No_File;
end if;
-- Put the name in lower case into Name_Buffer
loop
if not Is_Letter (Name_Buffer (Index)) then
- return No_Name;
+ return No_File;
else
loop
if Name_Buffer (Index) = '_' then
if Name_Buffer (Index + 1) = '_' then
- return No_Name;
+ return No_File;
end if;
end if;
if Name_Buffer (Index) /= '_'
and then not Is_Alphanumeric (Name_Buffer (Index))
then
- return No_Name;
+ return No_File;
end if;
end loop;
return Name_Find;
else
- return No_Name;
+ return No_File;
end if;
elsif Name_Buffer (Index) = '-' then
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Ada.Characters.Handling; use Ada.Characters.Handling;
-with Namet; use Namet;
with Output; use Output;
with Snames;
-- Outputs the indentation at the beginning of the line
procedure Output_String (S : Name_Id);
+ procedure Output_String (S : Path_Name_Type);
-- Outputs a string using the default output procedures
procedure Write_Empty_Line (Always : Boolean := False);
Column := Column + 1;
end Output_String;
+ procedure Output_String (S : Path_Name_Type) is
+ begin
+ Output_String (Name_Id (S));
+ end Output_String;
+
----------------
-- Start_Line --
----------------
-- Check if this project extends another project
- if Extended_Project_Path_Of (Node, In_Tree) /= No_Name then
+ if Extended_Project_Path_Of (Node, In_Tree) /= No_Path then
Write_String (" extends ");
if Is_Extending_All (Node, In_Tree) then
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
------------------------------------------------------------------------------
with Err_Vars; use Err_Vars;
-with Namet; use Namet;
with Opt; use Opt;
with Osint; use Osint;
with Output; use Output;
procedure Add (To_Exp : in out Name_Id; Str : Name_Id) is
begin
- if To_Exp = Types.No_Name or else To_Exp = Empty_String then
+ if To_Exp = No_Name or else To_Exp = Empty_String then
-- To_Exp is nil or empty. The result is Str
when N_Variable_Reference | N_Attribute_Reference =>
declare
- The_Project : Project_Id := Project;
- The_Package : Package_Id := Pkg;
- The_Name : Name_Id := No_Name;
- The_Variable_Id : Variable_Id := No_Variable;
+ The_Project : Project_Id := Project;
+ The_Package : Package_Id := Pkg;
+ The_Name : Name_Id := No_Name;
+ The_Variable_Id : Variable_Id := No_Variable;
The_Variable : Variable_Value;
Term_Project : constant Project_Node_Id :=
- Project_Node_Of
- (The_Current_Term, From_Project_Node_Tree);
+ Project_Node_Of
+ (The_Current_Term,
+ From_Project_Node_Tree);
Term_Package : constant Project_Node_Id :=
- Package_Node_Of
- (The_Current_Term, From_Project_Node_Tree);
+ Package_Node_Of
+ (The_Current_Term,
+ From_Project_Node_Tree);
Index : Name_Id := No_Name;
begin
The_Name :=
Name_Of (Term_Project, From_Project_Node_Tree);
+
The_Project := Imported_Or_Extended_Project_From
(Project => Project,
In_Tree => In_Tree,
The_Name :=
Name_Of (Term_Package, From_Project_Node_Tree);
+
The_Package := In_Tree.Projects.Table
(The_Project).Decl.Packages;
Follow_Links : Boolean := True;
When_No_Sources : Error_Warning := Error)
is
- Obj_Dir : Name_Id;
+ Obj_Dir : Path_Name_Type;
Extending : Project_Id;
Extending2 : Project_Id;
and then Is_Extending_All (From_Project_Node, From_Project_Node_Tree)
then
declare
- Object_Dir : constant Name_Id :=
+ Object_Dir : constant Path_Name_Type :=
In_Tree.Projects.Table (Project).Object_Directory;
begin
for Index in
if Error_Report = null then
Error_Msg
- ("project { cannot be extended by a virtual " &
+ ("project % cannot be extended by a virtual " &
"project with the same object directory",
In_Tree.Projects.Table (Proj).Location);
else
if Error_Report = null then
Error_Msg
- ("project { cannot extend project {",
+ ("project %% cannot extend project %%",
In_Tree.Projects.Table (Extending2).Location);
Error_Msg
("\they share the same object directory",
declare
Current_Item_Name : constant Name_Id :=
- Name_Of (Current_Item, From_Project_Node_Tree);
+ Name_Of
+ (Current_Item,
+ From_Project_Node_Tree);
-- The name of the attribute
New_Array : Array_Id;
-- Find the project where the value is declared
Orig_Project_Name :=
- Name_Of
- (Associative_Project_Of
- (Current_Item, From_Project_Node_Tree),
- From_Project_Node_Tree);
+ Name_Of
+ (Associative_Project_Of
+ (Current_Item, From_Project_Node_Tree),
+ From_Project_Node_Tree);
for Index in Project_Table.First ..
Project_Table.Last
if Error_Report = null then
Error_Msg
- ("value { is illegal for typed string %",
+ ("value %% is illegal for "
+ & "typed string %",
Location_Of
(Current_Item,
From_Project_Node_Tree));
Get_Name_String (Error_Msg_Name_2) &
"""",
Project, In_Tree);
+ -- Calls like this to Error_Report are
+ -- wrong, since they don't properly case
+ -- and decode names corresponding to the
+ -- ordinary case of % insertion ???
end if;
end if;
end;
Location_Of (From_Project_Node, From_Project_Node_Tree);
Processed_Data.Display_Directory :=
- Directory_Of (From_Project_Node, From_Project_Node_Tree);
+ Path_Name_Type
+ (Directory_Of (From_Project_Node, From_Project_Node_Tree));
Get_Name_String (Processed_Data.Display_Directory);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
Processed_Data.Directory := Name_Find;
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
(Kind => N_Comment_Zones,
Expr_Kind => Undefined,
Location => No_Location,
- Directory => No_Name,
+ Directory => No_Path,
Variables => Empty_Node,
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
- Path_Name => No_Name,
+ Path_Name => No_Path,
Value => No_Name,
Field1 => Empty_Node,
Field2 => Empty_Node,
Flag2 =>
Comments.Table (J).Is_Followed_By_Empty_Line,
Location => No_Location,
- Directory => No_Name,
+ Directory => No_Path,
Variables => Empty_Node,
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
- Path_Name => No_Name,
+ Path_Name => No_Path,
Value => Comments.Table (J).Value,
Field1 => Empty_Node,
Field2 => Empty_Node,
In_Tree.Project_Nodes.Table (Zone) :=
(Kind => N_Comment_Zones,
Location => No_Location,
- Directory => No_Name,
+ Directory => No_Path,
Expr_Kind => Undefined,
Variables => Empty_Node,
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
- Path_Name => No_Name,
+ Path_Name => No_Path,
Value => No_Name,
Field1 => Empty_Node,
Field2 => Empty_Node,
(Project_Node_Table.Last (In_Tree.Project_Nodes)) :=
(Kind => Of_Kind,
Location => No_Location,
- Directory => No_Name,
+ Directory => No_Path,
Expr_Kind => And_Expr_Kind,
Variables => Empty_Node,
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
- Path_Name => No_Name,
+ Path_Name => No_Path,
Value => No_Name,
Field1 => Empty_Node,
Field2 => Empty_Node,
(Kind => N_Comment_Zones,
Expr_Kind => Undefined,
Location => No_Location,
- Directory => No_Name,
+ Directory => No_Path,
Variables => Empty_Node,
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
- Path_Name => No_Name,
+ Path_Name => No_Path,
Value => No_Name,
Field1 => Empty_Node,
Field2 => Empty_Node,
Flag2 =>
Comments.Table (J).Is_Followed_By_Empty_Line,
Location => No_Location,
- Directory => No_Name,
+ Directory => No_Path,
Variables => Empty_Node,
Packages => Empty_Node,
Pkg_Id => Empty_Package,
Name => No_Name,
Src_Index => 0,
- Path_Name => No_Name,
+ Path_Name => No_Path,
Value => Comments.Table (J).Value,
Field1 => Empty_Node,
Field2 => Empty_Node,
function Directory_Of
(Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Name_Id is
+ In_Tree : Project_Node_Tree_Ref) return Path_Name_Type is
begin
pragma Assert
(Node /= Empty_Node
function Extended_Project_Path_Of
(Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Name_Id
+ In_Tree : Project_Node_Tree_Ref) return Path_Name_Type
is
begin
pragma Assert
(Node /= Empty_Node
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- return In_Tree.Project_Nodes.Table (Node).Value;
+ return Path_Name_Type (In_Tree.Project_Nodes.Table (Node).Value);
end Extended_Project_Path_Of;
--------------------------
function Path_Name_Of
(Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Name_Id
+ In_Tree : Project_Node_Tree_Ref) return Path_Name_Type
is
begin
pragma Assert
procedure Set_Directory_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
- To : Name_Id)
+ To : Path_Name_Type)
is
begin
pragma Assert
procedure Set_Extended_Project_Path_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
- To : Name_Id)
+ To : Path_Name_Type)
is
begin
pragma Assert
(Node /= Empty_Node
and then
In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- In_Tree.Project_Nodes.Table (Node).Value := To;
+ In_Tree.Project_Nodes.Table (Node).Value := Name_Id (To);
end Set_Extended_Project_Path_Of;
------------------------------
procedure Set_Path_Name_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
- To : Name_Id)
+ To : Path_Name_Type)
is
begin
pragma Assert
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
function Directory_Of
(Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Name_Id;
+ In_Tree : Project_Node_Tree_Ref) return Path_Name_Type;
pragma Inline (Directory_Of);
-- Only valid for N_Project nodes
function Path_Name_Of
(Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Name_Id;
+ In_Tree : Project_Node_Tree_Ref) return Path_Name_Type;
pragma Inline (Path_Name_Of);
-- Only valid for N_Project and N_With_Clause nodes
function Extended_Project_Path_Of
(Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Name_Id;
+ In_Tree : Project_Node_Tree_Ref) return Path_Name_Type;
pragma Inline (Extended_Project_Path_Of);
-- Only valid for N_With_Clause nodes
procedure Set_Directory_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
- To : Name_Id);
+ To : Path_Name_Type);
pragma Inline (Set_Directory_Of);
procedure Set_Expression_Kind_Of
procedure Set_Path_Name_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
- To : Name_Id);
+ To : Path_Name_Type);
pragma Inline (Set_Path_Name_Of);
procedure Set_String_Value_Of
procedure Set_Extended_Project_Path_Of
(Node : Project_Node_Id;
In_Tree : Project_Node_Tree_Ref;
- To : Name_Id);
+ To : Path_Name_Type);
pragma Inline (Set_Extended_Project_Path_Of);
procedure Set_Project_Node_Of
package Tree_Private_Part is
- -- This is conceptually in the private part.
- -- However, for efficiency, some packages are accessing it directly.
+ -- This is conceptually in the private part
+
+ -- However, for efficiency, some packages are accessing it directly
type Project_Node_Record is record
Location : Source_Ptr := No_Location;
- Directory : Name_Id := No_Name;
+ Directory : Path_Name_Type := No_Path;
-- Only for N_Project
Expr_Kind : Variable_Kind := Undefined;
-- Index of a unit in a multi-unit source.
-- Onli for some N_Attribute_Declaration and N_Literal_String.
- Path_Name : Name_Id := No_Name;
+ Path_Name : Path_Name_Type := No_Path;
-- See below for what Project_Node_Kind it is used
Value : Name_Id := No_Name;
Node : Project_Node_Id;
-- Node of the project in table Project_Nodes
- Canonical_Path : Name_Id;
+ Canonical_Path : Path_Name_Type;
-- Resolved and canonical path of the project file
Extended : Boolean;
No_Project_Name_And_Node : constant Project_Name_And_Node :=
(Name => No_Name,
Node => Empty_Node,
- Canonical_Path => No_Name,
+ Canonical_Path => No_Path,
Extended => True);
package Projects_Htable is new GNAT.Dynamic_HTables.Simple_HTable
Equal => "=");
-- This hash table contains a mapping of project names to project nodes.
-- Note that this hash table contains only the nodes whose Kind is
- -- N_Project. It is used to find the node of a project from its
- -- name, and to verify if a project has already been parsed, knowing
- -- its name.
+ -- N_Project. It is used to find the node of a project from its name,
+ -- and to verify if a project has already been parsed, knowing its name.
end Tree_Private_Part;
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Ada.Unchecked_Deallocation;
-with GNAT.Case_Util; use GNAT.Case_Util;
+with System.Case_Util; use System.Case_Util;
-with Namet; use Namet;
with Osint; use Osint;
with Output; use Output;
with Prj.Com;
function Executable_Of
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
- Main : Name_Id;
+ Main : File_Name_Type;
Index : Int;
- Ada_Main : Boolean := True) return Name_Id
+ Ada_Main : Boolean := True) return File_Name_Type
is
pragma Assert (Project /= No_Project);
Executable : Variable_Value :=
Prj.Util.Value_Of
- (Name => Main,
+ (Name => Name_Id (Main),
Index => Index,
Attribute_Or_Array_Name => Name_Executable,
In_Package => Builder_Package,
declare
Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;
- Result : Name_Id;
+ Result : File_Name_Type;
begin
if Executable_Suffix /= Nil_Variable_Value
Executable_Extension_On_Target := Executable_Suffix.Value;
end if;
- Result := Executable_Name (Executable.Value);
+ Result := Executable_Name (File_Name_Type (Executable.Value));
Executable_Extension_On_Target := Saved_EEOT;
return Result;
end;
File_Name (1 .. Name'Length) := Name;
File_Name (File_Name'Last) := ASCII.NUL;
FD := Open_Read (Name => File_Name'Address,
- Fmode => GNAT.OS_Lib.Text);
+ Fmode => GNAT.OS_Lib.Text);
if FD = Invalid_FD then
File := null;
else
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
function Executable_Of
(Project : Project_Id;
In_Tree : Project_Tree_Ref;
- Main : Name_Id;
+ Main : File_Name_Type;
Index : Int;
- Ada_Main : Boolean := True) return Name_Id;
+ Ada_Main : Boolean := True) return File_Name_Type;
-- Return the value of the attribute Builder'Executable for file Main in
-- the project Project, if it exists. If there is no attribute Executable
-- for Main, remove the suffix from Main; then, if the attribute
Src_Index : Int := 0;
In_Array : Array_Element_Id;
In_Tree : Project_Tree_Ref) return Variable_Value;
- -- Get a string array component (single String or String list).
- -- Returns Nil_Variable_Value if there is no component Index
- -- or if In_Array is null.
+ -- Get a string array component (single String or String list). Returns
+ -- Nil_Variable_Value if no component Index or if In_Array is null.
--
-- Depending on the attribute (only attributes may be associative arrays)
-- the index may or may not be case sensitive. If the index is not case
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
-with Namet; use Namet;
with Snames; use Snames;
package body Scans is
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
+with Namet; use Namet;
with Types; use Types;
with Uintp; use Uintp;
with Urealp; use Urealp;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Atree; use Atree;
with Errout; use Errout;
+with Namet; use Namet;
with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
-with Namet; use Namet;
with Opt; use Opt;
with System; use System;
with Ada.Unchecked_Conversion;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
+with System.OS_Lib; use System.OS_Lib;
package body Sinput.C is
Actual_Len : Integer;
- Path_Id : Name_Id;
- File_Id : Name_Id;
+ Path_Id : File_Name_Type;
+ File_Id : File_Name_Type;
begin
if Path = "" then
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Set_Casing (Cas);
Error_Msg_Name_1 := Name_Enter;
Error_Msg_N
- ("(style) bad casing of { declared in Standard", Ref);
+ ("(style) bad casing of %% declared in Standard", Ref);
end if;
end if;
end if;
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with Namet; use Namet;
with Opt; use Opt;
with Output; use Output;
No_Dir : aliased String := "";
Temp_Dir : String_Access := No_Dir'Access;
+ ----------------------
+ -- Create_Temp_File --
+ ----------------------
+
procedure Create_Temp_File
(FD : out File_Descriptor;
- Name : out Name_Id)
+ Name : out Path_Name_Type)
is
File_Name : String_Access;
Current_Dir : constant String := Get_Current_Dir;
end if;
if FD = Invalid_FD then
- Name := No_Name;
+ Name := No_Path;
else
declare
Path_Name : constant String :=
- Normalize_Pathname
- (Directory & Directory_Separator & File_Name.all);
+ Normalize_Pathname
+ (Directory & Directory_Separator & File_Name.all);
begin
Name_Len := Path_Name'Length;
-- --
-- S p e c --
-- --
--- Copyright (C) 2003 Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- designates an absolute path, temporary files are create in this directory.
-- Otherwise, temporary files are created in the current working directory.
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-with Types; use Types;
+with Namet; use Namet;
+
+with System.OS_Lib; use System.OS_Lib;
package Tempdir is
procedure Create_Temp_File
(FD : out File_Descriptor;
- Name : out Name_Id);
+ Name : out Path_Name_Type);
-- Create a temporary text file and return its file descriptor and
-- its path name as a Name_Id. If environment variable TMPDIR is defined
-- and its value is an absolute path, the temp file is created in the
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Einfo; use Einfo;
with Hostparm;
with Lib; use Lib;
-with Namet; use Namet;
with Nlists; use Nlists;
with Output; use Output;
with Sinfo; use Sinfo;
while Name_Buffer (Name_Len) /= '.' loop
if Name_Len = 1 then
- return No_Name; -- not a child or subunit name
+ return No_Unit_Name;
else
Name_Len := Name_Len - 1;
end if;
-- Get_Unit_Name_String --
--------------------------
- procedure Get_Unit_Name_String (N : Unit_Name_Type) is
+ procedure Get_Unit_Name_String
+ (N : Unit_Name_Type;
+ Suffix : Boolean := True)
+ is
Unit_Is_Body : Boolean;
begin
-- Now adjust the %s or %b to (spec) or (body)
- if Unit_Is_Body then
- Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)";
- else
- Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)";
+ if Suffix then
+ if Unit_Is_Body then
+ Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (body)";
+ else
+ Name_Buffer (Name_Len - 1 .. Name_Len + 5) := " (spec)";
+ end if;
end if;
for J in 1 .. Name_Len loop
end if;
end loop;
- Name_Len := Name_Len + (7 - 2);
+ -- Adjust Name_Len
+
+ if Suffix then
+ Name_Len := Name_Len + (7 - 2);
+ else
+ Name_Len := Name_Len - 2;
+ end if;
end Get_Unit_Name_String;
------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
+with Namet; use Namet;
with Types; use Types;
+
package Uname is
---------------------------
-- N_Protected_Body_Stub
-- N_Subunit
- procedure Get_Unit_Name_String (N : Unit_Name_Type);
- -- Places the display name of the unit in Name_Buffer and sets Name_Len
- -- to the length of the stored name, i.e. it uses the same interface as
- -- the Get_Name_String routine in the Namet package. The name contains
- -- an indication of spec or body, and is decoded.
+ procedure Get_Unit_Name_String
+ (N : Unit_Name_Type;
+ Suffix : Boolean := True);
+ -- Places the display name of the unit in Name_Buffer and sets Name_Len to
+ -- the length of the stored name, i.e. it uses the same interface as the
+ -- Get_Name_String routine in the Namet package. The name is decoded and
+ -- contains an indication of spec or body if Boolean parameter Suffix is
+ -- True.
function Is_Body_Name (N : Unit_Name_Type) return Boolean;
-- Returns True iff the given name is the unit name of a body (i.e. if
projects / thirdparty / gcc.git / commitdiff
