-------------------------------------------------------------------------------
-- (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 Wf_Ancestor_Part
  (Node       : in out STree.SyntaxNode;
   Scope      : in     Dictionary.Scopes;
   E_Stack    : in out Exp_Stack.Exp_Stack_Type;
   Heap_Param : in out Lists.List_Heap)
is
   Qualifying_Expression, Ancestor_Part : Sem.Exp_Record;
   Ptr                                  : Lists.List;

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

   function Has_Intervening_Private_Extensions
     (Root_Type, Extended_Type : Dictionary.Symbol;
      Scope                    : Dictionary.Scopes)
     return                     Boolean
   --# global in Dictionary.Dict;
   -- pre Dictionary.IsAnExtensionOf (Root_Type, Extended_Type);
   is
      Result         : Boolean := False;
      Current_Record : Dictionary.Symbol;
   begin
      Current_Record := Extended_Type;
      loop
         -- follow chain of Inherit field pointers
         Current_Record := Dictionary.CurrentSymbol (Dictionary.FirstRecordComponent (Current_Record));
         exit when Dictionary.Is_Null_Symbol (Current_Record); -- root record is a null record

         Current_Record := Dictionary.GetType (Current_Record);
         exit when Dictionary.Types_Are_Equal
           (Left_Symbol        => Current_Record,
            Right_Symbol       => Root_Type,
            Full_Range_Subtype => False);

         exit when not Dictionary.TypeIsTagged (Current_Record); -- all fields checked - false result exit

         if Dictionary.IsPrivateType (Current_Record, Scope) then
            Result := True;
            exit; -- true result exit
         end if;
      end loop;
      return Result;
   end Has_Intervening_Private_Extensions;

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

   function Is_Null_Agregate (Node : STree.SyntaxNode) return Boolean
   --# global in STree.Table;
   --# pre STree.Syntax_Node_Type (Node, STree.Table) = SP_Symbols.ancestor_part or
   --#   STree.Syntax_Node_Type (Node, STree.Table) = SP_Symbols.annotation_ancestor_part;
   is
      Next_Node : STree.SyntaxNode;
   begin
      Next_Node := STree.Next_Sibling (Current_Node => Node);
      -- ASSUME Next_Node = record_component_association OR annotation_record_component_association OR RWnull
      SystemErrors.RT_Assert
        (C       => STree.Syntax_Node_Type (Node => Next_Node) = SP_Symbols.record_component_association
           or else STree.Syntax_Node_Type (Node => Next_Node) = SP_Symbols.annotation_record_component_association
           or else STree.Syntax_Node_Type (Node => Next_Node) = SP_Symbols.RWnull,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Next_Node = record_component_association OR annotation_record_component_association OR " &
           "RWnull in Is_Null_Agregate");
      return STree.Syntax_Node_Type (Node => Next_Node) = SP_Symbols.RWnull;
   end Is_Null_Agregate;

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

   function Fields_Need_Defining (Root_Type, Extended_Type : Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   is
   begin
      return Dictionary.GetNumberOfComponents (Extended_Type) > Dictionary.GetNumberOfComponents (Root_Type);
   end Fields_Need_Defining;

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

   function Association_Is_Named (Node : STree.SyntaxNode) return Boolean
   --# global in STree.Table;
   --# pre STree.Syntax_Node_Type (Node, STree.Table) = SP_Symbols.ancestor_part or
   --#   STree.Syntax_Node_Type (Node, STree.Table) = SP_Symbols.annotation_ancestor_part;
   is
      Next_Node : STree.SyntaxNode;
      Result    : Boolean;
   begin
      Next_Node := STree.Next_Sibling (Current_Node => Node);
      -- ASSUME Next_Node = record_component_association OR annotation_record_component_association OR RWnull
      if STree.Syntax_Node_Type (Node => Next_Node) = SP_Symbols.record_component_association
        or else STree.Syntax_Node_Type (Node => Next_Node) = SP_Symbols.annotation_record_component_association then
         -- ASSUME Next_Node = record_component_association OR annotation_record_component_association
         Next_Node := STree.Child_Node (Current_Node => Next_Node);
         -- ASSUME Next_Node = named_record_component_association            OR positional_record_component_association OR
         --                    annotation_named_record_component_association OR annotation_positional_record_component_association
         if STree.Syntax_Node_Type (Node => Next_Node) = SP_Symbols.named_record_component_association
           or else STree.Syntax_Node_Type (Node => Next_Node) = SP_Symbols.annotation_named_record_component_association then
            Result := True;
         elsif STree.Syntax_Node_Type (Node => Next_Node) = SP_Symbols.positional_record_component_association
           or else STree.Syntax_Node_Type (Node => Next_Node) = SP_Symbols.annotation_positional_record_component_association then
            Result := False;
         else
            Result := False;
            SystemErrors.Fatal_Error
              (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
               Msg     => "Expect Next_Node = named_record_component_association OR positional_record_component_association OR " &
                 "annotation_named_record_component_association OR annotation_positional_record_component_association " &
                 "in Association_Is_Named");
         end if;
      elsif STree.Syntax_Node_Type (Node => Next_Node) = SP_Symbols.RWnull then
         -- ASSUME Next_Node = RWnull
         Result := False;
      else
         Result := False;
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Next_Node = record_component_association OR annotation_record_component_association OR " &
              "RWnull in Association_Is_Named");
      end if;
      return Result;
   end Association_Is_Named;

   --------------------------------------------------------------------
   -- Assume:
   -- 1. Node is [annotation_]ancestor_part going up
   -- 2. TOS is result of walking ancestor part expression
   -- 3. 2nd TOS is result of walking qualifier
   --
   -- Check:
   -- 1. Qualifier is an extended tagged type
   -- 2. Ancestor part represents an ancestor of the extended type
   -- 3. There are no private extensions between the ancestor and the qualifier
   -- 4. If the aggregate part is null record then there are no new components
   --    between ancestor part and the qualifier.
   --------------------------------------------------------------------

begin -- Wf_Ancestor_Part
   Exp_Stack.Pop (Item  => Ancestor_Part,
                  Stack => E_Stack);
   Exp_Stack.Pop (Item  => Qualifying_Expression,
                  Stack => E_Stack);
   -- seed syntax tree with type of ancestor for use in VCG
   STree.Add_Node_Symbol (Node => Node,
                          Sym  => Ancestor_Part.Type_Symbol);

   if Qualifying_Expression.Sort = Sem.Is_Type_Mark then
      -- Correctly formed qualifying expression so carry on with rest of checks
      Qualifying_Expression.Is_Constant := True;
      if not Dictionary.TypeIsExtendedTagged (Qualifying_Expression.Type_Symbol) then
         Exp_Stack.Push (X     => Sem.Unknown_Type_Record,
                         Stack => E_Stack);
         ErrorHandler.Semantic_Error_Sym
           (Err_Num   => 835,
            Reference => ErrorHandler.No_Reference,
            Position  => STree.Node_Position (Node => STree.Parent_Node (Current_Node => STree.Parent_Node (Current_Node => Node))),
            Sym       => Qualifying_Expression.Type_Symbol,
            Scope     => Scope);
         -- move up so as to prevent walk of rest of illegal aggregate
         Node := STree.Parent_Node (Current_Node => Node);
         -- ASSUME Node = extension_aggregate OR annotation_extension_aggregate
         SystemErrors.RT_Assert
           (C       => STree.Syntax_Node_Type (Node => Node) = SP_Symbols.extension_aggregate
              or else STree.Syntax_Node_Type (Node => Node) = SP_Symbols.annotation_extension_aggregate,
            Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Node = extension_aggregate OR annotation_extension_aggregate in Wf_Ancestor_Part");
      elsif not Dictionary.IsAnExtensionOf (Ancestor_Part.Type_Symbol, Qualifying_Expression.Type_Symbol) then
         Exp_Stack.Push (X     => Sem.Unknown_Type_Record,
                         Stack => E_Stack);
         ErrorHandler.Semantic_Error_Sym
           (Err_Num   => 836,
            Reference => ErrorHandler.No_Reference,
            Position  => STree.Node_Position (Node => Node),
            Sym       => Qualifying_Expression.Type_Symbol,
            Scope     => Scope);
         -- move up so as to prevent walk of rest of illegal aggregate
         Node := STree.Parent_Node (Current_Node => Node);
         -- ASSUME Node = extension_aggregate OR annotation_extension_aggregate
         SystemErrors.RT_Assert
           (C       => STree.Syntax_Node_Type (Node => Node) = SP_Symbols.extension_aggregate
              or else STree.Syntax_Node_Type (Node => Node) = SP_Symbols.annotation_extension_aggregate,
            Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Node = extension_aggregate OR annotation_extension_aggregate in Wf_Ancestor_Part");
      elsif Has_Intervening_Private_Extensions
        (Root_Type     => Ancestor_Part.Type_Symbol,
         Extended_Type => Qualifying_Expression.Type_Symbol,
         Scope         => Scope) then
         Exp_Stack.Push (X     => Sem.Unknown_Type_Record,
                         Stack => E_Stack);
         ErrorHandler.Semantic_Error_Sym
           (Err_Num   => 837,
            Reference => ErrorHandler.No_Reference,
            Position  => STree.Node_Position (Node => Node),
            Sym       => Qualifying_Expression.Type_Symbol,
            Scope     => Scope);
         -- move up so as to prevent walk of rest of illegal aggregate
         Node := STree.Parent_Node (Current_Node => Node);
         -- ASSUME Node = extension_aggregate OR annotation_extension_aggregate
         SystemErrors.RT_Assert
           (C       => STree.Syntax_Node_Type (Node => Node) = SP_Symbols.extension_aggregate
              or else STree.Syntax_Node_Type (Node => Node) = SP_Symbols.annotation_extension_aggregate,
            Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Node = extension_aggregate OR annotation_extension_aggregate in Wf_Ancestor_Part");
      elsif Is_Null_Agregate (Node => Node) then
         if Fields_Need_Defining (Root_Type     => Ancestor_Part.Type_Symbol,
                                  Extended_Type => Qualifying_Expression.Type_Symbol) then
            Exp_Stack.Push (X     => Sem.Unknown_Type_Record,
                            Stack => E_Stack);
            ErrorHandler.Semantic_Error_Sym
              (Err_Num   => 838,
               Reference => ErrorHandler.No_Reference,
               Position  => STree.Node_Position (Node => Node),
               Sym       => Qualifying_Expression.Type_Symbol,
               Scope     => Scope);
            -- move up so as to prevent walk of rest of illegal aggregate
            Node := STree.Parent_Node (Current_Node => Node);
            -- ASSUME Node = extension_aggregate OR annotation_extension_aggregate
            SystemErrors.RT_Assert
              (C       => STree.Syntax_Node_Type (Node => Node) = SP_Symbols.extension_aggregate
                 or else STree.Syntax_Node_Type (Node => Node) = SP_Symbols.annotation_extension_aggregate,
               Sys_Err => SystemErrors.Invalid_Syntax_Tree,
               Msg     => "Expect Node = extension_aggregate OR annotation_extension_aggregate in Wf_Ancestor_Part");
         else -- valid null record case, this means aggregate is complete
            Qualifying_Expression.Sort         := Sem.Type_Result;
            Qualifying_Expression.Is_Constant  := True;
            Qualifying_Expression.Param_Count  := 0;
            Qualifying_Expression.Param_List   := Lists.Null_List;
            Qualifying_Expression.Other_Symbol := Dictionary.NullSymbol;
            Qualifying_Expression.Is_ARange    := False;
            Qualifying_Expression.Is_Static    := False;
            Exp_Stack.Push (X     => Qualifying_Expression,
                            Stack => E_Stack);
            -- move up to qualified expression node since aggregate is complete
            Node := STree.Parent_Node (Current_Node => STree.Parent_Node (Current_Node => Node));
            -- ASSUME Node = qualified_expression OR annotation_qualified_expression
            SystemErrors.RT_Assert
              (C       => STree.Syntax_Node_Type (Node => Node) = SP_Symbols.qualified_expression
                 or else STree.Syntax_Node_Type (Node => Node) = SP_Symbols.annotation_qualified_expression,
               Sys_Err => SystemErrors.Invalid_Syntax_Tree,
               Msg     => "Expect Node = qualified_expression OR annotation_qualified_expression in Wf_Ancestor_Part");
         end if;
      else
         -- Valid non-null case
         -- Set up either counters, for positional, or check lists, for named association
         if Association_Is_Named (Node => Node) then
            Create_Name_List (List       => Ptr,
                              Heap_Param => Heap_Param);
            Qualifying_Expression.Param_List := Ptr;
            -- to check whether a field is correctly part of the record but NOT already in
            -- the ancestor part we need access to the ancestor symbol when processing
            -- the associations.  For this reason we put the ancestor symbol into the
            -- OtherSymbol field of the record representing the aggregate
            Qualifying_Expression.Other_Symbol := Ancestor_Part.Type_Symbol;
            Exp_Stack.Push (X     => Qualifying_Expression,
                            Stack => E_Stack);
            -- walk continues at STree.Next_Sibling (Node) -  record_component_association
         else
            -- positional association
            -- when we check the expressions we want to match those fields NOT included
            -- in the ancestor part so we set the field counter thus:
            Qualifying_Expression.Param_Count := Dictionary.GetNumberOfComponents (Ancestor_Part.Type_Symbol);
            Exp_Stack.Push (X     => Qualifying_Expression,
                            Stack => E_Stack);
            -- walk continues at STree.Next_Sibling (Node) -  record_component_association
         end if;
      end if;
   else -- qualifying prefix is not a type mark
      Exp_Stack.Push (X     => Sem.Unknown_Type_Record,
                      Stack => E_Stack);
      ErrorHandler.Semantic_Error
        (Err_Num   => 95,
         Reference => ErrorHandler.No_Reference,
         Position  => STree.Node_Position (Node => STree.Parent_Node (Current_Node => STree.Parent_Node (Current_Node => Node))),
         Id_Str    => LexTokenManager.Null_String);
      -- move up so as to prevent walk of rest of illegal aggregate
      Node := STree.Parent_Node (Current_Node => Node);
      -- ASSUME Node = extension_aggregate OR annotation_extension_aggregate
      SystemErrors.RT_Assert
        (C       => STree.Syntax_Node_Type (Node => Node) = SP_Symbols.extension_aggregate
           or else STree.Syntax_Node_Type (Node => Node) = SP_Symbols.annotation_extension_aggregate,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Node = extension_aggregate OR annotation_extension_aggregate in Wf_Ancestor_Part");
   end if;
end Wf_Ancestor_Part;
