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;