Commit b55993b3 by Arnaud Charlet

[multiple changes]

2017-05-02  Justin Squirek  <squirek@adacore.com>

	* sem_ch4.adb (Analyze_Case_Expression): Add check for valid
	alternative expression.
	* sem_res.adb (Resolve_Case_Expression): Ditto.

2017-05-02  Ed Schonberg  <schonberg@adacore.com>

	* exp_disp.adb (Set_All_DT_Position, In_Predef_Prim_DT):
	Refine predicate for the case where the primitive operation
	is a renaming of equality.  An overriding operation that is
	a user-defined renaming of predefined equality inherits its
	slot from the overridden operation. Otherwise it is treated
	as a predefined op and occupies the same predefined slot as
	equality. A call to it is transformed into a call to its alias,
	which is the predefined equality. A dispatching call thus uses
	the proper slot if operation is further inherited and called
	with class-wide arguments.

2017-05-02  Justin Squirek  <squirek@adacore.com>

	* errout.adb (Set_Msg_Text): Add a case to switch the message
	type when the character '[' is detected signifying a warning
	about a run-time exception.
	* opt.ads Add a new Warning_Mode value for new switch
	* switch-b.adb (Scan_Binder_Switches): Add case for the binder
	to handle new warning mode
	* usage.adb (Usage): Add usage entry for -gnatwE
	* warnsw.adb (Set_Warning_Switch): Add case for the new switch

2017-05-02  Ed Schonberg  <schonberg@adacore.com>

	* sem_prag.adb (Process_Conversion): Reject an intrinsic operator
	declaration that operates on some fixed point type.

2017-05-02  Justin Squirek  <squirek@adacore.com>

	* a-crbtgo.adb, s-taasde.adb: Remove unused use-type clauses.

