-------------------------------------------------------------------------------
-- (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:
-- Starting at node type mark there are 2 possibilities: type mark indicates
-- a type T or a package and type P.T
-- Case 1: type T.   WF if T is a type and T is visible.
-- Case 2: type P.T  WF if P is visible and P is a package and P.T is
--         visible and P.T is a type.
-- Possible errors: Not visible   (semantic error 1 or 754 or 755)
--                  Not a type    (semantic error 63)
--                  Not a package (semantic error 9)
--------------------------------------------------------------------------------

separate (Sem)
procedure Wf_Type_Mark
  (Node          : in     STree.SyntaxNode;
   Current_Scope : in     Dictionary.Scopes;
   Context       : in     Dictionary.Contexts;
   Type_Sym      :    out Dictionary.Symbol)
is

   Current_Node : STree.SyntaxNode;

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

   procedure Check_Symbol
     (Node_Pos : in     LexTokenManager.Token_Position;
      Id_Node  : in     STree.SyntaxNode;
      Sym      : in     Dictionary.Symbol;
      Prefix   : in     LexTokenManager.Lex_String;
      Type_Sym :    out Dictionary.Symbol)
   --# global in     CommandLineData.Content;
   --#        in     Dictionary.Dict;
   --#        in     LexTokenManager.State;
   --#        in out ErrorHandler.Error_Context;
   --#        in out SPARK_IO.File_Sys;
   --#        in out STree.Table;
   --# derives ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         ErrorHandler.Error_Context,
   --#                                         Id_Node,
   --#                                         LexTokenManager.State,
   --#                                         Node_Pos,
   --#                                         Prefix,
   --#                                         SPARK_IO.File_Sys,
   --#                                         STree.Table,
   --#                                         Sym &
   --#         STree.Table                from *,
   --#                                         Dictionary.Dict,
   --#                                         Id_Node,
   --#                                         Sym &
   --#         Type_Sym                   from Dictionary.Dict,
   --#                                         Sym;
   --# pre Syntax_Node_Type (Id_Node, STree.Table) = SP_Symbols.identifier;
   --# post (Dictionary.Is_Null_Symbol (Type_Sym) or Dictionary.IsTypeMark (Type_Sym, Dictionary.Dict)) and STree.Table = STree.Table~;
   is
   begin
      if Dictionary.Is_Null_Symbol (Sym) then
         -- not declared or visible
         Type_Sym := Dictionary.GetUnknownTypeMark;
         ErrorHandler.Semantic_Error2
           (Err_Num   => 145,
            Reference => ErrorHandler.No_Reference,
            Position  => Node_Pos,
            Id_Str1   => Node_Lex_String (Node => Id_Node),
            Id_Str2   => Prefix);
      elsif Dictionary.IsTypeMark (Sym) then
         if Dictionary.TypeIsWellformed (Sym) then
            STree.Set_Node_Lex_String (Sym  => Sym,
                                       Node => Id_Node);
            Type_Sym := Sym;
         else
            Type_Sym := Dictionary.GetUnknownTypeMark;
            ErrorHandler.Semantic_Error2
              (Err_Num   => 145,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Pos,
               Id_Str1   => Node_Lex_String (Node => Id_Node),
               Id_Str2   => Prefix);
         end if;
      else
         -- not a type
         Type_Sym := Dictionary.GetUnknownTypeMark;
         ErrorHandler.Semantic_Error
           (Err_Num   => 63,
            Reference => ErrorHandler.No_Reference,
            Position  => Node_Position (Node => Id_Node),
            Id_Str    => Node_Lex_String (Node => Id_Node));
      end if;
   end Check_Symbol;

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

   procedure Check_Type_Mark
     (Node_Pos      : in     LexTokenManager.Token_Position;
      Id_Node       : in     STree.SyntaxNode;
      Current_Scope : in     Dictionary.Scopes;
      Context       : in     Dictionary.Contexts;
      Type_Sym      :    out Dictionary.Symbol)
   --# global in     CommandLineData.Content;
   --#        in     Dictionary.Dict;
   --#        in     LexTokenManager.State;
   --#        in out ErrorHandler.Error_Context;
   --#        in out SPARK_IO.File_Sys;
   --#        in out STree.Table;
   --# derives ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from CommandLineData.Content,
   --#                                         Context,
   --#                                         Current_Scope,
   --#                                         Dictionary.Dict,
   --#                                         ErrorHandler.Error_Context,
   --#                                         Id_Node,
   --#                                         LexTokenManager.State,
   --#                                         Node_Pos,
   --#                                         SPARK_IO.File_Sys,
   --#                                         STree.Table &
   --#         STree.Table,
   --#         Type_Sym                   from CommandLineData.Content,
   --#                                         Context,
   --#                                         Current_Scope,
   --#                                         Dictionary.Dict,
   --#                                         Id_Node,
   --#                                         LexTokenManager.State,
   --#                                         STree.Table;
   --# pre Syntax_Node_Type (Id_Node, STree.Table) = SP_Symbols.identifier;
   --# post (Dictionary.Is_Null_Symbol (Type_Sym) or Dictionary.IsTypeMark (Type_Sym, Dictionary.Dict)) and STree.Table = STree.Table~;
   is
   begin
      Check_Symbol
        (Node_Pos => Node_Pos,
         Id_Node  => Id_Node,
         Sym      => Dictionary.LookupItem
           (Name              => Node_Lex_String (Node => Id_Node),
            Scope             => Current_Scope,
            Context           => Context,
            Full_Package_Name => False),
         Prefix   => LexTokenManager.Null_String,
         Type_Sym => Type_Sym);
   end Check_Type_Mark;

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

   procedure Check_Dotted_Type_Mark
     (Node          : in     STree.SyntaxNode;
      Current_Scope : in     Dictionary.Scopes;
      Context       : in     Dictionary.Contexts;
      Type_Sym      :    out Dictionary.Symbol)
   --# global in     CommandLineData.Content;
   --#        in     Dictionary.Dict;
   --#        in     LexTokenManager.State;
   --#        in out ErrorHandler.Error_Context;
   --#        in out SPARK_IO.File_Sys;
   --#        in out STree.Table;
   --# derives ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from CommandLineData.Content,
   --#                                         Context,
   --#                                         Current_Scope,
   --#                                         Dictionary.Dict,
   --#                                         ErrorHandler.Error_Context,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         SPARK_IO.File_Sys,
   --#                                         STree.Table &
   --#         STree.Table,
   --#         Type_Sym                   from CommandLineData.Content,
   --#                                         Context,
   --#                                         Current_Scope,
   --#                                         Dictionary.Dict,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         STree.Table;
   --# pre Syntax_Node_Type (Node, STree.Table) = SP_Symbols.type_mark;
   --# post (Dictionary.Is_Null_Symbol (Type_Sym) or Dictionary.IsTypeMark (Type_Sym, Dictionary.Dict)) and STree.Table = STree.Table~;
   is
      Sym          : Dictionary.Symbol;
      Current_Node : STree.SyntaxNode;
      Prefix       : LexTokenManager.Lex_String;
      Prev_Prefix  : LexTokenManager.Lex_String;
      Prefix_OK    : Boolean;
      In_Prefix    : Boolean;
      Err_Num      : Natural;

      ----------------------------------------------------------------------------
      -- In the case where a Prefix is not visible, we need to distinguish
      -- between two cases:
      -- 1) Where the Prefix appears in a public child package and might denote
      --    a parent of that package.  In this case, we need to issue a message
      --    saying that the named package needs to be inherited (not NOT withed)
      --    to be visible.
      -- 2) Where the child package may be inherited but the prefix erroneously
      --    includes the grandparent package.
      -- 3) Otherwise.  In these cases, we issue a message saying that the
      --    named package has to be BOTH inherited and withed.
      --
      -- Example 1.  Consider a type mark P.T appearing in a public child A.P.B.C
      -- In this case, we find that the prefix "P" _is_ a potential parent
      -- package, so P needs to be inherited.
      --
      -- Example 2.  Consider a type mark A.P.T appearing in a public child A.P.B.C
      -- In this case, we find that the prefix "P" _is_ a potential parent
      -- package but should not be prefixed by the garndparent A.
      --
      -- Example 3.  Consider a type mark P.T appearing in a public child X.Y.Z
      -- In this case, we find that P cannot be a parent, so P must be
      -- inherited AND withed.
      ----------------------------------------------------------------------------
      function Prefix_Can_Denote_An_Ancestor
        (Prefix        : LexTokenManager.Lex_String;
         Current_Scope : Dictionary.Scopes)
        return          Boolean
      --# global in Dictionary.Dict;
      --#        in LexTokenManager.State;
      is
         EP     : Dictionary.Symbol; -- Enclosing package where Prefix appears
         CP     : Dictionary.Symbol; -- Current Parent package
         Result : Boolean;
      begin
         EP     := Dictionary.GetEnclosingPackage (Current_Scope);
         CP     := Dictionary.GetPackageParent (EP);
         Result := False;
         -- CP = NullSymbol when EP is a library-level package.
         while not Dictionary.Is_Null_Symbol (CP) loop
            -- If the Prefix matches the current parent, then we're done.
            -- If not, then look for the grand-parent and try again until we
            -- reach library level.
            if LexTokenManager.Lex_String_Case_Insensitive_Compare (Lex_Str1 => Prefix,
                                                                    Lex_Str2 => Dictionary.GetSimpleName (CP)) =
              LexTokenManager.Str_Eq then
               Result := True;
               exit;
            end if;
            CP := Dictionary.GetPackageParent (CP);
         end loop;
         return Result;
      end Prefix_Can_Denote_An_Ancestor;

   begin -- Check_Dotted_Type_Mark
      In_Prefix    := False;
      Current_Node := Last_Child_Of (Start_Node => Node);
      -- 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 Check_Dotted_Type_Mark");
      Prefix := Node_Lex_String (Node => Current_Node);
      Sym    := Dictionary.LookupItem (Name              => Prefix,
                                       Scope             => Current_Scope,
                                       Context           => Context,
                                       Full_Package_Name => False);
      loop -- we need a loop to handle multiple prefixes

         --# assert STree.Table = STree.Table~;
         if Dictionary.Is_Null_Symbol (Sym) then
            -- not declared or visible
            Type_Sym := Dictionary.GetUnknownTypeMark;

            if Prefix_Can_Denote_An_Ancestor (Prefix        => Prefix,
                                              Current_Scope => Current_Scope) then
               --# accept F, 22, "Invariant expression OK here";
               if In_Prefix then
                  Err_Num := 756;
               else
                  Err_Num := 755;
               end if;
               --# end accept;
            else
               Err_Num := 754;
            end if;
            ErrorHandler.Semantic_Error
              (Err_Num   => Err_Num,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Current_Node),
               Id_Str    => Prefix);
            exit;
         end if;

         if not Dictionary.IsPackage (Sym) then
            -- can't be dotted
            Type_Sym := Dictionary.GetUnknownTypeMark;
            ErrorHandler.Semantic_Error
              (Err_Num   => 9,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Current_Node),
               Id_Str    => Prefix);
            exit;
         end if;

         -- Prefix (Sym) is visible and it's a package
         Check_Package_Prefix
           (Node_Pos => Node_Position (Node => Current_Node),
            Pack_Sym => Sym,
            Scope    => Current_Scope,
            OK       => Prefix_OK);
         if not Prefix_OK then
            Type_Sym := Dictionary.GetUnknownTypeMark;
            exit;
         end if;
         STree.Set_Node_Lex_String (Sym  => Sym,
                                    Node => Current_Node);
         Current_Node := Next_Sibling (Current_Node => Parent_Node (Current_Node => Current_Node));
         -- 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 Check_Dotted_Type_Mark");
         Sym :=
           Dictionary.LookupSelectedItem
           (Prefix   => Sym,
            Selector => Node_Lex_String (Node => Current_Node),
            Scope    => Current_Scope,
            Context  => Context);
         if Next_Sibling (Current_Node => Parent_Node (Current_Node => Current_Node)) = STree.NullNode then
            -- ASSUME Next_Sibling (Current_Node => Parent_Node (Current_Node => Current_Node)) = NULL
            -- no more identifiers to the right, so we should now have type name
            Check_Symbol
              (Node_Pos => Node_Position (Node => Node),
               Id_Node  => Current_Node,
               Sym      => Sym,
               Prefix   => Prefix,
               Type_Sym => Type_Sym);
            exit;
         end if;
         -- elsif Syntax_Node_Type (Node => Next_Sibling (Current_Node => Parent_Node (Current_Node => Current_Node))) /=
         --   SP_Symbols.identifier then
         SystemErrors.RT_Assert
           (C       => Syntax_Node_Type (Node => Next_Sibling (Current_Node => Parent_Node (Current_Node => Current_Node))) =
              SP_Symbols.identifier,
            Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Next_Sibling (Current_Node => Parent_Node (Current_Node => Current_Node)) = identifier OR " &
              "NULL in Check_Dotted_Type_Mark");
         -- end if;

         -- Check that there are not recursive layers of the
         -- same package name (e.g. A.A.B) as the Dictionary
         -- lookup above will always return the same A
         Prev_Prefix := Prefix;
         Prefix      := Node_Lex_String (Node => Current_Node);
         if LexTokenManager.Lex_String_Case_Insensitive_Compare (Lex_Str1 => Prev_Prefix,
                                                                 Lex_Str2 => Prefix) =
           LexTokenManager.Str_Eq then
            ErrorHandler.Semantic_Error
              (Err_Num   => 145,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Current_Node),
               Id_Str    => Node_Lex_String (Node => Current_Node));
         end if;

         -- otherwise go round again
         In_Prefix := True;
      end loop;
   end Check_Dotted_Type_Mark;

begin -- Wf_Type_Mark
   Current_Node := Child_Node (Current_Node => Child_Node (Current_Node => Node));
   -- ASSUME Current_Node = identifier OR dotted_simple_name
   if Syntax_Node_Type (Node => Current_Node) = SP_Symbols.identifier then
      -- ASSUME Current_Node = identifier
      Check_Type_Mark
        (Node_Pos      => Node_Position (Node => Node),
         Id_Node       => Current_Node,
         Current_Scope => Current_Scope,
         Context       => Context,
         Type_Sym      => Type_Sym);
   elsif Syntax_Node_Type (Node => Current_Node) = SP_Symbols.dotted_simple_name then
      -- ASSUME Current_Node = dotted_simple_name
      Check_Dotted_Type_Mark (Node          => Node,
                              Current_Scope => Current_Scope,
                              Context       => Context,
                              Type_Sym      => Type_Sym);
   else
      Type_Sym := Dictionary.NullSymbol;
      SystemErrors.Fatal_Error
        (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Current_Node = identifier OR dotted_simple_name in Wf_Type_Mark");
   end if;
end Wf_Type_Mark;
