Skip to content

R
riscv-gcc-1
Commit 2c6336be by Arnaud Charlet
Options

[multiple changes] 

2015-01-30  Gary Dismukes  <dismukes@adacore.com>

	* freeze.adb: Minor reformatting.

2015-01-30  Javier Miranda  <miranda@adacore.com>

	* errout.ads (Error_Msg_PT): Replace Node_Id by Entity_Id and
	improve its documentation.
	* errout.adb (Error_Msg_PT): Improve the error message.
	* sem_ch6.adb (Check_Conformance): Update call to Error_Msg_PT.
	(Check_Synchronized_Overriding): Update call to Error_Msg_PT.
	* sem_ch3.adb (Check_Abstract_Overriding): Code cleanup.

2015-01-30  Robert Dewar  <dewar@adacore.com>

	* sem_warn.adb (Warn_On_Known_Condition): Do special casing of
	message for False case.

2015-01-30  Doug Rupp  <rupp@adacore.com>

	* s-vxwext-kernel.ads (Task_Cont): Remove imported subprogram body.
	* s-vxwext-kernel.adb (Task_Cont): New subpprogram body specialized for
	kernel.

From-SVN: r220284
parent 46413d9e
Showing with 85 additions and 45 deletions
gcc/ada/ChangeLog
2015-01-30 Gary Dismukes <dismukes@adacore.com> 2015-01-30 Gary Dismukes <dismukes@adacore.com>
* freeze.adb: Minor reformatting.
2015-01-30 Javier Miranda <miranda@adacore.com>
* errout.ads (Error_Msg_PT): Replace Node_Id by Entity_Id and
improve its documentation.
* errout.adb (Error_Msg_PT): Improve the error message.
* sem_ch6.adb (Check_Conformance): Update call to Error_Msg_PT.
(Check_Synchronized_Overriding): Update call to Error_Msg_PT.
* sem_ch3.adb (Check_Abstract_Overriding): Code cleanup.
2015-01-30 Robert Dewar <dewar@adacore.com>
* sem_warn.adb (Warn_On_Known_Condition): Do special casing of
message for False case.
2015-01-30 Doug Rupp <rupp@adacore.com>
* s-vxwext-kernel.ads (Task_Cont): Remove imported subprogram body.
* s-vxwext-kernel.adb (Task_Cont): New subpprogram body specialized for
kernel.
2015-01-30 Gary Dismukes <dismukes@adacore.com>
* sem_attr.adb (Declared_Within_Generic_Unit): * sem_attr.adb (Declared_Within_Generic_Unit):
New function to test whether an entity is declared within the New function to test whether an entity is declared within the
declarative region of a given generic unit. declarative region of a given generic unit.
......
gcc/ada/errout.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -680,14 +680,14 @@ package body Errout is ...@@ -680,14 +680,14 @@ package body Errout is
-- Error_Msg_PT -- -- Error_Msg_PT --
------------------ ------------------
procedure Error_Msg_PT (Typ : Node_Id; Subp : Node_Id) is procedure Error_Msg_PT (E : Entity_Id; Iface_Prim : Entity_Id) is
begin begin
Error_Msg_NE
("first formal of & must be of mode `OUT`, `IN OUT` or " &
"access-to-variable", Typ, Subp);
Error_Msg_N Error_Msg_N
("\in order to be overridden by protected procedure or entry " & ("illegal overriding of subprogram inherited from interface", E);
"(RM 9.4(11.9/2))", Typ);
Error_Msg_Sloc := Sloc (Iface_Prim);
Error_Msg_N
("\first formal of & declared # has wrong mode (RM 9.4(11.9))", E);
end Error_Msg_PT; end Error_Msg_PT;
----------------- -----------------
......
gcc/ada/errout.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -848,9 +848,10 @@ package Errout is ...@@ -848,9 +848,10 @@ package Errout is
-- run-time mode or no run-time mode (as appropriate). In the former case, -- run-time mode or no run-time mode (as appropriate). In the former case,
-- the name of the library is output if available. -- the name of the library is output if available.
procedure Error_Msg_PT (Typ : Node_Id; Subp : Node_Id); procedure Error_Msg_PT (E : Entity_Id; Iface_Prim : Entity_Id);
-- Posts an error on the protected type declaration Typ indicating wrong -- Posts an error on protected type entry or subprogram E (referencing its
-- mode of the first formal of protected type primitive Subp. -- overridden interface primitive Iface_Prim) indicating wrong mode of the
-- first formal (RM 9.4(11.9/3))
procedure Error_Msg_Ada_2012_Feature (Feature : String; Loc : Source_Ptr); procedure Error_Msg_Ada_2012_Feature (Feature : String; Loc : Source_Ptr);
-- If not operating in Ada 2012 mode, posts errors complaining that Feature -- If not operating in Ada 2012 mode, posts errors complaining that Feature
......
gcc/ada/freeze.adb
...@@ -1800,7 +1800,7 @@ package body Freeze is ...@@ -1800,7 +1800,7 @@ package body Freeze is
-- Historical note: We used to create a finalization master for an -- Historical note: We used to create a finalization master for an
-- access type whose designated type is not controlled, but contains -- access type whose designated type is not controlled, but contains
-- private controlled compoments. This form of post processing is no -- private controlled compoments. This form of postprocessing is no
-- longer needed because the finalization master is now created when -- longer needed because the finalization master is now created when
-- the access type is frozen (see Exp_Ch3.Freeze_Type). -- the access type is frozen (see Exp_Ch3.Freeze_Type).
......
gcc/ada/s-vxwext-kernel.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2008-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2008-2015, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -86,6 +86,17 @@ package body System.VxWorks.Ext is ...@@ -86,6 +86,17 @@ package body System.VxWorks.Ext is
end taskMaskAffinitySet; end taskMaskAffinitySet;
-------------- --------------
-- taskCont --
--------------
function Task_Cont (tid : t_id) return int is
function taskCont (tid : t_id) return int;
pragma Import (C, taskCont, "taskCont");
begin
return taskCont (tid);
end Task_Cont;
--------------
-- taskStop -- -- taskStop --
-------------- --------------
......
gcc/ada/s-vxwext-kernel.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2008-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2008-2015, Free Software Foundation, Inc. --
-- -- -- --
-- GNARL is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -73,7 +73,7 @@ package System.VxWorks.Ext is ...@@ -73,7 +73,7 @@ package System.VxWorks.Ext is
pragma Convention (C, semDelete); pragma Convention (C, semDelete);
function Task_Cont (tid : t_id) return int; function Task_Cont (tid : t_id) return int;
pragma Import (C, Task_Cont, "taskCont"); pragma Convention (C, Task_Cont);
function Task_Stop (tid : t_id) return int; function Task_Stop (tid : t_id) return int;
pragma Convention (C, Task_Stop); pragma Convention (C, Task_Stop);
......
gcc/ada/sem_ch3.adb
...@@ -10050,47 +10050,35 @@ package body Sem_Ch3 is ...@@ -10050,47 +10050,35 @@ package body Sem_Ch3 is
elsif Is_Concurrent_Record_Type (T) elsif Is_Concurrent_Record_Type (T)
and then Present (Interfaces (T)) and then Present (Interfaces (T))
then then
-- If an inherited subprogram is implemented by a protected -- There is no need to check here RM 9.4(11.9/3) since we
-- procedure or an entry, then the first parameter of the -- are processing the corresponding record type and the
-- inherited subprogram shall be of mode OUT or IN OUT, or -- mode of the overriding subprograms was verified by
-- an access-to-variable parameter (RM 9.4(11.9/3)) -- Check_Conformance when the corresponding concurrent
-- type declaration was analyzed.
if Is_Protected_Type (Corresponding_Concurrent_Type (T))
and then Ekind (First_Formal (Subp)) = E_In_Parameter
and then Ekind (Subp) /= E_Function
and then not Is_Predefined_Dispatching_Operation (Subp)
then
Error_Msg_PT (T, Subp);
-- Some other kind of overriding failure
else
Error_Msg_NE Error_Msg_NE
("interface subprogram & must be overridden", ("interface subprogram & must be overridden", T, Subp);
T, Subp);
-- Examine primitive operations of synchronized type, -- Examine primitive operations of synchronized type to find
-- to find homonyms that have the wrong profile. -- homonyms that have the wrong profile.
declare declare
Prim : Entity_Id; Prim : Entity_Id;
begin begin
Prim := Prim := First_Entity (Corresponding_Concurrent_Type (T));
First_Entity (Corresponding_Concurrent_Type (T));
while Present (Prim) loop while Present (Prim) loop
if Chars (Prim) = Chars (Subp) then if Chars (Prim) = Chars (Subp) then
Error_Msg_NE Error_Msg_NE
("profile is not type conformant with " ("profile is not type conformant with prefixed "
& "prefixed view profile of " & "view profile of inherited operation&",
& "inherited operation&", Prim, Subp); Prim, Subp);
end if; end if;
Next_Entity (Prim); Next_Entity (Prim);
end loop; end loop;
end; end;
end if; end if;
end if;
else else
Error_Msg_Node_2 := T; Error_Msg_Node_2 := T;
......
gcc/ada/sem_ch6.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -5117,7 +5117,7 @@ package body Sem_Ch6 is ...@@ -5117,7 +5117,7 @@ package body Sem_Ch6 is
begin begin
if Is_Protected_Type (Corresponding_Concurrent_Type (T)) if Is_Protected_Type (Corresponding_Concurrent_Type (T))
then then
Error_Msg_PT (T, New_Id); Error_Msg_PT (New_Id, Ultimate_Alias (Old_Id));
else else
Conformance_Error Conformance_Error
("\mode of & does not match!", New_Formal); ("\mode of & does not match!", New_Formal);
...@@ -9364,7 +9364,7 @@ package body Sem_Ch6 is ...@@ -9364,7 +9364,7 @@ package body Sem_Ch6 is
or else Is_Synchronized_Interface (Iface_Typ) or else Is_Synchronized_Interface (Iface_Typ)
or else Is_Task_Interface (Iface_Typ)) or else Is_Task_Interface (Iface_Typ))
then then
Error_Msg_PT (Parent (Typ), Candidate); Error_Msg_PT (Def_Id, Candidate);
end if; end if;
end if; end if;
......
gcc/ada/sem_warn.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- -- Copyright (C) 1999-2015, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -3390,18 +3390,22 @@ package body Sem_Warn is ...@@ -3390,18 +3390,22 @@ package body Sem_Warn is
Cond : Node_Id := C; Cond : Node_Id := C;
begin begin
if Present (Parent (C)) and then Nkind (Parent (C)) = N_Op_Not if Present (Parent (C))
and then Nkind (Parent (C)) = N_Op_Not
then then
True_Branch := not True_Branch; True_Branch := not True_Branch;
Cond := Parent (C); Cond := Parent (C);
end if; end if;
-- Condition always True
if True_Branch then if True_Branch then
if Is_Entity_Name (Original_Node (C)) if Is_Entity_Name (Original_Node (C))
and then Nkind (Cond) /= N_Op_Not and then Nkind (Cond) /= N_Op_Not
then then
Error_Msg_NE Error_Msg_NE
("object & is always True?c?", Cond, Original_Node (C)); ("object & is always True?c?",
Cond, Original_Node (C));
Track (Original_Node (C), Cond); Track (Original_Node (C), Cond);
else else
...@@ -3409,10 +3413,22 @@ package body Sem_Warn is ...@@ -3409,10 +3413,22 @@ package body Sem_Warn is
Track (Cond, Cond); Track (Cond, Cond);
end if; end if;
-- Condition always False
else
if Is_Entity_Name (Original_Node (C))
and then Nkind (Cond) /= N_Op_Not
then
Error_Msg_NE
("object & is always False?c?",
Cond, Original_Node (C));
Track (Original_Node (C), Cond);
else else
Error_Msg_N ("condition is always False?c?", Cond); Error_Msg_N ("condition is always False?c?", Cond);
Track (Cond, Cond); Track (Cond, Cond);
end if; end if;
end if;
end; end;
end if; end if;
end if; end if;
......
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