-------------------------------------------------------------------------------
-- (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_Pragma)
procedure Wf_Attach_Handler (Pragma_Node : in STree.SyntaxNode;
                             Scope       : in Dictionary.Scopes) is
   -- Checks:
   --       (1) Positional association
   --       (2) Exactly 2 arguments
   --       (3) First is the procedure name
   --       (4) 2nd is ignore for now
   --       (5) pragma immediately follows procedure
   --       -- Rule 6 removed after design rethink (6) only one attach_handler per PT
   --       (7) procedure must be parameterless
   --       (8) must be in PT

   The_Region     : Dictionary.Symbol;
   Proc_Spec_Node : STree.SyntaxNode;
   Proc_Ident     : LexTokenManager.Lex_String;
   Proc_Sym       : Dictionary.Symbol;
   Error_Found    : Boolean := False;

   procedure Find_Proc_Spec (Pragma_Node    : in     STree.SyntaxNode;
                             Proc_Spec_Node :    out STree.SyntaxNode)
   --# global in STree.Table;
   --# derives Proc_Spec_Node from Pragma_Node,
   --#                             STree.Table;
   --# pre Syntax_Node_Type (Pragma_Node, STree.Table) = SP_Symbols.apragma;
   --# post Syntax_Node_Type (Proc_Spec_Node, STree.Table) = SP_Symbols.procedure_specification or
   --#   Syntax_Node_Type (Proc_Spec_Node, STree.Table) = SP_Symbols.function_specification or
   --#   Syntax_Node_Type (Proc_Spec_Node, STree.Table) = SP_Symbols.entry_specification or
   --#   Syntax_Node_Type (Proc_Spec_Node, STree.Table) = SP_Symbols.identifier or
   --#   Syntax_Node_Type (Proc_Spec_Node, STree.Table) = SP_Symbols.assert_pragma;
   -- locates the place where a procedure_specification should be if the pragma is
   -- correctly placed.
   is
      Current_Node : STree.SyntaxNode;
   begin
      -- There are two cases to consider: the attach_handler follows the first subprogram in the PT; or
      -- it follows some later subprogram declaration.
      -- Note that the protected_operation_declaration_rep grammar means that the sequence of declarations
      -- is "upside down" with the first declaration at the bottom.
      Current_Node := Child_Node (Current_Node => Parent_Node (Current_Node => Pragma_Node));
      -- ASSUME Current_Node = apragma OR
      --                       pragma_rep OR
      --                       initial_declarative_item_rep OR
      --                       later_declarative_item_rep OR
      --                       sequence_of_labels OR
      --                       code_insertion OR
      --                       visible_part_rep OR
      --                       basic_declarative_item_rep OR
      --                       renaming_declaration_rep OR
      --                       task_pragma OR
      --                       protected_operation_declaration_rep OR
      --                       procedure_specification OR
      --                       function_specification

      -- protected_operation_declaration_rep to left of pragma

      if Syntax_Node_Type (Node => Current_Node) = SP_Symbols.protected_operation_declaration_rep then
         -- ASSUME Current_Node = protected_operation_declaration_rep
         if Child_Node (Current_Node => Current_Node) = STree.NullNode then
            -- ASSUME Child_Node (Current_Node => Current_Node) = NULL
            -- The pragma is at the bottom of the sequence of protected_operation_declaration_reps and
            -- so we are dealing with FIRST subprogram in the PT (immediately after the priority pragma)

            -- Go to the top of the list of protected_operation_declaration_reps
            loop
               --# assert Syntax_Node_Type (Current_Node, STree.Table) = SP_Symbols.protected_operation_declaration_rep;
               Current_Node := Parent_Node (Current_Node => Current_Node);
               -- ASSUME Current_Node = protected_operation_declaration_rep OR protected_operation_declaration
               SystemErrors.RT_Assert
                 (C       => Syntax_Node_Type (Node => Current_Node) = SP_Symbols.protected_operation_declaration_rep
                    or else Syntax_Node_Type (Node => Current_Node) = SP_Symbols.protected_operation_declaration,
                  Sys_Err => SystemErrors.Invalid_Syntax_Tree,
                  Msg     => "Expect Current_Node = protected_operation_declaration_rep OR " &
                    "protected_operation_declaration in Find_Proc_Spec");
               exit when Syntax_Node_Type (Node => Current_Node) = SP_Symbols.protected_operation_declaration;
            end loop;
            -- ASSUME Current_Node = protected_operation_declaration
            -- Move to procedure spec
            Proc_Spec_Node :=
              Child_Node
              (Current_Node => Child_Node (Current_Node => Next_Sibling (Current_Node => Child_Node (Current_Node => Current_Node))));
            -- ASSUME Proc_Spec_Node = procedure_specification OR function_specification OR
            --                         proof_function_declaration OR entry_specification
         elsif Syntax_Node_Type (Node => Child_Node (Current_Node => Current_Node)) =
           SP_Symbols.protected_operation_declaration_rep then
            -- ASSUME Syntax_Node_Type (Node => Child_Node (Current_Node => Current_Node) = protected_operation_declaration_rep
            -- we are dealing with a potential subprogram in the
            -- sequence of declarations in the PT declarative part
            Proc_Spec_Node :=
              Child_Node (Current_Node => Next_Sibling (Current_Node => Child_Node (Current_Node => Current_Node)));
            -- ASSUME Proc_Spec_Node = procedure_specification OR function_specification OR
            --                         proof_function_declaration OR entry_specification OR
            --                         identifier OR assert_pragma
         else
            Proc_Spec_Node := STree.NullNode;
            SystemErrors.Fatal_Error
              (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
               Msg     => "Expect Child_Node (Current_Node => Current_Node) = protected_operation_declaration_rep OR " &
                 "NULL in Find_Proc_Spec");
         end if;
      else
         Proc_Spec_Node := STree.NullNode;
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Current_Node = protected_operation_declaration_rep in Find_Proc_Spec");
      end if;
      -- ASSUME Proc_Spec_Node = procedure_specification OR function_specification OR
      --                         proof_function_declaration OR entry_specification OR
      --                         identifier OR assert_pragma
      if Syntax_Node_Type (Node => Proc_Spec_Node) = SP_Symbols.proof_function_declaration then
         -- ASSERT_PRAGMA Proc_Spec_Node = proof_function_declaration
         Proc_Spec_Node := Child_Node (Current_Node => Proc_Spec_Node);
      elsif Syntax_Node_Type (Node => Proc_Spec_Node) /= SP_Symbols.procedure_specification
        and then Syntax_Node_Type (Node => Proc_Spec_Node) /= SP_Symbols.function_specification
        and then Syntax_Node_Type (Node => Proc_Spec_Node) /= SP_Symbols.entry_specification
        and then Syntax_Node_Type (Node => Proc_Spec_Node) /= SP_Symbols.identifier
        and then Syntax_Node_Type (Node => Proc_Spec_Node) /= SP_Symbols.assert_pragma then
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Proc_Spec_Node = procedure_specification OR function_specification OR " &
              "proof_function_declaration OR entry_specification OR identifier OR assert_pragma in Find_Proc_Spec");
      end if;
      -- ASSUME Proc_Spec_Node = procedure_specification OR function_specification OR entry_specification OR
      --                         identifier OR assert_pragma
      SystemErrors.RT_Assert
        (C       => Syntax_Node_Type (Node => Proc_Spec_Node) = SP_Symbols.procedure_specification
           or else Syntax_Node_Type (Node => Proc_Spec_Node) = SP_Symbols.function_specification
           or else Syntax_Node_Type (Node => Proc_Spec_Node) = SP_Symbols.entry_specification
           or else Syntax_Node_Type (Node => Proc_Spec_Node) = SP_Symbols.identifier
           or else Syntax_Node_Type (Node => Proc_Spec_Node) = SP_Symbols.assert_pragma,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Proc_Spec_Node = procedure_specification OR function_specification OR entry_specification OR " &
           "identifier OR assert_pragma in Find_Proc_Spec");
   end Find_Proc_Spec;

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

   procedure Check_Arguments
     (Pragma_Node : in     STree.SyntaxNode;
      Entity_Name : in     LexTokenManager.Lex_String;
      Error_Found : in out Boolean)
   --# global in     CommandLineData.Content;
   --#        in     Dictionary.Dict;
   --#        in     LexTokenManager.State;
   --#        in     STree.Table;
   --#        in out ErrorHandler.Error_Context;
   --#        in out SPARK_IO.File_Sys;
   --# derives ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         Entity_Name,
   --#                                         ErrorHandler.Error_Context,
   --#                                         LexTokenManager.State,
   --#                                         Pragma_Node,
   --#                                         SPARK_IO.File_Sys,
   --#                                         STree.Table &
   --#         Error_Found                from *,
   --#                                         Entity_Name,
   --#                                         LexTokenManager.State,
   --#                                         Pragma_Node,
   --#                                         STree.Table;
   --# pre Syntax_Node_Type (Pragma_Node, STree.Table) = SP_Symbols.apragma;
   is
      Arg_Assoc_Rep_Node : STree.SyntaxNode;
      Subprog_Name_Node  : STree.SyntaxNode;

      procedure Check_Represent_Same_Name
        (Exp_Node    : in     STree.SyntaxNode;
         Name        : in     LexTokenManager.Lex_String;
         Error_Found : in out Boolean)
      --# global in     CommandLineData.Content;
      --#        in     Dictionary.Dict;
      --#        in     LexTokenManager.State;
      --#        in     STree.Table;
      --#        in out ErrorHandler.Error_Context;
      --#        in out SPARK_IO.File_Sys;
      --# derives ErrorHandler.Error_Context,
      --#         SPARK_IO.File_Sys          from CommandLineData.Content,
      --#                                         Dictionary.Dict,
      --#                                         ErrorHandler.Error_Context,
      --#                                         Exp_Node,
      --#                                         LexTokenManager.State,
      --#                                         Name,
      --#                                         SPARK_IO.File_Sys,
      --#                                         STree.Table &
      --#         Error_Found                from *,
      --#                                         Exp_Node,
      --#                                         LexTokenManager.State,
      --#                                         Name,
      --#                                         STree.Table;
      --# pre Syntax_Node_Type (Exp_Node, STree.Table) = SP_Symbols.ADA_expression;
      is
         Is_Chain           : Boolean;
         Id_Node, Next_Node : STree.SyntaxNode;
      begin
         Id_Node := Exp_Node;
         loop
            Is_Chain  := Next_Sibling (Current_Node => Id_Node) = STree.NullNode;
            Next_Node := Child_Node (Current_Node => Id_Node);
            exit when not Is_Chain or else Next_Node = STree.NullNode;

            Id_Node := Next_Node;
         end loop;

         if not Is_Chain
           or else Syntax_Node_Type (Node => Id_Node) /= SP_Symbols.identifier
           or else LexTokenManager.Lex_String_Case_Insensitive_Compare
           (Lex_Str1 => Node_Lex_String (Node => Id_Node),
            Lex_Str2 => Name) /=
           LexTokenManager.Str_Eq then
            -- Rule 3 failure
            Error_Found := True;
            ErrorHandler.Semantic_Error
              (Err_Num   => 71,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Exp_Node),
               Id_Str    => Name);
         end if;
      end Check_Represent_Same_Name;

   begin -- Check_Arguments
      Arg_Assoc_Rep_Node := Child_Node (Current_Node => Pragma_Node);
      -- ASSUME Arg_Assoc_Rep_Node = identifier OR assert_pragma
      if Syntax_Node_Type (Node => Arg_Assoc_Rep_Node) = SP_Symbols.identifier then
         -- ASSUME Arg_Assoc_Rep_Node = identifier
         Arg_Assoc_Rep_Node := Next_Sibling (Current_Node => Arg_Assoc_Rep_Node);
         -- ASSUME Arg_Assoc_Rep_Node = argument_association_rep OR NULL
         if Syntax_Node_Type (Node => Arg_Assoc_Rep_Node) = SP_Symbols.argument_association_rep then
            -- ASSUME Arg_Assoc_Rep_Node = argument_association_rep
            Arg_Assoc_Rep_Node := Child_Node (Current_Node => Arg_Assoc_Rep_Node);
            -- ASSUME Arg_Assoc_Rep_Node = argument_association_rep OR argument_association
            if Syntax_Node_Type (Node => Arg_Assoc_Rep_Node) = SP_Symbols.argument_association_rep then
               -- ASSUME Arg_Assoc_Rep_Node = argument_association_rep
               Arg_Assoc_Rep_Node := Child_Node (Current_Node => Arg_Assoc_Rep_Node);
               -- ASSUME Arg_Assoc_Rep_Node = argument_association_rep OR argument_association
               if Syntax_Node_Type (Node => Arg_Assoc_Rep_Node) = SP_Symbols.argument_association then
                  -- ASSUME Arg_Assoc_Rep_Node = argument_association
                  -- pragma has two arguments
                  Subprog_Name_Node := Child_Node (Current_Node => Arg_Assoc_Rep_Node);
                  -- ASSUME Subprog_Name_Node = identifier OR ADA_expression
                  if Syntax_Node_Type (Node => Subprog_Name_Node) = SP_Symbols.identifier then
                     -- ASSUME Subprog_Name_Node = identifier
                     -- form of expression wrong - Rule 1 failure
                     Error_Found := True;
                     ErrorHandler.Semantic_Error
                       (Err_Num   => 71,
                        Reference => ErrorHandler.No_Reference,
                        Position  => Node_Position (Node => Subprog_Name_Node),
                        Id_Str    => Entity_Name);
                  elsif Syntax_Node_Type (Node => Subprog_Name_Node) = SP_Symbols.ADA_expression then
                     -- ASSUME Subprog_Name_Node = ADA_expression
                     -- form of expression ok so check name actually matches
                     Check_Represent_Same_Name (Exp_Node    => Subprog_Name_Node,
                                                Name        => Entity_Name,
                                                Error_Found => Error_Found);
                  else
                     Error_Found := True;
                     SystemErrors.Fatal_Error
                       (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
                        Msg     => "Expect Subprog_Name_Node = identifier OR ADA_expression in Check_Arguments");
                  end if;
               elsif Syntax_Node_Type (Node => Arg_Assoc_Rep_Node) = SP_Symbols.argument_association_rep then
                  -- ASSUME Arg_Assoc_Rep_Node = argument_association_rep
                  -- pragma does nor have exactly 2 arguments -- Rule 2 failure
                  Error_Found := True;
                  ErrorHandler.Semantic_Error
                    (Err_Num   => 69,
                     Reference => ErrorHandler.No_Reference,
                     Position  => Node_Position (Node => Pragma_Node),
                     Id_Str    => LexTokenManager.Attach_Handler_Token);
               else
                  Error_Found := True;
                  SystemErrors.Fatal_Error
                    (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
                     Msg     => "Expect Arg_Assoc_Rep_Node = argument_association_rep OR " &
                       "argument_association in Check_Arguments");
               end if;
            elsif Syntax_Node_Type (Node => Arg_Assoc_Rep_Node) = SP_Symbols.argument_association then
               -- ASSUME Arg_Assoc_Rep_Node = argument_association
               -- pragma does nor have exactly 2 arguments -- Rule 2 failure
               Error_Found := True;
               ErrorHandler.Semantic_Error
                 (Err_Num   => 69,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Pragma_Node),
                  Id_Str    => LexTokenManager.Attach_Handler_Token);
            else
               Error_Found := True;
               SystemErrors.Fatal_Error
                 (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
                  Msg     => "Expect Arg_Assoc_Rep_Node = argument_association_rep OR " &
                    "argument_association in Check_Arguments");
            end if;
         elsif Arg_Assoc_Rep_Node = STree.NullNode then
            -- ASSUME Arg_Assoc_Rep_Node = assert_pragma
            -- pragma does nor have exactly 2 arguments -- Rule 2 failure
            Error_Found := True;
            ErrorHandler.Semantic_Error
              (Err_Num   => 69,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Pragma_Node),
               Id_Str    => LexTokenManager.Attach_Handler_Token);
         else
            Error_Found := True;
            SystemErrors.Fatal_Error
              (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
               Msg     => "Expect Arg_Assoc_Rep_Node = argument_association_rep OR NULL in Check_Arguments");
         end if;
      elsif Syntax_Node_Type (Node => Arg_Assoc_Rep_Node) = SP_Symbols.assert_pragma then
         -- ASSUME Arg_Assoc_Rep_Node = assert_pragma
         -- pragma does nor have exactly 2 arguments -- Rule 2 failure
         Error_Found := True;
         ErrorHandler.Semantic_Error
           (Err_Num   => 69,
            Reference => ErrorHandler.No_Reference,
            Position  => Node_Position (Node => Pragma_Node),
            Id_Str    => LexTokenManager.Attach_Handler_Token);
      else
         Error_Found := True;
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Arg_Assoc_Rep_Node = identifier OR assert_pragma in Check_Arguments");
      end if;
   end Check_Arguments;

