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

-- Overview:
-- Checks a with clause for Sem starting at node with_clause.
-- Directly capable of raising errors for: undeclared item in with list,
-- duplicate item in with list or withing of something which is not a
-- package.
--
-- NB.  In present form permits with for something not inherited; this is
--      necessary for withing something to be used solely in hidden part
--      (eg. text_io by spark_io).  However, we wish to issue a
--      semantic warning in such circumstances.
--      It is also necessary to with something not inherited in the case
--      where an inherit cannot be placed; for example where a package
--      body withs a private child package.
--------------------------------------------------------------------------------

separate (Sem.Wf_Context_Clause_Package_Body)
procedure With_Clause
  (Node              : in     STree.SyntaxNode;
   Comp_Sym          : in     Dictionary.Symbol;
   Scope             : in     Dictionary.Scopes;
   With_Public_Child :    out Boolean)
is
   It             : STree.Iterator;
   Next_Node      : STree.SyntaxNode;
   A_Public_Child : Boolean;

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

   procedure Process_Dotted_Simple_Name
     (Node           : in     STree.SyntaxNode;
      Comp_Sym       : in     Dictionary.Symbol;
      Scope          : in     Dictionary.Scopes;
      A_Public_Child :    out Boolean)
   --# 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 A_Public_Child,
   --#         Dictionary.Dict,
   --#         STree.Table                from CommandLineData.Content,
   --#                                         Comp_Sym,
   --#                                         ContextManager.Ops.Unit_Stack,
   --#                                         Dictionary.Dict,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         Scope,
   --#                                         STree.Table &
   --#         ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from CommandLineData.Content,
   --#                                         Comp_Sym,
   --#                                         ContextManager.Ops.Unit_Stack,
   --#                                         Dictionary.Dict,
   --#                                         ErrorHandler.Error_Context,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         Scope,
   --#                                         SPARK_IO.File_Sys,
   --#                                         STree.Table;
   --# pre Syntax_Node_Type (Node, STree.Table) = SP_Symbols.dotted_simple_name;
   --# post STree.Table = STree.Table~;
   is
      Prefix_Sym         : Dictionary.Symbol := Dictionary.NullSymbol;
      Current_Sym        : Dictionary.Symbol;
      Current_Node       : STree.SyntaxNode;
      Explicit_Duplicate : Boolean;
      Withing_Descendent : Boolean           := False;
      Discard            : Boolean;
      Lib_Sym            : Dictionary.Symbol;
      Search_String      : LexTokenManager.Lex_String;

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

      function Dotted_Identifier_Found (Node : STree.SyntaxNode) return Boolean
      --# global in STree.Table;
      --# pre Syntax_Node_Type (Node, STree.Table) = SP_Symbols.dotted_simple_name;
      is
         Current_Node : STree.SyntaxNode;
      begin
         Current_Node := Child_Node (Current_Node => Node);
         -- ASSUME Current_Node = dotted_simple_name OR identifier
         SystemErrors.RT_Assert
           (C       => Syntax_Node_Type (Node => Current_Node) = SP_Symbols.dotted_simple_name or
              Syntax_Node_Type (Node => Current_Node) = SP_Symbols.identifier,
            Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Current_Node = dotted_simple_name OR identifier in Dotted_Simple_Name");
         return Syntax_Node_Type (Node => Current_Node) = SP_Symbols.dotted_simple_name;
      end Dotted_Identifier_Found;

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

      function Is_Last_Identifier_Node (Node : STree.SyntaxNode) return Boolean
      --# global in STree.Table;
      --# pre Syntax_Node_Type (Node, STree.Table) = SP_Symbols.identifier;
      is
      begin
         return Syntax_Node_Type (Node => Parent_Node (Current_Node => Parent_Node (Current_Node => Node))) /=
           SP_Symbols.dotted_simple_name;
      end Is_Last_Identifier_Node;

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

      function Look_Up
        (Prefix            : in Dictionary.Symbol;
         Str               : in LexTokenManager.Lex_String;
         Scope             : in Dictionary.Scopes;
         Full_Package_Name : in Boolean)
        return              Dictionary.Symbol
      --# global in CommandLineData.Content;
      --#        in Dictionary.Dict;
      --#        in LexTokenManager.State;
      is
         Sym : Dictionary.Symbol;
      begin
         if Dictionary.Is_Null_Symbol (Prefix) then
            Sym :=
              Dictionary.LookupItem
              (Name              => Str,
               Scope             => Scope,
               Context           => Dictionary.ProofContext,
               Full_Package_Name => Full_Package_Name);
         else
            Sym :=
              Dictionary.LookupSelectedItem
              (Prefix   => Prefix,
               Selector => Str,
               Scope    => Scope,
               Context  => Dictionary.ProofContext);
         end if;
         return Sym;
      end Look_Up;

   begin -- Process_Dotted_Simple_Name
      A_Public_Child := False;
      if Dotted_Identifier_Found (Node => Node) and then CommandLineData.Content.Language_Profile = CommandLineData.SPARK83 then
         ErrorHandler.Semantic_Error
           (Err_Num   => 610,
            Reference => ErrorHandler.No_Reference,
            Position  => Node_Position (Node => Node),
            Id_Str    => LexTokenManager.Null_String);
      else
         Lib_Sym      :=
           Dictionary.GetLibraryPackage (Dictionary.Set_Visibility (The_Visibility => Dictionary.Visible,
                                                                    The_Unit       => Comp_Sym));
         Current_Node := Last_Child_Of (Start_Node => Node);
         loop
            --# assert STree.Table = STree.Table~;
            -- ASSUME Current_Node = identifier
            SystemErrors.RT_Assert
              (C       => Syntax_Node_Type (Node => Current_Node) = SP_Symbols.identifier,
               Sys_Err => SystemErrors.Invalid_Syntax_Tree,
               Msg     => "Expect Current_Node = identifier in Process_Dotted_Simple_Name");
            -- look up in global scope first:
            Search_String := Node_Lex_String (Node => Current_Node);
            Current_Sym   :=
              Look_Up (Prefix            => Prefix_Sym,
                       Str               => Search_String,
                       Scope             => Dictionary.GlobalScope,
                       Full_Package_Name => True);

            if Dictionary.IsPackage (Current_Sym)
              and then not Dictionary.Packages_Are_Equal (Left_Symbol  => Current_Sym,
                                                          Right_Symbol => Lib_Sym) then
               -- package exists and is not self
               -- if necessary, check inherited by looking up in current scope
               if Dictionary.IsProperDescendent (Current_Sym, Lib_Sym) then
                  -- Withing a private descendent is allowed
                  if Dictionary.Packages_Are_Equal
                    (Left_Symbol  => Dictionary.GetPackageOwner (Current_Sym),
                     Right_Symbol => Lib_Sym) then
                     Withing_Descendent := True;
                     A_Public_Child     := False;
                     --# accept F, 41, "Structurally this is the preferred place for this test";
                  elsif -- Otherwise withing a descendent is allowed when
                        -- Language_Profile is an Auto_Code_Generator.
                    CommandLineData.Content.Language_Profile in CommandLineData.Auto_Code_Generators then
                     --# end accept;
                     Withing_Descendent := True;
                     -- Inform caller that a public child is inherited.
                     A_Public_Child := True;
                  else  -- Not a valid with of a descendent
                     Withing_Descendent := False;
                     A_Public_Child     := False;
                     -- For consistency with other options make Current_Sym = null
                     -- if not withing a descendent.
                     Current_Sym := Dictionary.NullSymbol;
                  end if;
               elsif Dictionary.IsProperDescendent (Lib_Sym, Current_Sym) then
                  -- withing an ancestor
                  if Is_Last_Identifier_Node (Node => Current_Node) then
                     Current_Sym :=
                       Look_Up
                       (Prefix            => Dictionary.NullSymbol,
                        Str               => Search_String,
                        Scope             => Scope,
                        Full_Package_Name => False);
                  end if;
               elsif not Dictionary.Is_Null_Symbol (Prefix_Sym) and then Dictionary.IsProperDescendent (Lib_Sym, Prefix_Sym) then
                  -- withing child of ancestor
                  Current_Sym :=
                    Look_Up (Prefix            => Dictionary.NullSymbol,
                             Str               => Search_String,
                             Scope             => Scope,
                             Full_Package_Name => False);
               else
                  Current_Sym := Look_Up (Prefix            => Prefix_Sym,
                                          Str               => Search_String,
                                          Scope             => Scope,
                                          Full_Package_Name => True);
               end if;
            end if;

            if not Dictionary.Is_Null_Symbol (Current_Sym)
              and then not Dictionary.IsPackage (Current_Sym)
              and then not Dictionary.Is_Generic_Subprogram (The_Symbol => Current_Sym) then
               -- can't be inherited
               ErrorHandler.Semantic_Error
                 (Err_Num   => 18,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Current_Node),
                  Id_Str    => Search_String);
               exit;
            end if;

            if Is_Last_Identifier_Node (Node => Current_Node)
              and then Dictionary.IsPackage (Current_Sym)
              and then Dictionary.Packages_Are_Equal (Left_Symbol  => Current_Sym,
                                                      Right_Symbol => Lib_Sym) then
               -- trying to with self (or enclosing package)
               ErrorHandler.Semantic_Error
                 (Err_Num   => 132,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Current_Node),
                  Id_Str    => Search_String);
               exit;
            end if;

            -- extra check for private root packages,
            -- which cannot be with'd by specs of public packages:
            if not Dictionary.Is_Null_Symbol (Current_Sym)
              and then Dictionary.IsPackage (Current_Sym)
              and then -- guard for precon of next line
              Dictionary.IsPrivatePackage (Current_Sym)
              and then Dictionary.Is_Null_Symbol (Dictionary.GetPackageParent (Current_Sym))
              and then Dictionary.Get_Visibility (Scope => Scope) = Dictionary.Visible
              and then Dictionary.Is_Null_Symbol (Dictionary.GetPackageOwner (Lib_Sym))
              and then not Dictionary.IsPrivatePackage (Dictionary.GetRootPackage (Lib_Sym)) then
               ErrorHandler.Semantic_Error
                 (Err_Num   => 616,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Current_Node),
                  Id_Str    => Search_String);
               exit;
            end if;

            -- Look up will find generic functions because they have an associated
            -- proof function in proof context.  We want to exclude them unless they have
            -- also been inherited.
            if Dictionary.Is_Generic_Subprogram (The_Symbol => Current_Sym)
              and then not Dictionary.IsInherited (Current_Sym, Comp_Sym) then
               Current_Sym := Dictionary.NullSymbol;
            end if;

            if Dictionary.Is_Null_Symbol (Current_Sym) then
               if CommandLineData.Ravenscar_Selected
                 and then LexTokenManager.Lex_String_Case_Insensitive_Compare
                 (Lex_Str1 => Search_String,
                  Lex_Str2 => LexTokenManager.Ada_Token) /=
                 LexTokenManager.Str_Eq
                 and then LexTokenManager.Lex_String_Case_Insensitive_Compare
                 (Lex_Str1 => Search_String,
                  Lex_Str2 => LexTokenManager.System_Token) /=
                 LexTokenManager.Str_Eq then
                  -- stronger warning for uninherited withs of non-predefined packages in Ravenscar
                  ErrorHandler.Semantic_Warning
                    (Err_Num  => 391,
                     Position => Node_Position (Node => Current_Node),
                     Id_Str   => Search_String);
               else
                  ErrorHandler.Semantic_Warning
                    (Err_Num  => 1,
                     Position => Node_Position (Node => Current_Node),
                     Id_Str   => Search_String);
               end if;
               exit;
            end if;

            -- check sym found is not a local redeclaration
            if not Dictionary.IsGlobalScope (Dictionary.GetScope (Current_Sym)) then
               -- This semantic error has not been checked with new error number
               -- because unable to find test case which causes the error.
               ErrorHandler.Semantic_Error
                 (Err_Num   => 133,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Current_Node),
                  Id_Str    => Search_String);
               exit;
            end if;

            -- there is something to add because symbol is not null
            Dictionary.AddWithReference
              (The_Visibility    => Dictionary.Get_Visibility (Scope => Scope),
               The_Unit          => Comp_Sym,
               The_Withed_Symbol => Current_Sym,
               Explicit          => Is_Last_Identifier_Node (Node => Current_Node),
               Comp_Unit         => ContextManager.Ops.Current_Unit,
               Declaration       => Dictionary.Location'(Start_Position => Node_Position (Node => Current_Node),
                                                         End_Position   => Node_Position (Node => Current_Node)),
               Already_Present   => Explicit_Duplicate);
            if Explicit_Duplicate then
               ErrorHandler.Semantic_Error_Sym
                 (Err_Num   => 191,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Node),
                  Sym       => Current_Sym,
                  Scope     => Dictionary.GlobalScope);
            end if;
            STree.Set_Node_Lex_String (Sym  => Current_Sym,
                                       Node => Current_Node);

            -- Handle the case of a with for a descendent package.
            -- Relevant for all private child packages, their descendents and
            -- for non-private descendent public child packages only if a code
            -- generator language profile is selected.

            -- Add a 'fake inherit' as well as the 'with'
            if Withing_Descendent then
               --# accept Flow, 10, Discard, "Can never be explicitly duplicated, as is only ever implicit";
               Dictionary.AddInheritsReference
                 (The_Unit             => Comp_Sym,
                  The_Inherited_Symbol => Current_Sym,
                  Explicit             => False,
                  Comp_Unit            => ContextManager.Ops.Current_Unit,
                  Declaration          => Dictionary.Location'(Start_Position => Node_Position (Node => Current_Node),
                                                               End_Position   => Node_Position (Node => Current_Node)),
                  Already_Present      => Discard);
               --# end accept;
            end if;

            Current_Node := Parent_Node (Current_Node => Current_Node);
            -- ASSUME Current_Node = dotted_simple_name
            SystemErrors.RT_Assert
              (C       => Syntax_Node_Type (Node => Current_Node) = SP_Symbols.dotted_simple_name,
               Sys_Err => SystemErrors.Invalid_Syntax_Tree,
               Msg     => "Expect Current_Node = dotted_simple_name in Process_Dotted_Simple_Name");
            exit when Current_Node = Node;
            Prefix_Sym   := Current_Sym; -- ready for next lookup
            Current_Node := Next_Sibling (Current_Node => Current_Node);
         end loop;
      end if;
      --# accept Flow, 33, Discard, "Expected to be neither referenced nor exported";
   end Process_Dotted_Simple_Name;

begin -- With_Clause
   With_Public_Child := False;

   It := Find_First_Node (Node_Kind    => SP_Symbols.dotted_simple_name,
                          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.dotted_simple_name and
      --#   Next_Node = Get_Node (It);
      Process_Dotted_Simple_Name (Node           => Next_Node,
                                  Comp_Sym       => Comp_Sym,
                                  Scope          => Scope,
                                  A_Public_Child => A_Public_Child);
      With_Public_Child := With_Public_Child or else A_Public_Child;
      It                := STree.NextNode (It);
   end loop;

end With_Clause;
