-------------------------------------------------------------------------------
-- (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.CompUnit)
procedure Wf_Task_Body (Node      : in     STree.SyntaxNode;
                        Scope     : in out Dictionary.Scopes;
                        Next_Node :    out STree.SyntaxNode) is

   Task_Sym                                                                   : Dictionary.Symbol;
   Ident_Node, Anno_Node, Subprogram_Implementation_Node, End_Node, With_Node : STree.SyntaxNode;
   OK_To_Add, In_Subunit                                                      : Boolean;
   Hidden                                                                     : Hidden_Class;
   Task_Scope                                                                 : Dictionary.Scopes;
   Ident_Str                                                                  : LexTokenManager.Lex_String;
   Valid_Annotation                                                           : Boolean := False;

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

   procedure Check_OK_To_Add
     (Type_Sym       : in     Dictionary.Symbol;
      In_Subunit     : in     Boolean;
      Ident_Node_Pos : in     LexTokenManager.Token_Position;
      Ident_Str      : in     LexTokenManager.Lex_String;
      OK_To_Add      :    out Boolean)
   --# global in     CommandLineData.Content;
   --#        in     Dictionary.Dict;
   --#        in     LexTokenManager.State;
   --#        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,
   --#                                         Ident_Node_Pos,
   --#                                         Ident_Str,
   --#                                         In_Subunit,
   --#                                         LexTokenManager.State,
   --#                                         SPARK_IO.File_Sys,
   --#                                         Type_Sym &
   --#         OK_To_Add                  from Dictionary.Dict,
   --#                                         In_Subunit,
   --#                                         Type_Sym;
   is
   begin
      OK_To_Add := True;
      if In_Subunit then
         -- we require a stub but must not have a previous body
         if Dictionary.HasBody (Type_Sym) then
            OK_To_Add := False;
            ErrorHandler.Semantic_Error
              (Err_Num   => 992,
               Reference => ErrorHandler.No_Reference,
               Position  => Ident_Node_Pos,
               Id_Str    => Ident_Str);
         end if;

         if not Dictionary.HasBodyStub (Type_Sym) then
            OK_To_Add := False;
            ErrorHandler.Semantic_Error
              (Err_Num   => 15,
               Reference => ErrorHandler.No_Reference,
               Position  => Ident_Node_Pos,
               Id_Str    => Ident_Str);
         end if;
      else
         -- we must have neither stub nor previous body
         if Dictionary.HasBody (Type_Sym) or else Dictionary.HasBodyStub (Type_Sym) then
            OK_To_Add := False;
            ErrorHandler.Semantic_Error
              (Err_Num   => 992,
               Reference => ErrorHandler.No_Reference,
               Position  => Ident_Node_Pos,
               Id_Str    => Ident_Str);
         end if;
      end if;
   end Check_OK_To_Add;

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

   function Requires_Second_Annotation (Task_Sym : Dictionary.Symbol) return Boolean
   --# global in Dictionary.Dict;
   is
      Global_Var       : Dictionary.Symbol;
      Required         : Boolean;
      Global_Item      : Dictionary.Iterator;
      Enclosing_Region : Dictionary.Symbol;
   begin
      Required         := False;
      Enclosing_Region := Dictionary.GetRegion (Dictionary.GetScope (Task_Sym));
      Global_Item      := Dictionary.FirstGlobalVariable (Dictionary.IsAbstract, Task_Sym);
      while Global_Item /= Dictionary.NullIterator loop
         Global_Var := Dictionary.CurrentSymbol (Global_Item);
         if Dictionary.IsRefinedOwnVariable (Global_Var) and then Dictionary.GetOwner (Global_Var) = Enclosing_Region then
            Required := True;
            exit;
         end if;
         Global_Item := Dictionary.NextSymbol (Global_Item);
      end loop;
      return Required;
   end Requires_Second_Annotation;

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

   function Empty_Annotation (Node : STree.SyntaxNode) return Boolean
   --# global in STree.Table;
   --# pre Syntax_Node_Type (Node, STree.Table) = SP_Symbols.procedure_annotation;
   is
      Current_Node : STree.SyntaxNode;
   begin
      Current_Node := Child_Node (Current_Node => Node);
      -- ASSUME Current_Node = moded_global_definition OR dependency_relation OR declare_annotation OR procedure_constraint
      if Syntax_Node_Type (Node => Current_Node) = SP_Symbols.procedure_constraint then
         Current_Node := Child_Node (Current_Node => Current_Node);
         -- ASSUME Current_Node = precondition OR postcondition OR NULL
         SystemErrors.RT_Assert
           (C       => Current_Node = STree.NullNode
              or else Syntax_Node_Type (Node => Current_Node) = SP_Symbols.precondition
              or else Syntax_Node_Type (Node => Current_Node) = SP_Symbols.postcondition,
            Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Current_Node = precondition OR postcondition OR NULL in Empty_Annotation");
      elsif Syntax_Node_Type (Node => Current_Node) /= SP_Symbols.moded_global_definition
        and then Syntax_Node_Type (Node => Current_Node) /= SP_Symbols.dependency_relation
        and then Syntax_Node_Type (Node => Current_Node) /= SP_Symbols.declare_annotation then
         Current_Node := STree.NullNode;
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Current_Node = moded_global_definition OR dependency_relation OR " &
              "declare_annotation OR procedure_constraint in Empty_Annotation");
      end if;
      return Current_Node = STree.NullNode;
   end Empty_Annotation;

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

   procedure Process_Annotation
     (Anno_Node        : in     STree.SyntaxNode;
      Scope            : in     Dictionary.Scopes;
      Task_Sym         : in     Dictionary.Symbol;
      Valid_Annotation : in out Boolean)
   --# global in     CommandLineData.Content;
   --#        in     ContextManager.Ops.File_Heap;
   --#        in     ContextManager.Ops.Unit_Heap;
   --#        in     ContextManager.Ops.Unit_Stack;
   --#        in out Aggregate_Stack.State;
   --#        in out Dictionary.Dict;
   --#        in out ErrorHandler.Error_Context;
   --#        in out LexTokenManager.State;
   --#        in out SLI.State;
   --#        in out SPARK_IO.File_Sys;
   --#        in out Statistics.TableUsage;
   --#        in out STree.Table;
   --#        in out TheHeap;
   --# derives Aggregate_Stack.State,
   --#         Dictionary.Dict,
   --#         LexTokenManager.State,
   --#         Statistics.TableUsage,
   --#         STree.Table,
   --#         TheHeap                    from *,
   --#                                         Anno_Node,
   --#                                         CommandLineData.Content,
   --#                                         ContextManager.Ops.Unit_Stack,
   --#                                         Dictionary.Dict,
   --#                                         LexTokenManager.State,
   --#                                         Scope,
   --#                                         STree.Table,
   --#                                         Task_Sym,
   --#                                         TheHeap &
   --#         ErrorHandler.Error_Context,
   --#         SLI.State,
   --#         SPARK_IO.File_Sys          from Anno_Node,
   --#                                         CommandLineData.Content,
   --#                                         ContextManager.Ops.File_Heap,
   --#                                         ContextManager.Ops.Unit_Heap,
   --#                                         ContextManager.Ops.Unit_Stack,
   --#                                         Dictionary.Dict,
   --#                                         ErrorHandler.Error_Context,
   --#                                         LexTokenManager.State,
   --#                                         Scope,
   --#                                         SLI.State,
   --#                                         SPARK_IO.File_Sys,
   --#                                         STree.Table,
   --#                                         Task_Sym,
   --#                                         TheHeap &
   --#         Valid_Annotation           from *,
   --#                                         Anno_Node,
   --#                                         STree.Table;
   --# pre Syntax_Node_Type (Anno_Node, STree.Table) = SP_Symbols.procedure_annotation;
   --# post STree.Table = STree.Table~;
   is
      Current_Node : STree.SyntaxNode;

      procedure Raise_Error (Node_Pos : in LexTokenManager.Token_Position)
      --# global in     CommandLineData.Content;
      --#        in     Dictionary.Dict;
      --#        in     LexTokenManager.State;
      --#        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,
      --#                                         LexTokenManager.State,
      --#                                         Node_Pos,
      --#                                         SPARK_IO.File_Sys;
      is
      begin
         ErrorHandler.Semantic_Error
           (Err_Num   => 990,
            Reference => ErrorHandler.No_Reference,
            Position  => Node_Pos,
            Id_Str    => LexTokenManager.Null_String);
      end Raise_Error;

   begin -- Process_Annotation
      Current_Node := Child_Node (Current_Node => Anno_Node);
      -- ASSUME Current_Node = moded_global_definition OR dependency_relation OR declare_annotation OR procedure_constraint
      -- to be legal, Current_Node must be a moded_global_definition
      if Syntax_Node_Type (Node => Current_Node) = SP_Symbols.moded_global_definition then
         -- ASSUME Current_Node = moded_global_definition
         Current_Node := Last_Sibling_Of (Start_Node => Current_Node);
         -- ASSUME Current_Node = procedure_constraint
         SystemErrors.RT_Assert
           (C       => Syntax_Node_Type (Node => Current_Node) = SP_Symbols.procedure_constraint,
            Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Current_Node = procedure_constraint in Process_Annotation");
         if Child_Node (Current_Node => Current_Node) = STree.NullNode then
            -- ASSUME Child_Node (Current_Node => Current_Node) = NULL
            Valid_Annotation := True;
            Wf_Subprogram_Annotation
              (Node          => Anno_Node,
               Current_Scope => Scope,
               Subprog_Sym   => Task_Sym,
               First_Seen    => False,
               The_Heap      => TheHeap);
         elsif Syntax_Node_Type (Node => Child_Node (Current_Node => Current_Node)) = SP_Symbols.precondition
           or else Syntax_Node_Type (Node => Child_Node (Current_Node => Current_Node)) = SP_Symbols.postcondition then
            -- ASSUME Child_Node (Current_Node => Current_Node) = precondition OR postcondition
            Raise_Error (Node_Pos => Node_Position (Node => Current_Node));
         else
            SystemErrors.Fatal_Error
              (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
               Msg     => "Expect Child_Node (Current_Node => Current_Node) = precondition OR postcondition OR " &
                 "NULL in Process_Annotation");
         end if;
      elsif Syntax_Node_Type (Node => Current_Node) = SP_Symbols.dependency_relation
        or else Syntax_Node_Type (Node => Current_Node) = SP_Symbols.declare_annotation
        or else Syntax_Node_Type (Node => Current_Node) = SP_Symbols.procedure_constraint then
         Raise_Error (Node_Pos => Node_Position (Node => Current_Node));
      else
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Current_Node = moded_global_definition OR dependency_relation OR " &
              "declare_annotation OR procedure_constraint in Process_Annotation");
      end if;
   end Process_Annotation;

