-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2013, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
-- Do not add any dependency to GNARL packages since this package is used
-- in both normal and restricted (ravenscar) environments.
+with System.Address_Image;
with System.CRTL;
with System.Task_Primitives;
with System.Task_Primitives.Operations;
-with Ada.Unchecked_Conversion;
package body System.Tasking.Debug is
package STPO renames System.Task_Primitives.Operations;
- function To_Integer is new
- Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address);
-
type Trace_Flag_Set is array (Character) of Boolean;
Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True);
+ Stderr_Fd : constant := 2;
+ -- File descriptor for standard error
+
-----------------------
-- Local Subprograms --
-----------------------
procedure Write (Fd : Integer; S : String; Count : Integer);
+ -- Write Count characters of S to the file descriptor Fd
procedure Put (S : String);
- -- Display S on standard output
+ -- Display S on standard error
procedure Put_Line (S : String := "");
- -- Display S on standard output with an additional line terminator
+ -- Display S on standard error with an additional line terminator
+
+ function Task_Image (T : Task_Id) return String;
+ -- Return the relevant characters from T.Common.Task_Image
+
+ function Task_Id_Image (T : Task_Id) return String;
+ -- Return the address in hexadecimal form
------------------------
-- Continue_All_Tasks --
return;
end if;
- Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len) & ": " &
- Task_States'Image (T.Common.State));
-
+ Put (Task_Image (T) & ": " & Task_States'Image (T.Common.State));
Parent := T.Common.Parent;
if Parent = null then
Put (", parent: <none>");
else
- Put (", parent: " &
- Parent.Common.Task_Image (1 .. Parent.Common.Task_Image_Len));
+ Put (", parent: " & Task_Image (Parent));
end if;
Put (", prio:" & T.Common.Current_Priority'Img);
Put (", serving:");
while Entry_Call /= null loop
- Put (To_Integer (Entry_Call.Self)'Img);
+ Put (Task_Id_Image (Entry_Call.Self));
Entry_Call := Entry_Call.Acceptor_Prev_Call;
end loop;
end if;
procedure Put (S : String) is
begin
- Write (2, S, S'Length);
+ Write (Stderr_Fd, S, S'Length);
end Put;
--------------
procedure Put_Line (S : String := "") is
begin
- Write (2, S & ASCII.LF, S'Length + 1);
+ Write (Stderr_Fd, S & ASCII.LF, S'Length + 1);
end Put_Line;
----------------------
null;
end Task_Creation_Hook;
+ ----------------
+ -- Task_Id_Image --
+ ----------------
+
+ function Task_Id_Image (T : Task_Id) return String is
+ begin
+ if T = null then
+ return "Null_Task_Id";
+ else
+ return Address_Image (T.all'Address);
+ end if;
+ end Task_Id_Image;
+
+ ----------------
+ -- Task_Image --
+ ----------------
+
+ function Task_Image (T : Task_Id) return String is
+ begin
+ -- In case T.Common.Task_Image_Len is uninitialized junk, we check that
+ -- it is in range, to make this more robust.
+
+ if T.Common.Task_Image_Len in T.Common.Task_Image'Range then
+ return T.Common.Task_Image (1 .. T.Common.Task_Image_Len);
+ else
+ return T.Common.Task_Image;
+ end if;
+ end Task_Image;
+
---------------------------
-- Task_Termination_Hook --
---------------------------
is
begin
if Trace_On (Flag) then
- Put (To_Integer (Self_Id)'Img &
+ Put (Task_Id_Image (Self_Id) &
':' & Flag & ':' &
- Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len) &
+ Task_Image (Self_Id) &
':');
if Other_Id /= null then
- Put (To_Integer (Other_Id)'Img & ':');
+ Put (Task_Id_Image (Other_Id) & ':');
end if;
Put_Line (Msg);
Discard : System.CRTL.ssize_t;
pragma Unreferenced (Discard);
begin
- Discard := System.CRTL.write (Fd, S (S'First)'Address,
+ Discard := System.CRTL.write (Fd, S'Address,
System.CRTL.size_t (Count));
- -- Is it really right to ignore write errors here ???
+ -- Ignore write errors here; this is just debugging output, and there's
+ -- nothing to be done about errors anyway.
end Write;
end System.Tasking.Debug;
("cannot mention state & in global refinement",
Item, Item_Id);
Error_Msg_N
- ("\\use its constituents instead", Item);
+ ("\use its constituents instead", Item);
return;
-- If the reference to the abstract state appears in
Error_Msg_Name_1 := Chars (Subp_Id);
Error_Msg_NE
- ("\\& is not part of the input or output set of subprogram %",
+ ("\& is not part of the input or output set of subprogram %",
Item, Item_Id);
-- The mode of the item and its role in pragma [Refined_]Depends
Error_Msg_NE
("cannot mention state & in global refinement",
Item, Item_Id);
- Error_Msg_N ("\\use its constituents instead", Item);
+ Error_Msg_N ("\use its constituents instead", Item);
return;
-- If the reference to the abstract state appears in an
("global item & cannot have mode In_Out or Output",
Item, Item_Id);
Error_Msg_NE
- ("\\item already appears as input of subprogram &",
+ ("\item already appears as input of subprogram &",
Item, Context);
-- Stop the traversal once an error has been detected
& "(SPARK RM 7.2.6(5))", Indic);
Error_Msg_Name_1 := Chars (Scope (State_Id));
Error_Msg_NE
- ("\\& is not part of the hidden state of package %",
+ ("\& is not part of the hidden state of package %",
Indic, Item_Id);
-- The item appears in the visible state space of some package. In
Error_Msg_N
("indicator Part_Of must denote an abstract state of "
& "parent unit or descendant (SPARK RM 7.2.6(3))", Indic);
+
+ -- If the unit is a public child of a private unit it cannot
+ -- refine the state of a private parent, only that of a
+ -- public ancestor or descendant thereof.
+
+ elsif not Private_Present
+ (Parent (Unit_Declaration_Node (Pack_Id)))
+ and then Is_Private_Descendant (Scope (State_Id))
+ then
+ Error_Msg_N
+ ("indicator Part_Of must denote the abstract state of "
+ & "a public ancestor", State);
end if;
-- Indicator Part_Of is not needed when the related package is not
& "RM 7.2.6(5))", Indic);
Error_Msg_Name_1 := Chars (Pack_Id);
Error_Msg_NE
- ("\\& is declared in the visible part of package %",
+ ("\& is declared in the visible part of package %",
Indic, Item_Id);
end if;
& "package & (SPARK RM 7.2.6(2))", Indic, Pack_Id);
Error_Msg_Name_1 := Chars (Pack_Id);
Error_Msg_NE
- ("\\& is declared in the private part of package %",
+ ("\& is declared in the private part of package %",
Indic, Item_Id);
end if;
if Scope (State_Id) = Pack_Id then
Error_Msg_Name_1 := Chars (Pack_Id);
Error_Msg_NE
- ("\\& is declared in the body of package %", Indic, Item_Id);
+ ("\& is declared in the body of package %", Indic, Item_Id);
end if;
end if;
Error_Msg_N
("& may not have Ghost convention", E);
Error_Msg_N
- ("\\only functions are permitted to have Ghost convention",
+ ("\only functions are permitted to have Ghost convention",
E);
return;
end if;
if Has_Refined_State then
Error_Msg_N
- ("\\check the use of constituents in dependence refinement",
+ ("\check the use of constituents in dependence refinement",
Ref_Clause);
end if;
end if;
if Has_Refined_State then
Match_Error
- ("\\check the use of constituents in dependence refinement",
+ ("\check the use of constituents in dependence refinement",
Dep_Input);
end if;
end if;
Error_Msg_NE
- ("\\constituent & is missing in output list",
+ ("\constituent & is missing in output list",
N, Constit_Id);
end if;
Error_Msg_Name_1 := Global_Mode;
Error_Msg_Name_2 := Expect;
- Error_Msg_N ("\\expected mode %, found mode %", Item);
+ Error_Msg_N ("\expected mode %, found mode %", Item);
end Inconsistent_Mode_Error;
-- Start of processing for Check_Refined_Global_Item
("& cannot act as constituent of state %",
Constit, Constit_Id);
Error_Msg_NE
- ("\\Part_Of indicator specifies & as encapsulating "
+ ("\Part_Of indicator specifies & as encapsulating "
& "state", Constit, Encapsulating_State (Constit_Id));
end if;
if Ekind (Constit_Id) = E_Abstract_State then
Error_Msg_NE
- ("\\abstract state & defined #", State, Constit_Id);
+ ("\abstract state & defined #", State, Constit_Id);
else
Error_Msg_NE
- ("\\variable & defined #", State, Constit_Id);
+ ("\variable & defined #", State, Constit_Id);
end if;
Next_Elmt (Constit_Elmt);
Error_Msg_N ("reference to & not allowed", Body_Ref);
Error_Msg_Sloc := Sloc (State);
- Error_Msg_N ("\\refinement of & is visible#", Body_Ref);
+ Error_Msg_N ("\refinement of & is visible#", Body_Ref);
Next_Elmt (Body_Ref_Elmt);
end loop;
if Ekind (State_Id) = E_Abstract_State then
Error_Msg_NE
- ("\\abstract state & defined #", Body_Id, State_Id);
+ ("\abstract state & defined #", Body_Id, State_Id);
else
Error_Msg_NE
- ("\\variable & defined #", Body_Id, State_Id);
+ ("\variable & defined #", Body_Id, State_Id);
end if;
Next_Elmt (State_Elmt);
& "(SPARK RM 7.2.6(3))", Item_Id);
Error_Msg_Name_1 := Chars (Pack_Id);
Error_Msg_N
- ("\\& is declared in the visible part of private child "
+ ("\& is declared in the visible part of private child "
& "unit %", Item_Id);
end if;
end if;
& "(SPARK RM 7.2.6(2))", Item_Id);
Error_Msg_Name_1 := Chars (Pack_Id);
Error_Msg_N
- ("\\& is declared in the private part of package %", Item_Id);
+ ("\& is declared in the private part of package %", Item_Id);
end if;
end if;
end Check_Missing_Part_Of;
projects / thirdparty / gcc.git / commitdiff
