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

separate (Sem.Walk_Expression_P)
procedure Wf_Simple_Expression_Opt
  (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
   Result    : Sem.Exp_Record;
   Base_Type : Dictionary.Symbol;
   Op_Node   : STree.SyntaxNode;
   Operator  : SP_Symbols.SP_Symbol;

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

   procedure Calc_Unary_Plus_Minus
     (Node_Pos      : in     LexTokenManager.Token_Position;
      Is_Annotation : in     Boolean;
      Op            : in     SP_Symbols.SP_Symbol;
      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,
   --#                                         LexTokenManager.State,
   --#                                         Node_Pos,
   --#                                         Op,
   --#                                         Result,
   --#                                         SPARK_IO.File_Sys &
   --#         Result                     from *,
   --#                                         Dictionary.Dict,
   --#                                         LexTokenManager.State,
   --#                                         Op;
   is
      type Err_Lookup is array (Boolean) of Positive;
      Which_Err : constant Err_Lookup := Err_Lookup'(False => 402,
                                                     True  => 399);

      The_Modulus_String : LexTokenManager.Lex_String;
      Temp_Arg           : Maths.Value;
      Err                : Maths.ErrorCode;
   begin
      if Op = SP_Symbols.minus then
         Maths.Negate (Result.Value);
         if Dictionary.TypeIsModular (Result.Type_Symbol) then
            The_Modulus_String :=
              Dictionary.GetScalarAttributeValue
              (Base     => False,
               Name     => LexTokenManager.Modulus_Token,
               TypeMark => Result.Type_Symbol);
            Temp_Arg           := Result.Value;
            Maths.Modulus
              (FirstNum  => Temp_Arg,
               SecondNum => Maths.ValueRep (The_Modulus_String),
               Result    => Result.Value,
               Ok        => Err);
            case Err is
               when Maths.NoError =>
                  null;
               when Maths.DivideByZero =>
                  ErrorHandler.Semantic_Error
                    (Err_Num   => 400,
                     Reference => ErrorHandler.No_Reference,
                     Position  => Node_Pos,
                     Id_Str    => LexTokenManager.Null_String);
               when Maths.ConstraintError =>
                  ErrorHandler.Semantic_Error
                    (Err_Num   => Which_Err (Is_Annotation),
                     Reference => ErrorHandler.No_Reference,
                     Position  => Node_Pos,
                     Id_Str    => LexTokenManager.Null_String);
               when Maths.OverFlow =>
                  Result.Value := Maths.NoValue;
                  ErrorHandler.Semantic_Warning (Err_Num  => 200,
                                                 Position => Node_Pos,
                                                 Id_Str   => LexTokenManager.Null_String);
               when others => -- indicates internal error in maths package
                  SystemErrors.Fatal_Error (Sys_Err => SystemErrors.Math_Error,
                                            Msg     => "in CalcBinaryPlusMinus");
            end case;
         end if;
      end if;
      -- only other possibility is unary plus which has no effect
   end Calc_Unary_Plus_Minus;

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

   procedure Resolve_Universal (T_Stack : in     Type_Context_Stack.T_Stack_Type;
                                T       : in out Dictionary.Symbol)
   --# global in Dictionary.Dict;
   --# derives T from *,
   --#                Dictionary.Dict,
   --#                T_Stack;
   --# pre (Dictionary.Is_Null_Symbol (T) or Dictionary.IsTypeMark (T, Dictionary.Dict)) and
   --#   Type_Context_Stack.Stack_Is_Valid (T_Stack);
   --# post Dictionary.Is_Null_Symbol (T) or Dictionary.IsTypeMark (T, Dictionary.Dict);
   is

      procedure Debug_Print
      --# derives ;
      is
         --# hide Debug_Print;
      begin
         if CommandLineData.Content.Debug.Expressions then
            SPARK_IO.Put_String
              (SPARK_IO.Standard_Output,
               "Wf_Simple_Expression_Opt encounters a universal expression.  Resolving by context to type ",
               0);
            E_Strings.Put_Line
              (File  => SPARK_IO.Standard_Output,
               E_Str => LexTokenManager.Lex_String_To_String
                 (Lex_Str => Dictionary.GetSimpleName (Type_Context_Stack.Top (Stack => T_Stack))));
         end if;
      end Debug_Print;

   begin -- Resolve_Universal
      if not Dictionary.IsUnknownTypeMark (Type_Context_Stack.Top (Stack => T_Stack)) then
         if Dictionary.IsUniversalRealType (T) then
            T := Type_Context_Stack.Top (Stack => T_Stack);
            Debug_Print;
         elsif Dictionary.IsUniversalIntegerType (T) then
            T := Type_Context_Stack.Top (Stack => T_Stack);
            Debug_Print;
            -- It's tempting to want to do a ConstraintCheck here against
            -- T'Base.  Unfortunately, this can't be done reliably since
            -- Ada95's "preference rule" _might_ kick in and actualy make
            -- a static expression legal that would be rejected by a simple
            -- minded ConstraintCheck.  For example, consider:
            --
            --   type T is range -128 .. 127;
            --   --# assert T'Base is Short_Short_Integer; -- same range!
            --
            --   C : constant T := -128;
            --
            --   Ada95 - legal, owing to preference rule (which the Examiner doesn't implement!)
            -- SPARK95 - legal, owing to imperfect implementation here
            --   Ada83 - illegal (rejected by DEC Ada, for instance)
            -- SPARK83 - accepted (wrongly) owing to imperfect implementation here
            --
            -- So...the only user-visible mistake is an acceptance of illegal Ada
            -- in SPARK83 mode, which is a long-standing problem and only affects SPARK83
            -- projects anyway.  The risk of messing with this code and incorrectly
            -- rejecting _legal_ SPARK83 is so great, that it's best to leave the
            -- current implementation as is.
         end if;
      end if;
   end Resolve_Universal;

begin -- Wf_Simple_Expression_Opt
   Op_Node := STree.Child_Node (Current_Node => Node);
   -- ASSUME Op_Node = unary_adding_operator OR term OR annotation_term
   if STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.unary_adding_operator then
      -- ASSUME Op_Node = unary_adding_operator
      Exp_Stack.Pop (Item  => Result,
                     Stack => E_Stack);
      Resolve_Universal (T_Stack => T_Stack,
                         T       => Result.Type_Symbol);
      if STree.Syntax_Node_Type (Node => Node) = SP_Symbols.simple_expression_opt then
         STree.Add_Node_Symbol (Node => Op_Node,
                                Sym  => Result.Type_Symbol);
      end if;

      Base_Type := Dictionary.GetRootType (Result.Type_Symbol);
      Operator  := STree.Syntax_Node_Type (Node => STree.Child_Node (Current_Node => Op_Node));
      -- ASSUME Operator = plus OR minus
      SystemErrors.RT_Assert
        (C       => Operator = SP_Symbols.plus or else Operator = SP_Symbols.minus,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Operator = plus OR minus in Wf_Simple_Expression_Opt");
      if not Dictionary.UnaryOperatorIsDefined (Operator, Base_Type) then
         Result := Sem.Unknown_Type_Record;
         if Dictionary.IsModularType (Base_Type, Scope) then
            ErrorHandler.Semantic_Error
              (Err_Num   => 803,
               Reference => ErrorHandler.No_Reference,
               Position  => STree.Node_Position (Node => STree.Next_Sibling (Current_Node => Op_Node)),
               Id_Str    => LexTokenManager.Null_String);
         else
            ErrorHandler.Semantic_Error
              (Err_Num   => 40,
               Reference => ErrorHandler.No_Reference,
               Position  => STree.Node_Position (Node => STree.Next_Sibling (Current_Node => Op_Node)),
               Id_Str    => LexTokenManager.Null_String);
         end if;
      elsif STree.Syntax_Node_Type (Node => Node) = SP_Symbols.simple_expression_opt
        and then not Dictionary.UnaryOperatorIsVisible (Operator, Base_Type, Scope) then
         Result := Sem.Unknown_Type_Record;
         ErrorHandler.Semantic_Error
           (Err_Num   => 309,
            Reference => ErrorHandler.No_Reference,
            Position  => STree.Node_Position (Node => Op_Node),
            Id_Str    => LexTokenManager.Null_String);
      else
         Calc_Unary_Plus_Minus
           (Node_Pos      => STree.Node_Position (Node => Node),
            Is_Annotation => STree.Syntax_Node_Type (Node => Node) = SP_Symbols.annotation_simple_expression_opt,
            Op            => Operator,
            Result        => Result);
         Result.Type_Symbol := Base_Type;
         -- (if we decide that unary plus is to be ignored for aliasing purposes
         --  then lines below will have to change to reflect this)
         Result.Variable_Symbol       := Dictionary.NullSymbol;
         Result.Is_AVariable          := False;
         Result.Is_An_Entire_Variable := False;
         Result.Has_Operators         := True;
      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 STree.Syntax_Node_Type (Node => Op_Node) /= SP_Symbols.term
     and then STree.Syntax_Node_Type (Node => Op_Node) /= SP_Symbols.annotation_term then
      SystemErrors.Fatal_Error
        (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Op_Node = unary_adding_operator OR term OR annotation_term in Wf_Simple_Expression_Opt");
   end if;
end Wf_Simple_Expression_Opt;
