diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 16 | ||||
| -rw-r--r-- | gcc/ada/s-tasdeb.adb | 74 | ||||
| -rw-r--r-- | gcc/ada/sem_ch10.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 54 |
4 files changed, 105 insertions, 43 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5bd6574f0f3..e3908c99f43 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +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 diff --git a/gcc/ada/s-tasdeb.adb b/gcc/ada/s-tasdeb.adb index ccc81d9d53b..2c8b638493c 100644 --- a/gcc/ada/s-tasdeb.adb +++ b/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; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 958bbb24c58..7714526ae99 100644 --- a/gcc/ada/sem_ch10.adb +++ b/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) diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c9c15172374..2b095eabbf6 100644 --- a/gcc/ada/sem_prag.adb +++ b/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; |
