-------------------------------------------------------------------------------
-- (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)
function Simple_Expression_Type_From_Context
  (Exp_Node : STree.SyntaxNode;
   T_Stack  : Type_Context_Stack.T_Stack_Type)
  return     Dictionary.Symbol
is
   New_Context_Type : Dictionary.Symbol;
   Parent, Child    : STree.SyntaxNode;
   Grand_Parent     : STree.SyntaxNode;
begin
   -- The determination of the type context for a simple_expression depends
   -- on the parent (and possibly the grandparent) node in the syntax tree.
   -- The possible parent nodes (as determined from the grammar) are as follows,
   -- and fall into 3 groups:
   --
   --  Group 1 - parent nodes where a change of context might be needed
   --      arange
   --      annotation_arange
   --      aggregate_choice
   --      annotation_aggregate_choice
   --      case_choice
   --      relation
   --      annotation_relation
   --
   -- Group 2 - parent nodes where the simple_expression appears in a universal
   --           context, and the context is supplied by whoever called WalkExpression,
   --           so no change in context needed.
   --      Modular_Type_Definition
   --      Floating_Accuracy_Definition
   --      Fixed_Accuracy_Definition
   --
   -- Group 3 - Simple_Expressions appearing in rep. clauses, which are not analysed
   --           at present, so no change in context needed.
   --      Attribute_Definition_Clause
   --      Mod_Clause
   --      Component_Clause
   --      At_Clause

   Parent := STree.Parent_Node (Current_Node => Exp_Node);
   -- ASSUME Parent = modular_type_definition OR floating_accuracy_definition OR fixed_accuracy_definition OR
   --                 case_choice OR attribute_definition_clause OR mod_clause OR component_clause OR at_clause OR
   --                 arange            OR aggregate_choice            OR relation            OR simple_expression OR
   --                 annotation_arange OR annotation_aggregate_choice OR annotation_relation OR annotation_simple_expression
   case STree.Syntax_Node_Type (Node => Parent) is

      --------------------------
      -- Group 1 Parent nodes --
      --------------------------

      when SP_Symbols.arange | SP_Symbols.annotation_arange =>
         -- ASSUME Parent = arange OR annotation_arange
         -- For [annotation_]arange, the new context depends on the
         -- grandparent node as well.  Possible grandparent nodes are:
         --   relation
         --   annotation_relation
         --   loop_parameter_specification
         --   range_constraint
         --   annotation_range_constraint
         --   quantified_expression
         --   component_clause

         Grand_Parent := STree.Parent_Node (Current_Node => Parent);
         -- ASSUME Grand_Parent = loop_parameter_specification OR component_clause OR quantified_expression OR
         --                       range_constraint            OR relation            OR
         --                       annotation_range_constraint OR annotation_relation
         case STree.Syntax_Node_Type (Node => Grand_Parent) is
            when SP_Symbols.relation | SP_Symbols.annotation_relation =>
               -- ASSUME Grand_Parent = relation OR annotation_relation
               -- Must be a membership test like "A in B .. C" or
               -- Context is lost here, since "in" is defined for all types.
               New_Context_Type := Dictionary.GetUnknownTypeMark;
            when SP_Symbols.loop_parameter_specification =>
               -- ASSUME Grand_Parent = loop_parameter_specification
               -- Context for the loop range is passed in from wf_loop_param,
               -- so no change is needed here.
               New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
            when SP_Symbols.range_constraint | SP_Symbols.annotation_range_constraint =>
               -- ASSUME Grand_Parent = range_constraint OR annotation_range_constraint
               -- These nodes have their own special function for determining context,
               -- so no change here.
               New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
            when SP_Symbols.quantified_expression =>
               -- ASSUME Grand_Parent = quantified_expression
               -- Down_wf_quantifier plants the quantified variable's symbol
               -- in the Identifier node below the quantified_expression node, so we
               -- can grab that and look up its type.
               New_Context_Type := Dictionary.GetType (STree.NodeSymbol (STree.Next_Sibling (STree.Child_Node (Grand_Parent))));
            when SP_Symbols.component_clause =>
               -- ASSUME Grand_Parent = component_clause
               -- Part of a rep. clause, so no change
               New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
            when others =>
               -- Must be an error resulting from an invalid syntax tree,
               -- but we need to push something so...
               New_Context_Type := Dictionary.NullSymbol;
               SystemErrors.Fatal_Error
                 (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
                  Msg     => "Expect Grand_Parent = loop_parameter_specification OR component_clause OR quantified_expression OR " &
                    "range_constraint            OR relation            OR " &
                    "annotation_range_constraint OR annotation_relation in Simple_Expression_Type_From_Context");
         end case;
      when SP_Symbols.aggregate_choice | SP_Symbols.annotation_aggregate_choice =>
         -- ASSUME Parent = aggregate_choice OR annotation_aggregate_choice
         -- For a named aggregate choice, the required index type is
         -- always on top of the aggregate stack, so...
         New_Context_Type := Aggregate_Stack.Top_Type_Sym;
      when SP_Symbols.case_choice =>
         -- ASSUME Parent = case_choice
         -- The correct type for the context is passed into WalkExpression
         -- from wf_case_choice, so no change required here.
         New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
      when SP_Symbols.relation | SP_Symbols.annotation_relation =>
         -- ASSUME Parent = relation OR annotation_relation
         Child := STree.Next_Sibling (Current_Node => STree.Child_Node (Current_Node => Parent));
         -- ASSUME Child = relational_operator OR inside OR outside OR NULL
         if Child = STree.NullNode then
            -- ASSUME Child = NULL
            -- This relation has no operator, so preserve context
            New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
         elsif STree.Syntax_Node_Type (Node => Child) = SP_Symbols.relational_operator
           or else STree.Syntax_Node_Type (Node => Child) = SP_Symbols.inside
           or else STree.Syntax_Node_Type (Node => Child) = SP_Symbols.outside then
            -- This relation has an operator, so context is lost
            New_Context_Type := Dictionary.GetUnknownTypeMark;
         else
            New_Context_Type := Dictionary.NullSymbol;
            SystemErrors.Fatal_Error
              (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
               Msg     => "Expect Child = relational_operator OR inside OR outside OR NULL in Simple_Expression_Type_From_Context");
         end if;
         --------------------------
         -- Group 2 Parent nodes --
         --------------------------
      when SP_Symbols.modular_type_definition | SP_Symbols.floating_accuracy_definition | SP_Symbols.fixed_accuracy_definition =>
         -- ASSUME Parent = modular_type_definition OR floating_accuracy_definition OR fixed_accuracy_definition
         -- No change in context here.
         New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
         --------------------------
         -- Group 3 Parent nodes --
         --------------------------
      when SP_Symbols.attribute_definition_clause | SP_Symbols.mod_clause | SP_Symbols.component_clause | SP_Symbols.at_clause =>
         -- ASSUME Parent = attribute_definition_clause OR mod_clause OR component_clause OR at_clause
         -- No change in context here.
         New_Context_Type := Type_Context_Stack.Top (Stack => T_Stack);
      when SP_Symbols.simple_expression | SP_Symbols.annotation_simple_expression =>
         -- ASSUME Parent = simple_expression OR annotation_simple_expression
         -- Must be an error, which will be caught elsewhere,
         -- but we need to push something so...
         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 = modular_type_definition OR floating_accuracy_definition OR fixed_accuracy_definition OR " &
              "case_choice OR attribute_definition_clause OR mod_clause OR component_clause OR at_clause OR " &
              "arange OR aggregate_choice OR relation OR simple_expression OR " &
              "annotation_arange OR annotation_aggregate_choice OR annotation_relation OR annotation_simple_expression " &
              "in Simple_Expression_Type_From_Context");
   end case;
   return New_Context_Type;
end Simple_Expression_Type_From_Context;
