-------------------------------------------------------------------------------
-- (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.Wf_Package_Declaration.Wf_Package_Specification.Wf_Visible)
procedure Wf_Private_Type_Declaration
  (Node          : in STree.SyntaxNode;
   Pack_Sym      : in Dictionary.Symbol;
   Current_Scope : in Dictionary.Scopes)
is

   Is_Limited                             : Boolean;
   Ident_Node, Next_Node, Tag_Option_Node : STree.SyntaxNode;
   Ident_Str                              : LexTokenManager.Lex_String;
   Sym                                    : Dictionary.Symbol;
   Is_Abstract                            : Boolean;
   Is_Tagged                              : Boolean;

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

   procedure Set_Tag_Status (Tag_Option_Node : in     STree.SyntaxNode;
                             Is_Abstract     :    out Boolean;
                             Is_Tagged       :    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;

begin -- Wf_Private_Type_Declaration
   Next_Node := Child_Node (Current_Node => Node);
   -- ASSUME Next_Node = non_limited_private_type_declaration OR limited_private_type_declaration
   SystemErrors.RT_Assert
     (C       => Syntax_Node_Type (Node => Next_Node) = SP_Symbols.non_limited_private_type_declaration
        or else Syntax_Node_Type (Node => Next_Node) = SP_Symbols.limited_private_type_declaration,
      Sys_Err => SystemErrors.Invalid_Syntax_Tree,
      Msg     => "Expect Next_Node = non_limited_private_type_declaration OR " &
        "limited_private_type_declaration in Wf_Private_Type_Declaration");

   Is_Limited := (Syntax_Node_Type (Node => Next_Node) = SP_Symbols.limited_private_type_declaration);

   Ident_Node := Child_Node (Current_Node => Next_Node);
   -- ASSUME Node = identifier
   SystemErrors.RT_Assert
     (C       => Syntax_Node_Type (Node => Ident_Node) = SP_Symbols.identifier,
      Sys_Err => SystemErrors.Invalid_Syntax_Tree,
      Msg     => "Expect Ident_Node = identifier in Wf_Private_Type_Declaration");

   Ident_Str := Node_Lex_String (Node => Ident_Node);

   Tag_Option_Node := Child_Node (Current_Node => Next_Sibling (Current_Node => Ident_Node));
   SystemErrors.RT_Assert
     (C       => Syntax_Node_Type (Node => Tag_Option_Node) = SP_Symbols.non_abstract_tagged
        or else Syntax_Node_Type (Node => Tag_Option_Node) = SP_Symbols.abstract_tagged
        or else Syntax_Node_Type (Node => Tag_Option_Node) = SP_Symbols.non_tagged,
      Sys_Err => SystemErrors.Invalid_Syntax_Tree,
      Msg     => "Expect Tag_Option_Node = non_abstract_tagged OR abstract_tagged OR non_tagged in Wf_Private_Type_Declaration");

   Set_Tag_Status (Tag_Option_Node => Tag_Option_Node,
                   Is_Abstract     => Is_Abstract,
                   Is_Tagged       => Is_Tagged);

   -- 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 => Ident_Node),
         Id_Str    => LexTokenManager.Null_String);
   end if;

   if Is_Tagged
     and then (Dictionary.PackageDeclaresTaggedType (Dictionary.GetRegion (Current_Scope))
                 or else Dictionary.PackageExtendsAnotherPackage (Dictionary.GetRegion (Current_Scope))) then
      -- illegal second private tagged type declaration
      ErrorHandler.Semantic_Error
        (Err_Num   => 839,
         Reference => ErrorHandler.No_Reference,
         Position  => Node_Position (Node => Node),
         Id_Str    => LexTokenManager.Null_String);
   else
      Sym :=
        Dictionary.LookupItem
        (Name              => Ident_Str,
         Scope             => Current_Scope,
         Context           => Dictionary.ProofContext,
         Full_Package_Name => False);
      if Dictionary.Is_Null_Symbol (Sym)
        or else (Dictionary.IsTypeMark (Sym)
                   and then Dictionary.TypeIsAnnounced (TheType => Sym)
                   and then not Dictionary.Is_Declared (Item => Sym)
                   -- already declared, non private
                   and then not Dictionary.TypeIsPrivate (TheType => Sym)) then  -- already declared, private
         if not Dictionary.Is_Null_Symbol (Sym) then
            STree.Set_Node_Lex_String (Sym  => Sym,
                                       Node => Ident_Node);
         end if;
         Dictionary.Add_Private_Type
           (Name           => Ident_Str,
            Comp_Unit      => ContextManager.Ops.Current_Unit,
            Declaration    => Dictionary.Location'(Start_Position => Node_Position (Node => Ident_Node),
                                                   End_Position   => Node_Position (Node => Ident_Node)),
            The_Package    => Pack_Sym,
            Is_Limited     => Is_Limited,
            Is_Tagged_Type => Is_Tagged,
            Extends        => Dictionary.NullSymbol,
            The_Type       => Sym);
         STree.Add_Node_Symbol (Node => Ident_Node,
                                Sym  => Sym);
      else
         ErrorHandler.Semantic_Error
           (Err_Num   => 10,
            Reference => ErrorHandler.No_Reference,
            Position  => Node_Position (Node => Ident_Node),
            Id_Str    => Ident_Str);
      end if;
   end if;
end Wf_Private_Type_Declaration;
