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;
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);
end if;
Continuation := Msg_Cont;
+ Continuation_New_Line := False;
Suppress_Message := False;
Kill_Message := False;
Set_Msg_Text (Msg, Sptr);
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
else
Cur_Msg := No_Error_Msg;
+
+ if not Continuation then
+ Last_Killed := True;
+ end if;
+
return;
end if;
end if;
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;
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;
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);
-- 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 =
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
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;
if Total_Errors_Detected + Warnings_Detected = Maximum_Errors then
raise Unrecoverable_Error;
end if;
-
end Error_Msg_Internal;
-----------------
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
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
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;
----------------
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;
------------------
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
if Loc < Eloc
and then Get_Source_File_Index (Loc) = Sfile
then
- Earliest := N;
+ Earliest := Original_Node (N);
Eloc := Loc;
end if;
-- an initial dummy entry covering all possible source locations.
Warnings.Init;
+ Specific_Warnings.Init;
if Warning_Mode = Suppress then
Warnings.Increment_Last;
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
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);
when '\' =>
Continuation := True;
+ if Text (P) = '\' then
+ Continuation_New_Line := True;
+ P := P + 1;
+ end if;
+
when '@' =>
Set_Msg_Insertion_Column;
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' =>
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
-- 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
-- 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
-- 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.
-- 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
-- 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 --
----------------------------------------
-- 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 --
-----------------------------------------------------
-- 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
-- --
-- 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- --
with Nlists; use Nlists;
with Opt; use Opt;
with Osint;
-with Output; use Output;
with Par;
with Prepcomp;
with Rtsfind;
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).
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 ");
-- 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
-- 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
-- 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
-- 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
-- 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");
-- 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).
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
-- 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
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
-- 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
-- --
-- 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- --
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.
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 --
-------------------------------
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;
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) :=
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 --
--------------------------------
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 --
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 --
------------------------
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);
-- --
-- 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- --
-- 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
-- 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 --
--------------------------------
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
-- 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;
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
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;
-- 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
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;
-- 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:");
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:");
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 --
---------------------------
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;
-----------------------
---------------------
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;
-- 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;
:= 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
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);
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);
-- 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
-- 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;
-- --
-- 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- --
-- --
------------------------------------------------------------------------------
--- 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;
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";
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,
-- 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
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
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)
-- 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 --
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 --
-- 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
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;
(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
-- 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;
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;
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' =>
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
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
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
(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;
OSDN Git Service
