-------------------------------------------------------------------------------
-- (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.
--
--=============================================================================

with SLI;

separate (Sem.Wf_Basic_Declarative_Item.Wf_Basic_Declaration.Wf_Full_Type_Declaration)
procedure Wf_Record
  (Node                        : in STree.SyntaxNode;
   Scope                       : in Dictionary.Scopes;
   Ident_Node                  : in STree.SyntaxNode;
   Dec_Loc                     : in LexTokenManager.Token_Position;
   Extends                     : in Dictionary.Symbol;
   Private_Type_Being_Resolved : in Dictionary.Symbol)
is
   Next_Node              : STree.SyntaxNode;
   It                     : STree.Iterator;
   Record_Sym             : Dictionary.Symbol;
   Is_Tagged, Is_Abstract : Boolean;
   Has_Fields             : Boolean := False;

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

   procedure Set_Tag_Status (Tag_Option_Node        : in     STree.SyntaxNode;
                             Is_Tagged, Is_Abstract :    out Boolean)
   --# global in STree.Table;
   --# derives Is_Abstract,
   --#         Is_Tagged   from STree.Table,
   --#                          Tag_Option_Node;
   --# pre Syntax_Node_Type (Tag_Option_Node, STree.Table) = SP_Symbols.non_abstract_tagged or
   --#   Syntax_Node_Type (Tag_Option_Node, STree.Table) = SP_Symbols.abstract_tagged or
   --#   Syntax_Node_Type (Tag_Option_Node, STree.Table) = SP_Symbols.non_tagged;
   is
   begin
      Is_Abstract := Syntax_Node_Type (Node => Tag_Option_Node) = SP_Symbols.abstract_tagged;
      Is_Tagged   := Is_Abstract or else Syntax_Node_Type (Node => Tag_Option_Node) = SP_Symbols.non_abstract_tagged;
   end Set_Tag_Status;

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

   procedure Wf_Component_Declaration (Node    : in STree.SyntaxNode;
                                       Rec_Sym : in Dictionary.Symbol;
                                       Scope   : in Dictionary.Scopes)
   --# global in     CommandLineData.Content;
   --#        in     ContextManager.Ops.Unit_Stack;
   --#        in     LexTokenManager.State;
   --#        in out Dictionary.Dict;
   --#        in out ErrorHandler.Error_Context;
   --#        in out SPARK_IO.File_Sys;
   --#        in out STree.Table;
   --# derives Dictionary.Dict            from *,
   --#                                         CommandLineData.Content,
   --#                                         ContextManager.Ops.Unit_Stack,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         Rec_Sym,
   --#                                         Scope,
   --#                                         STree.Table &
   --#         ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from CommandLineData.Content,
   --#                                         ContextManager.Ops.Unit_Stack,
   --#                                         Dictionary.Dict,
   --#                                         ErrorHandler.Error_Context,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         Rec_Sym,
   --#                                         Scope,
   --#                                         SPARK_IO.File_Sys,
   --#                                         STree.Table &
   --#         STree.Table                from *,
   --#                                         CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         Scope;
   --# pre Syntax_Node_Type (Node, STree.Table) = SP_Symbols.component_declaration;
   --# post STree.Table = STree.Table~;
   is
      Type_Node, Ident_List_Node, Next_Node : STree.SyntaxNode;
      It                                    : STree.Iterator;
      Type_Sym                              : Dictionary.Symbol;
      Component_Ident                       : LexTokenManager.Lex_String;
      Type_Pos                              : LexTokenManager.Token_Position;
      Type_Mark_Is_Not_Dotted               : Boolean;
      Type_Mark_Simple_Name                 : LexTokenManager.Lex_String;

      -----------------------------------------------------------------
      -- this function finds all the fields in a record including any
      -- non-private ones obtained by inheritance
      function Is_Existing_Field (Fieldname  : LexTokenManager.Lex_String;
                                  The_Record : Dictionary.Symbol) return Boolean
      --# global in Dictionary.Dict;
      --#        in LexTokenManager.State;
      is
         It              : Dictionary.Iterator;
         Result          : Boolean := False;
         Current_Record  : Dictionary.Symbol;
         This_Package    : Dictionary.Symbol;
         Current_Package : Dictionary.Symbol;

         function Is_Public_Descendant (Root_Package, The_Package : Dictionary.Symbol) return Boolean
         --# global in Dictionary.Dict;
         is
            Current_Package : Dictionary.Symbol;
            Result          : Boolean := False;
         begin
            Current_Package := The_Package;
            loop
               -- success case, we have got back to root all via public children
               if Dictionary.Packages_Are_Equal (Left_Symbol  => Current_Package,
                                                 Right_Symbol => Root_Package) then
                  Result := True;
                  exit;
               end if;
               -- fail case, private child found
               exit when Dictionary.IsPrivatePackage (Current_Package);

               Current_Package := Dictionary.GetPackageParent (Current_Package);
               exit when Dictionary.Is_Null_Symbol (Current_Package);
            end loop;
            return Result;
         end Is_Public_Descendant;

      begin -- Is_Existing_Field
         This_Package   := Dictionary.GetLibraryPackage (Dictionary.GetScope (The_Record));
         Current_Record := The_Record;
         loop
            Current_Package := Dictionary.GetLibraryPackage (Dictionary.GetScope (Current_Record));
            if not Dictionary.TypeIsPrivate (TheType => Current_Record)
              or else Is_Public_Descendant (Root_Package => Current_Package,
                                            The_Package  => This_Package) then
               -- not private so search for all fields
               It := Dictionary.FirstRecordComponent (Current_Record);
               while not Dictionary.IsNullIterator (It) loop
                  if LexTokenManager.Lex_String_Case_Insensitive_Compare
                    (Lex_Str1 => Dictionary.GetSimpleName (Dictionary.CurrentSymbol (It)),
                     Lex_Str2 => Fieldname) =
                    LexTokenManager.Str_Eq then
                     Result := True;
                     exit;
                  end if;
                  It := Dictionary.NextSymbol (It);
               end loop;
            end if;
            exit when Result;
            Current_Record := Dictionary.GetRootOfExtendedType (Current_Record);
            exit when Dictionary.Is_Null_Symbol (Current_Record);
         end loop;
         return Result;
      end Is_Existing_Field;

   begin -- Wf_Component_Declaration
      Type_Node := Child_Node (Current_Node => Next_Sibling (Current_Node => Child_Node (Current_Node => Node)));
      -- ASSUME Type_Node = type_mark
      SystemErrors.RT_Assert
        (C       => Syntax_Node_Type (Node => Type_Node) = SP_Symbols.type_mark,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Type_Node = type_mark in Wf_Component_Declaration");

      -- If the indicated typemark is not dotted (e.g. just "T" but not "P.T")
      -- then an additional check is required.
      -- Two nodes below type_mark, there will either be a
      -- dotted_simple_name node (dotted case) or an identifier node (not dotted).
      Type_Mark_Is_Not_Dotted := Syntax_Node_Type (Node => Child_Node (Current_Node => Child_Node (Current_Node => Type_Node))) =
        SP_Symbols.identifier;
      if Type_Mark_Is_Not_Dotted then
         Type_Mark_Simple_Name := Node_Lex_String (Node => Child_Node (Current_Node => Child_Node (Current_Node => Type_Node)));
      else
         Type_Mark_Simple_Name := LexTokenManager.Null_String;
      end if;

      Type_Pos := Node_Position (Node => Type_Node);
      Wf_Type_Mark (Node          => Type_Node,
                    Current_Scope => Scope,
                    Context       => Dictionary.ProgramContext,
                    Type_Sym      => Type_Sym);
      if not Dictionary.IsUnknownTypeMark (Type_Sym) then
         if Dictionary.Types_Are_Equal (Left_Symbol        => Type_Sym,
                                        Right_Symbol       => Rec_Sym,
                                        Full_Range_Subtype => False) then
            -- Type of field is same type as the record type being declared.
            ErrorHandler.Semantic_Error
              (Err_Num   => 751,
               Reference => ErrorHandler.No_Reference,
               Position  => Type_Pos,
               Id_Str    => Dictionary.GetSimpleName (Type_Sym));
         elsif Dictionary.Is_Unconstrained_Array_Type_Mark (Type_Sym, Scope) then
            ErrorHandler.Semantic_Error
              (Err_Num   => 39,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Type_Node),
               Id_Str    => LexTokenManager.Null_String);
         end if;
      end if;

      Ident_List_Node := Child_Node (Current_Node => Node);
      -- ASSUME Ident_List_Node = identifier_list
      SystemErrors.RT_Assert
        (C       => Syntax_Node_Type (Node => Ident_List_Node) = SP_Symbols.identifier_list,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Ident_List_Node = identifier_list in Wf_Component_Declaration");

      It := Find_First_Node (Node_Kind    => SP_Symbols.identifier,
                             From_Root    => Ident_List_Node,
                             In_Direction => STree.Down);

      while not STree.IsNull (It) loop
         Next_Node := Get_Node (It => It);
         --# assert STree.Table = STree.Table~ and
         --#   Syntax_Node_Type (Next_Node, STree.Table) = SP_Symbols.identifier and
         --#   Next_Node = Get_Node (It);
         Component_Ident := Node_Lex_String (Node => Next_Node);

         -- if the TypeMark is not dotted, then we need to check for the
         -- illegal case of a record field name which attempts to override
         -- the name of an existing directly visible TypeMake, such as
         --   type R is record
         --      T : T; -- illegal
         --   end record;
         if Type_Mark_Is_Not_Dotted
           and then LexTokenManager.Lex_String_Case_Insensitive_Compare
           (Lex_Str1 => Component_Ident,
            Lex_Str2 => Type_Mark_Simple_Name) =
           LexTokenManager.Str_Eq then
            ErrorHandler.Semantic_Error
              (Err_Num   => 757,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Type_Node),
               Id_Str    => Component_Ident);
         elsif Is_Existing_Field (Fieldname  => Component_Ident,
                                  The_Record => Rec_Sym) then
            --  catches repeat within dec which is an existing Examiner
            --  bug not to do with tagged types
            ErrorHandler.Semantic_Error
              (Err_Num   => 10,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Next_Node),
               Id_Str    => Component_Ident);
         elsif Dictionary.IsPredefinedSuspensionObjectType (Type_Sym) or else Dictionary.IsProtectedTypeMark (Type_Sym) then
            ErrorHandler.Semantic_Error
              (Err_Num   => 906,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Type_Node),
               Id_Str    => LexTokenManager.Null_String);
         else
            Dictionary.AddRecordComponent
              (Name                   => Component_Ident,
               Comp_Unit              => ContextManager.Ops.Current_Unit,
               Declaration            => Dictionary.Location'(Start_Position => Node_Position (Node => Next_Node),
                                                              End_Position   => Node_Position (Node => Next_Node)),
               TheRecordType          => Rec_Sym,
               TheComponentType       => Type_Sym,
               InheritedField         => False,
               ComponentTypeReference => Dictionary.Location'(Start_Position => Type_Pos,
                                                              End_Position   => Type_Pos));
         end if;
         It := STree.NextNode (It);
      end loop;
   end Wf_Component_Declaration;

