[multiple changes]
2015-02-20 Robert Dewar <dewar@adacore.com> * 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 <dewar@adacore.com> * g-alveop.adb: Minor style fixes. 2015-02-20 Robert Dewar <dewar@adacore.com> * freeze.adb (Warn_Overlay): Guard against blow up with address clause. 2015-02-20 Bob Duff <duff@adacore.com> * 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
This commit is contained in:
Arnaud Charlet
parent
67c0e6625c
commit
2290a0fec1
|
|
@ -1,3 +1,33 @@
|
|||
2015-02-20 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* 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 <dewar@adacore.com>
|
||||
|
||||
* g-alveop.adb: Minor style fixes.
|
||||
|
||||
2015-02-20 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* freeze.adb (Warn_Overlay): Guard against blow up with address
|
||||
clause.
|
||||
|
||||
2015-02-20 Bob Duff <duff@adacore.com>
|
||||
|
||||
* 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 <dewar@adacore.com>
|
||||
|
||||
* a-dispat.adb, a-stcoed.ads: Minor reformatting.
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
------------------------------
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
--------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -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));
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue