[multiple changes]

2015-05-21  Robert Dewar  <dewar@adacore.com>

	* 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  <schonberg@adacore.com>

	* 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

+2015-05-21  Robert Dewar  <dewar@adacore.com>
+
+	* 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  <schonberg@adacore.com>
+
+	* 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  <schonberg@adacore.com>
 
 	* sem_ch13.adb (Check_Iterator_Functions): Emit error on Iterator

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;
 

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;

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;

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

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;