-------------------------------------------------------------------------------
-- (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
  (Node           : in     STree.SyntaxNode;
   Scope          : in     Dictionary.Scopes;
   Table          : in out RefList.HashTable;
   Component_Data : in out ComponentManager.ComponentData)
is
   Case_Exp                   : Exp_Record;
   Ref_Var                    : SeqAlgebra.Seq;
   Case_Flags                 : Typ_Case_Flags;
   Upper_Bound                : Typ_Type_Bound;
   Lower_Bound                : Typ_Type_Bound;
   Complete_ADT               : CompleteCheck.T;
   Complete_Check_Range_From  : Integer;
   Complete_Check_Range_To    : Integer;
   Complete_Check_Range_State : CompleteCheck.TypRangeState;
   Child                      : STree.SyntaxNode;
begin
   SeqAlgebra.CreateSeq (TheHeap, Ref_Var);
   Child := Child_Node (Current_Node => Node);
   -- ASSUME Child = expression
   SystemErrors.RT_Assert
     (C       => Syntax_Node_Type (Node => Child) = SP_Symbols.expression,
      Sys_Err => SystemErrors.Invalid_Syntax_Tree,
      Msg     => "Expect Child = expression in Wf_Case");
   Walk_Expression_P.Walk_Expression
     (Exp_Node                => Child,
      Scope                   => Scope,
      Type_Context            => Dictionary.GetUnknownTypeMark,
      Context_Requires_Static => False,
      Ref_Var                 => Ref_Var,
      Result                  => Case_Exp,
      Component_Data          => Component_Data,
      The_Heap                => TheHeap);
   -- distinguish between the different possible situations, and
   -- set up the case checking accordingly
   if Dictionary.IsUnknownTypeMark (Case_Exp.Type_Symbol)
     or else not Dictionary.IsDiscreteTypeMark (Case_Exp.Type_Symbol, Scope) then
      Upper_Bound := Unknown_Type_Bound;
      Lower_Bound := Unknown_Type_Bound;

      -- for unknown or non-discrete types
      -- for unknown types still attempt overlap checking
      ErrorHandler.Semantic_Error
        (Err_Num   => 46,
         Reference => ErrorHandler.No_Reference,
         Position  => Node_Position (Node => Node),
         Id_Str    => LexTokenManager.Null_String);
      Case_Flags :=
        Typ_Case_Flags'
        (Check_Completeness  => False,
         Signal_Out_Of_Range => False,
         Out_Of_Range_Seen   => False,
         Check_Overlap       => Dictionary.IsUnknownTypeMark (Case_Exp.Type_Symbol),
         Warn_No_Others      => False,
         Others_Mandatory    => False);
      -- the completeness checker object will not be used if the type mark
      -- is not discrete
      Complete_Check_Range_From := -(ExaminerConstants.CompleteCheckSize / 2);
      Complete_Check_Range_To   := (Complete_Check_Range_From + ExaminerConstants.CompleteCheckSize) - 1;
      -- NB we 'know' that Complete_Check_Range_State will return RangeDoesFit,
      -- so the value is ignored, giving a flow error
      --# accept Flow, 10, Complete_Check_Range_State, "Expected ineffective assignment";
      CompleteCheck.Init (Complete_ADT, Complete_Check_Range_From, Complete_Check_Range_To, Complete_Check_Range_State);
      --# end accept;
   elsif Dictionary.IsUniversalIntegerType (Case_Exp.Type_Symbol) then
      Upper_Bound := Unknown_Type_Bound;
      Lower_Bound := Unknown_Type_Bound;
      -- for universal Integer: others is mandatory
      Case_Flags                :=
        Typ_Case_Flags'
        (Check_Completeness  => False,
         Signal_Out_Of_Range => True,
         Out_Of_Range_Seen   => False,
         Check_Overlap       => True,
         Warn_No_Others      => False,
         Others_Mandatory    => True);
      Complete_Check_Range_From := -(ExaminerConstants.CompleteCheckSize / 2);
      Complete_Check_Range_To   := (Complete_Check_Range_From + ExaminerConstants.CompleteCheckSize) - 1;
      -- NB we 'know' that Complete_Check_Range_State will return RangeDoesFit,
      -- so the value is ignored, giving a flow error
      --# accept Flow, 10, Complete_Check_Range_State, "Expected ineffective assignment";
      CompleteCheck.Init (Complete_ADT, Complete_Check_Range_From, Complete_Check_Range_To, Complete_Check_Range_State);
      --# end accept;
   else
      -- get bounds from dictionary
      Get_Type_Bounds (Type_Symbol => Case_Exp.Type_Symbol,
                       Lower_Bound => Lower_Bound,
                       Upper_Bound => Upper_Bound);

      if not (Lower_Bound.Is_Defined and then Upper_Bound.Is_Defined) then
         -- one or other bound is unknown to the dictionary
         Case_Flags :=
           Typ_Case_Flags'
           (Check_Completeness  => False,
            Signal_Out_Of_Range => True,
            Out_Of_Range_Seen   => False,
            Check_Overlap       => True,
            Warn_No_Others      => True,
            Others_Mandatory    => False);
         -- if both bounds unknown use symmetric range
         if (not Lower_Bound.Is_Defined) and then (not Upper_Bound.Is_Defined) then
            Complete_Check_Range_From := -(ExaminerConstants.CompleteCheckSize / 2);
            Complete_Check_Range_To   := (Complete_Check_Range_From + ExaminerConstants.CompleteCheckSize) - 1;
            -- otherwise use range extending from known bound
         elsif Lower_Bound.Is_Defined then
            Complete_Check_Range_From := Lower_Bound.Value;
            if Complete_Check_Range_From <= (Integer'Last - ExaminerConstants.CompleteCheckSize) then
               Complete_Check_Range_To := (Complete_Check_Range_From + ExaminerConstants.CompleteCheckSize) - 1;
            else
               Complete_Check_Range_To := Integer'Last;
            end if;
         else -- Upper_Bound.IsDefined
            Complete_Check_Range_To := Upper_Bound.Value;
            if Complete_Check_Range_To >= (Integer'First + ExaminerConstants.CompleteCheckSize) then
               Complete_Check_Range_From := (Complete_Check_Range_To - ExaminerConstants.CompleteCheckSize) + 1;
            else
               Complete_Check_Range_From := Integer'First;
            end if;
         end if;
         -- NB we 'know' that Complete_Check_Range_State will return RangeDoesFit,
         -- so the value is ignored, giving a flow error
         --# accept Flow, 10, Complete_Check_Range_State, "Expected ineffective assignment";
         CompleteCheck.Init (Complete_ADT, Complete_Check_Range_From, Complete_Check_Range_To, Complete_Check_Range_State);
         --# end accept;
      else -- both bounds known to dictionary: set up completeness checker
         CompleteCheck.Init (Complete_ADT, Lower_Bound.Value, Upper_Bound.Value, Complete_Check_Range_State);
         if Complete_Check_Range_State = CompleteCheck.RangeDoesFit then
            -- range fits in completeness checker
            Case_Flags :=
              Typ_Case_Flags'
              (Check_Completeness  => True,
               Signal_Out_Of_Range => False,
               Out_Of_Range_Seen   => False,
               Check_Overlap       => True,
               Warn_No_Others      => False,
               Others_Mandatory    => False);
         else -- range does not fit in completeness checker
            Case_Flags :=
              Typ_Case_Flags'
              (Check_Completeness  => False,
               Signal_Out_Of_Range => True,
               Out_Of_Range_Seen   => False,
               Check_Overlap       => True,
               Warn_No_Others      => True,
               Others_Mandatory    => False);
         end if;
      end if;
   end if;

   Case_Stack.Push
     (Case_Flags   => Case_Flags,
      Complete_ADT => Complete_ADT,
      Sym          => Case_Exp.Type_Symbol,
      Lower_Bound  => Lower_Bound,
      Upper_Bound  => Upper_Bound);

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