[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

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;