-------------------------------------------------------------------------------
-- (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
-- simple_expression node.  Replaces calls to StaticSimpleExpression,
-- BaseTypeSimpleExpression and CheckTypeSimpleExpression
----------------------------------------------------------------------------

separate (Sem.Walk_Expression_P)
procedure Wf_Simple_Expression
  (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;
   Context_Requires_Static : in     Boolean)
is
   Left, Right, Result   : Sem.Exp_Record;
   Op_Node               : STree.SyntaxNode;
   Operator              : SP_Symbols.SP_Symbol;
   Left_Base, Right_Base : Dictionary.Symbol;
   Result_Str, Temp_Str  : E_Strings.T;

   function Length_Sum (Left, Right : Sem.Exp_Record) return Maths.Value
   --# global in Dictionary.Dict;
   is
      Unused : Maths.ErrorCode;
      Sum    : Maths.Value;

      function Length_Of (S : Sem.Exp_Record) return Maths.Value
      --# global in Dictionary.Dict;
      is
         Result : Maths.Value;
      begin
         if Dictionary.IsPredefinedCharacterType (Dictionary.GetRootType (S.Type_Symbol)) then
            Result := Maths.OneInteger;
         else
            Result := S.Range_RHS;
         end if;
         return Result;
      end Length_Of;

   begin -- Length_Sum

      --# accept Flow, 10, Unused, "Expected ineffective assignment";
      Maths.Add (Length_Of (S => Left), Length_Of (S => Right), Sum, Unused);
      --# end accept;
      --# accept Flow, 33, Unused, "Expected to be neither referenced nor exported";
      return Sum;
   end Length_Sum;

   -- Returns either the Character or String Literal associated with Exp
   -- as a string literal. A character literal 'a' is returned as the
   -- string literal "a" for example. The resulting string does NOT
   -- include opening or closing quotations.
   procedure Get_String
     (Exp      : in     Sem.Exp_Record;
      Exp_Type : in     Dictionary.Symbol;
      Err_Pos  : in     LexTokenManager.Token_Position;
      Str      :    out E_Strings.T)
   --# 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,
   --#                                         Err_Pos,
   --#                                         Exp,
   --#                                         Exp_Type,
   --#                                         LexTokenManager.State,
   --#                                         SPARK_IO.File_Sys &
   --#         Str                        from Dictionary.Dict,
   --#                                         Exp,
   --#                                         Exp_Type,
   --#                                         LexTokenManager.State;
   --# pre Dictionary.IsPredefinedCharacterType (Exp_Type, Dictionary.Dict) or
   --#   Dictionary.IsPredefinedStringType (Exp_Type, Dictionary.Dict);
   is
      Str_Length : E_Strings.Lengths;
      Char_Code  : Integer;
      Unused     : Maths.ErrorCode;
   begin
      if Dictionary.IsPredefinedCharacterType (Exp_Type) then
         --# accept F, 10, Unused, "Ineffective assignment OK here";
         Maths.ValueToInteger (Exp.Value, Char_Code, Unused);
         --# end accept;
         Str := E_Strings.Empty_String;
         if Char_Code >= Character'Pos (Character'First) and then Char_Code <= Character'Pos (Character'Last) then
            E_Strings.Append_Char (Str, Character'Val (Char_Code));
         else
            ErrorHandler.Semantic_Error
              (Err_Num   => 402,
               Reference => ErrorHandler.No_Reference,
               Position  => Err_Pos,
               Id_Str    => LexTokenManager.Null_String);
         end if;
      else
         -- Get the String representation of Exp. This will include a preceding
         -- and a trailing " character at this point
         Str        := LexTokenManager.Lex_String_To_String (Exp.String_Value);
         Str_Length := E_Strings.Get_Length (Str); -- including two " characters
         if Str_Length > 2 then
            -- Must contain at least one character, but we still want
            -- to get rid of the outer " characters.
            Str := E_Strings.Section (Str, 2, Str_Length - 2);
         else
            -- Must be a null String "", so
            Str := E_Strings.Empty_String;
         end if;
      end if;
      --# accept F, 33, Unused, "Unused not referenced OK";
   end Get_String;

begin -- Wf_Simple_Expression
   Op_Node := STree.Child_Node (Current_Node => Node);
   -- ASSUME Op_Node = simple_expression OR simple_expression_opt OR
   --                  annotation_simple_expression OR annotation_simple_expression_opt
   if STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.simple_expression
     or else STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.annotation_simple_expression then
      -- ASSUME Op_Node = simple_expression OR annotation_simple_expression
      Op_Node := STree.Child_Node (Current_Node => STree.Next_Sibling (Current_Node => Op_Node));
      -- ASSUME Op_Node = plus OR minus OR ampersand
      SystemErrors.RT_Assert
        (C       => STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.plus
           or else STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.minus
           or else STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.ampersand,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Op_Node = plus OR minus OR ampersand in Wf_Simple_Expression");
      -- binary_adding_operator exists
      Operator := STree.Syntax_Node_Type (Node => Op_Node);
      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

      -- do static checks first
      Result.Is_Constant := Left.Is_Constant and then Right.Is_Constant;
      -- In Ada95 onwards & can be a static function.
      -- LRM83(4.9) says that & is never static, so...
      case CommandLineData.Content.Language_Profile is
         when CommandLineData.SPARK83 =>
            Result.Is_Static := Left.Is_Static and then Right.Is_Static and then Operator /= SP_Symbols.ampersand;
         when CommandLineData.SPARK95_Onwards =>
            Result.Is_Static := Left.Is_Static and then Right.Is_Static;
      end case;
      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  => STree.Node_Position (Node => Op_Node),
            Id_Str    => LexTokenManager.Null_String);
      else -- neither are ranges

         -- now do type compat and operator visibility checks
         if Operator = SP_Symbols.ampersand then
            Left_Base  := Dictionary.GetRootType (Left.Type_Symbol);
            Right_Base := Dictionary.GetRootType (Right.Type_Symbol);
            if (Dictionary.IsPredefinedCharacterType (Left_Base) or else Dictionary.IsPredefinedStringType (Left_Base))
              and then (Dictionary.IsPredefinedCharacterType (Right_Base) or else Dictionary.IsPredefinedStringType (Right_Base))
            then
               -- "&" expressions in SPARK are always expected to be constant (SR 4.5.3)
               -- As such, we should be able to compute the length and value of the result.
               if Result.Is_Constant then
                  Result.Range_RHS   := Length_Sum (Left  => Left,
                                                    Right => Right);
                  Result.Type_Symbol := Dictionary.GetPredefinedStringType;

                  -- Now build the result, from a starting ", then Left, then Right,
                  -- then a closing "
                  Result_Str := E_Strings.Empty_String;
                  E_Strings.Append_Char (Result_Str, '"');
                  Get_String (Exp      => Left,
                              Exp_Type => Left_Base,
                              Err_Pos  => STree.Node_Position (Node => Node),
                              Str      => Temp_Str);
                  E_Strings.Append_Examiner_String (Result_Str, Temp_Str);
                  Get_String
                    (Exp      => Right,
                     Exp_Type => Right_Base,
                     Err_Pos  => STree.Node_Position (Node => Node),
                     Str      => Temp_Str);
                  E_Strings.Append_Examiner_String (Result_Str, Temp_Str);
                  E_Strings.Append_Char (Result_Str, '"');

                  LexTokenManager.Insert_Examiner_String (Result_Str, Result.String_Value);
               else
                  Result := Sem.Unknown_Type_Record;
                  ErrorHandler.Semantic_Error
                    (Err_Num   => 37,
                     Reference => ErrorHandler.No_Reference,
                     Position  => STree.Node_Position (Node => Node),
                     Id_Str    => LexTokenManager.Null_String);
               end if;
            else
               -- Types of Left and/or Right are wrong...
               Result := Sem.Unknown_Type_Record;
               ErrorHandler.Semantic_Error_Sym2
                 (Err_Num   => 35,
                  Reference => ErrorHandler.No_Reference,
                  Position  => STree.Node_Position (Node => Op_Node),
                  Sym       => Left_Base,
                  Sym2      => Right_Base,
                  Scope     => Scope);
            end if;
         else -- its plus or minus
            Check_Binary_Operator
              (Operator      => Operator,
               Left          => Left,
               Right         => Right,
               Scope         => Scope,
               T_Stack       => T_Stack,
               Op_Pos        => STree.Node_Position (Node => Op_Node),
               Left_Pos      => STree.Node_Position (Node => STree.Child_Node (Current_Node => Node)),
               Right_Pos     => STree.Node_Position
                 (Node => STree.Next_Sibling
                    (Current_Node => STree.Next_Sibling (Current_Node => STree.Child_Node (Current_Node => Node)))),
               Convert       => True,
               Is_Annotation => STree.Syntax_Node_Type (Node => Node) = SP_Symbols.annotation_simple_expression,
               Result        => Result);

            -- Seed Op_Node with type to aid selection of operator in VCG
            STree.Add_Node_Symbol (Node => Op_Node,
                                   Sym  => Result.Type_Symbol);

            Calc_Binary_Operator
              (Node_Pos      => STree.Node_Position (Node => Node),
               Operator      => Operator,
               Left_Val      => Left.Value,
               Right_Val     => Right.Value,
               Is_Annotation => STree.Syntax_Node_Type (Node => Node) = SP_Symbols.annotation_simple_expression,
               Result        => Result);

            if STree.Syntax_Node_Type (Node => STree.Parent_Node (Current_Node => Node)) = SP_Symbols.simple_expression then
               -- ASSUME STree.Parent_Node (Current_Node => Node) = simple_expression
               ----------------------------------------------------------------
               -- If the parent is also a simple_expression, then we must have
               -- an unparenthesized expression with two adding operators, such
               -- as A + B + C
               --
               -- Here, we issue warning 302 to warn of potential evaluation
               -- order dependency.
               --
               -- We can reduce false-alarm rate here by suppressing the
               -- warning in two specific cases:
               --  a) If the sub-expression under consideration is static
               --     AND the expression as a whole appears in a context
               --     that requires a static expression.  Example: a type
               --     declaration such as
               --       type T is range B + 2 - 3 .. 10;
               --   or
               --  b) A modular-typed expression where the two operators
               --     under consideration are both the same and
               --     commutative.  For example:
               --       A := A + B + C;
               --     where A, B, and C are all of the same modular
               --     (sub-)type.
               --
               -- The same logic is used in wf_term for multiplying
               -- operators.
               ----------------------------------------------------------------
               if (Context_Requires_Static and then Result.Is_Static)
                 or else (Dictionary.TypeIsModular (Result.Type_Symbol)
                            and then Ops_Are_Same_And_Commutative
                            (Operator,
                             STree.Syntax_Node_Type
                               (Node => STree.Child_Node (Current_Node => STree.Next_Sibling (Current_Node => Node)))))
               then
                  null;
               else
                  ErrorHandler.Semantic_Warning
                    (Err_Num  => 302,
                     Position => STree.Node_Position (Node => Node),
                     Id_Str   => LexTokenManager.Null_String);
               end if;
            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;

      -- 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 STree.Syntax_Node_Type (Node => Op_Node) /= SP_Symbols.simple_expression_opt
     and then STree.Syntax_Node_Type (Node => Op_Node) /= SP_Symbols.annotation_simple_expression_opt then
      SystemErrors.Fatal_Error
        (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Op_Node = simple_expression OR simple_expression_opt OR annotation_simple_expression OR " &
           "annotation_simple_expression_opt in Wf_Simple_Expression");
   end if;
end Wf_Simple_Expression;
