Skip to content

R
riscv-gcc-1
Commit 4ecc031c by Robert Dewar Committed by Arnaud Charlet
Options

errout.ads, errout.adb (Finalize): Implement switch -gnatd.m Avoid abbreviation Creat 

2006-10-31  Robert Dewar  <dewar@adacore.com>

	* errout.ads, errout.adb (Finalize): Implement switch -gnatd.m
	Avoid abbreviation Creat
	(Finalize): List all sources in extended mail source if -gnatl
	switch is active.
	Suppress copyright notice to file in -gnatl=f mode if -gnatd7 set
	(Finalize): Implement new -gnatl=xxx switch to output listing to file
	(Set_Specific_Warning_On): New procedure
	(Set_Specific_Warning_Off): New procedure
	Add implementation of new insertion \\
	(Error_Msg_Internal): Add handling for Error_Msg_Line_Length
	(Unwind_Internal_Type): Improve report on anonymous access_to_subprogram
	types.
	(Error_Msg_Internal): Make sure that we set Last_Killed to
	True when a message from another package is suppressed.
	Implement insertion character ~ (insert string)
	(First_Node): Minor adjustments to get better placement.

	* frontend.adb: 
	Implement new -gnatl=xxx switch to output listing to file

	* gnat1drv.adb: 
	Implement new -gnatl=xxx switch to output listing to file

        * opt.ads: (Warn_On_Questionable_Missing_Paren): New switch
	(Commands_To_Stdout): New flag
	Implement new -gnatl=xxx switch to output listing to file
	New switch Dump_Source_Text
	(Warn_On_Deleted_Code): New warning flag for -gnatwt
	Define Error_Msg_Line_Length
	(Warn_On_Assumed_Low_Bound): New switch

	* osint.ads, osint.adb
	(Normalize_Directory_Name): Fix bug.
	Implement new -gnatl=xxx switch to output listing to file
	(Concat): Removed, replaced by real concatenation
	Make use of concatenation now allowed in compiler
	(Executable_Prefix.Get_Install_Dir): First get the full path, so that
	we find the 'lib' or 'bin' directory even when the tool has been
	invoked with a relative path.
	(Executable_Name): New function taking string parameters.

	* osint-c.ads, osint-c.adb: 
	Implement new -gnatl=xxx switch to output listing to file

	* sinput-d.adb: Change name Creat_Debug_File to Create_Debug_File

	* switch-c.adb: 
	Implement new -gnatl=xxx switch to output listing to file
	Recognize new -gnatL switch
	(no longer keep in old warning about old style usage)
	Use concatenation to simplify code
	Recognize -gnatjnn switch
	(Scan_Front_End_Switches): Clean up handling of -gnatW
	(Scan_Front_End_Switches): Include Warn_On_Assumed_Low_Bound for -gnatg

