-------------------------------------------------------------------------------
-- (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.
--
--=============================================================================

-- Given a (sub)type S with range S'First .. S'Last
-- and a base type   T with range T'First .. T'Last
--
-- First, checks that T'First and T'Last are well-defined, or raises sem error 793.
-- Then, if S is real and unconstrained, then no further checks.
-- Then, checks that (S'First >= T'First and S'Last <= T'Last) or raises sem error 794.
--
-- Used to check legality of derived numeric type declarations and base type assertions

separate (Sem.Wf_Basic_Declarative_Item)
procedure Check_Subtype_Against_Basetype_Bounds
  (Base_Type_Sym  : in     Dictionary.Symbol;
   Subtype_First  : in     LexTokenManager.Lex_String;
   Subtype_Last   : in     LexTokenManager.Lex_String;
   Ident_Node_Pos : in     LexTokenManager.Token_Position;
   Range_Node_Pos : in     LexTokenManager.Token_Position;
   Errors         : in out Boolean)
is
   Base_Type_First, Base_Type_Last                                                  : LexTokenManager.Lex_String;
   Type_First_Val, Type_Last_Val, Base_Type_First_Val, Base_Type_Last_Val, Comp_Val : Maths.Value;
   Bounds_OK                                                                        : Boolean;
   Maths_Error1, Maths_Error2                                                       : Maths.ErrorCode;
begin
   -- check that there are defined bounds for the base type, and also that
   -- the range of the type fits within the range of the specified base type
   if not Errors and then Dictionary.IsTypeMark (Base_Type_Sym) then
      Base_Type_First := Dictionary.GetScalarAttributeValue (False, LexTokenManager.First_Token, Base_Type_Sym);
      Base_Type_Last  := Dictionary.GetScalarAttributeValue (False, LexTokenManager.Last_Token, Base_Type_Sym);

      if Base_Type_First = LexTokenManager.Null_String or else Base_Type_Last = LexTokenManager.Null_String then
         if CommandLineData.Content.VCG then
            -- we require that the base type have defined bounds,
            ErrorHandler.Semantic_Error
              (Err_Num   => 793,
               Reference => ErrorHandler.No_Reference,
               Position  => Ident_Node_Pos,
               Id_Str    => LexTokenManager.Null_String);
            Errors := True;
         end if;
      elsif Subtype_First = LexTokenManager.Null_String or else Subtype_Last = LexTokenManager.Null_String then
         -- no check possible with unconstrained ranges
         null;
      else
         -- check that the range of the base type is at least that of the type
         Type_First_Val      := Maths.ValueRep (Subtype_First);
         Type_Last_Val       := Maths.ValueRep (Subtype_Last);
         Base_Type_First_Val := Maths.ValueRep (Base_Type_First);
         Base_Type_Last_Val  := Maths.ValueRep (Base_Type_Last);
         Maths.Lesser (Type_First_Val, Base_Type_First_Val, Comp_Val, Maths_Error1);
         Bounds_OK := (Comp_Val = Maths.FalseValue);
         Maths.Greater (Type_Last_Val, Base_Type_Last_Val, Comp_Val, Maths_Error2);
         Bounds_OK := Bounds_OK and then Comp_Val = Maths.FalseValue;
         if not Bounds_OK and then Maths_Error1 = Maths.NoError and then Maths_Error2 = Maths.NoError then
            ErrorHandler.Semantic_Error
              (Err_Num   => 794,
               Reference => ErrorHandler.No_Reference,
               Position  => Range_Node_Pos,
               Id_Str    => LexTokenManager.Null_String);
            Errors := True;
         end if;
      end if;
   end if;
end Check_Subtype_Against_Basetype_Bounds;
