[multiple changes]
2009-04-09 Thomas Quinot <quinot@adacore.com> * exp_ch4.adb (Expand_Concatenate): Add circuitry to properly handle overflows in computation of bounds. 2009-04-09 Pascal Obry <obry@adacore.com> * a-cihama.adb, a-cgcaso.adb, a-cihase.adb, a-cohase.adb: Fix some typos in comment. From-SVN: r145803
This commit is contained in:
parent
95b89f1bf9
commit
76c597a1fc
|
@ -1,3 +1,13 @@
|
|||
2009-04-09 Thomas Quinot <quinot@adacore.com>
|
||||
|
||||
* exp_ch4.adb (Expand_Concatenate): Add circuitry to properly handle
|
||||
overflows in computation of bounds.
|
||||
|
||||
2009-04-09 Pascal Obry <obry@adacore.com>
|
||||
|
||||
* a-cihama.adb, a-cgcaso.adb, a-cihase.adb, a-cohase.adb: Fix some
|
||||
typos in comment.
|
||||
|
||||
2009-04-09 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* sem_attr.adb (Check_Stream_Attribute): Check violation of
|
||||
|
|
|
@ -26,7 +26,7 @@
|
|||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- This unit has originally being developed by Matthew J Heaney. --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
-- This algorithm was adapted from GNAT.Heap_Sort_G (see g-hesorg.ad[sb])
|
||||
|
|
|
@ -26,7 +26,7 @@
|
|||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- This unit has originally being developed by Matthew J Heaney. --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Containers.Hash_Tables.Generic_Operations;
|
||||
|
|
|
@ -26,7 +26,7 @@
|
|||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- This unit has originally being developed by Matthew J Heaney. --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Unchecked_Deallocation;
|
||||
|
|
|
@ -6,7 +6,7 @@
|
|||
-- --
|
||||
-- B o d y --
|
||||
-- --
|
||||
-- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
|
||||
-- Copyright (C) 2004-2008, 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- --
|
||||
|
@ -26,7 +26,7 @@
|
|||
-- however invalidate any other reasons why the executable file might be --
|
||||
-- covered by the GNU Public License. --
|
||||
-- --
|
||||
-- This unit has originally being developed by Matthew J Heaney. --
|
||||
-- This unit was originally developed by Matthew J Heaney. --
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
with Ada.Unchecked_Deallocation;
|
||||
|
|
|
@ -2232,12 +2232,16 @@ package body Exp_Ch4 is
|
|||
|
||||
function To_Artyp (X : Node_Id) return Node_Id;
|
||||
-- Given a node of type Ityp, returns the corresponding value of type
|
||||
-- Artyp. For non-enumeration types, this is the identity. For enum
|
||||
-- types, the Pos of the value is returned.
|
||||
-- Artyp. For non-enumeration types, this is a plain integer conversion.
|
||||
-- For enum types, the Pos of the value is returned.
|
||||
|
||||
function To_Ityp (X : Node_Id) return Node_Id;
|
||||
-- The inverse function (uses Val in the case of enumeration types)
|
||||
|
||||
Known_Non_Null_Operand_Seen : Boolean;
|
||||
-- Set True during generation of the assignements of operands into
|
||||
-- result once an operand known to be non-null has been seen.
|
||||
|
||||
--------------
|
||||
-- To_Artyp --
|
||||
--------------
|
||||
|
@ -2275,38 +2279,10 @@ package body Exp_Ch4 is
|
|||
-- Case where we will do a type conversion
|
||||
|
||||
else
|
||||
-- If the value is known at compile time, and known to be out of
|
||||
-- range of the index subtype or its base type, we can signal that
|
||||
-- we are sure to have a constraint error at run time.
|
||||
|
||||
-- There are two reasons for doing this. First of all, it is of
|
||||
-- course nice to detect situations of certain exceptions, and
|
||||
-- generate a warning. But there is a more important reason. If
|
||||
-- the high bound is out of range of the base type, and is a
|
||||
-- literal, then that would cause a compilation illegality when
|
||||
-- we analyzed and resolved the expression.
|
||||
|
||||
Set_Parent (X, Cnode);
|
||||
Analyze_And_Resolve (X, Artyp, Suppress => All_Checks);
|
||||
|
||||
if Compile_Time_Compare
|
||||
(X, Type_High_Bound (Istyp), Assume_Valid => False) = GT
|
||||
or else
|
||||
Compile_Time_Compare
|
||||
(X, Type_High_Bound (Ityp), Assume_Valid => False) = GT
|
||||
then
|
||||
Apply_Compile_Time_Constraint_Error
|
||||
(N => Cnode,
|
||||
Msg => "concatenation result upper bound out of range?",
|
||||
Reason => CE_Range_Check_Failed);
|
||||
raise Concatenation_Error;
|
||||
|
||||
if Ityp = Base_Type (Artyp) then
|
||||
return X;
|
||||
else
|
||||
if Ityp = Base_Type (Artyp) then
|
||||
return X;
|
||||
else
|
||||
return Convert_To (Ityp, X);
|
||||
end if;
|
||||
return Convert_To (Ityp, X);
|
||||
end if;
|
||||
end if;
|
||||
end To_Ityp;
|
||||
|
@ -2320,6 +2296,8 @@ package body Exp_Ch4 is
|
|||
Clen : Node_Id;
|
||||
Set : Boolean;
|
||||
|
||||
Saved_In_Inlined_Body : Boolean;
|
||||
|
||||
begin
|
||||
Aggr_Length (0) := Make_Integer_Literal (Loc, 0);
|
||||
|
||||
|
@ -2607,9 +2585,7 @@ package body Exp_Ch4 is
|
|||
|
||||
Suppress => All_Checks);
|
||||
|
||||
Aggr_Length (NN) :=
|
||||
Make_Identifier (Loc,
|
||||
Chars => Chars (Ent));
|
||||
Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent));
|
||||
end if;
|
||||
|
||||
<<Continue>>
|
||||
|
@ -2707,8 +2683,7 @@ package body Exp_Ch4 is
|
|||
|
||||
begin
|
||||
Ent :=
|
||||
Make_Defining_Identifier (Loc,
|
||||
Chars => New_Internal_Name ('L'));
|
||||
Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('L'));
|
||||
|
||||
Insert_Action (Cnode,
|
||||
Make_Object_Declaration (Loc,
|
||||
|
@ -2722,7 +2697,8 @@ package body Exp_Ch4 is
|
|||
end;
|
||||
end if;
|
||||
|
||||
-- Now find the upper bound, normally this is Low_Bound + Length - 1
|
||||
-- Now we can safely compute the upper bound, normally
|
||||
-- Low_Bound + Length - 1.
|
||||
|
||||
High_Bound :=
|
||||
To_Ityp (
|
||||
|
@ -2733,7 +2709,11 @@ package body Exp_Ch4 is
|
|||
Left_Opnd => New_Copy (Aggr_Length (NN)),
|
||||
Right_Opnd => Make_Integer_Literal (Loc, 1))));
|
||||
|
||||
-- But there is one exception, namely when the result is null in which
|
||||
-- Now force overflow checking on High_Bound
|
||||
|
||||
Activate_Overflow_Check (High_Bound);
|
||||
|
||||
-- Handle the exceptional case where the result is null, in which case
|
||||
-- case the bounds come from the last operand (so that we get the proper
|
||||
-- bounds if the last operand is super-flat).
|
||||
|
||||
|
@ -2754,6 +2734,17 @@ package body Exp_Ch4 is
|
|||
Make_Defining_Identifier (Loc,
|
||||
Chars => New_Internal_Name ('S'));
|
||||
|
||||
-- Kludge! Kludge! ???
|
||||
-- If the bound is statically known to be out of range, we do not want
|
||||
-- to abort, we want a warning and a runtime constraint error, so we
|
||||
-- pretend this comes from an inlined body (otherwise a static out
|
||||
-- of range value would be an illegality).
|
||||
|
||||
-- This is horrible, we really must find a better way ???
|
||||
|
||||
Saved_In_Inlined_Body := In_Inlined_Body;
|
||||
In_Inlined_Body := True;
|
||||
|
||||
Insert_Action (Cnode,
|
||||
Make_Object_Declaration (Loc,
|
||||
Defining_Identifier => Ent,
|
||||
|
@ -2766,11 +2757,20 @@ package body Exp_Ch4 is
|
|||
Make_Range (Loc,
|
||||
Low_Bound => Low_Bound,
|
||||
High_Bound => High_Bound))))),
|
||||
|
||||
Suppress => All_Checks);
|
||||
|
||||
In_Inlined_Body := Saved_In_Inlined_Body;
|
||||
|
||||
-- Catch the static out of range case now
|
||||
|
||||
if Raises_Constraint_Error (High_Bound) then
|
||||
raise Concatenation_Error;
|
||||
end if;
|
||||
|
||||
-- Now we will generate the assignments to do the actual concatenation
|
||||
|
||||
Known_Non_Null_Operand_Seen := False;
|
||||
|
||||
for J in 1 .. NN loop
|
||||
declare
|
||||
Lo : constant Node_Id :=
|
||||
|
@ -2790,6 +2790,7 @@ package body Exp_Ch4 is
|
|||
-- Singleton case, simple assignment
|
||||
|
||||
if Base_Type (Etype (Operands (J))) = Ctyp then
|
||||
Known_Non_Null_Operand_Seen := True;
|
||||
Insert_Action (Cnode,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name =>
|
||||
|
@ -2799,20 +2800,47 @@ package body Exp_Ch4 is
|
|||
Expression => Operands (J)),
|
||||
Suppress => All_Checks);
|
||||
|
||||
-- Array case, slice assignment
|
||||
-- Array case, slice assignment, skipped when argument is fixed
|
||||
-- length and known to be null.
|
||||
|
||||
else
|
||||
Insert_Action (Cnode,
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name =>
|
||||
Make_Slice (Loc,
|
||||
Prefix => New_Occurrence_Of (Ent, Loc),
|
||||
Discrete_Range =>
|
||||
Make_Range (Loc,
|
||||
Low_Bound => To_Ityp (Lo),
|
||||
High_Bound => To_Ityp (Hi))),
|
||||
Expression => Operands (J)),
|
||||
Suppress => All_Checks);
|
||||
elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then
|
||||
declare
|
||||
Assign : Node_Id :=
|
||||
Make_Assignment_Statement (Loc,
|
||||
Name =>
|
||||
Make_Slice (Loc,
|
||||
Prefix =>
|
||||
New_Occurrence_Of (Ent, Loc),
|
||||
Discrete_Range =>
|
||||
Make_Range (Loc,
|
||||
Low_Bound => To_Ityp (Lo),
|
||||
High_Bound => To_Ityp (Hi))),
|
||||
Expression => Operands (J));
|
||||
begin
|
||||
if Is_Fixed_Length (J) then
|
||||
Known_Non_Null_Operand_Seen := True;
|
||||
|
||||
elsif not Known_Non_Null_Operand_Seen then
|
||||
|
||||
-- Here if operand length is not statically known and no
|
||||
-- operand known to be non-null has been processed yet.
|
||||
-- If operand length is 0, we do not need to perform the
|
||||
-- assignment, and we must avoid the evaluation of the
|
||||
-- high bound of the slice, since it may underflow if the
|
||||
-- low bound is Ityp'First.
|
||||
|
||||
Assign :=
|
||||
Make_Implicit_If_Statement (Cnode,
|
||||
Condition =>
|
||||
Make_Op_Ne (Loc,
|
||||
Left_Opnd =>
|
||||
New_Occurrence_Of (Var_Length (J), Loc),
|
||||
Right_Opnd => Make_Integer_Literal (Loc, 0)),
|
||||
Then_Statements =>
|
||||
New_List (Assign));
|
||||
end if;
|
||||
Insert_Action (Cnode, Assign, Suppress => All_Checks);
|
||||
end;
|
||||
end if;
|
||||
end;
|
||||
end loop;
|
||||
|
@ -2827,7 +2855,17 @@ package body Exp_Ch4 is
|
|||
|
||||
exception
|
||||
when Concatenation_Error =>
|
||||
Set_Etype (Cnode, Atyp);
|
||||
|
||||
-- Kill warning generated for the declaration of the static out of
|
||||
-- range high bound, and instead generate a Constraint_Error with
|
||||
-- an appropriate specific message.
|
||||
|
||||
Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
|
||||
Apply_Compile_Time_Constraint_Error
|
||||
(N => Cnode,
|
||||
Msg => "concatenation result upper bound out of range?",
|
||||
Reason => CE_Range_Check_Failed);
|
||||
-- Set_Etype (Cnode, Atyp);
|
||||
end Expand_Concatenate;
|
||||
|
||||
------------------------
|
||||
|
|
Loading…
Reference in New Issue