From 2290a0fec1ffaa96f33dcc79bef60ed3c00fd947 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 20 Feb 2015 15:35:51 +0100 Subject: [PATCH] [multiple changes] 2015-02-20 Robert Dewar * errout.ads: Document replacement of Name_uPre/Post/Type_Invariant. * erroutc.adb (Set_Msg_Str): Replace _xxx. (Pre/Post/Type_Invariant) by xxx'Class. * erroutc.ads (Set_Msg_Str): Replace _xxx. (Pre/Post/Type_Invariant) by xxx'Class. * sem_prag.adb (Fix_Error): Remove special casing of Name_uType_Invariant. (Analyze_Pre_Post_Condition_In_Decl_Part): Remove special casing of Name_uPre and Name_uPost in aspect case (done in Errout now). 2015-02-20 Robert Dewar * g-alveop.adb: Minor style fixes. 2015-02-20 Robert Dewar * freeze.adb (Warn_Overlay): Guard against blow up with address clause. 2015-02-20 Bob Duff * exp_attr.adb (May_Be_External_Call): Remove this. There is no need for the compiler to guess whether the call is internal or external -- it is always external. (Expand_Access_To_Protected_Op): For P'Access, where P is a protected subprogram, always create a pointer to the External_Subprogram. From-SVN: r220869 --- gcc/ada/ChangeLog | 30 +++++++++++++++++++++++++ gcc/ada/errout.ads | 9 ++++++++ gcc/ada/erroutc.adb | 45 +++++++++++++++++++++++++++++++------ gcc/ada/erroutc.ads | 5 +++-- gcc/ada/exp_attr.adb | 53 ++++++++------------------------------------ gcc/ada/freeze.adb | 18 +++++++++------ gcc/ada/g-alveop.adb | 8 ------- gcc/ada/sem_prag.adb | 22 ++---------------- 8 files changed, 102 insertions(+), 88 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 12f09a366ad..60acc83cbcd 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,33 @@ +2015-02-20 Robert Dewar + + * errout.ads: Document replacement of Name_uPre/Post/Type_Invariant. + * erroutc.adb (Set_Msg_Str): Replace _xxx. + (Pre/Post/Type_Invariant) by xxx'Class. + * erroutc.ads (Set_Msg_Str): Replace _xxx. + (Pre/Post/Type_Invariant) by xxx'Class. + * sem_prag.adb (Fix_Error): Remove special casing of + Name_uType_Invariant. + (Analyze_Pre_Post_Condition_In_Decl_Part): Remove special casing of + Name_uPre and Name_uPost in aspect case (done in Errout now). + +2015-02-20 Robert Dewar + + * g-alveop.adb: Minor style fixes. + +2015-02-20 Robert Dewar + + * freeze.adb (Warn_Overlay): Guard against blow up with address + clause. + +2015-02-20 Bob Duff + + * exp_attr.adb (May_Be_External_Call): Remove this. There is no need + for the compiler to guess whether the call is internal or external -- + it is always external. + (Expand_Access_To_Protected_Op): For P'Access, where P + is a protected subprogram, always create a pointer to the + External_Subprogram. + 2015-02-20 Robert Dewar * a-dispat.adb, a-stcoed.ads: Minor reformatting. diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index d02febe47fc..f23bed31ff5 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -139,12 +139,18 @@ package Errout is -- casing mode. Note: if a unit name ending with %b or %s is passed -- for this kind of insertion, this suffix is simply stripped. Use a -- unit name insertion ($) to process the suffix. + -- + -- Note: the special names _xxx (xxx = Pre/Post/Invariant) are changed + -- to insert the string xxx'Class into the message. -- Insertion character %% (Double percent: insert literal name) -- The character sequence %% acts as described above for %, except -- that the name is simply obtained with Get_Name_String and is not -- decoded or cased, it is inserted literally from the names table. -- A trailing %b or %s is not treated specially. + -- + -- Note: the special names _xxx (xxx = Pre/Post/Invariant) are changed + -- to insert the string xxx'Class into the message. -- Insertion character $ (Dollar: insert unit name from Names table) -- The character $ is treated similarly to %, except that the name is @@ -181,6 +187,9 @@ package Errout is -- Error_Msg_Qual_Level is non-zero, then the reference will include -- up to the given number of levels of qualification, using the scope -- chain. + -- + -- Note: the special names _xxx (xxx = Pre/Post/Invariant) are changed + -- to insert the string xxx'Class into the message. -- Insertion character # (Pound: insert line number reference) -- The character # is replaced by the string indicating the source diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index 32d9bbc7865..c76c1ceff27 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -1344,9 +1344,7 @@ package body Erroutc is procedure Set_Msg_Name_Buffer is begin - for J in 1 .. Name_Len loop - Set_Msg_Char (Name_Buffer (J)); - end loop; + Set_Msg_Str (Name_Buffer (1 .. Name_Len)); end Set_Msg_Name_Buffer; ------------------- @@ -1366,9 +1364,42 @@ package body Erroutc is procedure Set_Msg_Str (Text : String) is begin - for J in Text'Range loop - Set_Msg_Char (Text (J)); - end loop; + -- Do replacement for special x'Class aspect names + + if Text = "_Pre" then + Set_Msg_Str ("Pre'Class"); + + elsif Text = "_Post" then + Set_Msg_Str ("Post'Class"); + + elsif Text = "_Type_Invariant" then + Set_Msg_Str ("Type_Invariant'Class"); + + elsif Text = "_pre" then + Set_Msg_Str ("pre'class"); + + elsif Text = "_post" then + Set_Msg_Str ("post'class"); + + elsif Text = "_type_invariant" then + Set_Msg_Str ("type_invariant'class"); + + elsif Text = "_PRE" then + Set_Msg_Str ("PRE'CLASS"); + + elsif Text = "_POST" then + Set_Msg_Str ("POST'CLASS"); + + elsif Text = "_TYPE_INVARIANT" then + Set_Msg_Str ("TYPE_INVARIANT'CLASS"); + + -- Normal case with no replacement + + else + for J in Text'Range loop + Set_Msg_Char (Text (J)); + end loop; + end if; end Set_Msg_Str; ------------------------------ diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads index cb69f17f8b9..a2eec177e81 100644 --- a/gcc/ada/erroutc.ads +++ b/gcc/ada/erroutc.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -527,7 +527,8 @@ package Erroutc is procedure Set_Msg_Str (Text : String); -- Add a sequence of characters to the current message. This routine does -- not check for special insertion characters (they are just treated as - -- text characters if they occur). + -- text characters if they occur). It does perform the transformation of + -- the special strings _xxx (xxx = Pre/Post/Type_Invariant) to xxx'Class. procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id); -- Given a message id, move to next message id, but skip any deleted diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 74b013ee687..5cc45ae660f 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -690,41 +690,6 @@ package body Exp_Attr is Obj_Ref : Node_Id; Curr : Entity_Id; - function May_Be_External_Call return Boolean; - -- If the 'Access is to a local operation, but appears in a context - -- where it may lead to a call from outside the object, we must treat - -- this as an external call. Clearly we cannot tell without full - -- flow analysis, and a subsequent call that uses this 'Access may - -- lead to a bounded error (trying to seize locks twice, e.g.). For - -- now we treat 'Access as a potential external call if it is an actual - -- in a call to an outside subprogram. - - -------------------------- - -- May_Be_External_Call -- - -------------------------- - - function May_Be_External_Call return Boolean is - Subp : Entity_Id; - Par : Node_Id := Parent (N); - - begin - -- Account for the case where the Access attribute is part of a - -- named parameter association. - - if Nkind (Par) = N_Parameter_Association then - Par := Parent (Par); - end if; - - if Nkind (Par) in N_Subprogram_Call - and then Is_Entity_Name (Name (Par)) - then - Subp := Entity (Name (Par)); - return not In_Open_Scopes (Scope (Subp)); - else - return False; - end if; - end May_Be_External_Call; - -- Start of processing for Expand_Access_To_Protected_Op begin @@ -733,14 +698,14 @@ package body Exp_Attr is -- protected body of the current enclosing operation. if Is_Entity_Name (Pref) then - if May_Be_External_Call then - Sub := - New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc); - else - Sub := - New_Occurrence_Of - (Protected_Body_Subprogram (Entity (Pref)), Loc); - end if; + -- All indirect calls are external calls, so must do locking and + -- barrier reevaluation, even if the 'Access occurs within the + -- protected body. Hence the call to External_Subprogram, as opposed + -- to Protected_Body_Subprogram, below. See RM-9.5(5). This means + -- that indirect calls from within the same protected body will + -- deadlock, as allowed by RM-9.5.1(8,15,17). + + Sub := New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc); -- Don't traverse the scopes when the attribute occurs within an init -- proc, because we directly use the _init formal of the init proc in diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index aa3c52bc99f..c16a4e29cf6 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -8034,18 +8034,22 @@ package body Freeze is return; end if; - Decl := Next (Parent (Expr)); - -- If a pragma Import follows, we assume that it is for the current -- target of the address clause, and skip the warning. - if Present (Decl) - and then Nkind (Decl) = N_Pragma - and then Pragma_Name (Decl) = Name_Import - then - return; + if Is_List_Member (Parent (Expr)) then + Decl := Next (Parent (Expr)); + + if Present (Decl) + and then Nkind (Decl) = N_Pragma + and then Pragma_Name (Decl) = Name_Import + then + return; + end if; end if; + -- Otherwise give warning message + if Present (Old) then Error_Msg_Node_2 := Old; Error_Msg_N diff --git a/gcc/ada/g-alveop.adb b/gcc/ada/g-alveop.adb index c90c09c70e8..0a7b1d3f083 100644 --- a/gcc/ada/g-alveop.adb +++ b/gcc/ada/g-alveop.adb @@ -31,14 +31,6 @@ with GNAT.Altivec.Low_Level_Interface; use GNAT.Altivec.Low_Level_Interface; ------------------------------------- --- GNAT.Altivec.Vector_Operations -- ------------------------------------- - ------------------------------------- --- GNAT.Altivec.Vector_Operations -- ------------------------------------- - package body GNAT.Altivec.Vector_Operations is -------------------------------------------------------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index ec7292eae88..ac745e7706d 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -5918,17 +5918,6 @@ package body Sem_Prag is -- Get name from corresponding aspect Error_Msg_Name_1 := Original_Aspect_Name (N); - - if Class_Present (N) then - - -- Replace the name with a leading underscore used - -- internally, with a name that is more user-friendly. - - if Error_Msg_Name_1 = Name_uType_Invariant then - Error_Msg_Name_1 := Name_Type_Invariant_Class; - end if; - end if; - end if; -- Return possibly modified message @@ -21897,16 +21886,9 @@ package body Sem_Prag is -- Pre'Class/Post'Class aspect cases if From_Aspect_Specification (Prag) then - if Nam = Name_uPre then - Error_Msg_Name_1 := Name_Pre; - else - Error_Msg_Name_1 := Name_Post; - end if; - - Error_Msg_Name_2 := Name_Class; - + Error_Msg_Name_1 := Nam; Error_Msg_N - ("aspect `%''%` can only be specified for a primitive " + ("aspect% can only be specified for a primitive " & "operation of a tagged type", Corresponding_Aspect (Prag)); -- 2.30.2