-------------------------------------------------------------------------------
-- (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_Basic_Declarative_Item.Wf_Basic_Declaration.Wf_Full_Type_Declaration)
procedure Wf_Type_Extension
  (Node                        : in STree.SyntaxNode;
   Scope                       : in Dictionary.Scopes;
   Ident_Node                  : in STree.SyntaxNode;
   Dec_Loc                     : in LexTokenManager.Token_Position;
   Private_Type_Being_Resolved : in Dictionary.Symbol)
is
   Root_Type_Node : STree.SyntaxNode;
   Root_Type_Sym  : Dictionary.Symbol;
   This_Package   : Dictionary.Symbol;
   The_Type       : Dictionary.Symbol;
begin
   -- Rules: 1 type_mark must be visible tagged type from another package
   --        2 this package must not already contain a type extension
   --        3 record components handled as for any other record

   -- first check that we do not already have a type extension in this package
   -- since SPARK requires a maximum of one per package to avoid overloading
   -- introduced by unherited operations.  A second declaration is allowed if
   -- it completing a private extension in which case it must be compatible with
   -- the first declaration.
   case CommandLineData.Content.Language_Profile is
      when CommandLineData.SPARK83 =>
         ErrorHandler.Semantic_Error
           (Err_Num   => 826,
            Reference => ErrorHandler.No_Reference,
            Position  => Node_Position (Node => Node),
            Id_Str    => LexTokenManager.Null_String);
      when CommandLineData.SPARK95_Onwards =>
         -- check that we are in a library package spec
         if Dictionary.IsPackage (Dictionary.GetRegion (Scope))
           and then Dictionary.Packages_Are_Equal
           (Left_Symbol  => Dictionary.GetLibraryPackage (Scope),
            Right_Symbol => Dictionary.GetRegion (Scope))
           and then (Dictionary.Get_Visibility (Scope => Scope) = Dictionary.Visible
                       or else Dictionary.Get_Visibility (Scope => Scope) = Dictionary.Privat) then
            This_Package := Dictionary.GetRegion (Scope);
            if Dictionary.PackageDeclaresTaggedType (This_Package) then
               ErrorHandler.Semantic_Error
                 (Err_Num   => 839,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Node),
                  Id_Str    => LexTokenManager.Null_String);
            elsif Dictionary.PackageExtendsAnotherPackage (This_Package)
              and then not Is_Private_Type_Resolution (Sym   => Private_Type_Being_Resolved,
                                                       Scope => Scope) then
               ErrorHandler.Semantic_Error
                 (Err_Num   => 824,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Node),
                  Id_Str    => Dictionary.GetSimpleName (Dictionary.GetPackageThatIsExtended (This_Package)));
            else -- first extension or resolution of a private extension
               Root_Type_Node := Child_Node (Current_Node => Child_Node (Current_Node => Node));
               -- ASSUME Root_Type_Node = type_mark
               SystemErrors.RT_Assert
                 (C       => Syntax_Node_Type (Node => Root_Type_Node) = SP_Symbols.type_mark,
                  Sys_Err => SystemErrors.Invalid_Syntax_Tree,
                  Msg     => "Expect Root_Type_Node = type_mark in Wf_Type_Extension");
               Wf_Type_Mark
                 (Node          => Root_Type_Node,
                  Current_Scope => Scope,
                  Context       => Dictionary.ProgramContext,
                  Type_Sym      => Root_Type_Sym);
               -- if we are resolving a private extension then the Root_Type_Sym must be the same as
               -- the type we originally extended
               if Is_Private_Type_Resolution (Sym   => Private_Type_Being_Resolved,
                                              Scope => Scope)
                 and then not Dictionary.Types_Are_Equal
                 (Left_Symbol        => Root_Type_Sym,
                  Right_Symbol       => Dictionary.GetRootOfExtendedType (Private_Type_Being_Resolved),
                  Full_Range_Subtype => False) then
                  ErrorHandler.Semantic_Error_Sym
                    (Err_Num   => 825,
                     Reference => ErrorHandler.No_Reference,
                     Position  => Node_Position (Node => Root_Type_Node),
                     Sym       => Dictionary.GetRootOfExtendedType (Private_Type_Being_Resolved),
                     Scope     => Scope);
               end if;
               -- wf_type_mark will return the unknown type if it found any errors
               if not Dictionary.IsUnknownTypeMark (Root_Type_Sym) then
                  -- check that Root_Type_Sym represents a tagged
                  if Dictionary.TypeIsTagged (Root_Type_Sym) then
                     -- check that type being extended is not locally declared
                     if Dictionary.GetScope (Root_Type_Sym) /= Scope then
                        -- mark this package as extending the one declaring the root type
                        Dictionary.SetPackageAsExtendingAnother
                          (This_Package,
                           Dictionary.GetRegion (Dictionary.GetScope (Root_Type_Sym)));

                        -- add private type or add record type
                        -- ASSUME Child_Node (Current_Node => Node) = private_type_extension OR record_type_extension
                        if Syntax_Node_Type (Node => Child_Node (Current_Node => Node)) =
                          SP_Symbols.private_type_extension then
                           -- ASSUME Child_Node (Current_Node => Node) = private_type_extension
                           -- process with private
                           Dictionary.Add_Private_Type
                             (Name           => Node_Lex_String (Node => Ident_Node),
                              Comp_Unit      => ContextManager.Ops.Current_Unit,
                              Declaration    => Dictionary.Location'(Start_Position => Dec_Loc,
                                                                     End_Position   => Dec_Loc),
                              The_Package    => This_Package,
                              Is_Limited     => False,
                              Is_Tagged_Type => False,
                              Extends        => Root_Type_Sym,
                              The_Type       => The_Type);
                           STree.Add_Node_Symbol (Node => Ident_Node,
                                                  Sym  => The_Type);
                        elsif Syntax_Node_Type (Node => Child_Node (Current_Node => Node)) =
                          SP_Symbols.record_type_extension then
                           -- ASSUME Child_Node (Current_Node => Node) = record_type_extension
                           -- process rest of with record
                           Wf_Record
                             (Node                        => Child_Node (Current_Node => Node),
                              Scope                       => Scope,
                              Ident_Node                  => Ident_Node,
                              Dec_Loc                     => Dec_Loc,
                              Extends                     => Root_Type_Sym,
                              Private_Type_Being_Resolved => Private_Type_Being_Resolved);
                        else
                           SystemErrors.Fatal_Error
                             (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
                              Msg     => "Expect Child_Node (Current_Node => Node) = private_type_extension OR " &
                                "record_type_extension in Wf_Type_Extension");
                        end if;
                     else -- local type being extended
                        ErrorHandler.Semantic_Error
                          (Err_Num   => 823,
                           Reference => ErrorHandler.No_Reference,
                           Position  => Node_Position (Node => Root_Type_Node),
                           Id_Str    => LexTokenManager.Null_String);
                     end if;
                  else -- illegal type being extended
                     ErrorHandler.Semantic_Error_Sym
                       (Err_Num   => 822,
                        Reference => ErrorHandler.No_Reference,
                        Position  => Node_Position (Node => Root_Type_Node),
                        Sym       => Root_Type_Sym,
                        Scope     => Scope);
                  end if;
               end if;
            end if;
         else -- not in library spec
            ErrorHandler.Semantic_Error
              (Err_Num   => 828,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Node),
               Id_Str    => LexTokenManager.Null_String);

         end if;
   end case;
end Wf_Type_Extension;
