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

separate (Sem.Walk_Expression_P)
procedure Wf_Factor
  (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 : STree.SyntaxNode;

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

   procedure Do_Abs_Or_Not
     (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)
   --# global in     CommandLineData.Content;
   --#        in     Dictionary.Dict;
   --#        in     LexTokenManager.State;
   --#        in out ErrorHandler.Error_Context;
   --#        in out SPARK_IO.File_Sys;
   --#        in out STree.Table;
   --# derives ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         ErrorHandler.Error_Context,
   --#                                         E_Stack,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         Scope,
   --#                                         SPARK_IO.File_Sys,
   --#                                         STree.Table,
   --#                                         T_Stack &
   --#         E_Stack                    from *,
   --#                                         CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         Scope,
   --#                                         STree.Table,
   --#                                         T_Stack &
   --#         STree.Table                from *,
   --#                                         Dictionary.Dict,
   --#                                         E_Stack,
   --#                                         Node,
   --#                                         T_Stack;
   --# pre (STree.Syntax_Node_Type (Node, STree.Table) = SP_Symbols.factor or
   --#        STree.Syntax_Node_Type (Node, STree.Table) = SP_Symbols.annotation_factor) and
   --#   Type_Context_Stack.Stack_Is_Valid (T_Stack);
   --# post STree.Table = STree.Table~;
   is
      Result    : Sem.Exp_Record;
      Base_Type : Dictionary.Symbol;
      Op_Node   : STree.SyntaxNode;
      Operator  : SP_Symbols.SP_Symbol;
      Val       : Maths.Value;
      Error     : Boolean;

      procedure Resolve_Universal
        (Node     : in     STree.SyntaxNode;
         Operator : in     SP_Symbols.SP_Symbol;
         T_Stack  : in     Type_Context_Stack.T_Stack_Type;
         Val      : in     Maths.Value;
         T        : in out Dictionary.Symbol;
         Error    :    out Boolean)
      --# global in     CommandLineData.Content;
      --#        in     Dictionary.Dict;
      --#        in     LexTokenManager.State;
      --#        in     STree.Table;
      --#        in out ErrorHandler.Error_Context;
      --#        in out SPARK_IO.File_Sys;
      --# derives Error                      from Dictionary.Dict,
      --#                                         LexTokenManager.State,
      --#                                         Operator,
      --#                                         T,
      --#                                         T_Stack,
      --#                                         Val &
      --#         ErrorHandler.Error_Context,
      --#         SPARK_IO.File_Sys          from CommandLineData.Content,
      --#                                         Dictionary.Dict,
      --#                                         ErrorHandler.Error_Context,
      --#                                         LexTokenManager.State,
      --#                                         Node,
      --#                                         Operator,
      --#                                         SPARK_IO.File_Sys,
      --#                                         STree.Table,
      --#                                         T,
      --#                                         T_Stack,
      --#                                         Val &
      --#         T                          from *,
      --#                                         Dictionary.Dict,
      --#                                         T_Stack;
      --# pre (STree.Syntax_Node_Type (Node, STree.Table) = SP_Symbols.factor or
      --#        STree.Syntax_Node_Type (Node, STree.Table) = SP_Symbols.annotation_factor) and
      --#   Type_Context_Stack.Stack_Is_Valid (T_Stack) and
      --#   (Dictionary.Is_Null_Symbol (T) or Dictionary.IsTypeMark (T, Dictionary.Dict));
      --# post Dictionary.Is_Null_Symbol (T) or Dictionary.IsTypeMark (T, Dictionary.Dict);
      is
         Base_Type : Dictionary.Symbol;
         Val_Check : Maths.Value;

         procedure Debug_Print
         --# derives ;
         is
            --# hide Debug_Print;
         begin
            if CommandLineData.Content.Debug.Expressions then
               SPARK_IO.Put_String
                 (SPARK_IO.Standard_Output,
                  "Wf_Factor 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
         Error := False;
         if Dictionary.IsUniversalRealType (T) then -- We want to convert but not check
            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;
            Val_Check := Val;
            if Operator = SP_Symbols.RWabs then -- Check against T'Base
               Base_Type := Dictionary.GetBaseType (T);
               if not Dictionary.Is_Null_Symbol (Base_Type) then
                  Sem.Constraint_Check
                    (Val           => Val,
                     New_Val       => Val_Check,
                     Is_Annotation => False,
                     Typ           => Base_Type,
                     Position      => STree.Node_Position
                       (Node => STree.Last_Child_Of
                          (Start_Node => STree.Last_Sibling_Of (Start_Node => STree.Last_Child_Of (Start_Node => Node)))));
               end if;
            elsif Operator = SP_Symbols.RWnot then -- Check against T
               if Dictionary.IsUnknownTypeMark (T) then
                  -- Trying to resolve from Universal_Integer to Unknown means we don't have
                  -- enough context to resolve the type or value of this expression, so SPARK
                  -- requires qualification.
                  ErrorHandler.Semantic_Error
                    (Err_Num   => 806,
                     Reference => ErrorHandler.No_Reference,
                     Position  => STree.Node_Position (Node => Node),
                     Id_Str    => LexTokenManager.Null_String);
               else
                  Sem.Constraint_Check
                    (Val           => Val,
                     New_Val       => Val_Check,
                     Is_Annotation => False,
                     Typ           => T,
                     Position      => STree.Node_Position
                       (Node => STree.Last_Child_Of
                          (Start_Node => STree.Last_Sibling_Of (Start_Node => STree.Last_Child_Of (Start_Node => Node)))));
               end if;
            end if;
            if Maths.HasNoValue (Val_Check) then
               Error := True;
            end if;
         end if;
      end Resolve_Universal;

      procedure Calc_Abs_Or_Not (Base_Type : in     Dictionary.Symbol;
                                 Operator  : in     SP_Symbols.SP_Symbol;
                                 Val       : in out Maths.Value)
      --# global in Dictionary.Dict;
      --#        in LexTokenManager.State;
      --# derives Val from *,
      --#                  Base_Type,
      --#                  Dictionary.Dict,
      --#                  LexTokenManager.State,
      --#                  Operator;
      is
      begin
         if Operator = SP_Symbols.RWabs then
            Maths.Absolute (Val);
         elsif Operator = SP_Symbols.RWnot then
            if Dictionary.TypeIsModular (Base_Type) then
               Maths.ModularNotOp
                 (Val,
                  Maths.ValueRep (Dictionary.GetScalarAttributeValue (False, LexTokenManager.Modulus_Token, Base_Type)));
            else
               Maths.NotOp (Val);
            end if;
         end if;
      end Calc_Abs_Or_Not;

   begin -- Do_Abs_Or_Not
      Exp_Stack.Pop (Item  => Result,
                     Stack => E_Stack); -- same result type and flags

      Op_Node  := STree.Child_Node (Current_Node => Node);
      Operator := STree.Syntax_Node_Type (Node => Op_Node);
      -- ASSUME Operator = RWabs OR RWnot
      SystemErrors.RT_Assert
        (C       => Operator = SP_Symbols.RWabs or else Operator = SP_Symbols.RWnot,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Operator = RWabs OR RWnot in Do_Abs_Or_Not");

      Val := Result.Value;

      Resolve_Universal
        (Node     => Node,
         Operator => Operator,
         T_Stack  => T_Stack,
         Val      => Val,
         T        => Result.Type_Symbol,
         Error    => Error);

      Base_Type := Dictionary.GetRootType (Result.Type_Symbol);
      STree.Add_Node_Symbol (Node => Op_Node,
                             Sym  => Result.Type_Symbol);

      if Error then
         Result := Sem.Unknown_Type_Record;
      end if;

      if not Dictionary.UnaryOperatorIsDefined (Operator, Base_Type) then
         Result := Sem.Unknown_Type_Record;
         if Operator = SP_Symbols.RWabs then
            if Dictionary.IsModularType (Base_Type, Scope) then
               ErrorHandler.Semantic_Error
                 (Err_Num   => 803,
                  Reference => ErrorHandler.No_Reference,
                  Position  => STree.Node_Position (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 (Op_Node)),
                  Id_Str    => LexTokenManager.Null_String);
            end if;
         elsif Operator = SP_Symbols.RWnot then
            ErrorHandler.Semantic_Error_Sym
              (Err_Num   => 119,
               Reference => ErrorHandler.No_Reference,
               Position  => STree.Node_Position (Node => Op_Node),
               Sym       => Base_Type,
               Scope     => Scope);
         end if;
      elsif STree.Syntax_Node_Type (Node => Node) = SP_Symbols.factor
        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
         -- check for misuse of unconstrained boolean array
         if Dictionary.Is_Unconstrained_Array_Type_Mark (Result.Type_Symbol, Scope) then
            Result.Errors_In_Expression := True;
            ErrorHandler.Semantic_Error
              (Err_Num   => 39,
               Reference => ErrorHandler.No_Reference,
               Position  => STree.Node_Position (Node => STree.Next_Sibling (Op_Node)),
               Id_Str    => LexTokenManager.Null_String);
         end if;

         Val := Result.Value;
         Calc_Abs_Or_Not (Base_Type => Base_Type,
                          Operator  => Operator,
                          Val       => Val);
         Result.Value := Val;
         if Dictionary.TypeIsScalar (Result.Type_Symbol) then
            Result.Type_Symbol := Base_Type;
         end if;
         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 used 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);
   end Do_Abs_Or_Not;

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

   procedure Do_Star_Star
     (Node, Op_Node                 : in     STree.SyntaxNode;
      Left_Node_Pos, Right_Node_Pos : in     LexTokenManager.Token_Position;
      Scope                         : in     Dictionary.Scopes;
      E_Stack                       : in out Exp_Stack.Exp_Stack_Type;
      T_Stack                       : in     Type_Context_Stack.T_Stack_Type)
   --# global in     CommandLineData.Content;
   --#        in     Dictionary.Dict;
   --#        in     LexTokenManager.State;
   --#        in out ErrorHandler.Error_Context;
   --#        in out SPARK_IO.File_Sys;
   --#        in out STree.Table;
   --# derives ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         ErrorHandler.Error_Context,
   --#                                         E_Stack,
   --#                                         Left_Node_Pos,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         Op_Node,
   --#                                         Right_Node_Pos,
   --#                                         Scope,
   --#                                         SPARK_IO.File_Sys,
   --#                                         STree.Table,
   --#                                         T_Stack &
   --#         E_Stack                    from *,
   --#                                         CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         Scope,
   --#                                         STree.Table,
   --#                                         T_Stack &
   --#         STree.Table                from *,
   --#                                         CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         E_Stack,
   --#                                         Node,
   --#                                         Op_Node,
   --#                                         Scope,
   --#                                         T_Stack;
   --# pre (STree.Syntax_Node_Type (Node, STree.Table) = SP_Symbols.factor or
   --#        STree.Syntax_Node_Type (Node, STree.Table) = SP_Symbols.annotation_factor) and
   --#   STree.Syntax_Node_Type (Op_Node, STree.Table) = SP_Symbols.double_star and
   --#   Type_Context_Stack.Stack_Is_Valid (T_Stack);
   --# post STree.Table = STree.Table~;
   is
      Left, Right, Result : Sem.Exp_Record;
      The_Child_Node      : STree.SyntaxNode;
   begin
      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;
      Result.Is_Static     := Left.Is_Static and then Right.Is_Static;
      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 First,
         --  implicit type conversion

         --  Implicitly convert the Left operand if its type is
         --  Universal, and the context is not unknown.
         if (Dictionary.IsUniversalIntegerType (Left.Type_Symbol) or else Dictionary.IsUniversalRealType (Left.Type_Symbol))
           and then not Dictionary.IsUnknownTypeMark (Type_Context_Stack.Top (Stack => T_Stack)) then
            Left.Type_Symbol := Type_Context_Stack.Top (Stack => T_Stack);
         end if;

         -- The right operand of ** is always predefined Integer, so this
         -- does not depend upon the context stack.
         if Dictionary.IsUniversalIntegerType (Right.Type_Symbol) then
            Right.Type_Symbol := Dictionary.GetPredefinedIntegerType;
         end if;
         The_Child_Node := STree.Child_Node (Current_Node => Node);
         -- ASSUME The_Child_Node = primary OR annotation_primary OR RWabs OR RWnot
         SystemErrors.RT_Assert
           (C       => STree.Syntax_Node_Type (Node => The_Child_Node) = SP_Symbols.primary
              or else STree.Syntax_Node_Type (Node => The_Child_Node) = SP_Symbols.annotation_primary
              or else STree.Syntax_Node_Type (Node => The_Child_Node) = SP_Symbols.RWabs
              or else STree.Syntax_Node_Type (Node => The_Child_Node) = SP_Symbols.RWnot,
            Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect The_Child_Node = primary OR annotation_primary OR RWabs OR RWnot in Do_Star_Star");
         -- add type of LHS to syntax tree for use by VCG in run-time checks
         STree.Add_Node_Symbol (Node => The_Child_Node,
                                Sym  => Left.Type_Symbol);
         -- then, operator visibility
         Check_Binary_Operator
           (Operator      => SP_Symbols.double_star,
            Left          => Left,
            Right         => Right,
            Scope         => Scope,
            T_Stack       => T_Stack,
            Op_Pos        => STree.Node_Position (Node => Op_Node),
            Left_Pos      => Left_Node_Pos,
            Right_Pos     => Right_Node_Pos,
            Convert       => False,
            Is_Annotation => STree.Syntax_Node_Type (Node => Node) = SP_Symbols.annotation_factor,
            Result        => Result);
         STree.Add_Node_Symbol (Node => Op_Node,
                                Sym  => Result.Type_Symbol);
         Calc_Binary_Operator
           (Node_Pos      => STree.Node_Position (Node => Node),
            Operator      => SP_Symbols.double_star,
            Left_Val      => Left.Value,
            Right_Val     => Right.Value,
            Is_Annotation => STree.Syntax_Node_Type (Node => Node) = SP_Symbols.annotation_factor,
            Result        => Result);
      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);
   end Do_Star_Star;

begin -- Wf_Factor
   Op_Node := STree.Child_Node (Current_Node => Node);
   -- ASSUME Op_Node = RWabs OR RWnot OR primary OR annotation_primary
   if STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.RWabs
     or else STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.RWnot then
      -- ASSUME Op_Node = RWabs OR RWnot
      Do_Abs_Or_Not (Node    => Node,
                     Scope   => Scope,
                     E_Stack => E_Stack,
                     T_Stack => T_Stack);
   elsif STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.primary
     or else STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.annotation_primary then
      -- ASSUME Op_Node = primary OR annotation_primary
      Op_Node := STree.Next_Sibling (Current_Node => Op_Node);
      -- ASSUME Op_Node = double_star OR NULL
      if STree.Syntax_Node_Type (Node => Op_Node) = SP_Symbols.double_star then
         -- ASSUME Op_Node = double_star
         Do_Star_Star
           (Node           => Node,
            Op_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)),
            Scope          => Scope,
            E_Stack        => E_Stack,
            T_Stack        => T_Stack);
      elsif Op_Node /= STree.NullNode then
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Op_Node = double_star OR NULL in Wf_Factor");
      end if;
   else
      SystemErrors.Fatal_Error
        (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Op_Node = RWabs OR RWnot OR primary OR annotation_primary in Wf_Factor");
   end if;
end Wf_Factor;