begin -- Wf_Record
   if Syntax_Node_Type (Node => Node) = SP_Symbols.record_type_definition then
      -- ASSUME Node = record_type_definition
      Next_Node := Child_Node (Current_Node => Child_Node (Current_Node => Node));
      -- ASSUME Next_Node = non_abstract_tagged OR abstract_tagged OR non_tagged
      SystemErrors.RT_Assert
        (C       => Syntax_Node_Type (Node => Next_Node) = SP_Symbols.non_abstract_tagged
           or else Syntax_Node_Type (Node => Next_Node) = SP_Symbols.abstract_tagged
           or else Syntax_Node_Type (Node => Next_Node) = SP_Symbols.non_tagged,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Next_Node = non_abstract_tagged OR abstract_tagged OR non_tagged in Wf_Record");
      Set_Tag_Status (Tag_Option_Node => Next_Node,
                      Is_Tagged       => Is_Tagged,
                      Is_Abstract     => Is_Abstract);
   elsif Syntax_Node_Type (Node => Node) = SP_Symbols.record_type_extension then
      -- ASSUME Node = record_type_extension
      Is_Abstract := False;
      Is_Tagged   := False;
   else
      Is_Abstract := False;
      Is_Tagged   := False;
   end if;

   -- temporary prevention of use of abstract types
   if Is_Abstract then
      ErrorHandler.Semantic_Error
        (Err_Num   => 820,
         Reference => ErrorHandler.No_Reference,
         Position  => Node_Position (Node => Node),
         Id_Str    => LexTokenManager.Null_String);
   end if;

   -- tagged types can only be declared in library package specs
   if (Is_Tagged or else not Dictionary.Is_Null_Symbol (Extends))
     and then (not Dictionary.Packages_Are_Equal
                 (Left_Symbol  => Dictionary.GetLibraryPackage (Scope),
                  Right_Symbol => Dictionary.GetRegion (Scope))
                 or else not (Dictionary.Get_Visibility (Scope => Scope) = Dictionary.Visible
                                or else Dictionary.Get_Visibility (Scope => Scope) = Dictionary.Privat)) then
      ErrorHandler.Semantic_Error
        (Err_Num   => 828,
         Reference => ErrorHandler.No_Reference,
         Position  => Node_Position (Node => Node),
         Id_Str    => LexTokenManager.Null_String);
   elsif Is_Tagged
     and then (not Is_Private_Type_Resolution (Sym   => Private_Type_Being_Resolved,
                                               Scope => Scope))
     and then (Dictionary.PackageDeclaresTaggedType (Dictionary.GetRegion (Scope))
                 or else Dictionary.PackageExtendsAnotherPackage (Dictionary.GetRegion (Scope))) then
      -- illegal second root tagged type declaration
      ErrorHandler.Semantic_Error
        (Err_Num   => 839,
         Reference => ErrorHandler.No_Reference,
         Position  => Node_Position (Node => Node),
         Id_Str    => LexTokenManager.Null_String);
   else -- either not tagged type or correctly declared tagged type
      Dictionary.Add_Record_Type
        (Name           => Node_Lex_String (Node => Ident_Node),
         Is_Tagged_Type => Is_Tagged,
         Extends        => Extends,
         Comp_Unit      => ContextManager.Ops.Current_Unit,
         Declaration    => Dictionary.Location'(Start_Position => Dec_Loc,
                                                End_Position   => Dec_Loc),
         Scope          => Scope,
         Context        => Dictionary.ProgramContext,
         The_Type       => Record_Sym);
      STree.Add_Node_Symbol (Node => Ident_Node,
                             Sym  => Record_Sym);
      if ErrorHandler.Generate_SLI then
         SLI.Generate_Xref_Symbol
           (Comp_Unit      => ContextManager.Ops.Current_Unit,
            Parse_Tree     => Ident_Node,
            Symbol         => Record_Sym,
            Is_Declaration => True);
      end if;
      -- if Extends is not null then we need to add in the fields inherited
      -- from the root type
      if not Dictionary.Is_Null_Symbol (Extends) then
         Dictionary.AddRecordComponent
           (Name                   => LexTokenManager.Inherit_Token,
            Comp_Unit              => ContextManager.Ops.Current_Unit,
            Declaration            => Dictionary.Location'(Start_Position => Dec_Loc,
                                                           End_Position   => Dec_Loc),
            TheRecordType          => Record_Sym,
            TheComponentType       => Extends,
            InheritedField         => True,
            ComponentTypeReference => Dictionary.Location'(Start_Position => Dec_Loc,
                                                           End_Position   => Dec_Loc));
      end if;

      -- search for components unaffected by addition of tag info.  If the grammar
      -- is of the form "null record" then no components get found which is correct
      It := Find_First_Node (Node_Kind    => SP_Symbols.component_declaration,
                             From_Root    => Node,
                             In_Direction => STree.Down);
      while not STree.IsNull (It) loop
         Next_Node := Get_Node (It => It);
         --# assert STree.Table = STree.Table~ and
         --#   Syntax_Node_Type (Next_Node, STree.Table) = SP_Symbols.component_declaration and
         --#   Next_Node = Get_Node (It);
         Has_Fields := True;
         Wf_Component_Declaration (Node    => Next_Node,
                                   Rec_Sym => Record_Sym,
                                   Scope   => Scope);
         It := STree.NextNode (It);
      end loop;

      -- SPARK disallows null records unless they are tagged (and maybe abstract as well TBD)
      if not (Is_Tagged or else Has_Fields or else not Dictionary.Is_Null_Symbol (Extends)) then
         ErrorHandler.Semantic_Error
           (Err_Num   => 834,
            Reference => ErrorHandler.No_Reference,
            Position  => Node_Position (Node => Node),
            Id_Str    => LexTokenManager.Null_String);
      end if;
   end if;
end Wf_Record;