From-SVN: r247478
parent a6354842
2017-05-02 Justin Squirek <squirek@adacore.com>
* sem_ch4.adb (Analyze_Case_Expression): Add check for valid
alternative expression.
* sem_res.adb (Resolve_Case_Expression): Ditto.
2017-05-02 Ed Schonberg <schonberg@adacore.com>
* exp_disp.adb (Set_All_DT_Position, In_Predef_Prim_DT):
Refine predicate for the case where the primitive operation
is a renaming of equality. An overriding operation that is
a user-defined renaming of predefined equality inherits its
slot from the overridden operation. Otherwise it is treated
as a predefined op and occupies the same predefined slot as
equality. A call to it is transformed into a call to its alias,
which is the predefined equality. A dispatching call thus uses
the proper slot if operation is further inherited and called
with class-wide arguments.
2017-05-02 Justin Squirek <squirek@adacore.com>
* errout.adb (Set_Msg_Text): Add a case to switch the message
type when the character '[' is detected signifying a warning
about a run-time exception.
* opt.ads Add a new Warning_Mode value for new switch
* switch-b.adb (Scan_Binder_Switches): Add case for the binder
to handle new warning mode
* usage.adb (Usage): Add usage entry for -gnatwE
* warnsw.adb (Set_Warning_Switch): Add case for the new switch
2017-05-02 Ed Schonberg <schonberg@adacore.com>
* sem_prag.adb (Process_Conversion): Reject an intrinsic operator
declaration that operates on some fixed point type.
2017-05-02 Justin Squirek <squirek@adacore.com>
* a-crbtgo.adb, s-taasde.adb: Remove unused use-type clauses.
2017-05-02 Hristian Kirtchev <kirtchev@adacore.com> 2017-05-02 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch6.adb (Analyze_Null_Procedure): Revert previous change. * sem_ch6.adb (Analyze_Null_Procedure): Revert previous change.
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2004-2016, Free Software Foundation, Inc. -- -- Copyright (C) 2004-2017, 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- --
...@@ -512,7 +512,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is ...@@ -512,7 +512,7 @@ package body Ada.Containers.Red_Black_Trees.Generic_Operations is
procedure Generic_Adjust (Tree : in out Tree_Type) is procedure Generic_Adjust (Tree : in out Tree_Type) is
N : constant Count_Type := Tree.Length; N : constant Count_Type := Tree.Length;
Root : constant Node_Access := Tree.Root; Root : constant Node_Access := Tree.Root;
use type Helpers.Tamper_Counts;
begin begin
-- If the counts are nonzero, execution is technically erroneous, but -- If the counts are nonzero, execution is technically erroneous, but
-- it seems friendly to allow things like concurrent "=" on shared -- it seems friendly to allow things like concurrent "=" on shared
......
...@@ -3097,6 +3097,17 @@ package body Errout is ...@@ -3097,6 +3097,17 @@ package body Errout is
-- '[' (will be/would have been raised at run time) -- '[' (will be/would have been raised at run time)
when '[' => when '[' =>
-- Switch the message from a warning to an error if the flag
-- -gnatwE is specified to treat run-time exception warnings
-- as errors.
if Is_Warning_Msg
and then Warning_Mode = Treat_Run_Time_As_Error
then
Is_Warning_Msg := False;
end if;
if Is_Warning_Msg then if Is_Warning_Msg then
Set_Msg_Str ("will be raised at run time"); Set_Msg_Str ("will be raised at run time");
else else
......
...@@ -7430,8 +7430,6 @@ package body Exp_Disp is ...@@ -7430,8 +7430,6 @@ package body Exp_Disp is
------------------------ ------------------------
function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is function In_Predef_Prims_DT (Prim : Entity_Id) return Boolean is
E : Entity_Id;
begin begin
-- Predefined primitives -- Predefined primitives
...@@ -7446,20 +7444,19 @@ package body Exp_Disp is ...@@ -7446,20 +7444,19 @@ package body Exp_Disp is
if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then if Chars (Ultimate_Alias (Prim)) /= Name_Op_Eq then
return True; return True;
-- User-defined renamings of predefined equality have their own -- An overriding operation that is a user-defined renaming of
-- slot in the primary dispatch table -- predefined equality inherits its slot from the overridden
-- operation. Otherwise it is treated as a predefined op and
-- occupies the same predefined slot as equality. A call to it is
-- transformed into a call to its alias, which is the predefined
-- equality op. A dispatching call thus uses the proper slot if
-- operation is further inherited and called with class-wide
-- arguments.
else else
E := Prim; return
while Present (Alias (E)) loop not Comes_From_Source (Prim)
if Comes_From_Source (E) then or else No (Overridden_Operation (Prim));
return False;
end if;
E := Alias (E);
end loop;
return not Comes_From_Source (E);
end if; end if;
-- User-defined primitives -- User-defined primitives
......
...@@ -1860,16 +1860,19 @@ package Opt is ...@@ -1860,16 +1860,19 @@ package Opt is
-- or where no warning has been suppressed by the use of the pragma. -- or where no warning has been suppressed by the use of the pragma.
-- Modified by use of -gnatw.w/.W. -- Modified by use of -gnatw.w/.W.
type Warning_Mode_Type is (Suppress, Normal, Treat_As_Error); type Warning_Mode_Type is
(Suppress, Normal, Treat_As_Error, Treat_Run_Time_As_Error);
Warning_Mode : Warning_Mode_Type := Normal; Warning_Mode : Warning_Mode_Type := Normal;
-- GNAT, GNATBIND -- GNAT, GNATBIND
-- Controls treatment of warning messages. If set to Suppress, warning -- Controls treatment of warning messages. If set to Suppress, warning
-- messages are not generated at all. In Normal mode, they are generated -- messages are not generated at all. In Normal mode, they are generated
-- but do not count as errors. In Treat_As_Error mode, warning messages are -- but do not count as errors. In Treat_As_Error mode, warning messages are
-- generated and are treated as errors. Note that Warning_Mode = Suppress -- generated and are treated as errors. In Treat_Run_Time_As_Error, warning
-- causes pragma Warnings to be ignored (except for legality checks), -- messages regarding errors raised at run time are treated as errors. Note
-- unless we are in GNATprove_Mode, which requires pragma Warnings to -- that Warning_Mode = Suppress causes pragma Warnings to be ignored
-- be stored for the formal verification backend. -- (except for legality checks), unless we are in GNATprove_Mode, which
-- requires pragma Warnings to be stored for the formal verification
-- backend.
Warnings_As_Errors_Count : Natural; Warnings_As_Errors_Count : Natural;
-- GNAT -- GNAT
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1998-2014, Free Software Foundation, Inc. -- -- Copyright (C) 1998-2017, 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- --
...@@ -203,9 +203,6 @@ package body System.Tasking.Async_Delays is ...@@ -203,9 +203,6 @@ package body System.Tasking.Async_Delays is
Self_Id : constant Task_Id := STPO.Self; Self_Id : constant Task_Id := STPO.Self;
Q : Delay_Block_Access; Q : Delay_Block_Access;
use type ST.Task_Id;
-- for visibility of operator "="
begin begin
pragma Debug (Debug.Trace (Self_Id, "Async_Delay", 'P')); pragma Debug (Debug.Trace (Self_Id, "Async_Delay", 'P'));
pragma Assert (Self_Id.Deferral_Level = 1, pragma Assert (Self_Id.Deferral_Level = 1,
......
...@@ -1548,6 +1548,10 @@ package body Sem_Ch4 is ...@@ -1548,6 +1548,10 @@ package body Sem_Ch4 is
Alt := First (Alternatives (N)); Alt := First (Alternatives (N));
while Present (Alt) loop while Present (Alt) loop
if Error_Posted (Expression (Alt)) then
return;
end if;
Analyze (Expression (Alt)); Analyze (Expression (Alt));
if No (FirstX) and then Etype (Expression (Alt)) /= Any_Type then if No (FirstX) and then Etype (Expression (Alt)) /= Any_Type then
...@@ -2226,12 +2230,14 @@ package body Sem_Ch4 is ...@@ -2226,12 +2230,14 @@ package body Sem_Ch4 is
Check_Error_Detected; Check_Error_Detected;
return; return;
end if; end if;
Then_Expr := Next (Condition); Then_Expr := Next (Condition);
if No (Then_Expr) then if No (Then_Expr) then
Check_Error_Detected; Check_Error_Detected;
return; return;
end if; end if;
Else_Expr := Next (Then_Expr); Else_Expr := Next (Then_Expr);
if Comes_From_Source (N) then if Comes_From_Source (N) then
......
...@@ -7732,6 +7732,22 @@ package body Sem_Prag is ...@@ -7732,6 +7732,22 @@ package body Sem_Prag is
-- given entity, not its homonyms. -- given entity, not its homonyms.
if From_Aspect_Specification (N) then if From_Aspect_Specification (N) then
if C = Convention_Intrinsic
and then Nkind (Ent) = N_Defining_Operator_Symbol
then
if Is_Fixed_Point_Type (Etype (Ent))
or else Is_Fixed_Point_Type (Etype (First_Entity (Ent)))
or else Is_Fixed_Point_Type (Etype (Last_Entity (Ent)))
then
Error_Msg_N
("no intrinsic operator available for this fixed-point "
& "operation", N);
Error_Msg_N
("\use expression functions with the desired "
& "conversions made explicit", N);
end if;
end if;
return; return;
end if; end if;
...@@ -6712,6 +6712,11 @@ package body Sem_Res is ...@@ -6712,6 +6712,11 @@ package body Sem_Res is
Alt := First (Alternatives (N)); Alt := First (Alternatives (N));
while Present (Alt) loop while Present (Alt) loop
Alt_Expr := Expression (Alt); Alt_Expr := Expression (Alt);
if Error_Posted (Alt_Expr) then
return;
end if;
Resolve (Alt_Expr, Typ); Resolve (Alt_Expr, Typ);
Alt_Typ := Etype (Alt_Expr); Alt_Typ := Etype (Alt_Expr);
...@@ -8252,11 +8257,13 @@ package body Sem_Res is ...@@ -8252,11 +8257,13 @@ package body Sem_Res is
if No (Condition) then if No (Condition) then
return; return;
end if; end if;
Then_Expr := Next (Condition); Then_Expr := Next (Condition);
if No (Then_Expr) then if No (Then_Expr) then
return; return;
end if; end if;
Else_Expr := Next (Then_Expr); Else_Expr := Next (Then_Expr);
Resolve (Condition, Any_Boolean); Resolve (Condition, Any_Boolean);
...@@ -8268,9 +8275,7 @@ package body Sem_Res is ...@@ -8268,9 +8275,7 @@ package body Sem_Res is
-- a constraint check. The same is done for the else part below, again -- a constraint check. The same is done for the else part below, again
-- comparing subtypes rather than base types. -- comparing subtypes rather than base types.
if Is_Scalar_Type (Then_Typ) if Is_Scalar_Type (Then_Typ) and then Then_Typ /= Typ then
and then Then_Typ /= Typ
then
Rewrite (Then_Expr, Convert_To (Typ, Then_Expr)); Rewrite (Then_Expr, Convert_To (Typ, Then_Expr));
Analyze_And_Resolve (Then_Expr, Typ); Analyze_And_Resolve (Then_Expr, Typ);
end if; end if;
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2001-2016, Free Software Foundation, Inc. -- -- Copyright (C) 2001-2017, 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- --
...@@ -490,6 +490,9 @@ package body Switch.B is ...@@ -490,6 +490,9 @@ package body Switch.B is
when 'e' => when 'e' =>
Warning_Mode := Treat_As_Error; Warning_Mode := Treat_As_Error;
when 'E' =>
Warning_Mode := Treat_Run_Time_As_Error;
when 's' => when 's' =>
Warning_Mode := Suppress; Warning_Mode := Suppress;
......
...@@ -488,6 +488,7 @@ begin ...@@ -488,6 +488,7 @@ begin
Write_Line (" e treat all warnings (but not info) as errors"); Write_Line (" e treat all warnings (but not info) as errors");
Write_Line (" .e turn on every optional info/warning " & Write_Line (" .e turn on every optional info/warning " &
"(no exceptions)"); "(no exceptions)");
Write_Line (" E treat all run time warnings as errors");
Write_Line (" f+ turn on warnings for unreferenced formal"); Write_Line (" f+ turn on warnings for unreferenced formal");
Write_Line (" F* turn off warnings for unreferenced formal"); Write_Line (" F* turn off warnings for unreferenced formal");
Write_Line (" .f turn on warnings for suspicious Subp'Access"); Write_Line (" .f turn on warnings for suspicious Subp'Access");
......
...@@ -532,6 +532,9 @@ package body Warnsw is ...@@ -532,6 +532,9 @@ package body Warnsw is
when 'e' => when 'e' =>
Warning_Mode := Treat_As_Error; Warning_Mode := Treat_As_Error;
when 'E' =>
Warning_Mode := Treat_Run_Time_As_Error;
when 'f' => when 'f' =>
Check_Unreferenced_Formals := True; Check_Unreferenced_Formals := True;
......
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