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

----------------------------------------------------------------------------
-- Overview: Called to check validity of a
-- arange node.  Replaces calls to StaticARange, BaseTypeARange and
-- CheckTypeARange
----------------------------------------------------------------------------

separate (Sem.Walk_Expression_P)
procedure Wf_Arange (Node    : in     STree.SyntaxNode;
                     Scope   : in     Dictionary.Scopes;
                     E_Stack : in out Exp_Stack.Exp_Stack_Type) is
   Next_Node             : STree.SyntaxNode;
   Left, Right, Result   : Sem.Exp_Record;
   Left_Type, Right_Type : Dictionary.Symbol;

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

   procedure Integer_Implicit_Type_Conversion (Left_Type, Right_Type : in out Dictionary.Symbol;
                                               Scope                 : in     Dictionary.Scopes)
   --# global in Dictionary.Dict;
   --# derives Left_Type,
   --#         Right_Type from Dictionary.Dict,
   --#                         Left_Type,
   --#                         Right_Type,
   --#                         Scope;
   is
   begin
      if Dictionary.IsUniversalIntegerType (Left_Type) then
         if Dictionary.IsIntegerTypeMark (Right_Type, Scope) or else Dictionary.IsModularTypeMark (Right_Type, Scope) then
            Left_Type := Right_Type;
         end if;
      elsif Dictionary.IsUniversalIntegerType (Right_Type) then
         if Dictionary.IsIntegerTypeMark (Left_Type, Scope) or else Dictionary.IsModularTypeMark (Left_Type, Scope) then
            Right_Type := Left_Type;
         end if;
      end if;
   end Integer_Implicit_Type_Conversion;

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

   procedure Real_Implicit_Type_Conversion (Left_Type, Right_Type : in out Dictionary.Symbol;
                                            Scope                 : in     Dictionary.Scopes)
   --# global in Dictionary.Dict;
   --# derives Left_Type,
   --#         Right_Type from Dictionary.Dict,
   --#                         Left_Type,
   --#                         Right_Type,
   --#                         Scope;
   is
   begin
      if Dictionary.IsUniversalRealType (Left_Type) then
         if Dictionary.IsRealTypeMark (Right_Type, Scope) then
            Left_Type := Right_Type;
         end if;
      elsif Dictionary.IsUniversalRealType (Right_Type) then
         if Dictionary.IsRealTypeMark (Left_Type, Scope) then
            Right_Type := Left_Type;
         end if;
      end if;
   end Real_Implicit_Type_Conversion;

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

   function Range_Is_Empty (Left, Right : Maths.Value) return Boolean is
      Unused       : Maths.ErrorCode;
      Maths_Result : Maths.Value;
      Func_Result  : Boolean;
   begin
      --# accept Flow, 10, Unused, "Expected ineffective assignment : not used because it can only be ok or type mismatch";
      Maths.Lesser (Right, Left,
                    -- to get
                    Maths_Result, Unused);
      --# end accept;
      --# accept Flow, 10, Unused, "Expected ineffective assignment";
      Maths.ValueToBool (Maths_Result,
                         -- to get
                         Func_Result, Unused);
      --# end accept;
      --# accept Flow, 33, Unused, "Expected to be neither referenced nor exported";
      return Func_Result;
   end Range_Is_Empty;

