-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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 Output; use Output;
with Scans; use Scans;
+with Sem_Aux; use Sem_Aux;
with Sinput; use Sinput;
with Sinfo; use Sinfo;
with Snames; use Snames;
Error_Msg_Sloc := Flag_Location;
X := Get_Source_File_Index (Flag_Location);
-
while Instantiation (X) /= No_Location loop
-- Suppress instantiation message on continuation lines
Error_Msg_Internal
("?in inlined body #",
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
-
else
Error_Msg_Internal
("error in inlined body #",
Error_Msg_Internal
("?in instantiation #",
Actual_Error_Loc, Flag_Location, Msg_Cont_Status);
-
else
Error_Msg_Internal
("instantiation error #",
Configurable_Run_Time_Violations := Configurable_Run_Time_Violations + 1;
end Error_Msg_CRT;
+ ------------------
+ -- Error_Msg_PT --
+ ------------------
+
+ procedure Error_Msg_PT (Typ : Node_Id; Subp : Node_Id) is
+ begin
+ -- Error message below needs rewording (remember comma in -gnatj
+ -- mode) ???
+
+ Error_Msg_NE
+ ("first formal of & must be of mode `OUT`, `IN OUT` or " &
+ "access-to-variable", Typ, Subp);
+ Error_Msg_N
+ ("\in order to be overridden by protected procedure or entry " &
+ "(RM 9.4(11.9/2))", Typ);
+ end Error_Msg_PT;
+
-----------------
-- Error_Msg_F --
-----------------
if In_Extended_Main_Source_Unit (Sptr) then
null;
+ -- If the main unit has not been read yet. the warning must be on
+ -- a configuration file: gnat.adc or user-defined. This means we
+ -- are not parsing the main unit yet, so skip following checks.
+
+ elsif No (Cunit (Main_Unit)) then
+ null;
+
-- 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.
Errors.Append
((Text => new String'(Msg_Buffer (1 .. Msglen)),
Next => No_Error_Msg,
+ Prev => No_Error_Msg,
Sptr => Sptr,
Optr => Optr,
Sfile => Get_Source_File_Index (Sptr),
Nxt : Error_Msg_Id;
F : Error_Msg_Id;
+ procedure Delete_Warning (E : Error_Msg_Id);
+ -- Delete a message if not already deleted and adjust warning count
+
+ --------------------
+ -- Delete_Warning --
+ --------------------
+
+ procedure Delete_Warning (E : Error_Msg_Id) is
+ begin
+ if not Errors.Table (E).Deleted then
+ Errors.Table (E).Deleted := True;
+ Warnings_Detected := Warnings_Detected - 1;
+ end if;
+ end Delete_Warning;
+
+ -- Start of message for Finalize
+
begin
+ -- Set Prev pointers
+
+ Cur := First_Error_Msg;
+ while Cur /= No_Error_Msg loop
+ Nxt := Errors.Table (Cur).Next;
+ exit when Nxt = No_Error_Msg;
+ Errors.Table (Nxt).Prev := Cur;
+ Cur := Nxt;
+ end loop;
+
-- Eliminate any duplicated error messages from the list. This is
-- done after the fact to avoid problems with Change_Error_Text.
Cur := First_Error_Msg;
while Cur /= No_Error_Msg loop
- if not Errors.Table (Cur).Deleted
- and then Warning_Specifically_Suppressed
- (Errors.Table (Cur).Sptr,
- Errors.Table (Cur).Text)
- then
- Errors.Table (Cur).Deleted := True;
- Warnings_Detected := Warnings_Detected - 1;
- end if;
+ declare
+ CE : Error_Msg_Object renames Errors.Table (Cur);
+
+ begin
+ if not CE.Deleted
+ and then
+ (Warning_Specifically_Suppressed (CE.Sptr, CE.Text)
+ or else
+ Warning_Specifically_Suppressed (CE.Optr, CE.Text))
+ then
+ Delete_Warning (Cur);
+
+ -- If this is a continuation, delete previous messages
+
+ F := Cur;
+ while Errors.Table (F).Msg_Cont loop
+ F := Errors.Table (F).Prev;
+ Delete_Warning (F);
+ end loop;
+
+ -- Delete any following continuations
+
+ F := Cur;
+ loop
+ F := Errors.Table (F).Next;
+ exit when F = No_Error_Msg;
+ exit when not Errors.Table (F).Msg_Cont;
+ Delete_Warning (F);
+ end loop;
+ end if;
+ end;
Cur := Errors.Table (Cur).Next;
end loop;
----------------
function First_Node (C : Node_Id) return Node_Id is
- L : constant Source_Ptr := Sloc (Original_Node (C));
- Sfile : constant Source_File_Index := Get_Source_File_Index (L);
+ Orig : constant Node_Id := Original_Node (C);
+ Loc : constant Source_Ptr := Sloc (Orig);
+ Sfile : constant Source_File_Index := Get_Source_File_Index (Loc);
Earliest : Node_Id;
Eloc : Source_Ptr;
------------------
function Test_Earlier (N : Node_Id) return Traverse_Result is
- Loc : constant Source_Ptr := Sloc (Original_Node (N));
+ Norig : constant Node_Id := Original_Node (N);
+ Loc : constant Source_Ptr := Sloc (Norig);
begin
- -- Check for earlier. The tests for being in the same file ensures
- -- against strange cases of foreign code somehow being present. We
- -- don't want wild placement of messages if that happens, so it is
- -- best to just ignore this situation.
+ -- Check for earlier
if Loc < Eloc
+
+ -- Ignore nodes with no useful location information
+
+ and then Loc /= Standard_Location
+ and then Loc /= No_Location
+
+ -- Ignore nodes from a different file. This ensures against cases
+ -- of strange foreign code somehow being present. We don't want
+ -- wild placement of messages if that happens.
+
and then Get_Source_File_Index (Loc) = Sfile
then
- Earliest := Original_Node (N);
+ Earliest := Norig;
Eloc := Loc;
end if;
-- Start of processing for First_Node
begin
- Earliest := Original_Node (C);
- Eloc := Sloc (Earliest);
- Search_Tree_First (Original_Node (C));
- return Earliest;
+ if Nkind (Orig) in N_Subexpr then
+ Earliest := Orig;
+ Eloc := Loc;
+ Search_Tree_First (Orig);
+ return Earliest;
+
+ else
+ return Orig;
+ end if;
end First_Node;
----------------
-- if the loop does not exit, then the desired case will be left set to
-- Mixed_Case, this can happen if the name was not in canonical form,
-- and gets canonicalized on VMS. Possibly we could fix this by
- -- unconditinally canonicalizing these names ???
+ -- unconditionally canonicalizing these names ???
for J in 1 .. Last_Source_File loop
Get_Name_String (Full_Debug_Name (J));
-- in case, which is the case when we can copy from the source.
declare
- Src_Loc : constant Source_Ptr := Sloc (Error_Msg_Node_1);
+ Src_Loc : constant Source_Ptr := Sloc (Node);
Sbuffer : Source_Buffer_Ptr;
Ref_Ptr : Integer;
Src_Ptr : Source_Ptr;
if P <= Text'Last and then Text (P) = '$' then
P := P + 1;
Set_Msg_Insertion_Unit_Name (Suffix => False);
-
else
Set_Msg_Insertion_Unit_Name;
end if;
elsif Msg = "size for& too small, minimum allowed is ^" then
- -- Suppress "size too small" errors in CodePeer mode, since pragma
- -- Pack is also ignored in this configuration.
+ -- Suppress "size too small" errors in CodePeer mode and Alfa mode,
+ -- since pragma Pack is also ignored in these configurations.
- if CodePeer_Mode then
+ if CodePeer_Mode or Alfa_Mode then
return True;
-- When a size is wrong for a frozen type there is no explicit size
-- "type derived from" message more than once in the case where we climb
-- up multiple levels.
- loop
+ Find : loop
Old_Ent := Ent;
-- Implicit access type, use directly designated type In Ada 2005,
Set_Msg_Str ("access to procedure ");
end if;
- exit;
+ exit Find;
-- Type is access to object, named or anonymous
-- itself an internal name. This avoids the obvious loop (subtype ->
-- basetype -> subtype) which would otherwise occur!)
- elsif Present (Freeze_Node (Ent))
- and then Present (First_Subtype_Link (Freeze_Node (Ent)))
- and then
- not Is_Internal_Name
- (Chars (First_Subtype_Link (Freeze_Node (Ent))))
- then
- Ent := First_Subtype_Link (Freeze_Node (Ent));
+ else
+ declare
+ FST : constant Entity_Id := First_Subtype (Ent);
- -- Otherwise use root type
+ begin
+ if not Is_Internal_Name (Chars (FST)) then
+ Ent := FST;
+ exit Find;
- else
- if not Derived then
- Buffer_Remove ("type ");
+ -- Otherwise use root type
- -- Test for "subtype of type derived from" which seems
- -- excessive and is replaced by simply "type derived from"
+ else
+ if not Derived then
+ Buffer_Remove ("type ");
- Buffer_Remove ("subtype of");
+ -- Test for "subtype of type derived from" which seems
+ -- excessive and is replaced by "type derived from".
- -- Avoid duplication "type derived from type derived from"
+ Buffer_Remove ("subtype of");
- if not Buffer_Ends_With ("type derived from ") then
- Set_Msg_Str ("type derived from ");
- end if;
+ -- Avoid duplicated "type derived from type derived from"
- Derived := True;
- end if;
+ if not Buffer_Ends_With ("type derived from ") then
+ Set_Msg_Str ("type derived from ");
+ end if;
+
+ Derived := True;
+ end if;
+ end if;
+ end;
Ent := Etype (Ent);
end if;
-- If we are stuck in a loop, get out and settle for the internal
- -- name after all. In this case we set to kill the message if it
- -- is not the first error message (we really try hard not to show
- -- the dirty laundry of the implementation to the poor user!)
+ -- name after all. In this case we set to kill the message if it is
+ -- not the first error message (we really try hard not to show the
+ -- dirty laundry of the implementation to the poor user!)
if Ent = Old_Ent then
Kill_Message := True;
- exit;
+ exit Find;
end if;
-- Get out if we finally found a non-internal name to use
- exit when not Is_Internal_Name (Chars (Ent));
- end loop;
+ exit Find when not Is_Internal_Name (Chars (Ent));
+ end loop Find;
if Mchar = '"' then
Set_Msg_Char ('"');
OSDN Git Service