begin -- Wf_Task_Body

   -- set up default "pruning" of tree walk in case errors found below
   Next_Node := STree.NullNode;

   Ident_Node := Child_Node (Current_Node => Node);
   -- ASSUME Ident_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_Task_Body");
   Ident_Str := Node_Lex_String (Node => Ident_Node);

   Task_Sym :=
     Dictionary.LookupItem (Name              => Ident_Str,
                            Scope             => Scope,
                            Context           => Dictionary.ProgramContext,
                            Full_Package_Name => False);

   -- Check that Task_Sym is an task type declared in the spec.  Since we are looking up an identifier
   -- not a full, dotted name we can't find any other entry by mistake so a simple check is all that
   -- is needed.
   if Dictionary.IsTaskType (Task_Sym) then

      Anno_Node := Next_Sibling (Current_Node => Ident_Node);
      -- ASSUME Anno_Node = procedure_annotation
      SystemErrors.RT_Assert
        (C       => Syntax_Node_Type (Node => Anno_Node) = SP_Symbols.procedure_annotation,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Anno_Node = procedure_annotation in Wf_Task_Body");
      Subprogram_Implementation_Node := Next_Sibling (Current_Node => Anno_Node);
      -- ASSUME Subprogram_Implementation_Node = subprogram_implementation
      SystemErrors.RT_Assert
        (C       => Syntax_Node_Type (Node => Subprogram_Implementation_Node) = SP_Symbols.subprogram_implementation,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Subprogram_Implementation_Node = subprogram_implementation in Wf_Task_Body");
      End_Node := Last_Sibling_Of (Start_Node => Child_Node (Current_Node => Subprogram_Implementation_Node));
      -- ASSUME End_Node = designator OR hidden_part
      SystemErrors.RT_Assert
        (C       => Syntax_Node_Type (Node => End_Node) = SP_Symbols.designator
           or else Syntax_Node_Type (Node => End_Node) = SP_Symbols.hidden_part,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect End_Node = designator OR hidden_part in Wf_Task_Body");

      Hidden     := Body_Hidden_Class (Node => Subprogram_Implementation_Node);
      Task_Scope := Dictionary.Set_Visibility (The_Visibility => Dictionary.Local,
                                               The_Unit       => Task_Sym);

      -- see if we are a subunit or an ordinary in-line declaration
      With_Node := Parent_Node (Current_Node => Parent_Node (Current_Node => Node));
      -- ASSUME With_Node = subunit OR abody
      if Syntax_Node_Type (Node => With_Node) = SP_Symbols.abody then
         -- ASSUME With_Node = abody
         In_Subunit := False;
      elsif Syntax_Node_Type (Node => With_Node) = SP_Symbols.subunit then
         -- ASSUME With_Node = subunit
         In_Subunit := True;
         With_Node  :=
           Child_Node
           (Current_Node => Child_Node (Current_Node => Parent_Node (Current_Node => Parent_Node (Current_Node => With_Node))));
         -- ASSUME With_Node = subunit OR with_clause
         if Syntax_Node_Type (Node => With_Node) = SP_Symbols.with_clause then
            With_Node := Parent_Node (Current_Node => With_Node);
            -- ASSUME With_Node = context_clause
            SystemErrors.RT_Assert
              (C       => Syntax_Node_Type (Node => With_Node) = SP_Symbols.context_clause,
               Sys_Err => SystemErrors.Invalid_Syntax_Tree,
               Msg     => "Expect With_Node = context_clause in Wf_Task_Body");
            Wf_Context_Clause (Node     => With_Node,
                               Comp_Sym => Task_Sym,
                               Scope    => Task_Scope);
         elsif Syntax_Node_Type (Node => With_Node) /= SP_Symbols.subunit then
            SystemErrors.Fatal_Error
              (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
               Msg     => "Expect With_Node = subunit OR with_clause in Wf_Task_Body");
         end if;
      else
         In_Subunit := False;
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect With_Node = subunit OR abody in Wf_Task_Body");
      end if;

      -- The task is valid so far, it may be hidden or it may have a real sequence of statements
      -- see if a body has already been declared etc.
      Check_OK_To_Add
        (Type_Sym       => Task_Sym,
         In_Subunit     => In_Subunit,
         Ident_Node_Pos => Node_Position (Node => Ident_Node),
         Ident_Str      => Ident_Str,
         OK_To_Add      => OK_To_Add);
      if OK_To_Add then
         case Hidden is
            when All_Hidden =>
               Dictionary.AddBody
                 (CompilationUnit => Task_Sym,
                  Comp_Unit       => ContextManager.Ops.Current_Unit,
                  TheBody         => Dictionary.Location'(Start_Position => Node_Position (Node => Node),
                                                          End_Position   => Node_Position (Node => Node)),
                  Hidden          => True);
               ErrorHandler.Hidden_Text
                 (Position => Node_Position (Node => End_Node),
                  Unit_Str => Ident_Str,
                  Unit_Typ => SP_Symbols.subprogram_implementation);
            when Not_Hidden =>
               Dictionary.AddBody
                 (CompilationUnit => Task_Sym,
                  Comp_Unit       => ContextManager.Ops.Current_Unit,
                  TheBody         => Dictionary.Location'(Start_Position => Node_Position (Node => Node),
                                                          End_Position   => Node_Position (Node => Node)),
                  Hidden          => False);
            when Handler_Hidden =>
               Dictionary.AddBody
                 (CompilationUnit => Task_Sym,
                  Comp_Unit       => ContextManager.Ops.Current_Unit,
                  TheBody         => Dictionary.Location'(Start_Position => Node_Position (Node => Node),
                                                          End_Position   => Node_Position (Node => Node)),
                  Hidden          => False);
               ErrorHandler.Hidden_Handler
                 (Position => Node_Position (Node => End_Node),
                  Unit_Str => Ident_Str,
                  Unit_Typ => SP_Symbols.task_body);
         end case;

         -- check annotation
         if In_Subunit then
            -- no anno expected
            if not Empty_Annotation (Node => Anno_Node) then
               ErrorHandler.Semantic_Error
                 (Err_Num   => 155,
                  Reference => ErrorHandler.No_Reference,
                  Position  => Node_Position (Node => Anno_Node),
                  Id_Str    => Ident_Str);
            else
               STree.Set_Node_Lex_String (Sym  => Task_Sym,
                                          Node => Ident_Node);
            end if;
         else -- not in subunit, anno may be needed
            if Requires_Second_Annotation (Task_Sym => Task_Sym) then
               if Empty_Annotation (Node => Anno_Node) then
                  ErrorHandler.Semantic_Error
                    (Err_Num   => 154,
                     Reference => ErrorHandler.No_Reference,
                     Position  => Node_Position (Node => Node),
                     Id_Str    => Ident_Str);
               else -- anno present and required
                  STree.Set_Node_Lex_String (Sym  => Task_Sym,
                                             Node => Ident_Node);
                  Process_Annotation
                    (Anno_Node        => Anno_Node,
                     Scope            => Scope,
                     Task_Sym         => Task_Sym,
                     Valid_Annotation => Valid_Annotation);
               end if;
            else -- second anno not required
               if Empty_Annotation (Node => Anno_Node) then
                  STree.Set_Node_Lex_String (Sym  => Task_Sym,
                                             Node => Ident_Node);
               else
                  ErrorHandler.Semantic_Error
                    (Err_Num   => 155,
                     Reference => ErrorHandler.No_Reference,
                     Position  => Node_Position (Node => Anno_Node),
                     Id_Str    => Ident_Str);
               end if;
            end if;
         end if;

         -- set up scope for rest of tree walk
         Scope := Task_Scope;

         -- set up next node for rest of tree walk
         Next_Node := Subprogram_Implementation_Node;
      end if;

      -- Synthesise all from all dependency if necessary
      -- (The checks for whether there was a derives on the spec and not the body or vice versa
      -- are performed in wf_procedure_annotation, called earlier.)
      -- As this is a task body then this must be a refined annotation - there's no other reason to have
      -- an annotation on a task body.
      if Valid_Annotation and then Needs_Synthetic_Dependency (Proc_Task_Or_Entry => Task_Sym) then
         Dependency_Relation.Create_Full_Subprog_Dependency
           (Node_Pos    => Node_Position (Node => Node),
            Subprog_Sym => Task_Sym,
            Abstraction => Dictionary.IsRefined,
            The_Heap    => TheHeap);
      end if;

      -- Check closing identifier if present (i.e. not hidden)
      if Syntax_Node_Type (Node => End_Node) = SP_Symbols.designator
        and then LexTokenManager.Lex_String_Case_Insensitive_Compare
        (Lex_Str1 => Node_Lex_String (Node => Ident_Node),
         Lex_Str2 => Node_Lex_String (Node => Child_Node (Current_Node => End_Node))) /=
        LexTokenManager.Str_Eq then
         ErrorHandler.Semantic_Error
           (Err_Num   => 58,
            Reference => ErrorHandler.No_Reference,
            Position  => Node_Position (Node => End_Node),
            Id_Str    => Node_Lex_String (Node => Ident_Node));
      end if;
   else
      -- not a valid Task
      ErrorHandler.Semantic_Error
        (Err_Num   => 991,
         Reference => ErrorHandler.No_Reference,
         Position  => Node_Position (Node => Ident_Node),
         Id_Str    => Ident_Str);
   end if;

end Wf_Task_Body;
