+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,
Ptr : in out Natural)
is
Load_Address : Address;
+
begin
if X.Num_Tracebacks = 0 then
return;
-- 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);
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;
---------------------------------------
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
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
-- 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.
-------------------
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
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;
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;
-- 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 :=
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,
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,
-- --
-- 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- --
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 --
--------------------
-- --
-- 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- --
-- 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
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 (' ');
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 ???
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;
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;
projects / platform / upstream / linaro-gcc.git / commitdiff