-------------------------------------------------------------------------------
-- (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.Walk_Expression_P)
procedure Expression_Type_From_Context
  (Exp_Node         : in     STree.SyntaxNode;
   E_Stack          : in     Exp_Stack.Exp_Stack_Type;
   T_Stack          : in     Type_Context_Stack.T_Stack_Type;
   New_Context_Type :    out Dictionary.Symbol)
is
   Top_Of_Exp_Stack  : Sem.Exp_Record;
   Parameter_Name_OK : Boolean;
   Param_Symbol      : Dictionary.Symbol;
   Parent, T_Node_2  : STree.SyntaxNode;
begin
   ------------------------------------------------------------------------
   -- Possible parent nodes are:
   --
   -- Group 1 - Expressions appearing in statements or declarations
   --
   -- constant_declaration
   -- variable_declaration
   -- assignment_statement
   -- condition
   -- case_statement
   -- return_statement
   -- delay_statement
   --
   -- Group 2 - Expressions appearing in expressions, common to both code
   --           and annotations
   --
   -- annotation_named_argument_association
   -- named_argument_association
   -- annotation_positional_argument_association
   -- positional_argument_association
   -- annotation_attribute_designator_opt
   -- attribute_designator_opt
   -- annotation_aggregate_or_expression
   -- aggregate_or_expression
   -- annotation_primary
   -- primary
   -- annotation_qualified_expression
   -- qualified_expression
   --
   -- Group 3 - Expressions appearing in annotations only
   --
   -- store
   -- store_list
   -- return_expression
   -- predicate
   ------------------------------------------------------------------------
   Parent := STree.Parent_Node (Current_Node => Exp_Node);
   -- ASSUME Parent = constant_declaration       OR named_argument_association            OR return_statement  OR
   --                 proof_constant_declaration OR annotation_named_argument_association OR return_expression OR
   --                 positional_argument_association            OR attribute_designator_opt            OR primary            OR
   --                 annotation_positional_argument_association OR annotation_attribute_designator_opt OR annotation_primary OR
   --                 aggregate_or_expression            OR qualified_expression            OR ancestor_part            OR
   --                 annotation_aggregate_or_expression OR annotation_qualified_expression OR annotation_ancestor_part OR
   --                 positional_record_component_association            OR named_record_component_association            OR
   --                 annotation_positional_record_component_association OR annotation_named_record_component_association OR
   --                 variable_declaration OR unconstrained_array_assignment OR assignment_statement OR condition OR
   --                 case_statement OR priority_pragma OR delay_statement OR store OR store_list OR predicate
   case STree.Syntax_Node_Type (Node => Parent) is
      when SP_Symbols.constant_declaration |
        SP_Symbols.variable_declaration |
        SP_Symbols.assignment_statement |
        SP_Symbols.condition            |
        SP_Symbols.case_statement       |
        SP_Symbols.return_statement     |
        SP_Symbols.delay_statement      =>
         -- ASSUME Parent = constant_declaration OR variable_declaration OR assignment_statement OR condition OR
         --                 case_statement OR return_statement OR delay_statement

         -- Context here is passed in from calling environment, and
         -- no change required.
         New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
      when SP_Symbols.named_argument_association | SP_Symbols.annotation_named_argument_association =>
         -- ASSUME Parent = named_argument_association OR annotation_named_argument_association
         if Exp_Stack.Is_Empty (Stack => E_Stack) then
            -- Must be a named argument association in a procedure
            -- call.  Wf_Proc_Call processes the parameter name, and
            -- does NOT put it on the expression stack, but it does pass
            -- the expected type into WalkExpression, so this is unchanged
            -- in this case.
            New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
         else
            -- Must be a named argument association which is the parameter
            -- list of a function call.
            Top_Of_Exp_Stack := Exp_Stack.Top (Stack => E_Stack);

            -- We need to find the parameter name, and determine if it is legal:
            Find_Named_Argument_Association_Parameter
              (Node                   => Parent,
               Subprog_Sym            => Top_Of_Exp_Stack.Other_Symbol,
               Name_Is_Parameter_Name => Parameter_Name_OK,
               Param_Sym              => Param_Symbol);

            if Parameter_Name_OK then
               -- The parameter name denotes a legal parameter of this subprogram,
               -- so look up its type.
               New_Context_Type := Dictionary.GetType (Param_Symbol);
            else
               -- The parameter name is illegal.  This will be picked up again later
               -- on in wf_named_argument_association.  The type context simply
               -- becomes unknown.
               New_Context_Type := Dictionary.GetUnknownTypeMark;
            end if;
         end if;
      when SP_Symbols.qualified_expression | SP_Symbols.annotation_qualified_expression =>
         -- ASSUME Parent = qualified_expression OR annotation_qualified_expression

         -- Context changes to the type denoted by the Name preceeding the
         -- expression.  The result of evaluating this Name should be on the
         -- top of the Expression stack.
         Top_Of_Exp_Stack := Exp_Stack.Top (Stack => E_Stack);
         New_Context_Type := Top_Of_Exp_Stack.Type_Symbol;
      when SP_Symbols.positional_argument_association | SP_Symbols.annotation_positional_argument_association =>
         -- ASSUME Parent = positional_argument_association OR annotation_positional_argument_association

         -- Parent could be name_argument_list or another
         -- positional_argument_association.
         -- This could be part of a
         --   Type conversion
         --   Array index
         --   Function call
         if Exp_Stack.Is_Empty (Stack => E_Stack) then
            -- EStack might be empty here => we must be processing an
            -- actual param of a procedure call statement.  Context
            -- will have been passed in from wf_proc_call, so no change here.
            New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
         else
            Top_Of_Exp_Stack := Exp_Stack.Top (Stack => E_Stack);
            case Top_Of_Exp_Stack.Sort is
               when Sem.Is_Object =>
                  -- Must be an array indexing expression.  The context is therefore
                  -- the subtype corresponding to the N'th dimension of that array type.
                  if Top_Of_Exp_Stack.Param_Count < Natural'Last then
                     New_Context_Type := Dictionary.GetArrayIndex (Top_Of_Exp_Stack.Type_Symbol, Top_Of_Exp_Stack.Param_Count + 1);
                  else
                     New_Context_Type := Dictionary.GetUnknownTypeMark;
                  end if;
               when Sem.Is_Function =>
                  -- Must be an actual parameter of a function call.  The context
                  -- is the subtype indicated by the corresponding formal parameter,
                  -- if there is any such parameter.  If the wrong number of actual
                  -- parameters has been given, then return UnknownTypeMark - this
                  -- error will be picked up later in the UP pass.
                  if Top_Of_Exp_Stack.Param_Count < Dictionary.GetNumberOfSubprogramParameters (Top_Of_Exp_Stack.Other_Symbol) then
                     New_Context_Type :=
                       Dictionary.GetType
                       (Dictionary.GetSubprogramParameter (Top_Of_Exp_Stack.Other_Symbol, Top_Of_Exp_Stack.Param_Count + 1));
                  else
                     New_Context_Type := Dictionary.GetUnknownTypeMark;
                  end if;
               when Sem.Is_Type_Mark =>
                  -- Must be a type conversion.  The argument of the type conversion
                  -- could be pretty much anything - legal or illegal, so the
                  -- context is unknown.
                  New_Context_Type := Dictionary.GetUnknownTypeMark;
               when others =>
                  -- Other cases - all errors which will be caught later on...
                  -- We still need to push something onto the TStack to make
                  -- it balance, so simply copy the existing top entry.
                  New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
            end case;
         end if;
      when SP_Symbols.aggregate_or_expression | SP_Symbols.annotation_aggregate_or_expression =>
         -- ASSUME Parent = aggregate_or_expression OR annotation_aggregate_or_expression
         Parent := STree.Parent_Node (Current_Node => Parent);
         -- ASSUME Parent = component_association            OR named_association            OR named_association_rep            OR
         --                 annotation_component_association OR annotation_named_association OR annotation_named_association_rep OR
         --                 positional_association            OR positional_association_rep OR
         --                 annotation_positional_association OR annotation_positional_association_rep OR name_value_property
         case STree.Syntax_Node_Type (Node => Parent) is
            when SP_Symbols.component_association | SP_Symbols.annotation_component_association =>
               -- ASSUME Parent = component_association OR annotation_component_association

               -- Must be an array aggregate with a single others clause, so the
               -- new context type is the type of the array element
               Top_Of_Exp_Stack := Exp_Stack.Top (Stack => E_Stack);
               New_Context_Type := Dictionary.GetArrayComponent (Top_Of_Exp_Stack.Type_Symbol);
            when SP_Symbols.named_association                |
              SP_Symbols.named_association_rep            |
              SP_Symbols.annotation_named_association     |
              SP_Symbols.annotation_named_association_rep =>
               -- ASSUME Parent = named_association            OR named_association_rep OR
               --                 annotation_named_association OR annotation_named_association_rep
               Top_Of_Exp_Stack := Exp_Stack.Top (Stack => E_Stack);
               case Top_Of_Exp_Stack.Sort is
                  when Sem.Is_Parameter_Name =>
                     -- Must be a named field of a record aggregate.  New context is
                     -- the type of that field, unless the field was itself illegal,
                     -- in which case the context is unknown.
                     if Top_Of_Exp_Stack = Null_Parameter_Record then
                        New_Context_Type := Dictionary.GetUnknownTypeMark;
                     else
                        New_Context_Type := Dictionary.GetType (Top_Of_Exp_Stack.Other_Symbol);
                     end if;
                  when Sem.Is_Type_Mark =>
                     -- Must be a named element of an array aggregate.  New context is
                     -- the type of the array element.
                     New_Context_Type := Dictionary.GetArrayComponent (Top_Of_Exp_Stack.Type_Symbol);
                  when others =>
                     New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
               end case;
            when SP_Symbols.positional_association                |
              SP_Symbols.positional_association_rep            |
              SP_Symbols.annotation_positional_association     |
              SP_Symbols.annotation_positional_association_rep =>
               -- ASSUME Parent = positional_association            OR positional_association_rep OR
               --                 annotation_positional_association OR annotation_positional_association_rep
               Top_Of_Exp_Stack := Exp_Stack.Top (Stack => E_Stack);
               case Top_Of_Exp_Stack.Sort is
                  when Sem.Is_Type_Mark =>
                     if Dictionary.TypeIsRecord (Top_Of_Exp_Stack.Type_Symbol) then
                        -- New context is the type of the N'th field of the record, assuming
                        -- there is such a field.
                        if Top_Of_Exp_Stack.Param_Count < Dictionary.GetNumberOfComponents (Top_Of_Exp_Stack.Type_Symbol) then
                           New_Context_Type :=
                             Dictionary.GetType
                             (Dictionary.GetRecordComponent (Top_Of_Exp_Stack.Type_Symbol, Top_Of_Exp_Stack.Param_Count + 1));
                        else
                           New_Context_Type := Dictionary.GetUnknownTypeMark;
                        end if;
                     elsif Dictionary.TypeIsArray (Top_Of_Exp_Stack.Type_Symbol) then
                        -- New context is the element type of the array
                        New_Context_Type := Dictionary.GetArrayComponent (Top_Of_Exp_Stack.Type_Symbol);
                     else
                        -- Must be an error - this will be caught later on in the UP
                        -- pass, but we need to push something so...
                        New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
                     end if;
                  when others =>
                     -- Must be an error - this will be caught later on in the UP
                     -- pass, but we need to push something so...
                     New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
               end case;
            when SP_Symbols.name_value_property =>
               -- ASSUME Parent = name_value_property
               New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
            when others =>
               New_Context_Type := Dictionary.NullSymbol;
               SystemErrors.Fatal_Error
                 (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
                  Msg     => "Expect Parent = component_association OR named_association OR named_association_rep OR " &
                    "annotation_component_association OR annotation_named_association OR annotation_named_association_rep OR " &
                    "positional_association OR positional_association_rep OR annotation_positional_association OR " &
                    "annotation_positional_association_rep OR name_value_property in Expression_Type_From_Context");
         end case;
      when SP_Symbols.attribute_designator_opt | SP_Symbols.annotation_attribute_designator_opt =>
         -- ASSUME Parent = attribute_designator_opt OR annotation_attribute_designator_opt

         -- Context change for attribute arguments is handled in
         -- AttributeDesignatorTypeFromContext, so no change here.
         New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
      when SP_Symbols.primary | SP_Symbols.annotation_primary =>
         -- ASSUME Parent = primary OR annotation_primary

         -- Must be a parenthesized expression - context does not change.
         New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
      when SP_Symbols.store =>
         -- ASSUME Parent = store
         Top_Of_Exp_Stack := Exp_Stack.Top (Stack => E_Stack);
         case Top_Of_Exp_Stack.Sort is
            when Sem.Is_Object =>
               if Dictionary.TypeIsArray (Top_Of_Exp_Stack.Type_Symbol) then
                  New_Context_Type := Dictionary.GetArrayComponent (Top_Of_Exp_Stack.Type_Symbol);
               elsif Dictionary.TypeIsRecord (Top_Of_Exp_Stack.Type_Symbol) then
                  -- The record field being updated should be an identifier
                  -- node directly below the store node, so
                  T_Node_2 := STree.Last_Child_Of (Start_Node => Parent);
                  if STree.Syntax_Node_Type (Node => T_Node_2) = SP_Symbols.identifier then
                     -- ASSUME T_Node_2 = identifier
                     Param_Symbol :=
                       Dictionary.LookupSelectedItem
                       (Prefix   => Top_Of_Exp_Stack.Type_Symbol,
                        Selector => STree.Node_Lex_String (Node => T_Node_2),
                        Scope    => Dictionary.GetScope (Top_Of_Exp_Stack.Type_Symbol),
                        Context  => Dictionary.ProofContext);
                     if not Dictionary.Is_Null_Symbol (Param_Symbol) and then Dictionary.IsRecordComponent (Param_Symbol) then
                        STree.Set_Node_Lex_String (Sym  => Param_Symbol,
                                                   Node => T_Node_2);
                        New_Context_Type := Dictionary.GetType (Param_Symbol);
                     else
                        -- error - will be caught in up_wf_store
                        New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
                     end if;
                  else
                     -- error - will be caught in up_wf_store
                     New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
                  end if;
               else
                  -- error - will be caught in up_wf_store
                  New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
               end if;
            when others =>
               -- Must be an error - this will be caught later on in the UP
               -- pass, but we need to push something so...
               New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
         end case;
      when SP_Symbols.store_list =>
         -- ASSUME Parent = store_list
         Top_Of_Exp_Stack := Exp_Stack.Top (Stack => E_Stack);
         case Top_Of_Exp_Stack.Sort is
            when Sem.Is_Object =>
               if Dictionary.TypeIsArray (Top_Of_Exp_Stack.Type_Symbol) then
                  if Top_Of_Exp_Stack.Param_Count < Natural'Last then
                     New_Context_Type := Dictionary.GetArrayIndex (Top_Of_Exp_Stack.Type_Symbol, Top_Of_Exp_Stack.Param_Count + 1);
                  else
                     New_Context_Type := Dictionary.GetUnknownTypeMark;
                  end if;
               else
                  -- error - will be caught in up_wf_store
                  New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
               end if;
            when others =>
               -- Must be an error - this will be caught later on in the UP
               -- pass, but we need to push something so...
               New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
         end case;
      when SP_Symbols.return_expression | SP_Symbols.predicate =>
         -- ASSUME return_expression OR predicate

         -- Context for predicate and return_expression is always passed
         -- in from wf_predicate, or wf_function_constraint, so no change needed.
         New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
      when SP_Symbols.proof_constant_declaration                         |
        SP_Symbols.ancestor_part                                      |
        SP_Symbols.annotation_ancestor_part                           |
        SP_Symbols.positional_record_component_association            |
        SP_Symbols.annotation_positional_record_component_association |
        SP_Symbols.named_record_component_association                 |
        SP_Symbols.annotation_named_record_component_association      |
        SP_Symbols.unconstrained_array_assignment                     |
        SP_Symbols.priority_pragma                                    =>
         -- ASSUME Parent = proof_constant_declaration OR ancestor_part OR annotation_ancestor_part OR
         --                 positional_record_component_association            OR named_record_component_association            OR
         --                 annotation_positional_record_component_association OR annotation_named_record_component_association OR
         --                 unconstrained_array_assignment OR priority_pragma

         -- In all other cases, the context is unchanged, but we push a copy
         -- of the current context type to keep the stack balanced.
         New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
      when others =>
         New_Context_Type := Dictionary.NullSymbol;
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Parent = constant_declaration OR named_argument_association OR return_statement OR " &
              "proof_constant_declaration OR annotation_named_argument_association OR return_expression OR " &
              "positional_argument_association OR attribute_designator_opt OR primary OR " &
              "annotation_positional_argument_association OR annotation_attribute_designator_opt OR annotation_primary OR " &
              "aggregate_or_expression OR qualified_expression OR ancestor_part OR " &
              "annotation_aggregate_or_expression OR annotation_qualified_expression OR annotation_ancestor_part OR " &
              "positional_record_component_association OR named_record_component_association OR " &
              "annotation_positional_record_component_association OR annotation_named_record_component_association OR " &
              "variable_declaration OR unconstrained_array_assignment OR assignment_statement OR condition OR case_statement OR " &
              "priority_pragma OR delay_statement OR store OR store_list OR predicate in Expression_Type_From_Context");
   end case;
end Expression_Type_From_Context;
