-------------------------------------------------------------------------------
-- (C) Altran Praxis Limited
-------------------------------------------------------------------------------
--
-- The SPARK toolset is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the Free
-- Software Foundation; either version 3, or (at your option) any later
-- version. The SPARK toolset is distributed in the hope that it will be
-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
-- Public License for more details. You should have received a copy of the GNU
-- General Public License distributed with the SPARK toolset; see file
-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy of
-- the license.
--
--=============================================================================

-- This  routine checks that  a value  supplied will  fit in  a type          --
-- supplied.  It does nothing if  the type is Unknown or non-scalar           --
-- or if the value is unknown.  If the type is REAL then constraint           --
-- violations are reported as  warnings (because limitations of our           --
-- handling  of  reals  mean  that  false alarms  may  occur.   For           --
-- integers and enumerations constraint violations are errors.                --
--------------------------------------------------------------------------------

separate (Sem)
procedure Constraint_Check
  (Val           : in     Maths.Value;
   New_Val       :    out Maths.Value;
   Is_Annotation : in     Boolean;
   Typ           : in     Dictionary.Symbol;
   Position      : in     LexTokenManager.Token_Position)
is
   Lower_Bound, Upper_Bound, Result : Maths.Value;
   Error                            : Maths.ErrorCode;

   -------------------------------

   procedure Raise_Error_Or_Warning
     (Result        : in     Maths.Value;
      Error         : in     Maths.ErrorCode;
      Is_Annotation : in     Boolean;
      Position      : in     LexTokenManager.Token_Position;
      New_Val       : in out Maths.Value)
   --# global in     CommandLineData.Content;
   --#        in     Dictionary.Dict;
   --#        in     LexTokenManager.State;
   --#        in out ErrorHandler.Error_Context;
   --#        in out SPARK_IO.File_Sys;
   --# derives ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         Error,
   --#                                         ErrorHandler.Error_Context,
   --#                                         Is_Annotation,
   --#                                         LexTokenManager.State,
   --#                                         Position,
   --#                                         Result,
   --#                                         SPARK_IO.File_Sys &
   --#         New_Val                    from *,
   --#                                         Error,
   --#                                         Result;
   is
   begin
      if Error = Maths.NoError then
         if Result = Maths.TrueValue then
            New_Val := Maths.NoValue;
            if Is_Annotation then
               ErrorHandler.Semantic_Error
                 (Err_Num   => 399,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Position,
                  Id_Str    => LexTokenManager.Null_String);
            else
               ErrorHandler.Semantic_Error
                 (Err_Num   => 402,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Position,
                  Id_Str    => LexTokenManager.Null_String);
            end if;
         end if;
      elsif Error = Maths.OverFlow then
         -- Arithmetic overflow. Constraint check has not been peformed.
         ErrorHandler.Semantic_Warning (Err_Num  => 202,
                                        Position => Position,
                                        Id_Str   => LexTokenManager.Null_String);
      end if;
   end Raise_Error_Or_Warning;

begin -- Constraint_Check
   New_Val := Val;
   if Dictionary.TypeIsScalar (Typ) and then not Maths.HasNoValue (Val) and then not Dictionary.IsUnknownTypeMark (Typ) then
      Lower_Bound :=
        Maths.ValueRep
        (Dictionary.GetScalarAttributeValue (False, -- without base
                                             LexTokenManager.First_Token, Typ));
      if not Maths.HasNoValue (Lower_Bound) then
         Maths.Lesser (Val, Lower_Bound, Result, Error);
         Raise_Error_Or_Warning
           (Result        => Result,
            Error         => Error,
            Is_Annotation => Is_Annotation,
            Position      => Position,
            New_Val       => New_Val);

         if Error = Maths.NoError then
            Upper_Bound :=
              Maths.ValueRep
              (Dictionary.GetScalarAttributeValue (False, -- without base
                                                   LexTokenManager.Last_Token, Typ));
            if not Maths.HasNoValue (Upper_Bound) then
               Maths.Greater (Val, Upper_Bound, Result, Error);
               Raise_Error_Or_Warning
                 (Result        => Result,
                  Error         => Error,
                  Is_Annotation => Is_Annotation,
                  Position      => Position,
                  New_Val       => New_Val);
            end if;
         end if;
      end if;
   end if;
end Constraint_Check;
