-------------
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;
-- 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 --
-----------------------------
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
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
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.
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
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;
projects / gcc.git / commitdiff