From 76c597a1fc1b674e2afaaa483b925f3637eb0d48 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 9 Apr 2009 10:21:08 +0200 Subject: [multiple changes] 2009-04-09 Thomas Quinot * exp_ch4.adb (Expand_Concatenate): Add circuitry to properly handle overflows in computation of bounds. 2009-04-09 Pascal Obry * a-cihama.adb, a-cgcaso.adb, a-cihase.adb, a-cohase.adb: Fix some typos in comment. From-SVN: r145803 --- gcc/ada/ChangeLog | 10 ++++ gcc/ada/a-cgcaso.adb | 2 +- gcc/ada/a-cihama.adb | 2 +- gcc/ada/a-cihase.adb | 2 +- gcc/ada/a-cohase.adb | 4 +- gcc/ada/exp_ch4.adb | 148 ++++++++++++++++++++++++++++++++------------------- 6 files changed, 108 insertions(+), 60 deletions(-) (limited to 'gcc') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1756db0..1a5089c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2009-04-09 Thomas Quinot + + * exp_ch4.adb (Expand_Concatenate): Add circuitry to properly handle + overflows in computation of bounds. + +2009-04-09 Pascal Obry + + * a-cihama.adb, a-cgcaso.adb, a-cihase.adb, a-cohase.adb: Fix some + typos in comment. + 2009-04-09 Robert Dewar * sem_attr.adb (Check_Stream_Attribute): Check violation of diff --git a/gcc/ada/a-cgcaso.adb b/gcc/ada/a-cgcaso.adb index 747c2a9..760238d 100644 --- a/gcc/ada/a-cgcaso.adb +++ b/gcc/ada/a-cgcaso.adb @@ -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]) diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb index 16658a2..faca39b 100644 --- a/gcc/ada/a-cihama.adb +++ b/gcc/ada/a-cihama.adb @@ -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; diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb index 50a30af..aac3509 100644 --- a/gcc/ada/a-cihase.adb +++ b/gcc/ada/a-cihase.adb @@ -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; diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index a3de950..61598ee 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -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; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 78c4285..f49afe7 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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; <> @@ -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; ------------------------ -- cgit v1.1