Skip to content

R
riscv-gcc-1
Commit e4691ba9 by Arnaud Charlet
Options

[multiple changes] 

2013-10-14  Robert Dewar  <dewar@adacore.com>

	* exp_prag.adb, sem_prag.adb, a-exexda.adb, s-vmexta.ads: Minor
	reformatting.

2013-10-14  Vincent Celier  <celier@adacore.com>

	* ali.adb (Get_File_Name): New Boolean parameter May_Be_Quoted,
	defaulted to False.  Calls Get_Name with May_Be_Quoted.
	(Get_Name): New Boolean parameter May_Be_Quoted, defaulted to
	False. If May_Be_Quoted is True and first non blank charater is
	'"', unquote the name.
	(Scan_ALI): For the file/path name on the D line, call Get_File_Name
	with May_Be_Quoted = True, as it may have been quoted.
	* lib-util.adb, lib-util.ads (Write_Info_Name_May_Be_Quoted): New
	procedure to write file/path names that may contain spaces and if they
	do are quoted.
	* lib-writ.adb (Write_ALI): Use new procedure
	Write_Info_Name_May_Be_Quoted to write file/path names on D lines.

From-SVN: r203534
parent 0a387eca
Showing with 180 additions and 52 deletions
gcc/ada/ChangeLog
2013-10-14 Robert Dewar <dewar@adacore.com>
* exp_prag.adb, sem_prag.adb, a-exexda.adb, s-vmexta.ads: Minor
reformatting.
2013-10-14 Vincent Celier <celier@adacore.com>
* ali.adb (Get_File_Name): New Boolean parameter May_Be_Quoted,
defaulted to False. Calls Get_Name with May_Be_Quoted.
(Get_Name): New Boolean parameter May_Be_Quoted, defaulted to
False. If May_Be_Quoted is True and first non blank charater is
'"', unquote the name.
(Scan_ALI): For the file/path name on the D line, call Get_File_Name
with May_Be_Quoted = True, as it may have been quoted.
* lib-util.adb, lib-util.ads (Write_Info_Name_May_Be_Quoted): New
procedure to write file/path names that may contain spaces and if they
do are quoted.
* lib-writ.adb (Write_ALI): Use new procedure
Write_Info_Name_May_Be_Quoted to write file/path names on D lines.
2013-10-14 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Depends_In_Decl_Part,
......
gcc/ada/a-exexda.adb
......@@ -390,6 +390,7 @@ package body Exception_Data is
Ptr : in out Natural)
is
Load_Address : Address;
begin
if X.Num_Tracebacks = 0 then
return;
......@@ -398,6 +399,7 @@ package body Exception_Data is
-- The executable load address line
Load_Address := Get_Executable_Load_Address;
if Load_Address /= Null_Address then
Append_Info_String (LDAD_Header, Info, Ptr);
Append_Info_Address (Load_Address, Info, Ptr);
......@@ -427,9 +429,9 @@ package body Exception_Data is
Space_Per_Address : constant := 2 + 16 + 1;
-- Space for "0x" + HHHHHHHHHHHHHHHH + " "
begin
return LDAD_Header'Length + Space_Per_Address +
BETB_Header'Length + 1 +
X.Num_Tracebacks * Space_Per_Address + 1;
return
LDAD_Header'Length + Space_Per_Address + BETB_Header'Length + 1 +
X.Num_Tracebacks * Space_Per_Address + 1;
end Basic_Exception_Tback_Maxlength;
---------------------------------------
......
gcc/ada/ali.adb
......@@ -186,9 +186,13 @@ package body ALI is
function Getc return Character;
-- Get next character, bumping P past the character obtained
function Get_File_Name (Lower : Boolean := False) return File_Name_Type;
function Get_File_Name
(Lower : Boolean := False;
May_Be_Quoted : 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 May_Be_Quoted is True and the first non blank character is '"',
-- then remove starting and ending quotes and undoubled internal quotes.
-- 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
......@@ -198,7 +202,8 @@ package body ALI is
function Get_Name
(Ignore_Spaces : Boolean := False;
Ignore_Special : Boolean := False) return Name_Id;
Ignore_Special : Boolean := False;
May_Be_Quoted : 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
......@@ -215,6 +220,10 @@ package body ALI is
-- an operator name starting with a double quote which is terminated
-- by another double quote.
--
-- If May_Be_Quoted is True and the first non blank character is '"'
-- the name is 'unquoted'. In this case Ignore_Special is ignored and
-- assumed to be True.
--
-- It is an error to set both Ignore_Spaces and Ignore_Special to True.
-- This function handles wide characters properly.
......@@ -450,12 +459,14 @@ package body ALI is
-------------------
function Get_File_Name
(Lower : Boolean := False) return File_Name_Type
(Lower : Boolean := False;
May_Be_Quoted : Boolean := False) return File_Name_Type
is
F : Name_Id;
begin
F := Get_Name (Ignore_Special => True);
F := Get_Name (Ignore_Special => True,
May_Be_Quoted => May_Be_Quoted);
-- Convert file name to all lower case if file names are not case
-- sensitive. This ensures that we handle names in the canonical
......@@ -475,8 +486,11 @@ package body ALI is
function Get_Name
(Ignore_Spaces : Boolean := False;
Ignore_Special : Boolean := False) return Name_Id
Ignore_Special : Boolean := False;
May_Be_Quoted : Boolean := False) return Name_Id
is
Char : Character;
begin
Name_Len := 0;
Skip_Space;
......@@ -489,38 +503,79 @@ package body ALI is
end if;
end if;
loop
Add_Char_To_Name_Buffer (Getc);
Char := Getc;
exit when At_End_Of_Field and then not Ignore_Spaces;
-- Deal with quoted characters
if not Ignore_Special then
if Name_Buffer (1) = '"' then
exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"';
if May_Be_Quoted and then Char = '"' then
loop
if At_Eol then
if Ignore_Errors then
return Error_Name;
else
Fatal_Error;
end if;
end if;
else
-- Terminate on parens or angle brackets or equal sign
Char := Getc;
exit when Nextc = '(' or else Nextc = ')'
or else Nextc = '{' or else Nextc = '}'
or else Nextc = '<' or else Nextc = '>'
or else Nextc = '=';
if Char = '"' then
if At_Eol then
exit;
-- Terminate on comma
else
Char := Getc;
exit when Nextc = ',';
if Char /= '"' then
P := P - 1;
exit;
end if;
end if;
end if;
-- Terminate if left bracket not part of wide char sequence
-- Note that we only recognize brackets notation so far ???
Add_Char_To_Name_Buffer (Char);
end loop;
exit when Nextc = '[' and then T (P + 1) /= '"';
-- Other than case of quoted character
-- Terminate if right bracket not part of wide char sequence
else
P := P - 1;
loop
Add_Char_To_Name_Buffer (Getc);
exit when At_End_Of_Field and then not Ignore_Spaces;
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
exit when Nextc = '(' or else Nextc = ')'
or else Nextc = '{' or else Nextc = '}'
or else Nextc = '<' or else Nextc = '>'
or else Nextc = '=';
-- Terminate on comma
exit when Nextc = ',';
-- 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.
exit when Nextc = ']' and then T (P - 1) /= '"';
end if;
end if;
end if;
end loop;
end loop;
end if;
return Name_Find;
end Get_Name;
......@@ -2224,7 +2279,10 @@ package body ALI is
-- 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;
-- The file/path name may be quoted
Sdep.Table (Sdep.Last).Sfile :=
Get_File_Name (May_Be_Quoted => True);
Sdep.Table (Sdep.Last).Stamp := Get_Stamp;
Sdep.Table (Sdep.Last).Dummy_Entry :=
......
gcc/ada/exp_prag.adb
......@@ -642,8 +642,8 @@ package body Exp_Prag is
if Exception_Code (Id) /= No_Uint then
-- The code for the exception is present.Create a
-- linker alias to define the symbol.
-- The code for the exception is present. Create a linker
-- alias to define the symbol.
Code :=
Make_Integer_Literal (Loc,
......@@ -666,8 +666,8 @@ package body Exp_Prag is
Store_String_Int
(UI_To_Int (Exception_Code (Id)) / 8 * 8);
-- Insert a pragma Linker_Alias to set the value of
-- the dummy object symbol.
-- Insert a pragma Linker_Alias to set the value of the
-- dummy object symbol.
Excep_Alias :=
Make_Pragma (Loc,
......
gcc/ada/lib-util.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2013, 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- --
......@@ -176,6 +176,51 @@ package body Lib.Util is
Write_Info_Name (Name_Id (Name));
end Write_Info_Name;
-----------------------------------
-- Write_Info_Name_May_Be_Quoted --
-----------------------------------
procedure Write_Info_Name_May_Be_Quoted (Name : File_Name_Type) is
Quoted : Boolean := False;
Cur : Positive;
begin
Get_Name_String (Name);
-- The file/path name is quoted only if it includes spaces
for J in 1 .. Name_Len loop
if Name_Buffer (J) = ' ' then
Quoted := True;
exit;
end if;
end loop;
-- Deal with quoting string if needed
if Quoted then
Insert_Str_In_Name_Buffer ("""", 1);
Add_Char_To_Name_Buffer ('"');
-- Any character '"' is doubled
Cur := 2;
while Cur < Name_Len loop
if Name_Buffer (Cur) = '"' then
Insert_Str_In_Name_Buffer ("""", Cur);
Cur := Cur + 2;
else
Cur := Cur + 1;
end if;
end loop;
end if;
Info_Buffer (Info_Buffer_Len + 1 .. Info_Buffer_Len + Name_Len) :=
Name_Buffer (1 .. Name_Len);
Info_Buffer_Len := Info_Buffer_Len + Name_Len;
Info_Buffer_Col := Info_Buffer_Col + Name_Len;
end Write_Info_Name_May_Be_Quoted;
--------------------
-- Write_Info_Nat --
--------------------
......
gcc/ada/lib-util.ads
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2013, 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- --
......@@ -65,6 +65,10 @@ package Lib.Util is
-- name is written literally from the names table entry without modifying
-- the case, using simply Get_Name_String.
procedure Write_Info_Name_May_Be_Quoted (Name : File_Name_Type);
-- Similar to Write_Info_Name, but if Name includes spaces, then it is
-- quoted and the '"' are doubled.
procedure Write_Info_Slit (S : String_Id);
-- Write string literal value in format required for L/N lines in ali file
......
gcc/ada/lib-writ.adb
......@@ -1428,7 +1428,7 @@ package body Lib.Writ is
Fname := Name_Find;
end if;
Write_Info_Name (Fname);
Write_Info_Name_May_Be_Quoted (Fname);
Write_Info_Tab (25);
Write_Info_Str (String (Time_Stamp (Sind)));
Write_Info_Char (' ');
......
gcc/ada/s-vmexta.ads
......@@ -41,13 +41,12 @@ package System.VMS_Exception_Table is
procedure Register_VMS_Exception
(Code : SSL.Exception_Code;
E : SSL.Exception_Data_Ptr);
-- Register an exception in the hash table mapping with a VMS
-- condition code.
-- The table is used by exception code (the personnality routine) to
-- detect wether a VMS exception (aka condition) is known by the Ada code.
-- In that case, the identity of the imported or exported exception is
-- used to create the occurrence.
-- Register an exception in hash table mapping with a VMS condition code.
--
-- The table is used by exception code (the personnality routine) to detect
-- wether a VMS exception (aka condition) is known by the Ada code. In
-- that case, the identity of the imported or exported exception is used
-- to create the occurrence.
-- LOTS more comments needed here regarding the entire scheme ???
......@@ -61,6 +60,6 @@ private
function Coded_Exception (X : SSL.Exception_Code)
return SSL.Exception_Data_Ptr;
-- Given a VMS condition, find and return it's allocated Ada exception
-- Given a VMS condition, find and return its allocated Ada exception
end System.VMS_Exception_Table;
gcc/ada/sem_prag.adb
......@@ -213,13 +213,13 @@ package body Sem_Prag is
Has_In_Out_State : out Boolean;
Has_Out_State : out Boolean;
Has_Null_State : out Boolean);
-- Subsidiary to the analysis of pragma Refined_Depends and pragma
-- Refined_Global. Prag denotes pragma [Refined_]Global. Gather all input,
-- in out and output items of Prag in lists In_Items, In_Out_Items and
-- Out_Items. Flags Has_In_State, Has_In_Out_State and Has_Out_State are
-- set when there is at least one abstract state with visible refinement
-- available in the corresponding mode. Flag Has_Null_State is set when at
-- least state has a null refinement.
-- Subsidiary to the analysis of pragma Refined_Depends/Refined_Global.
-- Prag denotes pragma [Refined_]Global. Gather all input, in out and
-- output items of Prag in lists In_Items, In_Out_Items and Out_Items.
-- Flags Has_In_State, Has_In_Out_State and Has_Out_State are set when
-- there is at least one abstract state with visible refinement available
-- in the corresponding mode. Flag Has_Null_State is set when at least
-- state has a null refinement.
procedure Collect_Subprogram_Inputs_Outputs
(Subp_Id : Entity_Id;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment