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

separate (Sem.CompUnit.WalkStatements)
procedure Wf_Case_Choice
  (Node           : in     STree.SyntaxNode;
   Scope          : in     Dictionary.Scopes;
   Table          : in out RefList.HashTable;
   Component_Data : in out ComponentManager.ComponentData)
is
   type Case_Choice_Sorts is (Single_Expression, Explicit_Range, Range_Constraint);

   Case_Choice_Sort            : Case_Choice_Sorts;
   First_Node, Second_Node     : STree.SyntaxNode;
   First_Result, Second_Result : Exp_Record;
   Ref_Var                     : SeqAlgebra.Seq;

   Case_Flags            : Typ_Case_Flags;
   Complete_ADT          : CompleteCheck.T;
   Case_Type_Symbol      : Dictionary.Symbol;
   Case_Type_Lower_Bound : Typ_Type_Bound;
   Case_Type_Upper_Bound : Typ_Type_Bound;

   Is_A_Range                             : Boolean; -- these refer to the value/range
   Choice_Lower_Maths_Value               : Maths.Value; -- specified in the case choice
   Choice_Upper_Maths_Value               : Maths.Value    := Maths.NoValue; -- init to remove spurious flowerrs
   Choice_Lower_Bound, Choice_Upper_Bound : Typ_Type_Bound := Unknown_Type_Bound; -- init to remove spurious flowerrs

   Lower_Bound_Unknown      : Boolean;
   Upper_Bound_Unknown      : Boolean := False;
   Lower_Bound_Out_Of_Range : Boolean;
   Upper_Bound_Out_Of_Range : Boolean := False;

   Semantic_Errors_Found : Boolean := False;

   Out_Of_Range_Seen            : Boolean;
   Overlap_Seen                 : CompleteCheck.TypOverlapState;
   Both_Choice_Bounds_Known     : Boolean := False;
   Range_Constraint_Lower_Bound : Typ_Type_Bound;
   Range_Constraint_Upper_Bound : Typ_Type_Bound;

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

   procedure Convert_Choice_Bound
     (Maths_Value        : in     Maths.Value;
      Bound              :    out Typ_Type_Bound;
      Unknown_Bound      :    out Boolean;
      Bound_Out_Of_Range :    out Boolean)
   --# derives Bound,
   --#         Bound_Out_Of_Range,
   --#         Unknown_Bound      from Maths_Value;
   --# post Bound.Is_Defined <-> (not Unknown_Bound and not Bound_Out_Of_Range);
   is
      Int         : Integer;
      Maths_Error : Maths.ErrorCode;
   begin
      if Maths.HasNoValue (Maths_Value) then
         Bound              := Typ_Type_Bound'(Value      => 0,
                                               Is_Defined => False);
         Unknown_Bound      := True;
         Bound_Out_Of_Range := False;
      else
         Maths.ValueToInteger (Maths_Value, Int, Maths_Error);
         if Maths_Error = Maths.NoError then
            Bound              := Typ_Type_Bound'(Value      => Int,
                                                  Is_Defined => True);
            Unknown_Bound      := False;
            Bound_Out_Of_Range := False;
         else
            Bound              := Typ_Type_Bound'(Value      => 0,
                                                  Is_Defined => False);
            Unknown_Bound      := False;
            Bound_Out_Of_Range := True;
         end if;
      end if;
   end Convert_Choice_Bound;

   ------------------------------------------------------------------------
   -- note: returns True if any of the bounds is undefined, unless the
   -- choice is not a range, in which case, Choice_Upper is unused
   function Is_Choice_In_Range
     (Choice_Lower    : Typ_Type_Bound;
      Choice_Upper    : Typ_Type_Bound;
      Choice_Is_Range : Boolean;
      Range_Lower     : Typ_Type_Bound;
      Range_Upper     : Typ_Type_Bound)
     return            Boolean
   is
      Result : Boolean;
   begin
      if (Choice_Lower.Is_Defined and then Range_Lower.Is_Defined and then Choice_Lower.Value < Range_Lower.Value)
        or else (Choice_Lower.Is_Defined and then Range_Upper.Is_Defined and then Choice_Lower.Value > Range_Upper.Value)
        or else (Choice_Is_Range
                   and then Choice_Upper.Is_Defined
                   and then Range_Upper.Is_Defined
                   and then Choice_Upper.Value > Range_Upper.Value) then
         Result := False;
      else
         Result := True;
      end if;
      return Result;
   end Is_Choice_In_Range;

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

   function Is_Range_Empty (Range_Lower : Typ_Type_Bound;
                            Range_Upper : Typ_Type_Bound) return Boolean
   --# pre Range_Lower.Is_Defined and Range_Upper.Is_Defined;
   --# return not (Range_Lower.Value <= Range_Upper.Value);
   is
   begin
      return not (Range_Lower.Value <= Range_Upper.Value);
   end Is_Range_Empty;

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

   procedure Convert_Boolean_Maths_Value (Value : in out Maths.Value)
   --# derives Value from *;
   is
   begin
      if Value = Maths.FalseValue then
         Value := Maths.ZeroInteger;
      elsif Value = Maths.TrueValue then
         Value := Maths.OneInteger;
      end if;
   end Convert_Boolean_Maths_Value;

begin -- Wf_Case_Choice
   Second_Result := Unknown_Type_Record;
   Case_Stack.Pop
     (Case_Flags   => Case_Flags,
      Complete_ADT => Complete_ADT,
      Sym          => Case_Type_Symbol,
      Lower_Bound  => Case_Type_Lower_Bound,
      Upper_Bound  => Case_Type_Upper_Bound);

   First_Node := Child_Node (Current_Node => Node);
   -- ASSUME First_Node = simple_expression
   SystemErrors.RT_Assert
     (C       => Syntax_Node_Type (Node => First_Node) = SP_Symbols.simple_expression,
      Sys_Err => SystemErrors.Invalid_Syntax_Tree,
      Msg     => "Expect First_Node = simple_expression in Wf_Case_Choice");

   SeqAlgebra.CreateSeq (TheHeap, Ref_Var);
   Walk_Expression_P.Walk_Expression
     (Exp_Node                => First_Node,
      Scope                   => Scope,
      Type_Context            => Case_Type_Symbol,
      Context_Requires_Static => False,
      Ref_Var                 => Ref_Var,
      Result                  => First_Result,
      Component_Data          => Component_Data,
      The_Heap                => TheHeap);
   SystemErrors.RT_Assert
     (C       => Dictionary.Is_Null_Symbol (Case_Type_Symbol) or else Dictionary.IsTypeMark (Case_Type_Symbol),
      Sys_Err => SystemErrors.Invalid_Syntax_Tree,
      Msg     => "Expect Case_Type_Symbol to be a type in Wf_Case_Choice");

   --# assert Syntax_Node_Type (First_Node, STree.Table) = SP_Symbols.simple_expression and
   --#   STree.Table = STree.Table~ and
   --#   Case_Stack.Stack_Is_Valid (Case_Stack.State) and
   --#   (Complete_ADT.ActualUpperBound - Complete_ADT.LowerBound < ExaminerConstants.CompleteCheckSize) and
   --#   (Dictionary.Is_Null_Symbol (Case_Type_Symbol) or Dictionary.IsTypeMark (Case_Type_Symbol, Dictionary.Dict));

   Second_Node := Next_Sibling (Current_Node => First_Node);
   -- ASSUME Second_Node = range_constraint OR simple_expression OR NULL
   if Second_Node = STree.NullNode then
      -- ASSUME Second_Node = NULL
      Case_Choice_Sort := Single_Expression;
   else
      -- ASSUME Second_Node = range_constraint OR simple_expression
      if Syntax_Node_Type (Node => Second_Node) = SP_Symbols.simple_expression then
         -- ASSUME Second_Node = simple_expression
         Case_Choice_Sort := Explicit_Range;
      elsif Syntax_Node_Type (Node => Second_Node) = SP_Symbols.range_constraint then
         -- ASSUME Second_Node = range_constraint
         Case_Choice_Sort := Range_Constraint;
      else
         Case_Choice_Sort := Single_Expression;
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Second_Node = range_constraint OR simple_expression in Wf_Case_Choice");
      end if;
      Walk_Expression_P.Walk_Expression
        (Exp_Node                => Second_Node,
         Scope                   => Scope,
         Type_Context            => Case_Type_Symbol,
         Context_Requires_Static => False,
         Ref_Var                 => Ref_Var,
         Result                  => Second_Result,
         Component_Data          => Component_Data,
         The_Heap                => TheHeap);
      SystemErrors.RT_Assert
        (C       => Dictionary.Is_Null_Symbol (Case_Type_Symbol) or else Dictionary.IsTypeMark (Case_Type_Symbol),
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Case_Type_Symbol to be a type in Wf_Case_Choice");
   end if;

   --# assert Syntax_Node_Type (First_Node, STree.Table) = SP_Symbols.simple_expression and
   --#   (Syntax_Node_Type (Second_Node, STree.Table) = SP_Symbols.simple_expression or
   --#      Syntax_Node_Type (Second_Node, STree.Table) = SP_Symbols.range_constraint or
   --#      Second_Node = STree.NullNode) and
   --#   STree.Table = STree.Table~ and
   --#   Case_Stack.Stack_Is_Valid (Case_Stack.State) and
   --#   (Complete_ADT.ActualUpperBound - Complete_ADT.LowerBound < ExaminerConstants.CompleteCheckSize) and
   --#   (Dictionary.Is_Null_Symbol (Case_Type_Symbol) or Dictionary.IsTypeMark (Case_Type_Symbol, Dictionary.Dict));

   case Case_Choice_Sort is
      when Single_Expression =>
         if not First_Result.Is_Static then
            ErrorHandler.Semantic_Error
              (Err_Num   => 36,
               Reference => 1,
               Position  => Node_Position (Node => First_Node),
               Id_Str    => LexTokenManager.Null_String);
            Semantic_Errors_Found := True;
         end if;
         if not Dictionary.CompatibleTypes (Scope, First_Result.Type_Symbol, Case_Type_Symbol) then
            ErrorHandler.Semantic_Error
              (Err_Num   => 38,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => First_Node),
               Id_Str    => LexTokenManager.Null_String);
            Semantic_Errors_Found := True;
         end if;

         -- code to work out whether we have a single choice or a
         -- range and to collect the appropriate values
         -- note that these will be nonsense if semantic errors have been found
         Choice_Lower_Maths_Value := First_Result.Value;
         if First_Result.Is_ARange then
            Is_A_Range               := True;
            Choice_Upper_Maths_Value := First_Result.Range_RHS;
         else
            Is_A_Range := False;
         end if;

      when Explicit_Range =>
         if not Dictionary.CompatibleTypes (Scope, First_Result.Type_Symbol, Second_Result.Type_Symbol) then
            ErrorHandler.Semantic_Error
              (Err_Num   => 42,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Second_Node),
               Id_Str    => LexTokenManager.Null_String);
            Semantic_Errors_Found := True;
         elsif not Dictionary.CompatibleTypes (Scope, First_Result.Type_Symbol, Case_Type_Symbol) then
            ErrorHandler.Semantic_Error
              (Err_Num   => 106,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => First_Node),
               Id_Str    => LexTokenManager.Null_String);
            Semantic_Errors_Found := True;
         end if;
         if not (First_Result.Is_Static and then Second_Result.Is_Static) then
            ErrorHandler.Semantic_Error
              (Err_Num   => 45,
               Reference => 1,
               Position  => Node_Position (Node => First_Node),
               Id_Str    => LexTokenManager.Null_String);
            Semantic_Errors_Found := True;
         end if;

         -- code to collect the appropriate values for the extent of the range
         -- note that these will be nonsense if semantic errors have been found
         Choice_Lower_Maths_Value := First_Result.Value;
         Choice_Upper_Maths_Value := Second_Result.Value;
         Is_A_Range               := True;

      when Range_Constraint =>
         if not Dictionary.CompatibleTypes (Scope, First_Result.Type_Symbol, Second_Result.Type_Symbol) then
            ErrorHandler.Semantic_Error
              (Err_Num   => 42,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Second_Node),
               Id_Str    => LexTokenManager.Null_String);
            Semantic_Errors_Found := True;
         elsif not Dictionary.CompatibleTypes (Scope, First_Result.Type_Symbol, Case_Type_Symbol) then
            ErrorHandler.Semantic_Error
              (Err_Num   => 106,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => First_Node),
               Id_Str    => LexTokenManager.Null_String);
            Semantic_Errors_Found := True;
         end if;
         if not (First_Result.Is_Constant and then First_Result.Is_ARange) then
            ErrorHandler.Semantic_Error
              (Err_Num   => 95,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => First_Node),
               Id_Str    => LexTokenManager.Null_String);
            Semantic_Errors_Found := True;
         end if;
         if not Second_Result.Is_Static then
            ErrorHandler.Semantic_Error
              (Err_Num   => 45,
               Reference => 1,
               Position  => Node_Position (Node => Second_Node),
               Id_Str    => LexTokenManager.Null_String);
            Semantic_Errors_Found := True;
         end if;

         -- code to collect the appropriate values for the extent of the range
         -- note that these will be nonsense if semantic errors have been found
         Choice_Lower_Maths_Value := Second_Result.Value;
         Choice_Upper_Maths_Value := Second_Result.Range_RHS;
         Is_A_Range               := True;

         -- somewhere need to check that Second_Result range is within the type
         -- given by First_Result
   end case;

   --# assert Syntax_Node_Type (First_Node, STree.Table) = SP_Symbols.simple_expression and
   --#   (Syntax_Node_Type (Second_Node, STree.Table) = SP_Symbols.simple_expression or
   --#      Syntax_Node_Type (Second_Node, STree.Table) = SP_Symbols.range_constraint or
   --#      Second_Node = STree.NullNode) and
   --#   STree.Table = STree.Table~ and
   --#   Case_Stack.Stack_Is_Valid (Case_Stack.State) and
   --#   (Complete_ADT.ActualUpperBound - Complete_ADT.LowerBound < ExaminerConstants.CompleteCheckSize) and
   --#   (Dictionary.Is_Null_Symbol (Case_Type_Symbol) or Dictionary.IsTypeMark (Case_Type_Symbol, Dictionary.Dict));

   if not Semantic_Errors_Found then
      Convert_Boolean_Maths_Value (Value => Choice_Lower_Maths_Value);
      Convert_Choice_Bound
        (Maths_Value        => Choice_Lower_Maths_Value,
         Bound              => Choice_Lower_Bound,
         Unknown_Bound      => Lower_Bound_Unknown,
         Bound_Out_Of_Range => Lower_Bound_Out_Of_Range);

      if Is_A_Range then
         Convert_Boolean_Maths_Value (Value => Choice_Upper_Maths_Value);
         Convert_Choice_Bound
           (Maths_Value        => Choice_Upper_Maths_Value,
            Bound              => Choice_Upper_Bound,
            Unknown_Bound      => Upper_Bound_Unknown,
            Bound_Out_Of_Range => Upper_Bound_Out_Of_Range);
      else
         Choice_Upper_Bound := Unknown_Type_Bound;
      end if;

      if Lower_Bound_Out_Of_Range or else (Is_A_Range and then Upper_Bound_Out_Of_Range) then
         Both_Choice_Bounds_Known := False;
         ErrorHandler.Semantic_Warning
           (Err_Num  => 305,
            Position => Node_Position (Node => First_Node),
            Id_Str   => LexTokenManager.Null_String);
      elsif Lower_Bound_Unknown or else (Is_A_Range and then Upper_Bound_Unknown) then
         Both_Choice_Bounds_Known    := False;
         Complete_ADT.Undeterminable := True;
         ErrorHandler.Semantic_Warning
           (Err_Num  => 200,
            Position => Node_Position (Node => First_Node),
            Id_Str   => LexTokenManager.Null_String);
      else
         Both_Choice_Bounds_Known := True;
      end if;

      --# assert Syntax_Node_Type (First_Node, STree.Table) = SP_Symbols.simple_expression and
      --#   (Syntax_Node_Type (Second_Node, STree.Table) = SP_Symbols.simple_expression or
      --#      Syntax_Node_Type (Second_Node, STree.Table) = SP_Symbols.range_constraint or
      --#      Second_Node = STree.NullNode) and
      --#   STree.Table = STree.Table~ and
      --#   not Semantic_Errors_Found and
      --#   ((Both_Choice_Bounds_Known and Is_A_Range) -> (Choice_Lower_Bound.Is_Defined and Choice_Upper_Bound.Is_Defined)) and
      --#   Case_Stack.Stack_Is_Valid (Case_Stack.State) and
      --#   (Complete_ADT.ActualUpperBound - Complete_ADT.LowerBound < ExaminerConstants.CompleteCheckSize) and
      --#   (Dictionary.Is_Null_Symbol (Case_Type_Symbol) or Dictionary.IsTypeMark (Case_Type_Symbol, Dictionary.Dict));

      if Both_Choice_Bounds_Known then
         -- check the case choice lies within controlling type
         if not Is_Choice_In_Range
           (Choice_Lower    => Choice_Lower_Bound,
            Choice_Upper    => Choice_Upper_Bound,
            Choice_Is_Range => Is_A_Range,
            Range_Lower     => Case_Type_Lower_Bound,
            Range_Upper     => Case_Type_Upper_Bound) then
            if Case_Choice_Sort = Range_Constraint then
               ErrorHandler.Semantic_Error
                 (Err_Num   => 410,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Second_Node),
                  Id_Str    => LexTokenManager.Null_String);
            else
               ErrorHandler.Semantic_Error
                 (Err_Num   => 410,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => First_Node),
                  Id_Str    => LexTokenManager.Null_String);
            end if;
            Semantic_Errors_Found := True;
         elsif Is_A_Range and then Is_Range_Empty (Range_Lower => Choice_Lower_Bound,
                                                   Range_Upper => Choice_Upper_Bound) then
            if Case_Choice_Sort = Range_Constraint then
               ErrorHandler.Semantic_Error
                 (Err_Num   => 409,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Second_Node),
                  Id_Str    => LexTokenManager.Null_String);
            else
               ErrorHandler.Semantic_Error
                 (Err_Num   => 409,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => First_Node),
                  Id_Str    => LexTokenManager.Null_String);
            end if;
            Semantic_Errors_Found := True;
         end if;

         --# assert Syntax_Node_Type (First_Node, STree.Table) = SP_Symbols.simple_expression and
         --#   (Syntax_Node_Type (Second_Node, STree.Table) = SP_Symbols.simple_expression or
         --#      Syntax_Node_Type (Second_Node, STree.Table) = SP_Symbols.range_constraint or
         --#      Second_Node = STree.NullNode) and
         --#   STree.Table = STree.Table~ and
         --#   Both_Choice_Bounds_Known and
         --#   ((not Semantic_Errors_Found and Is_A_Range) -> (Choice_Lower_Bound.Value <= Choice_Upper_Bound.Value)) and
         --#   Case_Stack.Stack_Is_Valid (Case_Stack.State) and
         --#   (Complete_ADT.ActualUpperBound - Complete_ADT.LowerBound < ExaminerConstants.CompleteCheckSize) and
         --#   (Dictionary.Is_Null_Symbol (Case_Type_Symbol) or Dictionary.IsTypeMark (Case_Type_Symbol, Dictionary.Dict));

         -- check the case choice lies within Range_Constraint type
         if Case_Choice_Sort = Range_Constraint then
            Get_Type_Bounds
              (Type_Symbol => First_Result.Type_Symbol,
               Lower_Bound => Range_Constraint_Lower_Bound,
               Upper_Bound => Range_Constraint_Upper_Bound);

            if not Is_Choice_In_Range
              (Choice_Lower    => Choice_Lower_Bound,
               Choice_Upper    => Choice_Upper_Bound,
               Choice_Is_Range => Is_A_Range,
               Range_Lower     => Range_Constraint_Lower_Bound,
               Range_Upper     => Range_Constraint_Upper_Bound) then
               ErrorHandler.Semantic_Error
                 (Err_Num   => 413,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Second_Node),
                  Id_Str    => LexTokenManager.Null_String);
               Semantic_Errors_Found := True;
            end if;
         end if;
      end if;
   end if;

   --# assert Syntax_Node_Type (First_Node, STree.Table) = SP_Symbols.simple_expression and
   --#   STree.Table = STree.Table~ and
   --#   ((not Semantic_Errors_Found and Both_Choice_Bounds_Known and Is_A_Range) ->
   --#      (Choice_Lower_Bound.Value <= Choice_Upper_Bound.Value)) and
   --#   Case_Stack.Stack_Is_Valid (Case_Stack.State) and
   --#   (Complete_ADT.ActualUpperBound - Complete_ADT.LowerBound < ExaminerConstants.CompleteCheckSize) and
   --#   (Dictionary.Is_Null_Symbol (Case_Type_Symbol) or Dictionary.IsTypeMark (Case_Type_Symbol, Dictionary.Dict));

   if (not Semantic_Errors_Found)
     and then Both_Choice_Bounds_Known
     and then (Case_Flags.Check_Completeness or else Case_Flags.Check_Overlap) then
      if Is_A_Range then
         CompleteCheck.SeenRange
           (Complete_ADT,
            Choice_Lower_Bound.Value,
            Choice_Upper_Bound.Value,
            Out_Of_Range_Seen,
            Overlap_Seen);
      else
         CompleteCheck.SeenElement (Complete_ADT, Choice_Lower_Bound.Value, Out_Of_Range_Seen, Overlap_Seen);
      end if;
      if Out_Of_Range_Seen then
         Case_Flags.Out_Of_Range_Seen := True;
      end if;
      if Case_Flags.Check_Overlap and then Overlap_Seen = CompleteCheck.Overlap then
         ErrorHandler.Semantic_Error
           (Err_Num   => 407,
            Reference => ErrorHandler.No_Reference,
            Position  => Node_Position (Node => First_Node),
            Id_Str    => LexTokenManager.Null_String);
         Semantic_Errors_Found := True;
      end if;
   end if;

   -- add reference variable list to RefList hash table
   RefList.AddRelation (Table, TheHeap, Node, Dictionary.NullSymbol, Ref_Var);

   --# assert STree.Table = STree.Table~ and
   --#   Case_Stack.Stack_Is_Valid (Case_Stack.State) and
   --#   (Complete_ADT.ActualUpperBound - Complete_ADT.LowerBound < ExaminerConstants.CompleteCheckSize) and
   --#   (Dictionary.Is_Null_Symbol (Case_Type_Symbol) or Dictionary.IsTypeMark (Case_Type_Symbol, Dictionary.Dict));

   if Semantic_Errors_Found then
      Case_Flags.Check_Completeness := False;
   end if;

   Case_Stack.Push
     (Case_Flags   => Case_Flags,
      Complete_ADT => Complete_ADT,
      Sym          => Case_Type_Symbol,
      Lower_Bound  => Case_Type_Lower_Bound,
      Upper_Bound  => Case_Type_Upper_Bound);
end Wf_Case_Choice;