begin -- Wf_Attach_Handler
   The_Region := Dictionary.GetRegion (Scope);
   -- attach_Handler can only appear in the spec of a protected type
   if Dictionary.IsType (The_Region) and then Dictionary.IsProtectedTypeMark (The_Region) then
      Find_Proc_Spec (Pragma_Node    => Pragma_Node,
                      Proc_Spec_Node => Proc_Spec_Node);
      -- ASSUME Proc_Spec_Node = procedure_specification OR function_specification OR entry_specification OR
      --                         identifier OR assert_pragma
      if Syntax_Node_Type (Node => Proc_Spec_Node) = SP_Symbols.procedure_specification then
         -- ASSUME Proc_Spec_Node = procedure_specification
         Proc_Spec_Node := Child_Node (Current_Node => Child_Node (Current_Node => Proc_Spec_Node));
         -- ASSUME Proc_Spec_Node = identifier
         SystemErrors.RT_Assert
           (C       => Syntax_Node_Type (Node => Proc_Spec_Node) = SP_Symbols.identifier,
            Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Proc_Spec_Node = identifier in Wf_Attach_Handler");
         Proc_Ident := Node_Lex_String (Node => Proc_Spec_Node);
         Check_Arguments (Pragma_Node => Pragma_Node,
                          Entity_Name => Proc_Ident,
                          Error_Found => Error_Found);
         if not Error_Found then
            Proc_Sym :=
              Dictionary.LookupItem
              (Name              => Proc_Ident,
               Scope             => Scope,
               Context           => Dictionary.ProgramContext,
               Full_Package_Name => False);
            if Dictionary.GetNumberOfSubprogramParameters (Proc_Sym) = 0 then
               STree.Set_Node_Lex_String (Sym  => Proc_Sym,
                                          Node => Proc_Spec_Node);
               Dictionary.SetIsInterruptHandler (Proc_Sym);
               Dictionary.SetTypeHasPragma (The_Region, Dictionary.AttachHandler);
            else -- rule 7 failure
               ErrorHandler.Semantic_Error
                 (Err_Num   => 885,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Pragma_Node),
                  Id_Str    => LexTokenManager.Null_String);

            end if;
         end if; -- Error_Found
      elsif Syntax_Node_Type (Node => Proc_Spec_Node) = SP_Symbols.function_specification
        or else Syntax_Node_Type (Node => Proc_Spec_Node) = SP_Symbols.entry_specification
        or else Syntax_Node_Type (Node => Proc_Spec_Node) = SP_Symbols.identifier
        or else Syntax_Node_Type (Node => Proc_Spec_Node) = SP_Symbols.assert_pragma then
         -- ASSUME Proc_Spec_Node = function_specification OR entry_specification OR identifier OR assert_pragma
         -- rule 5 failure
         ErrorHandler.Semantic_Error
           (Err_Num   => 884,
            Reference => ErrorHandler.No_Reference,
            Position  => Node_Position (Node => Pragma_Node),
            Id_Str    => LexTokenManager.Null_String);
      end if;
   else -- not in PT (Rule 8)
      ErrorHandler.Semantic_Error
        (Err_Num   => 884,
         Reference => ErrorHandler.No_Reference,
         Position  => Node_Position (Node => Pragma_Node),
         Id_Str    => LexTokenManager.Null_String);
   end if;
end Wf_Attach_Handler;
