Skip to content

R
riscv-gcc-1
Commit 08ce7bb8 by Arnaud Charlet
Options

[multiple changes] 

2011-10-24  Geert Bosch  <bosch@adacore.com>

	* s-gearop.adb (Back_Substitute): Avoid overflow if matrix
	bounds start at Integer'First.

2011-10-24  Robert Dewar  <dewar@adacore.com>

	* sem_ch12.adb, s-gearop.adb: Minor reformatting

2011-10-24  Robert Dewar  <dewar@adacore.com>

	* warnsw.adb: Add some missing warnings to Set_GNAT_Mode_Warnings
	* warnsw.ads: Add comments to Set_GNAT_Mode_Warnings

From-SVN: r180372
parent d2111e2f
Showing with 84 additions and 34 deletions
gcc/ada/ChangeLog
2011-10-24 Geert Bosch <bosch@adacore.com>
* s-gearop.adb (Back_Substitute): Avoid overflow if matrix
bounds start at Integer'First.
2011-10-24 Robert Dewar <dewar@adacore.com>
* sem_ch12.adb, s-gearop.adb: Minor reformatting
2011-10-24 Robert Dewar <dewar@adacore.com>
* warnsw.adb: Add some missing warnings to Set_GNAT_Mode_Warnings
* warnsw.ads: Add comments to Set_GNAT_Mode_Warnings
2011-10-24 Emmanuel Briot <briot@adacore.com>
* prj-proc.adb (Process_Expression_Variable_Decl): No special
......
gcc/ada/s-gearop.adb
......@@ -33,11 +33,11 @@ with Ada.Numerics; use Ada.Numerics;
package body System.Generic_Array_Operations is
-- The local function Check_Unit_Last computes the index
-- of the last element returned by Unit_Vector or Unit_Matrix.
-- A separate function is needed to allow raising Constraint_Error
-- before declaring the function result variable. The result variable
-- needs to be declared first, to allow front-end inlining.
-- The local function Check_Unit_Last computes the index of the last
-- element returned by Unit_Vector or Unit_Matrix. A separate function is
-- needed to allow raising Constraint_Error before declaring the function
-- result variable. The result variable needs to be declared first, to
-- allow front-end inlining.
function Check_Unit_Last
(Index : Integer;
......@@ -50,7 +50,6 @@ package body System.Generic_Array_Operations is
--------------
function Diagonal (A : Matrix) return Vector is
N : constant Natural := Natural'Min (A'Length (1), A'Length (2));
R : Vector (A'First (1) .. A'First (1) + N - 1);
......@@ -82,7 +81,8 @@ package body System.Generic_Array_Operations is
function Check_Unit_Last
(Index : Integer;
Order : Positive;
First : Integer) return Integer is
First : Integer) return Integer
is
begin
-- Order the tests carefully to avoid overflow
......@@ -101,11 +101,10 @@ package body System.Generic_Array_Operations is
---------------------
procedure Back_Substitute (M, N : in out Matrix) is
pragma Assert (M'First (1) = N'First (1) and then
pragma Assert (M'First (1) = N'First (1)
and then
M'Last (1) = N'Last (1));
Max_Col : Integer := M'Last (2);
procedure Sub_Row
(M : in out Matrix;
Target : Integer;
......@@ -126,27 +125,47 @@ package body System.Generic_Array_Operations is
end loop;
end Sub_Row;
-- Local declarations
Max_Col : Integer := M'Last (2);
-- Start of processing for Back_Substitute
begin
for Row in reverse M'Range (1) loop
Find_Non_Zero : for Col in M'First (2) .. Max_Col loop
Do_Rows : for Row in reverse M'Range (1) loop
Find_Non_Zero : for Col in reverse M'First (2) .. Max_Col loop
if Is_Non_Zero (M (Row, Col)) then
-- Found first non-zero element, so subtract a multiple
-- of this row from all higher rows, to reduce all other
-- elements in this column to zero.
-- Found first non-zero element, so subtract a multiple of this
-- element from all higher rows, to reduce all other elements
-- in this column to zero.
declare
-- We can't use a for loop, as we'd need to iterate to
-- Row - 1, but that expression will overflow if M'First
-- equals Integer'First, which is true for aggregates
-- without explicit bounds..
for J in M'First (1) .. Row - 1 loop
J : Integer := M'First (1);
begin
while J < Row loop
Sub_Row (N, J, Row, (M (J, Col) / M (Row, Col)));
Sub_Row (M, J, Row, (M (J, Col) / M (Row, Col)));
J := J + 1;
end loop;
end;
-- Avoid potential overflow in the subtraction below
exit Do_Rows when Col = M'First (2);
Max_Col := Col - 1;
exit Find_Non_Zero;
end if;
end loop Find_Non_Zero;
end loop;
end loop Do_Rows;
end Back_Substitute;
-----------------------
......@@ -158,7 +177,8 @@ package body System.Generic_Array_Operations is
N : in out Matrix;
Det : out Scalar)
is
pragma Assert (M'First (1) = N'First (1) and then
pragma Assert (M'First (1) = N'First (1)
and then
M'Last (1) = N'Last (1));
-- The following are variations of the elementary matrix row operations:
......@@ -220,8 +240,8 @@ package body System.Generic_Array_Operations is
end loop;
for J in N'Range (2) loop
N (Row - M'First (1) + N'First (1), J)
:= N (Row - M'First (1) + N'First (1), J) / Scale;
N (Row - M'First (1) + N'First (1), J) :=
N (Row - M'First (1) + N'First (1), J) / Scale;
end loop;
end Divide_Row;
......@@ -261,6 +281,8 @@ package body System.Generic_Array_Operations is
end if;
end Switch_Row;
-- Local declarations
Row : Integer := M'First (1);
-- Start of processing for Forward_Eliminate
......@@ -301,7 +323,9 @@ package body System.Generic_Array_Operations is
Row := Row + 1;
else
Det := Zero; -- Zero, but we don't have literals
-- Set zero (note that we do not have literals)
Det := Zero;
end if;
end;
end loop;
......@@ -313,8 +337,7 @@ package body System.Generic_Array_Operations is
function Inner_Product
(Left : Left_Vector;
Right : Right_Vector)
return Result_Scalar
Right : Right_Vector) return Result_Scalar
is
R : Result_Scalar := Zero;
......@@ -337,6 +360,7 @@ package body System.Generic_Array_Operations is
function L2_Norm (X : X_Vector) return Result_Real'Base is
Sum : Result_Real'Base := 0.0;
begin
for J in X'Range loop
Sum := Sum + Result_Real'Base (abs X (J))**2;
......@@ -383,14 +407,14 @@ package body System.Generic_Array_Operations is
function Matrix_Matrix_Elementwise_Operation
(Left : Left_Matrix;
Right : Right_Matrix)
return Result_Matrix
Right : Right_Matrix) return Result_Matrix
is
R : Result_Matrix (Left'Range (1), Left'Range (2));
begin
if Left'Length (1) /= Right'Length (1)
or else Left'Length (2) /= Right'Length (2)
or else
Left'Length (2) /= Right'Length (2)
then
raise Constraint_Error with
"matrices are of different dimension in elementwise operation";
......@@ -423,7 +447,8 @@ package body System.Generic_Array_Operations is
begin
if X'Length (1) /= Y'Length (1)
or else X'Length (2) /= Y'Length (2)
or else
X'Length (2) /= Y'Length (2)
then
raise Constraint_Error with
"matrices are of different dimension in elementwise operation";
......@@ -584,6 +609,7 @@ package body System.Generic_Array_Operations is
end if;
elsif X > Real'Base'Last then
-- X is infinity, which is its own square root
return X;
......@@ -639,8 +665,8 @@ package body System.Generic_Array_Operations is
begin
for M in Left'Range (2) loop
S := S + Left (J, M)
* Right (M - Left'First (2) + Right'First (1), K);
S := S + Left (J, M) *
Right (M - Left'First (2) + Right'First (1), K);
end loop;
R (J, K) := S;
......
gcc/ada/sem_ch12.adb
......@@ -8058,6 +8058,8 @@ package body Sem_Ch12 is
exit when Present (Interface_Alias (Prim_G));
-- Here we install one hidden primitive
if Chars (Prim_G) /= Chars (Prim_A)
and then Has_Suffix (Prim_A, 'P')
and then Remove_Suffix (Prim_A, 'P') = Chars (Prim_G)
......@@ -8076,7 +8078,7 @@ package body Sem_Ch12 is
end loop;
-- Append the elements to the list of temporarily visible primitives
-- avoiding duplicates
-- avoiding duplicates.
if Present (List) then
if No (Prims_List) then
......
gcc/ada/warnsw.adb
......@@ -212,12 +212,16 @@ package body Warnsw is
Warn_On_Modified_Unread := True;
Warn_On_No_Value_Assigned := True;
Warn_On_Non_Local_Exception := False;
Warn_On_Object_Renames_Function := False;
Warn_On_Object_Renames_Function := True;
Warn_On_Obsolescent_Feature := True;
Warn_On_Overlap := True;
Warn_On_Overridden_Size := True;
Warn_On_Parameter_Order := True;
Warn_On_Questionable_Missing_Parens := True;
Warn_On_Record_Holes := False;
Warn_On_Redundant_Constructs := True;
Warn_On_Reverse_Bit_Order := False;
Warn_On_Object_Renames_Function := True;
Warn_On_Suspicious_Contract := True;
Warn_On_Unchecked_Conversion := True;
Warn_On_Unordered_Enumeration_Type := False;
Warn_On_Unrecognized_Pragma := True;
......
gcc/ada/warnsw.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1999-2010, Free Software Foundation, Inc. --
-- Copyright (C) 1999-2011, 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- --
......@@ -65,6 +65,10 @@ package Warnsw is
procedure Set_GNAT_Mode_Warnings;
-- This is called in -gnatg mode to set the warnings for gnat mode. It is
-- also used to set the proper warning statuses for -gnatw.g.
-- also used to set the proper warning statuses for -gnatw.g. Note that
-- this set of warnings is disjoint from -gnatwa, it enables warnings that
-- are not included in -gnatwa, and it disables warnings that are included
-- in -gnatwa (such as Warn_On_Implementation_Units, which we clearly want
-- to be False for units built with -gnatg).
end Warnsw;
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