-------------------------------------------------------------------------------
-- (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 relation node.
-- Replaces calls to StaticTerm, BaseTypeTerm and CheckTypeTerm
----------------------------------------------------------------------------

separate (Sem.Walk_Expression_P)
procedure Wf_Relation
  (Node    : in     STree.SyntaxNode;
   Scope   : in     Dictionary.Scopes;
   E_Stack : in out Exp_Stack.Exp_Stack_Type;
   T_Stack : in     Type_Context_Stack.T_Stack_Type)
is
   Op_Node, Right_Node : STree.SyntaxNode;
   Right, Left, Result : Sem.Exp_Record;
   Ident_Str           : LexTokenManager.Lex_String;
   Errors_Found        : Boolean := False;

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

   function Membership_Test (Operator                      : SP_Symbols.SP_Symbol;
                             Val, Lower_Bound, Upper_Bound : Maths.Value) return Maths.Value is
      Result : Maths.Value;
      OK     : Maths.ErrorCode;
   begin
      if Operator = SP_Symbols.inside then
         --# accept Flow, 10, OK, "Expected ineffective assignment";
         Maths.InsideRange (Val, Lower_Bound, Upper_Bound,
                            --to get
                            Result, OK);
         --# end accept;
      else
         --# accept Flow, 10, OK, "Expected ineffective assignment";
         Maths.OutsideRange (Val, Lower_Bound, Upper_Bound,
                             --to get
                             Result, OK);
         --# end accept;
      end if;
      --# accept Flow, 33, OK, "Expected to be neither referenced nor exported";
      return Result;
   end Membership_Test;

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

   function Type_Membership_Test
     (Operator : SP_Symbols.SP_Symbol;
      Left     : Sem.Exp_Record;
      RH_Type  : Dictionary.Symbol;
      Scope    : Dictionary.Scopes)
     return     Maths.Value
   --# global in Dictionary.Dict;
   --#        in LexTokenManager.State;
   is
      Result : Maths.Value;

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

      function Invert_If_Outside (Operator   : SP_Symbols.SP_Symbol;
                                  Raw_Result : Maths.Value) return Maths.Value is
         Result : Maths.Value;
      begin
         Result := Raw_Result;
         if Operator = SP_Symbols.outside then
            Maths.NotOp (Result);
         end if;
         return Result;
      end Invert_If_Outside;

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

      function Scalar_Type_Membership_Test
        (Operator : SP_Symbols.SP_Symbol;
         Val      : Maths.Value;
         RH_Type  : Dictionary.Symbol)
        return     Maths.Value
      --# global in Dictionary.Dict;
      --#        in LexTokenManager.State;
      is
      begin
         return Membership_Test
           (Operator    => Operator,
            Val         => Val,
            Lower_Bound => Maths.ValueRep
              (Dictionary.GetScalarAttributeValue (False, -- not base type
                                                   LexTokenManager.First_Token, RH_Type)),
            Upper_Bound => Maths.ValueRep
              (Dictionary.GetScalarAttributeValue (False, -- not base type
                                                   LexTokenManager.Last_Token, RH_Type)));
      end Scalar_Type_Membership_Test;

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

      function Non_Scalar_Type_Membership_Test
        (Operator         : SP_Symbols.SP_Symbol;
         LH_Type, RH_Type : Dictionary.Symbol;
         Scope            : Dictionary.Scopes)
        return             Maths.Value
      --# global in Dictionary.Dict;
      --#        in LexTokenManager.State;
      is
         Result : Maths.Value;
      begin
         if Dictionary.TypeIsRecord (RH_Type) then
            Result := Maths.TrueValue; -- no record subtypes so must be member
         elsif Dictionary.Is_Unconstrained_Array_Type_Mark (RH_Type, Scope) then
            Result := Maths.TrueValue; -- array must be member of its base type
         else -- two constrained arrays
            if Sem.Indexes_Match (Target => LH_Type,
                                  Source => RH_Type) then
               Result := Maths.TrueValue;
            else
               Result := Maths.FalseValue;
            end if;
         end if;
         return Invert_If_Outside (Operator   => Operator,
                                   Raw_Result => Result);
      end Non_Scalar_Type_Membership_Test;

   begin -- Type_Membership_Test
      if Dictionary.IsPrivateType (RH_Type, Scope) or else Dictionary.TypeIsBoolean (RH_Type) then
         Result := Invert_If_Outside (Operator   => Operator,
                                      Raw_Result => Maths.TrueValue);
      elsif Dictionary.TypeIsScalar (RH_Type) then
         Result := Scalar_Type_Membership_Test (Operator => Operator,
                                                Val      => Left.Value,
                                                RH_Type  => RH_Type);
      else
         Result :=
           Non_Scalar_Type_Membership_Test
           (Operator => Operator,
            LH_Type  => Left.Type_Symbol,
            RH_Type  => RH_Type,
            Scope    => Scope);
      end if;
      return Result;
   end Type_Membership_Test;

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

   -- if we have statically evaluated the result plant it for VCG;
   -- otherwise plant the left hand type so we can distinguish Boolean
   -- models from normal inequality models in the VCG
   procedure Plant_Result (Op_Node : in STree.SyntaxNode;
                           Result  : in Maths.Value;
                           LH_Type : in Dictionary.Symbol)
   --# global in     Dictionary.Dict;
   --#        in out STree.Table;
   --# derives STree.Table from *,
   --#                          Dictionary.Dict,
   --#                          LH_Type,
   --#                          Op_Node,
   --#                          Result;
   --# pre (STree.Syntax_Node_Type (Op_Node, STree.Table) = SP_Symbols.inside or
   --#        STree.Syntax_Node_Type (Op_Node, STree.Table) = SP_Symbols.outside) and
   --#   (Dictionary.Is_Null_Symbol (LH_Type) or Dictionary.IsTypeMark (LH_Type, Dictionary.Dict));
   --# post STree.Table = STree.Table~;
   is
   begin
      if Result = Maths.TrueValue then
         STree.Add_Node_Symbol (Node => Op_Node,
                                Sym  => Dictionary.GetTrue);
      elsif Result = Maths.FalseValue then
         STree.Add_Node_Symbol (Node => Op_Node,
                                Sym  => Dictionary.GetFalse);
      else
         -- no statically evaluated result available so plant type instead
         STree.Add_Node_Symbol (Node => Op_Node,
                                Sym  => LH_Type);
      end if;
   end Plant_Result;

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

   procedure Do_Boolean_Binary_Operator
     (Operator                                   : in     SP_Symbols.SP_Symbol;
      Op_Node_Pos, Left_Node_Pos, Right_Node_Pos : in     LexTokenManager.Token_Position;
      Left, Right                                : in     Sem.Exp_Record;
      Scope                                      : in     Dictionary.Scopes;
      Is_Annotation                              : in     Boolean;
      T_Stack                                    : in     Type_Context_Stack.T_Stack_Type;
      Result                                     : in out Sem.Exp_Record)
   --# 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,
   --#                                         ErrorHandler.Error_Context,
   --#                                         Is_Annotation,
   --#                                         Left,
   --#                                         Left_Node_Pos,
   --#                                         LexTokenManager.State,
   --#                                         Operator,
   --#                                         Op_Node_Pos,
   --#                                         Result,
   --#                                         Right,
   --#                                         Right_Node_Pos,
   --#                                         Scope,
   --#                                         SPARK_IO.File_Sys,
   --#                                         T_Stack &
   --#         Result                     from *,
   --#                                         CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         Is_Annotation,
   --#                                         Left,
   --#                                         LexTokenManager.State,
   --#                                         Operator,
   --#                                         Right,
   --#                                         Scope,
   --#                                         T_Stack;
   --# pre (Dictionary.Is_Null_Symbol (Result.Type_Symbol) or Dictionary.IsTypeMark (Result.Type_Symbol, Dictionary.Dict)) and
   --#   Type_Context_Stack.Stack_Is_Valid (T_Stack);
   --# post Dictionary.Is_Null_Symbol (Result.Type_Symbol) or Dictionary.IsTypeMark (Result.Type_Symbol, Dictionary.Dict);
   is
   begin
      Result.Is_Constant   := Left.Is_Constant and then Right.Is_Constant;
      Result.Is_Static     := Left.Is_Static
        and then Right.Is_Static
        and then Dictionary.TypeIsScalar (Left.Type_Symbol)
        and then Dictionary.TypeIsScalar (Right.Type_Symbol);
      Result.Has_Operators := True;

      if Left.Is_ARange or else Right.Is_ARange then
         Result := Sem.Unknown_Type_Record;
         ErrorHandler.Semantic_Error
           (Err_Num   => 90,
            Reference => ErrorHandler.No_Reference,
            Position  => Op_Node_Pos,
            Id_Str    => LexTokenManager.Null_String);
      else -- neither are ranges
         if Operator = SP_Symbols.equals or else Operator = SP_Symbols.not_equal then
            Check_Binary_Operator
              (Operator      => Operator,
               Left          => Left,
               Right         => Right,
               Scope         => Scope,
               T_Stack       => T_Stack,
               Op_Pos        => Op_Node_Pos,
               Left_Pos      => Left_Node_Pos,
               Right_Pos     => Right_Node_Pos,
               Convert       => True,
               Is_Annotation => Is_Annotation,
               Result        => Result);
            if Result /= Sem.Unknown_Type_Record then
               if not Dictionary.IsPredefinedStringType (Dictionary.GetRootType (Left.Type_Symbol))
                 and then not Dictionary.IsPredefinedStringType (Dictionary.GetRootType (Right.Type_Symbol)) then
                  -- Unconstrained array types only permitted if:
                  -- 1. we are in annotation context, and
                  -- 2. both sides are unconstrained.
                  -- So you are allowed to say, for example, "post X = T'(others => 0)" for a
                  -- subprogram that initializes an unconstrained array or "post X /= Y" where
                  -- both X and Y are compatible unconstrained array types.
                  -- Note that test 2 is almost certainly redundant because if only one side was
                  -- unconstrained then the incompatibility would be detected elsewhere before
                  -- this code was reached.
                  if (Dictionary.Is_Unconstrained_Array_Type_Mark (Left.Type_Symbol, Scope)
                        and then not (Is_Annotation and then Dictionary.Is_Unconstrained_Array_Type_Mark (Right.Type_Symbol, Scope)))
                    or else (Dictionary.Is_Unconstrained_Array_Type_Mark (Right.Type_Symbol, Scope)
                               and then not (Is_Annotation
                                               and then Dictionary.Is_Unconstrained_Array_Type_Mark (Left.Type_Symbol, Scope))) then
                     Result := Sem.Unknown_Type_Record;
                     ErrorHandler.Semantic_Error
                       (Err_Num   => 39,
                        Reference => ErrorHandler.No_Reference,
                        Position  => Op_Node_Pos,
                        Id_Str    => LexTokenManager.Null_String);
                  elsif Sem.Illegal_Unconstrained (Left_Type  => Left.Type_Symbol,
                                                   Right_Type => Right.Type_Symbol) then
                     Result := Sem.Unknown_Type_Record;
                     ErrorHandler.Semantic_Error
                       (Err_Num   => 418,
                        Reference => ErrorHandler.No_Reference,
                        Position  => Op_Node_Pos,
                        Id_Str    => LexTokenManager.Null_String);
                  end if;
               end if;
               if Result /= Sem.Unknown_Type_Record then
                  Calc_Binary_Operator
                    (Node_Pos      => Left_Node_Pos,
                     Operator      => Operator,
                     Left_Val      => Left.Value,
                     Right_Val     => Right.Value,
                     Is_Annotation => Is_Annotation,
                     Result        => Result);
               end if;
            end if;
         else -- ordering operator
            if Dictionary.IsUnknownTypeMark (Left.Type_Symbol)
              or else Dictionary.IsUnknownTypeMark (Right.Type_Symbol)
              or else (Dictionary.IsScalarTypeMark (Left.Type_Symbol, Scope)
                         and then Dictionary.IsScalarTypeMark (Right.Type_Symbol, Scope))
              or else (Dictionary.IsPredefinedStringType (Dictionary.GetRootType (Left.Type_Symbol))
                         and then Dictionary.IsPredefinedStringType (Dictionary.GetRootType (Right.Type_Symbol)))
              or else (CommandLineData.Ravenscar_Selected
                         and then Dictionary.IsPredefinedTimeType (Left.Type_Symbol)
                         and then Dictionary.IsPredefinedTimeType (Right.Type_Symbol)) then
               Check_Binary_Operator
                 (Operator      => Operator,
                  Left          => Left,
                  Right         => Right,
                  Scope         => Scope,
                  T_Stack       => T_Stack,
                  Op_Pos        => Op_Node_Pos,
                  Left_Pos      => Left_Node_Pos,
                  Right_Pos     => Right_Node_Pos,
                  Convert       => True,
                  Is_Annotation => Is_Annotation,
                  Result        => Result);
               Calc_Binary_Operator
                 (Node_Pos      => Left_Node_Pos,
                  Operator      => Operator,
                  Left_Val      => Left.Value,
                  Right_Val     => Right.Value,
                  Is_Annotation => Is_Annotation,
                  Result        => Result);
            elsif Dictionary.IsArrayTypeMark (Left.Type_Symbol, Scope)
              and then Dictionary.IsArrayTypeMark (Right.Type_Symbol, Scope) then
               Result := Sem.Unknown_Type_Record;
               ErrorHandler.Semantic_Error
                 (Err_Num   => 51,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Op_Node_Pos,
                  Id_Str    => LexTokenManager.Null_String);
            else
               Result := Sem.Unknown_Type_Record;
               ErrorHandler.Semantic_Error
                 (Err_Num   => 52,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Op_Node_Pos,
                  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;
   end Do_Boolean_Binary_Operator;

begin -- Wf_Relation
   Op_Node := STree.Next_Sibling (Current_Node => STree.Child_Node (Current_Node => Node));
   -- ASSUME Op_Node = relational_operator OR inside OR outside OR NULL
   if STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.relational_operator
     or else STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.inside
     or else STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.outside then
      -- ASSUME Op_Node = relational_operator OR inside OR outside
      Exp_Stack.Pop (Item  => Right,
                     Stack => E_Stack);
      Exp_Stack.Pop (Item  => Left,
                     Stack => E_Stack);
      Result := Null_Type_Record;
      if STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.inside
        or else STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.outside then
         -- ASSUME Op_Node = inside OR outside
         Right_Node := STree.Next_Sibling (Current_Node => Op_Node);
         -- ASSUME Right_Node = name OR arange OR annotation_name OR annotation_arange
         if STree.Syntax_Node_Type (Node => Right_Node) = SP_Symbols.name
           or else STree.Syntax_Node_Type (Node => Right_Node) = SP_Symbols.annotation_name then
            -- ASSUME Right_Node = name OR annotation_name
            if Right.Sort = Sem.Is_Unknown then
               Result := Sem.Unknown_Type_Record;
            elsif Right.Sort /= Sem.Is_Type_Mark then
               Result    := Sem.Unknown_Type_Record;
               Ident_Str := Dictionary.GetSimpleName (Right.Other_Symbol);
               if LexTokenManager.Lex_String_Case_Insensitive_Compare
                 (Lex_Str1 => Ident_Str,
                  Lex_Str2 => LexTokenManager.Null_String) =
                 LexTokenManager.Str_Eq then
                  Errors_Found := True;
                  ErrorHandler.Semantic_Error
                    (Err_Num   => 95,
                     Reference => ErrorHandler.No_Reference,
                     Position  => STree.Node_Position (Node => Right_Node),
                     Id_Str    => Ident_Str);
               else
                  Errors_Found := True;
                  ErrorHandler.Semantic_Error
                    (Err_Num   => 63,
                     Reference => ErrorHandler.No_Reference,
                     Position  => STree.Node_Position (Node => Right_Node),
                     Id_Str    => Ident_Str);
               end if;
            else
               if Dictionary.CompatibleTypes (Scope, Left.Type_Symbol, Right.Type_Symbol) then
                  Result.Is_Constant   := Left.Is_Constant;
                  Result.Is_Static     := CommandLineData.Content.Language_Profile /= CommandLineData.SPARK83
                    and then Left.Is_Static;
                  Result.Type_Symbol   := Dictionary.GetPredefinedBooleanType;
                  Result.Value         :=
                    Type_Membership_Test
                    (Operator => STree.Syntax_Node_Type (Node => Op_Node),
                     Left     => Left,
                     RH_Type  => Right.Type_Symbol,
                     Scope    => Scope);
                  Result.Has_Operators := True;
                  Plant_Result (Op_Node => Op_Node,
                                Result  => Result.Value,
                                LH_Type => Left.Type_Symbol);
                  -- calculate value here depending on bounds of type mark
                  -- obtained from the dictionary
               else -- type mismatch
                  Result := Sem.Unknown_Type_Record;
                  ErrorHandler.Semantic_Error
                    (Err_Num   => 42,
                     Reference => ErrorHandler.No_Reference,
                     Position  => STree.Node_Position (Node => Node),
                     Id_Str    => LexTokenManager.Null_String);
               end if;
            end if;
         elsif STree.Syntax_Node_Type (Node => Right_Node) = SP_Symbols.arange
           or else STree.Syntax_Node_Type (Node => Right_Node) = SP_Symbols.annotation_arange then
            -- ASSUME Right_Node = arange OR annotation_arange
            if Dictionary.CompatibleTypes (Scope, Left.Type_Symbol, Right.Type_Symbol) and then Right.Is_ARange then
               Result.Is_Constant   := Left.Is_Constant and then Right.Is_Constant;
               Result.Is_Static     := CommandLineData.Content.Language_Profile /= CommandLineData.SPARK83
                 and then Left.Is_Static
                 and then Right.Is_Static;
               Result.Type_Symbol   := Dictionary.GetPredefinedBooleanType;
               Result.Value         :=
                 Membership_Test
                 (Operator    => STree.Syntax_Node_Type (Node => Op_Node),
                  Val         => Left.Value,
                  Lower_Bound => Right.Value,
                  Upper_Bound => Right.Range_RHS);
               Result.Has_Operators := True;
               Plant_Result (Op_Node => Op_Node,
                             Result  => Result.Value,
                             LH_Type => Left.Type_Symbol);
            else -- type mismatch or RHS is not a range
               Result := Sem.Unknown_Type_Record;
               ErrorHandler.Semantic_Error
                 (Err_Num   => 42,
                  Reference => ErrorHandler.No_Reference,
                  Position  => STree.Node_Position (Node => Node),
                  Id_Str    => LexTokenManager.Null_String);
            end if;
         else
            SystemErrors.Fatal_Error
              (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
               Msg     => "Expect Right_Node = name OR arange OR annotation_name OR annotation_arange in Wf_Relation");
         end if;
         Result.Errors_In_Expression := Errors_Found
           or else Result.Errors_In_Expression
           or else Left.Errors_In_Expression
           or else Right.Errors_In_Expression;
      elsif STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.relational_operator then
         -- ASSUME Op_Node = relational_operator
         Do_Boolean_Binary_Operator
           (Operator       => STree.Syntax_Node_Type (Node => STree.Child_Node (Current_Node => Op_Node)),
            Op_Node_Pos    => STree.Node_Position (Node => STree.Child_Node (Current_Node => Op_Node)),
            Left_Node_Pos  => STree.Node_Position (Node => STree.Child_Node (Current_Node => Node)),
            Right_Node_Pos => STree.Node_Position (Node => STree.Next_Sibling (Current_Node => Op_Node)),
            Left           => Left,
            Right          => Right,
            Scope          => Scope,
            Is_Annotation  => STree.Syntax_Node_Type (Node => Node) = SP_Symbols.annotation_relation,
            T_Stack        => T_Stack,
            Result         => Result);
      else
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Op_Node = relational_operator OR inside OR outside in Wf_Relation");
      end if;

      -- OtherSymbol may carry a function symbol in the case of uses of unchecked_conversion.
      -- This symbol is used (by wf_Assign) to convery information to the VCG to supress
      -- checks when an unchecked_conversion is assigned to something of the same subtype.
      -- We do not want this mechanism if the unchecked_conversion is sued in any other context
      -- than a direct assignment.  Therefore we clear OtherSymbol here:
      Result.Other_Symbol := Dictionary.NullSymbol;
      Exp_Stack.Push (X     => Result,
                      Stack => E_Stack);
   elsif Op_Node /= STree.NullNode then
      SystemErrors.Fatal_Error
        (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Op_Node = relational_operator OR inside OR outside OR NULL in Wf_Relation");
   end if;
end Wf_Relation;
