From cad97339449568ae711fb6430d56372e0974958d Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 21 May 2015 12:51:22 +0200 Subject: [PATCH] [multiple changes] 2015-05-21 Robert Dewar * freeze.adb: Minor reformatting. * cstand.adb (Print_Standard): Fix bad printing of Duration low bound. * a-reatim.adb (Time_Of): Complete rewrite to properly detect out of range args. 2015-05-21 Ed Schonberg * sem_ch5.adb: add (useless) initial value. * sem_ch3.adb (Replace_Anonymous_Access_To_Protected_Subprogram): Check whether the procedure has parameters before processing formals in ASIS mode. From-SVN: r223477 --- gcc/ada/ChangeLog | 15 ++++ gcc/ada/a-reatim.adb | 165 +++++++++++++++++++++++++++---------------- gcc/ada/cstand.adb | 6 +- gcc/ada/freeze.adb | 6 +- gcc/ada/sem_ch3.adb | 6 +- gcc/ada/sem_ch5.adb | 61 +++++++++++----- 6 files changed, 174 insertions(+), 85 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 230a62b905b..04e0cae6be7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2015-05-21 Robert Dewar + + * freeze.adb: Minor reformatting. + * cstand.adb (Print_Standard): Fix bad printing of Duration + low bound. + * a-reatim.adb (Time_Of): Complete rewrite to properly detect + out of range args. + +2015-05-21 Ed Schonberg + + * sem_ch5.adb: add (useless) initial value. + * sem_ch3.adb (Replace_Anonymous_Access_To_Protected_Subprogram): + Check whether the procedure has parameters before processing + formals in ASIS mode. + 2015-05-21 Ed Schonberg * sem_ch13.adb (Check_Iterator_Functions): Emit error on Iterator diff --git a/gcc/ada/a-reatim.adb b/gcc/ada/a-reatim.adb index 0405a0b1b29..c259e817644 100644 --- a/gcc/ada/a-reatim.adb +++ b/gcc/ada/a-reatim.adb @@ -227,78 +227,119 @@ package body Ada.Real_Time is ------------- function Time_Of (SC : Seconds_Count; TS : Time_Span) return Time is + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + -- We do all our own checks for this function + + -- This is not such a simple case, since TS is already 64 bits, and + -- so we can't just promote everything to a wider type to ensure proper + -- testing for overflow. The situation is that Seconds_Count is a MUCH + -- wider type than Time_Span and Time (both of which have the underlying + -- type Duration). + + -- <------------------- Seconds_Count --------------------> + -- <-- Duration --> + + -- Now it is possible for an SC value outside the Duration range to + -- be "brought back into range" by an appropriate TS value, but there + -- are also clearly SC values that are completely out of range. Note + -- that the above diagram is wildly out of scale, the difference in + -- ranges is much greater than shown. + + -- We can't just go generating out of range Duration values to test for + -- overflow, since Duration is a full range type, so we follow the steps + -- shown below. + + SC_Lo : constant Seconds_Count := + Seconds_Count (Duration (Time_Span_First) + Duration'(0.5)); + SC_Hi : constant Seconds_Count := + Seconds_Count (Duration (Time_Span_Last) - Duration'(0.5)); + -- These are the maximum values of the seconds (integer) part of the + -- Duration range. Used to compute and check the seconds in the result. + + TS_SC : Seconds_Count; + -- Seconds part of input value + + TS_Fraction : Duration; + -- Fractional part of input value, may be negative + + Result_SC : Seconds_Count; + -- Seconds value for result + + Fudge : constant Seconds_Count := 10; + -- Fudge value used to do end point checks far from end point + + FudgeD : constant Duration := Duration (Fudge); + -- Fudge value as Duration + + Fudged_Result : Duration; + -- Result fudged up or down by FudgeD + + procedure Out_Of_Range; + pragma No_Return (Out_Of_Range); + -- Raise exception for result out of range + + ------------------ + -- Out_Of_Range -- + ------------------ + + procedure Out_Of_Range is + begin + raise Constraint_Error with + "result for Ada.Real_Time.Time_Of is out of range"; + end Out_Of_Range; + + -- Start of processing for Time_Of + begin - -- Simple case first, TS = 0.0, we need to make sure SC is in range + -- If SC is so far out of range that there is no possibility of the + -- addition of TS getting it back in range, raise an exception right + -- away. That way we don't have to worry about SC values overflowing. + + if SC < 3 * SC_Lo or else SC > 3 * SC_Hi then + Out_Of_Range; + end if; + + -- Decompose input TS value + + TS_SC := Seconds_Count (Duration (TS)); + TS_Fraction := Duration (TS) - Duration (TS_SC); + + -- Compute result seconds. If clearly out of range, raise error now - if TS = 0.0 then - if SC >= Seconds_Count (Duration (Time_Span_First) + Duration'(0.5)) - and then - SC <= Seconds_Count (Duration (Time_Span_Last) - Duration'(0.5)) - then - -- Don't need any further checks after that manual check + Result_SC := SC + TS_SC; - declare - pragma Suppress (All_Checks); - begin - return Time (SC); - end; + if Result_SC < (SC_Lo - 1) or else Result_SC > (SC_Hi + 1) then + Out_Of_Range; + end if; + + -- Now the result is simply Result_SC + TS_Fraction, but we can't just + -- go computing that since it might be out of range. So what we do is + -- to compute a value fudged down or up by 10.0 (arbitrary value, but + -- that will do fine), and check that fudged value, and if in range + -- unfudge it and return the result. - -- Here we have a Seconds_Count value that is out of range + -- Fudge positive result down, and check high bound + if Result_SC > 0 then + Fudged_Result := Duration (Result_SC - Fudge) + TS_Fraction; + + if Fudged_Result <= Duration'Last - FudgeD then + return Time (Fudged_Result + FudgeD); else - raise Constraint_Error; + Out_Of_Range; end if; - end if; - -- We want to return Time (SC) + TS. To avoid spurious overflows in - -- the intermediate result Time (SC) we take advantage of the different - -- signs in SC and TS (when that is the case). - - -- If the signs of SC and TS are different then we avoid converting SC - -- to Time (as we do in the else part). The reason for that is that SC - -- converted to Time may overflow the range of Time, while the addition - -- of SC plus TS does not overflow (because of their different signs). - -- The approach is to add and remove the greatest value of time - -- (greatest absolute value) to both SC and TS. SC and TS have different - -- signs, so we add the positive constant to the negative value, and the - -- negative constant to the positive value, to prevent overflows. - - if (SC > 0 and then TS < 0.0) or else (SC < 0 and then TS > 0.0) then - declare - Closest_Boundary : constant Seconds_Count := - (if TS >= 0.0 then - Seconds_Count (Time_Span_Last - Time_Span (0.5)) - else - Seconds_Count (Time_Span_First + Time_Span (0.5))); - -- Value representing the integer part of the Time_Span boundary - -- closest to TS (its number of seconds). Truncate towards zero - -- to be sure that transforming this value back into Time cannot - -- overflow (when SC is equal to 0). The sign of Closest_Boundary - -- is always different from the sign of SC, hence avoiding - -- overflow in the expression Time (SC + Closest_Boundary) - -- which is part of the return statement. - - Dist_To_Boundary : constant Time_Span := - TS - Time_Span (Closest_Boundary); - -- Distance between TS and Closest_Boundary expressed in Time_Span - -- Both operands in the subtraction have the same sign, hence - -- avoiding overflow. - - begin - -- Both operands in the inner addition have different signs, - -- hence avoiding overflow. The Time () conversion and the outer - -- addition can overflow only if SC + TC is not within Time'Range. - - return Time (SC + Closest_Boundary) + Dist_To_Boundary; - end; - - -- Both operands have the same sign, so we can convert SC into Time - -- right away; if this conversion overflows then the result of adding SC - -- and TS would overflow anyway (so we would just be detecting the - -- overflow a bit earlier). + -- Same for negative values of seconds, fundge up and check low bound else - return Time (SC) + TS; + Fudged_Result := Duration (Result_SC + Fudge) + TS_Fraction; + + if Fudged_Result >= Duration'First + FudgeD then + return Time (Fudged_Result - FudgeD); + else + Out_Of_Range; + end if; end if; end Time_Of; diff --git a/gcc/ada/cstand.adb b/gcc/ada/cstand.adb index a86397cb9ba..da30887b36d 100644 --- a/gcc/ada/cstand.adb +++ b/gcc/ada/cstand.adb @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -2033,13 +2033,13 @@ package body CStand is if Duration_32_Bits_On_Target then P (" type Duration is delta 0.020"); - P (" range -((2 ** 31 - 1) * 0.020) .."); + P (" range -((2 ** 31) * 0.020) .."); P (" +((2 ** 31 - 1) * 0.020);"); P (" for Duration'Small use 0.020;"); else P (" type Duration is delta 0.000000001"); - P (" range -((2 ** 63 - 1) * 0.000000001) .."); + P (" range -((2 ** 63) * 0.000000001) .."); P (" +((2 ** 63 - 1) * 0.000000001);"); P (" for Duration'Small use 0.000000001;"); end if; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 14c2aa3336f..b87027ded73 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -4290,7 +4290,7 @@ package body Freeze is end if; end if; - -- Make sure that if we have terator aspect, then we have + -- Make sure that if we have an iterator aspect, then we have -- either Constant_Indexing or Variable_Indexing. declare @@ -4305,14 +4305,14 @@ package body Freeze is if Present (Iterator_Aspect) then if Has_Aspect (Rec, Aspect_Constant_Indexing) - or else + or else Has_Aspect (Rec, Aspect_Variable_Indexing) then null; else Error_Msg_N ("Iterator_Element requires indexing aspect", - Iterator_Aspect); + Iterator_Aspect); end if; end if; end; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 75bf87448a7..565efe01dbb 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -5834,7 +5834,11 @@ package body Sem_Ch3 is Set_Scope (Typ, Current_Scope); Push_Scope (Typ); - Process_Formals (Parameter_Specifications (Spec), Spec); + -- Nothing to do if procedure is parameterless + + if Present (Parameter_Specifications (Spec)) then + Process_Formals (Parameter_Specifications (Spec), Spec); + end if; if Nkind (Spec) = N_Access_Function_Definition then declare diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index eb742438510..38c32df4c1e 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -1726,6 +1726,11 @@ package body Sem_Ch5 is -- indicator, verify that the container type has an Iterate aspect that -- implements the reversible iterator interface. + function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id; + -- For containers with Iterator and related aspects, the cursor the + -- is obtained by locating an entity with the proper name in the + -- scope of the type. + ----------------------------- -- Check_Reverse_Iteration -- ----------------------------- @@ -1741,6 +1746,34 @@ package body Sem_Ch5 is end if; end Check_Reverse_Iteration; + --------------------- + -- Get_Cursor_Type -- + --------------------- + + function Get_Cursor_Type (Typ : Entity_Id) return Entity_Id is + Ent : Entity_Id; + + begin + Ent := First_Entity (Scope (Typ)); + while Present (Ent) loop + exit when Chars (Ent) = Name_Cursor; + Next_Entity (Ent); + end loop; + + if No (Ent) then + return Any_Type; + end if; + + -- The cursor is the target of generated assignments in the + -- loop, and cannot have a limited type. + + if Is_Limited_Type (Etype (Ent)) then + Error_Msg_N ("cursor type cannot be limited", N); + end if; + + return Etype (Ent); + end Get_Cursor_Type; + -- Start of processing for Analyze_iterator_Specification begin @@ -2054,8 +2087,9 @@ package body Sem_Ch5 is else declare - Element : constant Entity_Id := + Element : constant Entity_Id := Find_Value_Of_Aspect (Typ, Aspect_Iterator_Element); + Cursor_Type : Entity_Id; begin if No (Element) then @@ -2064,6 +2098,8 @@ package body Sem_Ch5 is else Set_Etype (Def_Id, Entity (Element)); + Cursor_Type := Get_Cursor_Type (Typ); + pragma Assert (Present (Cursor_Type)); -- If subtype indication was given, verify that it covers -- the element type of the container. @@ -2139,8 +2175,15 @@ package body Sem_Ch5 is begin if Iter_Kind = N_Selected_Component then Obj := Prefix (Original_Node (Iter_Name)); + elsif Iter_Kind = N_Function_Call then Obj := First_Actual (Original_Node (Iter_Name)); + + -- If neither, likely previous error, make sure Obj has some + -- reasonable value in such a case. + + else + Obj := Iter_Name; end if; if Nkind (Obj) = N_Selected_Component @@ -2166,23 +2209,9 @@ package body Sem_Ch5 is Ent := Etype (Def_Id); else - Ent := First_Entity (Scope (Typ)); - while Present (Ent) loop - if Chars (Ent) = Name_Cursor then - Set_Etype (Def_Id, Etype (Ent)); - exit; - end if; - - Next_Entity (Ent); - end loop; + Set_Etype (Def_Id, Get_Cursor_Type (Typ)); end if; - -- The cursor is the target of generated assignments in the - -- loop, and cannot have a limited type. - - if Is_Limited_Type (Etype (Def_Id)) then - Error_Msg_N ("cursor type cannot be limited", N); - end if; end if; end if; -- 2.30.2