Skip to content

R
riscv-gcc-1
Commit 1ae8beef by Arnaud Charlet
Options

[multiple changes] 

2014-02-25  Tristan Gingold  <gingold@adacore.com>

	* sem_ch10.adb: Minor comment fix.

2014-02-25  Bob Duff  <duff@adacore.com>

	* s-tasdeb.adb: Misc cleanup of this package,
	including printing addresses in hexadecimal.
	(Write): Fix minor bug when taking 'Address of an empty string.

2014-02-25  Ed Schonberg  <schonberg@adacore.com>

	* sem_prag.adb (Analyze_Part_Of): Reject state refinement in a
	public child unit when it does not refer to the abstract state
	of a public ancestor.

From-SVN: r208131
parent ca11219d
Showing with 105 additions and 43 deletions
gcc/ada/ChangeLog
2014-02-25 Tristan Gingold <gingold@adacore.com>
* sem_ch10.adb: Minor comment fix.
2014-02-25 Bob Duff <duff@adacore.com>
* s-tasdeb.adb: Misc cleanup of this package,
including printing addresses in hexadecimal.
(Write): Fix minor bug when taking 'Address of an empty string.
2014-02-25 Ed Schonberg <schonberg@adacore.com>
* sem_prag.adb (Analyze_Part_Of): Reject state refinement in a
public child unit when it does not refer to the abstract state
of a public ancestor.
2014-02-25 Yannick Moy <moy@adacore.com>
* sem_prag.adb (Analyze_Pragma/Pragma_Validity_Checks): Ignore pragma
......
gcc/ada/s-tasdeb.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -37,33 +37,40 @@
-- 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 --
......@@ -134,16 +141,13 @@ package body System.Tasking.Debug is
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);
......@@ -165,7 +169,7 @@ package body System.Tasking.Debug is
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;
......@@ -195,7 +199,7 @@ package body System.Tasking.Debug is
procedure Put (S : String) is
begin
Write (2, S, S'Length);
Write (Stderr_Fd, S, S'Length);
end Put;
--------------
......@@ -204,7 +208,7 @@ package body System.Tasking.Debug is
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;
----------------------
......@@ -323,6 +327,35 @@ package body System.Tasking.Debug is
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 --
---------------------------
......@@ -344,13 +377,13 @@ package body System.Tasking.Debug is
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);
......@@ -365,9 +398,10 @@ package body System.Tasking.Debug is
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;
gcc/ada/sem_ch10.adb
......@@ -1110,8 +1110,8 @@ package body Sem_Ch10 is
end;
end if;
-- Deal with creating elaboration Boolean if needed. We create an
-- elaboration boolean only for units that come from source since
-- Deal with creating elaboration counter if needed. We create an
-- elaboration counter only for units that come from source since
-- units manufactured by the compiler never need elab checks.
if Comes_From_Source (N)
......
gcc/ada/sem_prag.adb
......@@ -907,7 +907,7 @@ package body Sem_Prag is
("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
......@@ -1168,7 +1168,7 @@ package body Sem_Prag is
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
......@@ -2018,7 +2018,7 @@ package body Sem_Prag is
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
......@@ -2166,7 +2166,7 @@ package body Sem_Prag is
("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
......@@ -3490,7 +3490,7 @@ package body Sem_Prag is
& "(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
......@@ -3507,6 +3507,18 @@ package body Sem_Prag is
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
......@@ -3518,7 +3530,7 @@ package body Sem_Prag is
& "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;
......@@ -3532,7 +3544,7 @@ package body Sem_Prag is
& "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;
......@@ -3547,7 +3559,7 @@ package body Sem_Prag is
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;
......@@ -6652,7 +6664,7 @@ package body Sem_Prag is
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;
......@@ -21862,7 +21874,7 @@ package body Sem_Prag is
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;
......@@ -22087,7 +22099,7 @@ package body Sem_Prag is
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;
......@@ -22737,7 +22749,7 @@ package body Sem_Prag is
end if;
Error_Msg_NE
("\\constituent & is missing in output list",
("\constituent & is missing in output list",
N, Constit_Id);
end if;
......@@ -22898,7 +22910,7 @@ package body Sem_Prag is
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
......@@ -23395,7 +23407,7 @@ package body Sem_Prag is
("& 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;
......@@ -23612,10 +23624,10 @@ package body Sem_Prag is
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);
......@@ -23679,7 +23691,7 @@ package body Sem_Prag is
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;
......@@ -23995,10 +24007,10 @@ package body Sem_Prag is
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);
......@@ -24607,7 +24619,7 @@ package body Sem_Prag is
& "(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;
......@@ -24640,7 +24652,7 @@ package body Sem_Prag is
& "(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;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment