[Ada] New switch -gnatl=xxx
Arnaud Charlet
charlet@adacore.com
Tue Oct 31 19:55:00 GMT 2006
Tested on i686-linux, committed on trunk.
This patch implements a new feature allowing full listing output to
be directed to a file. This is achieved with the switch -gnatl=xxx
where xxx is either a file name, or an extension starting with period.
In the latter case the output is to filename.extension (or in the
case of VMS, filename_extension).
If the following program is compiled with -gnatl=.lst -gnatd7
procedure h is
begin
null
end;
Then the output in file h.adb.lst is to:
GNAT 4.3.0 20061030 (experimental)
Copyright 1992-2006, Free Software Foundation, Inc.
Compiling: h.adb
1. procedure h is
2. begin
3. null
|
>>> missing ";"
4. end;
4 lines: 1 error
This patch also changes the behavior of -gnatl.
The listing now includes not only the main source
but all source files in the extended main source unit (including
the package spec and all subunits).
An example of the patch in action is the following listing from
compiling p.adb with the switch -gnatld7
Compiling: p.adb
1. package body p is
2. procedure a;
3. procedure a is separate;
4. begin
5. null
|
>>> missing ";"
6. end;
Compiling: p.ads
1. package p is
2. pragma Elaborate_Body
|
>>> missing ";"
3. end p;
Compiling: p-a.adb
1. separate p
|
>>> missing "("
2. procedure a is
3. begin
4. null
|
>>> missing ";"
5. end;
6 lines: 4 errors
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
-------------- next part --------------
Index: errout.ads
===================================================================
--- errout.ads (revision 118179)
+++ errout.ads (working copy)
@@ -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
Index: errout.adb
===================================================================
--- errout.adb (revision 118179)
+++ errout.adb (working copy)
@@ -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;
+ -- Output to file
- -- Then output errors, if any, for subsidiary units
+ else
+ Create_List_File_Access.all (Full_List_File_Name.all);
+ Set_Special_Output (Write_List_Info_Access.all'Access);
- 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;
+ -- Write copyright notice to file
- -- Verbose mode (error lines only with error flags)
+ 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;
- if Verbose_Mode and not Full_List then
- E := First_Error_Msg;
+ -- First list extended main source file units with errors
- -- Loop through error lines
+ -- Note: if debug flag d.m is set, only the main source is listed
- 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;
+ 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);
- -- Output error summary if verbose or full list mode
+ begin
+ Write_Eol;
+ Write_Header (Sfile);
+ Write_Eol;
- if Verbose_Mode or else Full_List then
+ -- 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.
- -- Extra blank line if error messages or source listing were output
+ 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
Index: frontend.adb
===================================================================
--- frontend.adb (revision 118179)
+++ frontend.adb (working copy)
@@ -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).
Index: gnat1drv.adb
===================================================================
--- gnat1drv.adb (revision 118179)
+++ gnat1drv.adb (working copy)
@@ -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 ");
Index: opt.ads
===================================================================
--- opt.ads (revision 118179)
+++ opt.ads (working copy)
@@ -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
Index: osint.ads
===================================================================
--- osint.ads (revision 118179)
+++ osint.ads (working copy)
@@ -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;
Index: osint.adb
===================================================================
--- osint.adb (revision 118179)
+++ osint.adb (working copy)
@@ -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;
Index: osint-c.ads
===================================================================
--- osint-c.ads (revision 118179)
+++ osint-c.ads (working copy)
@@ -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 --
--------------------------------
Index: osint-c.adb
===================================================================
--- osint-c.adb (revision 118179)
+++ osint-c.adb (working copy)
@@ -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);
Index: switch-c.adb
===================================================================
--- switch-c.adb (revision 118179)
+++ switch-c.adb (working copy)
@@ -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;
More information about the Gcc-patches
mailing list