From-SVN: r118251
parent 6e443c90
Showing with 835 additions and 327 deletions
gcc/ada/errout.adb
......@@ -37,6 +37,7 @@ with Debug; use Debug;
with Einfo; use Einfo;
with Erroutc; use Erroutc;
with Fname; use Fname;
with Gnatvsn; use Gnatvsn;
with Hostparm; use Hostparm;
with Lib; use Lib;
with Namet; use Namet;
......@@ -264,7 +265,7 @@ package body Errout is
return;
end if;
-- Start procesing of new message
-- Start processing of new message
Sindex := Get_Source_File_Index (Flag_Location);
Test_Style_Warning_Serious_Msg (Msg);
......@@ -676,6 +677,7 @@ package body Errout is
end if;
Continuation := Msg_Cont;
Continuation_New_Line := False;
Suppress_Message := False;
Kill_Message := False;
Set_Msg_Text (Msg, Sptr);
......@@ -735,8 +737,9 @@ package body Errout is
if In_Extended_Main_Source_Unit (Sptr) then
null;
-- If the flag location is not in the main extended source
-- unit then we want to eliminate the warning.
-- If the flag location is not in the main extended source unit,
-- then we want to eliminate the warning, unless it is in the
-- extended main code unit and we want warnings on the instance.
elsif In_Extended_Main_Code_Unit (Sptr)
and then Warn_On_Instance
......@@ -752,6 +755,11 @@ package body Errout is
else
Cur_Msg := No_Error_Msg;
if not Continuation then
Last_Killed := True;
end if;
return;
end if;
end if;
......@@ -767,6 +775,74 @@ package body Errout is
return;
end if;
-- If error message line length set, and this is a continuation message
-- then all we do is to append the text to the text of the last message
-- with a comma space separator.
if Error_Msg_Line_Length /= 0
and then Continuation
then
Cur_Msg := Errors.Last;
declare
Oldm : String_Ptr := Errors.Table (Cur_Msg).Text;
Newm : String (1 .. Oldm'Last + 2 + Msglen);
Newl : Natural;
begin
-- First copy old message to new one and free it
Newm (Oldm'Range) := Oldm.all;
Newl := Oldm'Length;
Free (Oldm);
-- Now deal with separation between messages. Normally this
-- is simply comma space, but there are some special cases.
-- If continuation new line, then put actual NL character in msg
if Continuation_New_Line then
Newl := Newl + 1;
Newm (Newl) := ASCII.LF;
-- If continuation message is enclosed in parentheses, then
-- special treatment (don't need a comma, and we want to combine
-- successive parenthetical remarks into a single one with
-- separating commas).
elsif Msg_Buffer (1) = '(' and then Msg_Buffer (Msglen) = ')' then
-- Case where existing message ends in right paren, remove
-- and separate parenthetical remarks with a comma.
if Newm (Newl) = ')' then
Newm (Newl) := ',';
Msg_Buffer (1) := ' ';
-- Case where we are adding new parenthetical comment
else
Newl := Newl + 1;
Newm (Newl) := ' ';
end if;
-- Case where continuation not in parens and no new line
else
Newm (Newl + 1 .. Newl + 2) := ", ";
Newl := Newl + 2;
end if;
-- Append new message
Newm (Newl + 1 .. Newl + Msglen) := Msg_Buffer (1 .. Msglen);
Newl := Newl + Msglen;
Errors.Table (Cur_Msg).Text := new String'(Newm (1 .. Newl));
end;
return;
end if;
-- Otherwise build error message object for new message
Errors.Increment_Last;
......@@ -781,8 +857,8 @@ package body Errout is
Errors.Table (Cur_Msg).Warn := Is_Warning_Msg;
Errors.Table (Cur_Msg).Style := Is_Style_Msg;
Errors.Table (Cur_Msg).Serious := Is_Serious_Error;
Errors.Table (Cur_Msg).Uncond
:= Is_Unconditional_Msg or Is_Warning_Msg;
Errors.Table (Cur_Msg).Uncond := Is_Unconditional_Msg
or Is_Warning_Msg;
Errors.Table (Cur_Msg).Msg_Cont := Continuation;
Errors.Table (Cur_Msg).Deleted := False;
......@@ -792,8 +868,8 @@ package body Errout is
if Debug_Flag_OO or else Debug_Flag_1 then
Write_Eol;
Output_Source_Line (Errors.Table (Cur_Msg).Line,
Errors.Table (Cur_Msg).Sfile, True);
Output_Source_Line
(Errors.Table (Cur_Msg).Line, Errors.Table (Cur_Msg).Sfile, True);
Temp_Msg := Cur_Msg;
Output_Error_Msgs (Temp_Msg);
......@@ -803,9 +879,9 @@ package body Errout is
-- location (earlier flag location first in the chain).
else
-- First a quick check, does this belong at the very end of the
-- chain of error messages. This saves a lot of time in the
-- normal case if there are lots of messages.
-- First a quick check, does this belong at the very end of the chain
-- of error messages. This saves a lot of time in the normal case if
-- there are lots of messages.
if Last_Error_Msg /= No_Error_Msg
and then Errors.Table (Cur_Msg).Sfile =
......@@ -868,12 +944,12 @@ package body Errout is
if not Errors.Table (Cur_Msg).Uncond
and then not Continuation
then
-- Don't delete if prev msg is warning and new msg is
-- an error. This is because we don't want a real error
-- masked by a warning. In all other cases (that is parse
-- errors for the same line that are not unconditional)
-- we do delete the message. This helps to avoid
-- junk extra messages from cascaded parsing errors
-- Don't delete if prev msg is warning and new msg is an error.
-- This is because we don't want a real error masked by a
-- warning. In all other cases (that is parse errors for the
-- same line that are not unconditional) we do delete the
-- message. This helps to avoid junk extra messages from
-- cascaded parsing errors
if not (Errors.Table (Prev_Msg).Warn
or
......@@ -883,8 +959,8 @@ package body Errout is
or
Errors.Table (Cur_Msg).Style)
then
-- All tests passed, delete the message by simply
-- returning without any further processing.
-- All tests passed, delete the message by simply returning
-- without any further processing.
if not Continuation then
Last_Killed := True;
......@@ -934,7 +1010,6 @@ package body Errout is
if Total_Errors_Detected + Warnings_Detected = Maximum_Errors then
raise Unrecoverable_Error;
end if;
end Error_Msg_Internal;
-----------------
......@@ -1093,6 +1168,137 @@ package body Errout is
E, F : Error_Msg_Id;
Err_Flag : Boolean;
procedure Write_Error_Summary;
-- Write error summary
procedure Write_Header (Sfile : Source_File_Index);
-- Write header line (compiling or checking given file)
procedure Write_Max_Errors;
-- Write message if max errors reached
-------------------------
-- Write_Error_Summary --
-------------------------
procedure Write_Error_Summary is
begin
-- Extra blank line if error messages or source listing were output
if Total_Errors_Detected + Warnings_Detected > 0
or else Full_List
then
Write_Eol;
end if;
-- Message giving number of lines read and number of errors detected.
-- This normally goes to Standard_Output. The exception is when brief
-- mode is not set, verbose mode (or full list mode) is set, and
-- there are errors. In this case we send the message to standard
-- error to make sure that *something* appears on standard error in
-- an error situation.
-- Formerly, only the "# errors" suffix was sent to stderr, whereas
-- "# lines:" appeared on stdout. This caused problems on VMS when
-- the stdout buffer was flushed, giving an extra line feed after
-- the prefix.
if Total_Errors_Detected + Warnings_Detected /= 0
and then not Brief_Output
and then (Verbose_Mode or Full_List)
then
Set_Standard_Error;
end if;
-- Message giving total number of lines
Write_Str (" ");
Write_Int (Num_Source_Lines (Main_Source_File));
if Num_Source_Lines (Main_Source_File) = 1 then
Write_Str (" line: ");
else
Write_Str (" lines: ");
end if;
if Total_Errors_Detected = 0 then
Write_Str ("No errors");
elsif Total_Errors_Detected = 1 then
Write_Str ("1 error");
else
Write_Int (Total_Errors_Detected);
Write_Str (" errors");
end if;
if Warnings_Detected /= 0 then
Write_Str (", ");
Write_Int (Warnings_Detected);
Write_Str (" warning");
if Warnings_Detected /= 1 then
Write_Char ('s');
end if;
if Warning_Mode = Treat_As_Error then
Write_Str (" (treated as error");
if Warnings_Detected /= 1 then
Write_Char ('s');
end if;
Write_Char (')');
end if;
end if;
Write_Eol;
Set_Standard_Output;
end Write_Error_Summary;
------------------
-- Write_Header --
------------------
procedure Write_Header (Sfile : Source_File_Index) is
begin
if Verbose_Mode or Full_List then
if Original_Operating_Mode = Generate_Code then
Write_Str ("Compiling: ");
else
Write_Str ("Checking: ");
end if;
Write_Name (Full_File_Name (Sfile));
if not Debug_Flag_7 then
Write_Str (" (source file time stamp: ");
Write_Time_Stamp (Sfile);
Write_Char (')');
end if;
Write_Eol;
end if;
end Write_Header;
----------------------
-- Write_Max_Errors --
----------------------
procedure Write_Max_Errors is
begin
if Maximum_Errors /= 0
and then Total_Errors_Detected + Warnings_Detected = Maximum_Errors
then
Set_Standard_Error;
Write_Str ("fatal error: maximum errors reached");
Write_Eol;
Set_Standard_Output;
end if;
end Write_Max_Errors;
-- Start of processing for Finalize
begin
-- Reset current error source file if the main unit has a pragma
-- Source_Reference. This ensures outputting the proper name of
......@@ -1122,6 +1328,25 @@ package body Errout is
Cur := Nxt;
end loop;
-- Mark any messages suppressed by specific warnings as Deleted
Cur := First_Error_Msg;
while Cur /= No_Error_Msg loop
if Warning_Specifically_Suppressed
(Errors.Table (Cur).Sptr,
Errors.Table (Cur).Text)
then
Errors.Table (Cur).Deleted := True;
Warnings_Detected := Warnings_Detected - 1;
end if;
Cur := Errors.Table (Cur).Next;
end loop;
-- Check consistency of specific warnings (may add warnings)
Validate_Specific_Warnings (Error_Msg'Access);
-- Brief Error mode
if Brief_Output or (not Full_List and not Verbose_Mode) then
......@@ -1164,140 +1389,156 @@ package body Errout is
List_Pragmas_Index := 1;
List_Pragmas_Mode := True;
E := First_Error_Msg;
Write_Eol;
-- First list initial main source file with its error messages
for N in 1 .. Last_Source_Line (Main_Source_File) loop
Err_Flag :=
E /= No_Error_Msg
and then Errors.Table (E).Line = N
and then Errors.Table (E).Sfile = Main_Source_File;
Output_Source_Line (N, Main_Source_File, Err_Flag);
if Err_Flag then
Output_Error_Msgs (E);
-- Normal case, to stdout (copyright notice already output)
if not Debug_Flag_2 then
Write_Eol;
end if;
if Full_List_File_Name = null then
if not Debug_Flag_7 then
Write_Eol;
end if;
end loop;
-- Then output errors, if any, for subsidiary units
-- Output to file
while E /= No_Error_Msg
and then Errors.Table (E).Sfile /= Main_Source_File
loop
Write_Eol;
Output_Source_Line
(Errors.Table (E).Line, Errors.Table (E).Sfile, True);
Output_Error_Msgs (E);
end loop;
end if;
else
Create_List_File_Access.all (Full_List_File_Name.all);
Set_Special_Output (Write_List_Info_Access.all'Access);
-- Verbose mode (error lines only with error flags)
-- Write copyright notice to file
if Verbose_Mode and not Full_List then
E := First_Error_Msg;
if not Debug_Flag_7 then
Write_Str ("GNAT ");
Write_Str (Gnat_Version_String);
Write_Eol;
Write_Str ("Copyright 1992-" &
Current_Year &
", Free Software Foundation, Inc.");
Write_Eol;
end if;
end if;
-- Loop through error lines
-- First list extended main source file units with errors
while E /= No_Error_Msg loop
Write_Eol;
Output_Source_Line
(Errors.Table (E).Line, Errors.Table (E).Sfile, True);
Output_Error_Msgs (E);
end loop;
end if;
-- Note: if debug flag d.m is set, only the main source is listed
-- Output error summary if verbose or full list mode
for U in Main_Unit .. Last_Unit loop
if In_Extended_Main_Source_Unit (Cunit_Entity (U))
and then (U = Main_Unit or else not Debug_Flag_Dot_M)
then
declare
Sfile : constant Source_File_Index := Source_Index (U);
if Verbose_Mode or else Full_List then
begin
Write_Eol;
Write_Header (Sfile);
Write_Eol;
-- Extra blank line if error messages or source listing were output
-- Normally, we don't want an "error messages from file"
-- message when listing the entire file, so we set the
-- current source file as the current error source file.
-- However, the old style of doing things was to list this
-- message if pragma Source_Reference is present, even for
-- the main unit. Since the purpose of the -gnatd.m switch
-- is to duplicate the old behavior, we skip the reset if
-- this debug flag is set.
if not Debug_Flag_Dot_M then
Current_Error_Source_File := Sfile;
end if;
if Total_Errors_Detected + Warnings_Detected > 0
or else Full_List
then
Write_Eol;
end if;
for N in 1 .. Last_Source_Line (Sfile) loop
while E /= No_Error_Msg
and then Errors.Table (E).Deleted
loop
E := Errors.Table (E).Next;
end loop;
Err_Flag :=
E /= No_Error_Msg
and then Errors.Table (E).Line = N
and then Errors.Table (E).Sfile = Sfile;
Output_Source_Line (N, Sfile, Err_Flag);
if Err_Flag then
Output_Error_Msgs (E);
if not Debug_Flag_2 then
Write_Eol;
end if;
end if;
end loop;
end;
end if;
end loop;
-- Message giving number of lines read and number of errors detected.
-- This normally goes to Standard_Output. The exception is when brief
-- mode is not set, verbose mode (or full list mode) is set, and
-- there are errors. In this case we send the message to standard
-- error to make sure that *something* appears on standard error in
-- an error situation.
-- Then output errors, if any, for subsidiary units not in the
-- main extended unit.
-- Formerly, only the "# errors" suffix was sent to stderr, whereas
-- "# lines:" appeared on stdout. This caused problems on VMS when
-- the stdout buffer was flushed, giving an extra line feed after
-- the prefix.
-- Note: if debug flag d.m set, include errors for any units other
-- than the main unit in the extended source unit (e.g. spec and
-- subunits for a body).
if Total_Errors_Detected + Warnings_Detected /= 0
and then not Brief_Output
and then (Verbose_Mode or Full_List)
then
Set_Standard_Error;
end if;
while E /= No_Error_Msg
and then (not In_Extended_Main_Source_Unit (Errors.Table (E).Sptr)
or else
(Debug_Flag_Dot_M
and then Get_Source_Unit
(Errors.Table (E).Sptr) /= Main_Unit))
loop
if Errors.Table (E).Deleted then
E := Errors.Table (E).Next;
-- Message giving total number of lines
else
Write_Eol;
Output_Source_Line
(Errors.Table (E).Line, Errors.Table (E).Sfile, True);
Output_Error_Msgs (E);
end if;
end loop;
Write_Str (" ");
Write_Int (Num_Source_Lines (Main_Source_File));
-- If output to file, write extra copy of error summary to the
-- output file, and then close it.
if Num_Source_Lines (Main_Source_File) = 1 then
Write_Str (" line: ");
else
Write_Str (" lines: ");
if Full_List_File_Name /= null then
Write_Error_Summary;
Write_Max_Errors;
Close_List_File_Access.all;
Cancel_Special_Output;
end if;
end if;
if Total_Errors_Detected = 0 then
Write_Str ("No errors");
elsif Total_Errors_Detected = 1 then
Write_Str ("1 error");
-- Verbose mode (error lines only with error flags). Normally this is
-- ignored in full list mode, unless we are listing to a file, in which
-- case we still generate -gnatv output to standard output.
else
Write_Int (Total_Errors_Detected);
Write_Str (" errors");
end if;
if Verbose_Mode
and then (not Full_List or else Full_List_File_Name /= null)
then
Write_Eol;
Write_Header (Main_Source_File);
E := First_Error_Msg;
if Warnings_Detected /= 0 then
Write_Str (", ");
Write_Int (Warnings_Detected);
Write_Str (" warning");
-- Loop through error lines
if Warnings_Detected /= 1 then
Write_Char ('s');
while E /= No_Error_Msg loop
if Errors.Table (E).Deleted then
E := Errors.Table (E).Next;
else
Write_Eol;
Output_Source_Line
(Errors.Table (E).Line, Errors.Table (E).Sfile, True);
Output_Error_Msgs (E);
end if;
end loop;
end if;
if Warning_Mode = Treat_As_Error then
Write_Str (" (treated as error");
if Warnings_Detected /= 1 then
Write_Char ('s');
end if;
Write_Char (')');
end if;
end if;
-- Output error summary if verbose or full list mode
Write_Eol;
Set_Standard_Output;
if Verbose_Mode or else Full_List then
Write_Error_Summary;
end if;
if Maximum_Errors /= 0
and then Total_Errors_Detected + Warnings_Detected = Maximum_Errors
then
Set_Standard_Error;
Write_Str ("fatal error: maximum errors reached");
Write_Eol;
Set_Standard_Output;
end if;
Write_Max_Errors;
if Warning_Mode = Treat_As_Error then
Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
......@@ -1310,7 +1551,7 @@ package body Errout is
----------------
function First_Node (C : Node_Id) return Node_Id is
L : constant Source_Ptr := Sloc (C);
L : constant Source_Ptr := Sloc (Original_Node (C));
Sfile : constant Source_File_Index := Get_Source_File_Index (L);
Earliest : Node_Id;
Eloc : Source_Ptr;
......@@ -1329,7 +1570,7 @@ package body Errout is
------------------
function Test_Earlier (N : Node_Id) return Traverse_Result is
Loc : constant Source_Ptr := Sloc (N);
Loc : constant Source_Ptr := Sloc (Original_Node (N));
begin
-- Check for earlier. The tests for being in the same file ensures
......@@ -1340,7 +1581,7 @@ package body Errout is
if Loc < Eloc
and then Get_Source_File_Index (Loc) = Sfile
then
Earliest := N;
Earliest := Original_Node (N);
Eloc := Loc;
end if;
......@@ -1428,6 +1669,7 @@ package body Errout is
-- an initial dummy entry covering all possible source locations.
Warnings.Init;
Specific_Warnings.Init;
if Warning_Mode = Suppress then
Warnings.Increment_Last;
......@@ -1988,7 +2230,15 @@ package body Errout is
Set_Qualification (Error_Msg_Qual_Level, Ent);
Set_Msg_Node (Ent);
Add_Class;
Set_Msg_Quote;
-- If Ent is an anonymous subprogram type, there is no name
-- to print, so remove enclosing quotes.
if Buffer_Ends_With ("""") then
Buffer_Remove ("""");
else
Set_Msg_Quote;
end if;
end if;
-- If the original type did not come from a predefined
......@@ -2106,8 +2356,15 @@ package body Errout is
Ent := Node;
end if;
Unwind_Internal_Type (Ent);
Nam := Chars (Ent);
-- If the type is the designated type of an access_to_subprogram,
-- there is no name to provide in the call.
if Ekind (Ent) = E_Subprogram_Type then
return;
else
Unwind_Internal_Type (Ent);
Nam := Chars (Ent);
end if;
else
Nam := Chars (Node);
......@@ -2241,6 +2498,11 @@ package body Errout is
when '\' =>
Continuation := True;
if Text (P) = '\' then
Continuation_New_Line := True;
P := P + 1;
end if;
when '@' =>
Set_Msg_Insertion_Column;
......@@ -2270,6 +2532,9 @@ package body Errout is
Set_Msg_Char (Text (P));
P := P + 1;
when '~' =>
Set_Msg_Str (Error_Msg_String (1 .. Error_Msg_Strlen));
-- Upper case letter
when 'A' .. 'Z' =>
......@@ -2435,10 +2700,36 @@ package body Errout is
Old_Ent := Ent;
-- Implicit access type, use directly designated type
-- In Ada 2005, the designated type may be an anonymous access to
-- subprogram, in which case we can only point to its definition.
if Is_Access_Type (Ent) then
Set_Msg_Str ("access to ");
Ent := Directly_Designated_Type (Ent);
if Ekind (Ent) = E_Access_Subprogram_Type
or else Ekind (Ent) = E_Anonymous_Access_Subprogram_Type
or else Ekind (Ent) = E_Access_Protected_Subprogram_Type
then
Ent := Directly_Designated_Type (Ent);
if not Comes_From_Source (Ent) then
if Buffer_Ends_With ("type ") then
Buffer_Remove ("type ");
end if;
Set_Msg_Str ("access to subprogram with profile ");
elsif Ekind (Ent) = E_Function then
Set_Msg_Str ("access to function ");
else
Set_Msg_Str ("access to procedure ");
end if;
exit;
-- Type is access to object, named or anonymous
else
Set_Msg_Str ("access to ");
Ent := Directly_Designated_Type (Ent);
end if;
-- Classwide type
......
gcc/ada/errout.ads
......@@ -235,9 +235,18 @@ package Errout is
-- of the cases in which messages are normally suppressed. Note that
-- warnings are never suppressed, so the use of the ! character in a
-- warning message is never useful.
--
-- Note: the presence of ! is ignored in continuation messages (i.e.
-- messages starting with the \ insertion character). The effect of the
-- use of ! in a parent message automatically applies to all of its
-- continuation messages (since we clearly don't want any case in which
-- continuations are separated from the parent message. It is allowable
-- to put ! in continuation messages, and the usual style is to include
-- it, since it makes it clear that the continuation is part of an
-- unconditional message.
-- Insertion character ? (Question: warning message)
-- The character ? appearing anywhere in a message makes the message a
-- The character ? appearing anywhere in a message makes the message
-- warning instead of a normal error message, and the text of the
-- message will be preceded by "Warning:" instead of "Error:" in the
-- normal case. The handling of warnings if further controlled by the
......@@ -247,6 +256,13 @@ package Errout is
-- the parser), but currently all relevant warnings are posted by the
-- semantic phase anyway. Messages starting with (style) are also
-- treated as warning messages.
--
-- Note: the presence of ? is ignored in continuation messages (i.e.
-- messages starting with the \ insertion character). The warning
-- status of continuations is determined only by the parent message
-- which is being continued. It is allowable to put ? in continuation
-- messages, and the usual style is to include it, since it makes it
-- clear that the continuation is part of a warning message.
-- Insertion character < (Less Than: conditional warning message)
-- The character < appearing anywhere in a message is used for a
......@@ -262,7 +278,7 @@ package Errout is
-- 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
-- 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.
......@@ -280,7 +296,12 @@ package Errout is
-- messages are treated as a unit. The \ character must be the first
-- character of the message text.
-- Insertion character | (vertical bar, non-serious error)
-- Insertion character \\ (Two backslashes, continuation with new line)
-- This differs from \ only in -gnatjnn mode (Error_Message_Line_Length
-- set non-zero). This sequence forces a new line to start even when
-- continuations are being gathered into a single message.
-- Insertion character | (Vertical bar: non-serious error)
-- By default, error messages (other than warning messages) are
-- considered to be fatal error messages which prevent expansion or
-- generation of code in the presence of the -gnatQ switch. If the
......@@ -288,6 +309,11 @@ package Errout is
-- non-serious, and does not cause Serious_Errors_Detected to be
-- incremented (so expansion is not prevented by such a msg).
-- Insertion character ~ (Tilde: insert string)
-- Indicates that Error_Msg_String (1 .. Error_Msg_Strlen) is to be
-- inserted to replace the ~ character. The string is inserted in the
-- literal form it appears, without any action on special characters.
----------------------------------------
-- Specialization of Messages for VMS --
----------------------------------------
......@@ -376,6 +402,11 @@ package Errout is
-- Used if current message contains a < insertion character to indicate
-- if the current message is a warning message.
Error_Msg_String : String renames Err_Vars.Error_Msg_String;
Error_Msg_Strlen : Natural renames Err_Vars.Error_Msg_Strlen;
-- Used if current message contains a ~ insertion character to indicate
-- insertion of the string Error_Msg_String (1 .. Error_Msg_Strlen).
-----------------------------------------------------
-- Format of Messages and Manual Quotation Control --
-----------------------------------------------------
......@@ -636,6 +667,26 @@ package Errout is
-- Called in response to a pragma Warnings (On) to record the source
-- location from which warnings are to be turned back on.
procedure Set_Specific_Warning_Off (Loc : Source_Ptr; Msg : String)
renames Erroutc.Set_Specific_Warning_Off;
-- This is called in response to the two argument form of pragma Warnings
-- where the first argument is OFF, and the second argument is the prefix
-- of a specific warning to be suppressed. The first argument is the start
-- of the suppression range, and the second argument is the string from
-- the pragma.
procedure Set_Specific_Warning_On
(Loc : Source_Ptr;
Msg : String;
Err : out Boolean)
renames Erroutc.Set_Specific_Warning_On;
-- This is called in response to the two argument form of pragma Warnings
-- where the first argument is ON, and the second argument is the prefix
-- of a specific warning to be suppressed. The first argument is the end
-- of the suppression range, and the second argument is the string from
-- the pragma. Err is set to True on return to report the error of no
-- matching Warnings Off pragma preceding this one.
function Compilation_Errors return Boolean
renames Erroutc.Compilation_Errors;
-- Returns true if errors have been detected, or warnings in -gnatwe
......
gcc/ada/frontend.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2006, 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- --
......@@ -43,7 +43,6 @@ with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
with Osint;
with Output; use Output;
with Par;
with Prepcomp;
with Rtsfind;
......@@ -215,28 +214,6 @@ begin
Initialize_Scanner (Main_Unit, Source_Index (Main_Unit));
-- Output header if in verbose mode or full list mode
if Verbose_Mode or Full_List then
Write_Eol;
if Operating_Mode = Generate_Code then
Write_Str ("Compiling: ");
else
Write_Str ("Checking: ");
end if;
Write_Name (Full_File_Name (Current_Source_File));
if not Debug_Flag_7 then
Write_Str (" (source file time stamp: ");
Write_Time_Stamp (Current_Source_File);
Write_Char (')');
end if;
Write_Eol;
end if;
-- Here we call the parser to parse the compilation unit (or units in
-- the check syntax mode, but in that case we won't go on to the
-- semantics in any case).
......
gcc/ada/gnat1drv.adb
......@@ -170,10 +170,11 @@ begin
List_Representation_Info_Mechanisms := True;
end if;
-- Output copyright notice if full list mode
-- Output copyright notice if full list mode unless we have a list
-- file, in which case we defer this so that it is output in the file
if (Verbose_Mode or Full_List)
and then (not Debug_Flag_7)
if (Verbose_Mode or else (Full_List and Full_List_File_Name = null))
and then not Debug_Flag_7
then
Write_Eol;
Write_Str ("GNAT ");
......
gcc/ada/opt.ads
......@@ -127,7 +127,7 @@ package Opt is
-- GNAT
-- Flag set to force display of multiple errors on a single line and
-- also repeated error messages for references to undefined identifiers
-- and certain other repeated error messages.
-- and certain other repeated error messages. Set by use of -gnatf.
All_Sources : Boolean := False;
-- GNATBIND
......@@ -239,6 +239,10 @@ package Opt is
-- Set to True to enable checking for unused withs, and also the case
-- of withing a package and using none of the entities in the package.
Commands_To_Stdout : Boolean := False;
-- GNATMAKE
-- True if echoed commands to be written to stdout instead of stderr
Comment_Deleted_Lines : Boolean := False;
-- GNATPREP
-- True if source lines removed by the preprocessor should be commented
......@@ -344,6 +348,11 @@ package Opt is
-- GNATMAKE
-- Set to True if no actual compilations should be undertaken.
Dump_Source_Text : Boolean := False;
-- GNAT
-- Set to True (by -gnatL) to dump source text intermingled with generated
-- code. Effective only if either of Debug/Print_Generated_Code is true.
Dynamic_Elaboration_Checks : Boolean := False;
-- GNAT
-- Set True for dynamic elaboration checking mode, as set by the -gnatE
......@@ -377,6 +386,15 @@ package Opt is
-- Set to True if -gnato (enable overflow checks) switch is set,
-- but not -gnatp.
Error_Msg_Line_Length : Nat := 0;
-- GNAT
-- Records the error message line length limit. If this is set to zero,
-- then we get the old style behavior, in which each call to the error
-- message routines generates one line of output as a separate message.
-- If it is set to a non-zero value, then continuation lines are folded
-- to make a single long message, and then this message is split up into
-- multiple lines not exceeding the specified length. Set by -gnatLnnn.
Exception_Locations_Suppressed : Boolean := False;
-- GNAT
-- This flag is set True if a Suppress_Exception_Locations configuration
......@@ -485,6 +503,12 @@ package Opt is
-- GNAT
-- Set True to generate full source listing with embedded errors
Full_List_File_Name : String_Ptr := null;
-- GNAT
-- Set to file name to generate full source listing to named file (or if
-- the name is of the form .xxx, then to name.xxx where name is the source
-- file name with extension stripped.
function get_gcc_version return Int;
pragma Import (C, get_gcc_version, "get_gcc_version");
......@@ -643,22 +667,38 @@ package Opt is
-- before preprocessing occurs. Set to True by switch -s of gnatprep
-- or -s in preprocessing data file for the compiler.
type Creat_Repinfo_File_Proc is access procedure (Src : File_Name_Type);
type Write_Repinfo_Line_Proc is access procedure (Info : String);
type Close_Repinfo_File_Proc is access procedure;
type Create_Repinfo_File_Proc is access procedure (Src : File_Name_Type);
type Write_Repinfo_Line_Proc is access procedure (Info : String);
type Close_Repinfo_File_Proc is access procedure;
-- Types used for procedure addresses below
Creat_Repinfo_File_Access : Creat_Repinfo_File_Proc := null;
Write_Repinfo_Line_Access : Write_Repinfo_Line_Proc := null;
Close_Repinfo_File_Access : Close_Repinfo_File_Proc := null;
Create_Repinfo_File_Access : Create_Repinfo_File_Proc := null;
Write_Repinfo_Line_Access : Write_Repinfo_Line_Proc := null;
Close_Repinfo_File_Access : Close_Repinfo_File_Proc := null;
-- GNAT
-- These three locations are left null when operating in non-compiler
-- (e.g. ASIS mode), but when operating in compiler mode, they are
-- set to point to the three corresponding procedures in Osint. The
-- set to point to the three corresponding procedures in Osint-C. The
-- reason for this slightly strange interface is to prevent Repinfo
-- from dragging in Osint in ASIS mode, which would include a lot of
-- unwanted units in the ASIS build.
type Create_List_File_Proc is access procedure (S : String);
type Write_List_Info_Proc is access procedure (S : String);
type Close_List_File_Proc is access procedure;
-- Types used for procedure addresses below
Create_List_File_Access : Create_List_File_Proc := null;
Write_List_Info_Access : Write_List_Info_Proc := null;
Close_List_File_Access : Close_List_File_Proc := null;
-- GNAT
-- These three locations are left null when operating in non-compiler
-- (e.g. from the binder), but when operating in compiler mode, they are
-- set to point to the three corresponding procedures in Osint-C. The
-- reason for this slightly strange interface is to prevent Repinfo
-- from dragging in Osint-C in the binder, which would include unwanted
-- units in the binder.
Locking_Policy : Character := ' ';
-- GNAT, GNATBIND
-- Set to ' ' for the default case (no locking policy specified).
......@@ -1070,10 +1110,16 @@ package Opt is
Warn_On_Ada_2005_Compatibility : Boolean := True;
-- GNAT
-- Set to True to active all warnings on Ada 2005 compatibility issues,
-- Set to True to generate all warnings on Ada 2005 compatibility issues,
-- including warnings on Ada 2005 obsolescent features used in Ada 2005
-- mode. Set False by -gnatwY.
Warn_On_Assumed_Low_Bound : Boolean := True;
-- GNAT
-- Set to True to activate warnings for string parameters that are indexed
-- with literals or S'Length, presumably assuming a lower bound of one. Set
-- False by -gnatwW.
Warn_On_Bad_Fixed_Value : Boolean := False;
-- GNAT
-- Set to True to generate warnings for static fixed-point expression
......@@ -1084,6 +1130,12 @@ package Opt is
-- Set to True to generate warnings for variables that could be declared
-- as constants. Modified by use of -gnatwk/K.
Warn_On_Deleted_Code : Boolean := False;
-- GNAT
-- Set to True to generate warnings for code deleted by the front end
-- for conditional statements whose outcome is known at compile time.
-- Modified by use of -gnatwt/T.
Warn_On_Dereference : Boolean := False;
-- GNAT
-- Set to True to generate warnings for implicit dereferences for array
......@@ -1102,7 +1154,8 @@ package Opt is
Warn_On_Modified_Unread : Boolean := False;
-- GNAT
-- Set to True to generate warnings if a variable is assigned but is never
-- read. The default is that this warning is suppressed.
-- read. The default is that this warning is suppressed. Also controls
-- warnings about assignments whose value is never read.
Warn_On_No_Value_Assigned : Boolean := True;
-- GNAT
......@@ -1115,6 +1168,11 @@ package Opt is
-- Set to True to generate warnings on use of any feature in Annex or if a
-- subprogram is called for which a pragma Obsolescent applies.
Warn_On_Questionable_Missing_Parens : Boolean := False;
-- GNAT
-- Set to True to generate warnings for cases where parenthese are missing
-- and the usage is questionable, because the intent is unclear.
Warn_On_Redundant_Constructs : Boolean := False;
-- GNAT
-- Set to True to generate warnings for redundant constructs (e.g. useless
......
gcc/ada/osint-c.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2005 Free Software Foundation, Inc. --
-- Copyright (C) 2001-2006, 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- --
......@@ -43,9 +43,10 @@ package body Osint.C is
function Create_Auxiliary_File
(Src : File_Name_Type;
Suffix : String) return File_Name_Type;
-- Common processing for Creat_Repinfo_File and Create_Debug_File.
-- Src is the file name used to create the required output file and
-- Suffix is the desired suffic (dg/rep for debug/repinfo file).
-- Common processing for Create_List_File, Create_Repinfo_File and
-- Create_Debug_File. Src is the file name used to create the required
-- output file and Suffix is the desired suffic (dg/rep/xxx for debug/
-- repinfo/list file where xxx is specified extension.
procedure Set_Library_Info_Name;
-- Sets a default ali file name from the main compiler source name.
......@@ -70,6 +71,23 @@ package body Osint.C is
end if;
end Close_Debug_File;
---------------------
-- Close_List_File --
---------------------
procedure Close_List_File is
Status : Boolean;
begin
Close (Output_FD, Status);
if not Status then
Fail
("error while closing list file ",
Get_Name_String (Output_File_Name));
end if;
end Close_List_File;
-------------------------------
-- Close_Output_Library_Info --
-------------------------------
......@@ -110,7 +128,7 @@ package body Osint.C is
function Create_Auxiliary_File
(Src : File_Name_Type;
Suffix : String) return File_Name_Type
Suffix : String) return File_Name_Type
is
Result : File_Name_Type;
......@@ -128,13 +146,10 @@ package body Osint.C is
Name_Len := Name_Len + Suffix'Length;
if Output_Object_File_Name /= null then
for Index in reverse Output_Object_File_Name'Range loop
if Output_Object_File_Name (Index) = Directory_Separator then
declare
File_Name : constant String := Name_Buffer (1 .. Name_Len);
begin
Name_Len := Index - Output_Object_File_Name'First + 1;
Name_Buffer (1 .. Name_Len) :=
......@@ -165,6 +180,24 @@ package body Osint.C is
return Create_Auxiliary_File (Src, "dg");
end Create_Debug_File;
----------------------
-- Create_List_File --
----------------------
procedure Create_List_File (S : String) is
F : File_Name_Type;
pragma Warnings (Off, F);
begin
if S (S'First) = '.' then
F := Create_Auxiliary_File (Current_Main, S (S'First + 1 .. S'Last));
else
Name_Buffer (1 .. S'Length) := S;
Name_Len := S'Length + 1;
Name_Buffer (Name_Len) := ASCII.NUL;
Create_File_And_Check (Output_FD, Text);
end if;
end Create_List_File;
--------------------------------
-- Create_Output_Library_Info --
--------------------------------
......@@ -175,17 +208,16 @@ package body Osint.C is
Create_File_And_Check (Output_FD, Text);
end Create_Output_Library_Info;
--------------------------
-- Creat_Repinfo_File --
--------------------------
-------------------------
-- Create_Repinfo_File --
-------------------------
procedure Creat_Repinfo_File (Src : File_Name_Type) is
procedure Create_Repinfo_File (Src : File_Name_Type) is
S : constant File_Name_Type := Create_Auxiliary_File (Src, "rep");
pragma Warnings (Off, S);
begin
return;
end Creat_Repinfo_File;
end Create_Repinfo_File;
---------------------------
-- Debug_File_Eol_Length --
......@@ -412,6 +444,15 @@ package body Osint.C is
procedure Write_Library_Info (Info : String) renames Write_Info;
---------------------
-- Write_List_Info --
---------------------
procedure Write_List_Info (S : String) is
begin
Write_With_Check (S'Address, S'Length);
end Write_List_Info;
------------------------
-- Write_Repinfo_Line --
------------------------
......@@ -419,11 +460,15 @@ package body Osint.C is
procedure Write_Repinfo_Line (Info : String) renames Write_Info;
begin
Adjust_OS_Resource_Limits;
Opt.Creat_Repinfo_File_Access := Creat_Repinfo_File'Access;
Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access;
Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access;
Opt.Create_Repinfo_File_Access := Create_Repinfo_File'Access;
Opt.Write_Repinfo_Line_Access := Write_Repinfo_Line'Access;
Opt.Close_Repinfo_File_Access := Close_Repinfo_File'Access;
Opt.Create_List_File_Access := Create_List_File'Access;
Opt.Write_List_Info_Access := Write_List_Info'Access;
Opt.Close_List_File_Access := Close_List_File'Access;
Set_Program (Compiler);
......
gcc/ada/osint-c.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001 Free Software Foundation, Inc. --
-- Copyright (C) 2001-2006, 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- --
......@@ -91,7 +91,7 @@ package Osint.C is
-- procedures in appropriate variables in Repinfo, so that they can
-- be called indirectly without creating a dependence.
procedure Creat_Repinfo_File (Src : File_Name_Type);
procedure Create_Repinfo_File (Src : File_Name_Type);
-- Given the simple name of a source file, this routine creates the
-- corresponding file to hold representation information
......@@ -139,6 +139,22 @@ package Osint.C is
-- text is returned in Text. If the file does not exist, then Text is
-- set to null.
----------------------
-- List File Output --
----------------------
procedure Create_List_File (S : String);
-- Creates the file whose name is given by S. If the name starts with a
-- period, then the name is xxx & S, where xxx is the name of the main
-- source file without the extension stripped. Information is written to
-- this file using Write_List_File.
procedure Write_List_Info (S : String);
-- Writes given string to the list file created by Create_List_File
procedure Close_List_File;
-- Close file previously opened by Create_List_File
--------------------------------
-- Semantic Tree Input-Output --
--------------------------------
......
gcc/ada/osint.adb
......@@ -82,9 +82,6 @@ package body Osint is
function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type;
-- Convert OS format time to GNAT format time stamp
function Concat (String_One : String; String_Two : String) return String;
-- Concatenates 2 strings and returns the result of the concatenation
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
......@@ -97,13 +94,6 @@ package body Osint is
-- Update the specified path to replace the prefix with the location
-- where GNAT is installed. See the file prefix.c in GCC for details.
procedure Write_With_Check (A : Address; N : Integer);
-- Writes N bytes from buffer starting at address A to file whose FD is
-- stored in Output_FD, and whose file name is stored as a File_Name_Type
-- in Output_File_Name. A check is made for disk full, and if this is
-- detected, the file being written is deleted, and a fatal error is
-- signalled.
function Locate_File
(N : File_Name_Type;
T : File_Type;
......@@ -264,6 +254,7 @@ package body Osint is
function Get_Libraries_From_Registry return String_Ptr;
-- On Windows systems, get the list of installed standard libraries
-- from the registry key:
--
-- HKEY_LOCAL_MACHINE\SOFTWARE\Ada Core Technologies\
-- GNAT\Standard Libraries
-- Return an empty string on other systems
......@@ -302,7 +293,7 @@ package body Osint is
procedure Get_Dirs_From_File (Additional_Source_Dir : Boolean) is
File_FD : File_Descriptor;
Buffer : String (1 .. Path_File_Name'Length + 1);
Buffer : constant String := Path_File_Name.all & ASCII.NUL;
Len : Natural;
Actual_Len : Natural;
S : String_Access;
......@@ -314,11 +305,6 @@ package body Osint is
-- For the call to Close
begin
-- Construct a C compatible character string buffer
Buffer (1 .. Buffer'Last - 1) := Path_File_Name.all;
Buffer (Buffer'Last) := ASCII.NUL;
File_FD := Open_Read (Buffer'Address, Binary);
-- If we cannot open the file, we ignore it, we don't fail
......@@ -384,13 +370,16 @@ package body Osint is
function C_Get_Libraries_From_Registry return Address;
pragma Import (C, C_Get_Libraries_From_Registry,
"__gnat_get_libraries_from_registry");
function Strlen (Str : Address) return Integer;
pragma Import (C, Strlen, "strlen");
procedure Strncpy (X : Address; Y : Address; Length : Integer);
pragma Import (C, Strncpy, "strncpy");
Result_Ptr : Address;
Result_Ptr : Address;
Result_Length : Integer;
Out_String : String_Ptr;
Out_String : String_Ptr;
begin
Result_Ptr := C_Get_Libraries_From_Registry;
......@@ -428,9 +417,9 @@ package body Osint is
-- will handle the expansion as part of the file processing.
for Additional_Source_Dir in False .. True loop
if Additional_Source_Dir then
Search_Path := Getenv (Ada_Include_Path);
if Search_Path'Length > 0 then
if Hostparm.OpenVMS then
Search_Path := To_Canonical_Path_Spec ("ADA_INCLUDE_PATH:");
......@@ -438,8 +427,10 @@ package body Osint is
Search_Path := To_Canonical_Path_Spec (Search_Path.all);
end if;
end if;
else
Search_Path := Getenv (Ada_Objects_Path);
if Search_Path'Length > 0 then
if Hostparm.OpenVMS then
Search_Path := To_Canonical_Path_Spec ("ADA_OBJECTS_PATH:");
......@@ -644,18 +635,6 @@ package body Osint is
end if;
end Canonical_Case_File_Name;
------------
-- Concat --
------------
function Concat (String_One : String; String_Two : String) return String is
Buffer : String (1 .. String_One'Length + String_Two'Length);
begin
Buffer (1 .. String_One'Length) := String_One;
Buffer (String_One'Length + 1 .. Buffer'Last) := String_Two;
return Buffer;
end Concat;
---------------------------
-- Create_File_And_Check --
---------------------------
......@@ -743,23 +722,87 @@ package body Osint is
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;
end if;
if Executable_Extension_On_Target = No_Name then
Exec_Suffix := Get_Target_Executable_Suffix;
else
Get_Name_String (Executable_Extension_On_Target);
Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
end if;
Get_Name_String (Name);
Exec_Suffix := Get_Executable_Suffix;
for J in Exec_Suffix'Range loop
Name_Len := Name_Len + 1;
Name_Buffer (Name_Len) := Exec_Suffix (J);
end loop;
if Exec_Suffix'Length /= 0 then
declare
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.
Canonical_Case_File_Name (Buffer);
-- If the Executable does not end with the executable
-- suffix, add it.
if Buffer'Length <= Exec_Suffix'Length
or else
Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last)
/= Exec_Suffix.all
then
Name_Buffer (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) :=
Exec_Suffix.all;
Name_Len := Name_Len + Exec_Suffix'Length;
Free (Exec_Suffix);
return Name_Find;
end if;
end;
end if;
Free (Exec_Suffix);
return Name;
end Executable_Name;
return Name_Enter;
function Executable_Name (Name : String) return String is
Exec_Suffix : String_Access;
Canonical_Name : String := Name;
begin
if Executable_Extension_On_Target = No_Name then
Exec_Suffix := Get_Target_Executable_Suffix;
else
Get_Name_String (Executable_Extension_On_Target);
Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len));
end if;
declare
Suffix : constant String := Exec_Suffix.all;
begin
Free (Exec_Suffix);
Canonical_Case_File_Name (Canonical_Name);
if Suffix'Length /= 0
and then
(Canonical_Name'Length <= Suffix'Length
or else Canonical_Name (Canonical_Name'Last - Suffix'Length + 1
.. Canonical_Name'Last) /= Suffix)
then
declare
Result : String (1 .. Name'Length + Suffix'Length);
begin
Result (1 .. Name'Length) := Name;
Result (Name'Length + 1 .. Result'Last) := Suffix;
return Result;
end;
else
return Name;
end if;
end;
end Executable_Name;
-----------------------
......@@ -776,19 +819,24 @@ package body Osint is
---------------------
function Get_Install_Dir (Exec : String) return String_Ptr is
Full_Path : constant String := Normalize_Pathname (Exec);
-- Use the full path, so that we find "lib" or "bin", even when
-- the tool has been invoked with a relative path, as in
-- "./gnatls -v" invoked in the GNAT bin directory.
begin
for J in reverse Exec'Range loop
if Is_Directory_Separator (Exec (J)) then
if J < Exec'Last - 5 then
if (To_Lower (Exec (J + 1)) = 'l'
and then To_Lower (Exec (J + 2)) = 'i'
and then To_Lower (Exec (J + 3)) = 'b')
for J in reverse Full_Path'Range loop
if Is_Directory_Separator (Full_Path (J)) then
if J < Full_Path'Last - 5 then
if (To_Lower (Full_Path (J + 1)) = 'l'
and then To_Lower (Full_Path (J + 2)) = 'i'
and then To_Lower (Full_Path (J + 3)) = 'b')
or else
(To_Lower (Exec (J + 1)) = 'b'
and then To_Lower (Exec (J + 2)) = 'i'
and then To_Lower (Exec (J + 3)) = 'n')
(To_Lower (Full_Path (J + 1)) = 'b'
and then To_Lower (Full_Path (J + 2)) = 'i'
and then To_Lower (Full_Path (J + 3)) = 'n')
then
return new String'(Exec (Exec'First .. J));
return new String'(Full_Path (Full_Path'First .. J));
end if;
end if;
end if;
......@@ -1207,8 +1255,8 @@ package body Osint is
-- so that we can directly append a file to the directory
if Search_Dir (Search_Dir'Last) /= Directory_Separator then
Local_Search_Dir := new String'
(Concat (Search_Dir, String'(1 => Directory_Separator)));
Local_Search_Dir :=
new String'(Search_Dir & String'(1 => Directory_Separator));
else
Local_Search_Dir := new String'(Search_Dir);
end if;
......@@ -1232,8 +1280,8 @@ package body Osint is
:= Read_Default_Search_Dirs (Norm_Search_Dir,
Search_File,
null);
Default_Search_Dir := new String'
(Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all));
Default_Search_Dir :=
new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
Free (Norm_Search_Dir);
if Result_Search_Dir /= null then
......@@ -1265,14 +1313,13 @@ package body Osint is
end;
Norm_Search_Dir :=
new String'(Concat (Current_Dir.all, Local_Search_Dir.all));
new String'(Current_Dir.all & Local_Search_Dir.all);
Result_Search_Dir :=
Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
Default_Search_Dir :=
new String'
(Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all));
new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
Free (Norm_Search_Dir);
......@@ -1287,15 +1334,13 @@ package body Osint is
Norm_Search_Dir :=
new String'
(Concat (Update_Path (Search_Dir_Prefix).all,
Local_Search_Dir.all));
(Update_Path (Search_Dir_Prefix).all & Local_Search_Dir.all);
Result_Search_Dir :=
Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
Default_Search_Dir :=
new String'
(Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all));
new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
Free (Norm_Search_Dir);
......@@ -1309,18 +1354,16 @@ package body Osint is
-- We finally search in Search_Dir_Prefix/rts-Search_Dir
Temp_String :=
new String'
(Concat (Update_Path (Search_Dir_Prefix).all, "rts-"));
new String'(Update_Path (Search_Dir_Prefix).all & "rts-");
Norm_Search_Dir :=
new String'(Concat (Temp_String.all, Local_Search_Dir.all));
new String'(Temp_String.all & Local_Search_Dir.all);
Result_Search_Dir :=
Read_Default_Search_Dirs (Norm_Search_Dir, Search_File, null);
Default_Search_Dir :=
new String'
(Concat (Norm_Search_Dir.all, Default_Suffix_Dir.all));
new String'(Norm_Search_Dir.all & Default_Suffix_Dir.all);
Free (Norm_Search_Dir);
if Result_Search_Dir /= null then
......@@ -1720,7 +1763,7 @@ package body Osint is
-- spawn routines. This ensure that quotes will be added when needed.
Result := new String (1 .. Directory'Length - 1);
Result (1 .. Directory'Length - 1) :=
Result (1 .. Directory'Length - 2) :=
Directory (Directory'First + 1 .. Directory'Last - 1);
Result (Result'Last) := Directory_Separator;
......
gcc/ada/osint.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2006 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- --
......@@ -24,9 +24,8 @@
-- --
------------------------------------------------------------------------------
-- This package contains the low level, operating system routines used in
-- the GNAT compiler and binder for command line processing and file input
-- output.
-- 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;
......@@ -37,9 +36,9 @@ pragma Elaborate (GNAT.OS_Lib);
package Osint is
Multi_Unit_Index_Character : Character := '~';
-- The character before the index of the unit in a multi-unit source,
-- in ALI and object file names. This is not a constant, because it is
-- changed to '$' on VMS.
-- The character before the index of the unit in a multi-unit source, in
-- ALI and object file names. This is not a constant, because it is changed
-- to '$' on VMS.
Ada_Include_Path : constant String := "ADA_INCLUDE_PATH";
Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH";
......@@ -59,18 +58,17 @@ package Osint is
function Find_File
(N : File_Name_Type;
T : File_Type) return File_Name_Type;
-- Finds a source, library or config file depending on the value
-- of T following the directory search order rules unless N is the
-- name of the file just read with Next_Main_File and already
-- contains directiory information, in which case just look in the
-- Primary_Directory. Returns File_Name_Type of the full file name
-- if found, No_File if file not found. Note that for the special
-- case of gnat.adc, only the compilation environment directory is
-- searched, i.e. the directory where the ali and object files are
-- written. Another special case is when Debug_Generated_Code is
-- set and the file name ends on ".dg", in which case we look for
-- the generated file only in the current directory, since that is
-- where it is always built.
-- Finds a source, library or config file depending on the value of T
-- following the directory search order rules unless N is the name of the
-- file just read with Next_Main_File and already contains directiory
-- information, in which case just look in the Primary_Directory. Returns
-- File_Name_Type of the full file name if found, No_File if file not
-- found. Note that for the special case of gnat.adc, only the compilation
-- environment directory is searched, i.e. the directory where the ali and
-- object files are written. Another special case is Debug_Generated_Code
-- set and the file name ends on ".dg", in which case we look for the
-- generated file only in the current directory, since that is where it is
-- always built.
function Get_File_Names_Case_Sensitive return Int;
pragma Import (C, Get_File_Names_Case_Sensitive,
......@@ -147,6 +145,9 @@ package Osint is
-- instance under DOS it adds the ".exe" suffix, whereas under UNIX no
-- suffix is added.
function Executable_Name (Name : String) return String;
-- 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
......@@ -374,14 +375,14 @@ package Osint is
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
-- 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 source file directory lookup penalty is incurred
-- every single time the routines are called unless you have previously
-- called Source_File_Data (Cache => True). See below.
-- 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.
-- The source file directory lookup penalty is incurred every single time
-- the routines are called unless you have previously called
-- Source_File_Data (Cache => True). See below.
function Current_File_Index return Int;
-- Return the index in its source file of the current main unit
......@@ -389,9 +390,9 @@ package Osint is
function Matching_Full_Source_Name
(N : File_Name_Type;
T : Time_Stamp_Type) return File_Name_Type;
-- Same semantics than Full_Source_Name but will search on the source
-- path until a source file with time stamp matching T is found. If
-- none is found returns No_File.
-- Same semantics than Full_Source_Name but will search on the source path
-- until a source file with time stamp matching T is found. If none is
-- found returns No_File.
procedure Source_File_Data (Cache : Boolean);
-- By default source file data (full source file name and time stamp)
......@@ -433,7 +434,9 @@ package Osint is
-- Which of these three methods is chosen depends on the constraints of the
-- host operating system. The interface described here is independent of
-- which of these approaches is used.
-- which of these approaches is used. Currently all versions of GNAT use
-- the third approach with a file name of xxx.ali where xxx is the source
-- file name.
-------------------------------
-- Library Information Input --
......@@ -523,9 +526,9 @@ package Osint is
procedure Exit_Program (Exit_Code : Exit_Code_Type);
pragma No_Return (Exit_Program);
-- A call to Exit_Program terminates execution with the given status.
-- A status of zero indicates normal completion, a non-zero status
-- indicates abnormal termination.
-- A call to Exit_Program terminates execution with the given status. A
-- status of zero indicates normal completion, a non-zero status indicates
-- abnormal termination.
-------------------------
-- Command Line Access --
......@@ -562,7 +565,7 @@ private
-- The suffix used for the target object files
Output_FD : File_Descriptor;
-- The file descriptor for the current library info, tree or binder output
-- File descriptor for current library info, list, tree, or binder output
Output_File_Name : File_Name_Type;
-- File_Name_Type for name of open file whose FD is in Output_FD, the name
......@@ -575,10 +578,10 @@ private
type File_Name_Array_Ptr is access File_Name_Array;
File_Names : File_Name_Array_Ptr :=
new File_Name_Array (1 .. Int (Argument_Count) + 2);
-- As arguments are scanned, file names are stored in this array
-- The strings do not have terminating NUL files. The array is
-- extensible, because when using project files, there may be
-- more files than arguments on the command line.
-- As arguments are scanned, file names are stored in this array The
-- strings do not have terminating NUL files. The array is extensible,
-- because when using project files, there may be more files than
-- arguments on the command line.
type File_Index_Array is array (Int range <>) of Int;
type File_Index_Array_Ptr is access File_Index_Array;
......@@ -594,17 +597,17 @@ private
(Fdesc : out File_Descriptor;
Fmode : Mode);
-- Create file whose name (NUL terminated) is in Name_Buffer (with the
-- 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 (see description
-- 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).
type Program_Type is (Compiler, Binder, Make, Gnatls, Unspecified);
-- Program currently running
procedure Set_Program (P : Program_Type);
-- Indicates to the body of Osint the program currently running.
-- This procedure is called by the child packages of Osint.
-- A check is made that this procedure is not called several times.
-- Indicates to the body of Osint the program currently running. This
-- procedure is called by the child packages of Osint. A check is made
-- that this procedure is not called more than once.
function More_Files return Boolean;
-- Implements More_Source_Files and More_Lib_Files
......@@ -613,14 +616,20 @@ private
-- Implements Next_Main_Source and Next_Main_Lib_File
function Object_File_Name (N : File_Name_Type) return File_Name_Type;
-- Constructs the name of the object file corresponding to library
-- file N. If N is a full file name than the returned file name will
-- also be a full file name. Note that no lookup in the library file
-- directories is done for this file. This routine merely constructs
-- the name.
-- Constructs the name of the object file corresponding to library file N.
-- If N is a full file name than the returned file name will also be a full
-- file name. Note that no lookup in the library file directories is done
-- for this file. This routine merely constructs the name.
procedure Write_Info (Info : String);
-- Implementation of Write_Binder_Info, Write_Debug_Info and
-- Write_Library_Info (identical)
procedure Write_With_Check (A : Address; N : Integer);
-- Writes N bytes from buffer starting at address A to file whose FD is
-- stored in Output_FD, and whose file name is stored as a File_Name_Type
-- in Output_File_Name. A check is made for disk full, and if this is
-- detected, the file being written is deleted, and a fatal error is
-- signalled.
end Osint;
gcc/ada/switch-c.adb
......@@ -498,6 +498,7 @@ package body Switch.C is
Constant_Condition_Warnings := True;
Implementation_Unit_Warnings := True;
Ineffective_Inline_Warnings := True;
Warn_On_Assumed_Low_Bound := True;
Warn_On_Bad_Fixed_Value := True;
Warn_On_Constant := True;
Warn_On_Export_Import := True;
......@@ -553,6 +554,19 @@ package body Switch.C is
Bad_Switch (C);
end if;
-- Processing for j switch
when 'j' =>
Ptr := Ptr + 1;
-- There may be an equal sign between -gnatj and the value
if Ptr <= Max and then Switch_Chars (Ptr) = '=' then
Ptr := Ptr + 1;
end if;
Scan_Nat (Switch_Chars, Max, Ptr, Error_Msg_Line_Length, C);
-- Processing for k switch
when 'k' =>
......@@ -566,12 +580,23 @@ package body Switch.C is
Ptr := Ptr + 1;
Full_List := True;
-- There may be an equal sign between -gnatl and a file name
if Ptr <= Max and then Switch_Chars (Ptr) = '=' then
if Ptr = Max then
Osint.Fail ("file name for -gnatl= is null");
else
Opt.Full_List_File_Name :=
new String'(Switch_Chars (Ptr + 1 .. Max));
Ptr := Max + 1;
end if;
end if;
-- Processing for L switch
when 'L' =>
Ptr := Ptr + 1;
Osint.Fail
("-gnatL is no longer supported: consider using --RTS=sjlj");
Dump_Source_Text := True;
-- Processing for m switch
......@@ -584,7 +609,7 @@ package body Switch.C is
Ptr := Ptr + 1;
end if;
Scan_Pos (Switch_Chars, Max, Ptr, Maximum_Errors, C);
Scan_Nat (Switch_Chars, Max, Ptr, Maximum_Errors, C);
-- Processing for n switch
......@@ -805,15 +830,13 @@ package body Switch.C is
Bad_Switch (C);
end if;
for J in WC_Encoding_Method loop
if Switch_Chars (Ptr) = WC_Encoding_Letters (J) then
Wide_Character_Encoding_Method := J;
exit;
elsif J = WC_Encoding_Method'Last then
begin
Wide_Character_Encoding_Method :=
Get_WC_Encoding_Method (Switch_Chars (Ptr));
exception
when Constraint_Error =>
Bad_Switch (C);
end if;
end loop;
end;
Upper_Half_Encoding :=
Wide_Character_Encoding_Method in
......@@ -856,15 +879,9 @@ package body Switch.C is
(Switch_Chars (Ptr .. Max), OK, Ptr);
if not OK then
declare
R : String (1 .. Style_Msg_Len + 20);
begin
R (1 .. 19) := "bad -gnaty switch (";
R (20 .. R'Last - 1) :=
Style_Msg_Buf (1 .. Style_Msg_Len);
R (R'Last) := ')';
Osint.Fail (R);
end;
Osint.Fail
("bad -gnaty switch (" &
Style_Msg_Buf (1 .. Style_Msg_Len) & ')');
end if;
Ptr := First_Char + 1;
......
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