begin -- Wf_Arange
   Next_Node := STree.Child_Node (Current_Node => Node);
   -- ASSUME Next_Node = attribute            OR simple_expression
   --                    annotation_attribute OR annotation_simple_expression
   if STree.Syntax_Node_Type (Node => Next_Node) = SP_Symbols.attribute
     or else STree.Syntax_Node_Type (Node => Next_Node) = SP_Symbols.annotation_attribute then
      -- ASSUME Next_Node = attribute OR annotation_attribute
      Exp_Stack.Pop (Item  => Result,
                     Stack => E_Stack);
      if not Result.Is_ARange then
         Result.Is_ARange            := True;
         Result.Errors_In_Expression := True;
         ErrorHandler.Semantic_Error
           (Err_Num   => 98,
            Reference => ErrorHandler.No_Reference,
            Position  => STree.Node_Position (Node => Next_Node),
            Id_Str    => LexTokenManager.Null_String);
      end if;
   elsif STree.Syntax_Node_Type (Node => Next_Node) = SP_Symbols.simple_expression
     or else STree.Syntax_Node_Type (Node => Next_Node) = SP_Symbols.annotation_simple_expression then
      -- ASSUME Next_Node = simple_expression OR annotation_simple_expression
      -- explicit range of the form "Left .. Right"
      Exp_Stack.Pop (Item  => Right,
                     Stack => E_Stack);
      Exp_Stack.Pop (Item  => Left,
                     Stack => E_Stack);

      Result := Null_Type_Record; -- safety : we may not set all fields below

      -- In this case neither "Left" nor "Right" can themselves denote a Range.
      -- The following two checks prevent cases such as
      --   S'First .. S'Range
      --   S'Range .. S'Last
      --   S'Range .. S'Range
      -- which are all illegal.  We check both Left and Right separately so
      -- that two errors are issued for the latter case.

      if Left.Is_ARange then
         Result := Sem.Unknown_Type_Record;
         ErrorHandler.Semantic_Error
           (Err_Num   => 114,
            Reference => ErrorHandler.No_Reference,
            Position  => STree.Node_Position (Node => Next_Node),
            Id_Str    => LexTokenManager.Null_String);
      end if;

      if Right.Is_ARange then
         Result := Sem.Unknown_Type_Record;
         ErrorHandler.Semantic_Error
           (Err_Num   => 114,
            Reference => ErrorHandler.No_Reference,
            Position  => STree.Node_Position (Node => STree.Next_Sibling (Next_Node)),
            Id_Str    => LexTokenManager.Null_String);
      end if;

      if not Left.Is_ARange and then not Right.Is_ARange then
         -- Neither Left nor Right is a Range, so we can proceed...
         Result.Is_Constant := Left.Is_Constant and then Right.Is_Constant;
         Result.Is_Static   := Left.Is_Static and then Right.Is_Static;
         Result.Is_ARange   := True;
         Left_Type          := Dictionary.GetRootType (Left.Type_Symbol);
         Right_Type         := Dictionary.GetRootType (Right.Type_Symbol);
         Integer_Implicit_Type_Conversion (Left_Type  => Left_Type,
                                           Right_Type => Right_Type,
                                           Scope      => Scope);
         Real_Implicit_Type_Conversion (Left_Type  => Left_Type,
                                        Right_Type => Right_Type,
                                        Scope      => Scope);
         if not Dictionary.Types_Are_Equal
           (Left_Symbol        => Left_Type,
            Right_Symbol       => Right_Type,
            Full_Range_Subtype => False) then
            Result := Sem.Unknown_Type_Record;
            ErrorHandler.Semantic_Error
              (Err_Num   => 42,
               Reference => ErrorHandler.No_Reference,
               Position  => STree.Node_Position (Node => STree.Next_Sibling (Next_Node)),
               Id_Str    => LexTokenManager.Null_String);
         elsif not (Dictionary.IsScalarType (Left_Type, Scope) or else Dictionary.IsUnknownTypeMark (Left_Type)) then
            Result := Sem.Unknown_Type_Record;
            ErrorHandler.Semantic_Error
              (Err_Num   => 44,
               Reference => ErrorHandler.No_Reference,
               Position  => STree.Node_Position (Node => Node),
               Id_Str    => LexTokenManager.Null_String);
         else
            Result.Type_Symbol := Left_Type;
            Result.Value       := Left.Value;
            Result.Range_RHS   := Right.Value;

            -- check that static range is non empty
            if STree.Syntax_Node_Type (Node => Node) = SP_Symbols.arange
              and then Range_Is_Empty (Left  => Left.Value,
                                       Right => Right.Value) then
               Result.Value                := Maths.NoValue;
               Result.Range_RHS            := Maths.NoValue;
               Result.Errors_In_Expression := True;
               ErrorHandler.Semantic_Error
                 (Err_Num   => 409,
                  Reference => ErrorHandler.No_Reference,
                  Position  => STree.Node_Position (Node => Node),
                  Id_Str    => LexTokenManager.Null_String);
            end if;
         end if;
      end if;
      Result.Errors_In_Expression := Result.Errors_In_Expression
        or else Left.Errors_In_Expression
        or else Right.Errors_In_Expression;
   else
      Result := Sem.Null_Exp_Record;
      SystemErrors.Fatal_Error
        (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Next_Node = attribute OR simple_expression OR " &
           "annotation_attribute OR annotation_simple_expression in Wf_Arange");
   end if;
   Exp_Stack.Push (X     => Result,
                   Stack => E_Stack);
end Wf_Arange;
