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

with SLI;

separate (Sem.Wf_Basic_Declarative_Item.Wf_Basic_Declaration.Wf_Full_Type_Declaration)
procedure Wf_Task_Type_Declaration (Node     : in     STree.SyntaxNode;
                                    Scope    : in     Dictionary.Scopes;
                                    The_Heap : in out Heap.HeapRecord) is
   Task_Type_Sym      : Dictionary.Symbol;
   Task_Scope         : Dictionary.Scopes;
   Sym                : Dictionary.Symbol;
   Ident_Node         : STree.SyntaxNode;
   Anno_Node          : STree.SyntaxNode;
   Closing_Ident_Node : STree.SyntaxNode;
   Discriminant_Node  : STree.SyntaxNode;
   Ident_Str          : LexTokenManager.Lex_String;
   Pragma_Node        : STree.SyntaxNode;
   Global_Error       : Boolean;
   Derives_Error      : Boolean := False;

   function Get_Discriminant_Node (Task_Type_Declaration_Node : STree.SyntaxNode) return STree.SyntaxNode
   --# global in STree.Table;
   --# pre Syntax_Node_Type (Task_Type_Declaration_Node, STree.Table) = SP_Symbols.task_type_declaration;
   --# return Node => (Syntax_Node_Type (Node, STree.Table) = SP_Symbols.known_discriminant_part or
   --#                   Syntax_Node_Type (Node, STree.Table) = SP_Symbols.task_type_annotation);
   is
      Result : STree.SyntaxNode;
   begin
      Result := Next_Sibling (Current_Node => Child_Node (Current_Node => Task_Type_Declaration_Node));
      -- ASSUME Result = known_discriminant_part OR task_type_annotation
      SystemErrors.RT_Assert
        (C       => Syntax_Node_Type (Node => Result) = SP_Symbols.known_discriminant_part
           or else Syntax_Node_Type (Node => Result) = SP_Symbols.task_type_annotation,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Result = known_discriminant_part OR task_type_annotation in Get_Discriminant_Node");
      return Result;
   end Get_Discriminant_Node;

   ----------

   function Get_Anno_Node (Task_Type_Declaration_Node : STree.SyntaxNode) return STree.SyntaxNode
   --# global in STree.Table;
   --# pre Syntax_Node_Type (Task_Type_Declaration_Node, STree.Table) = SP_Symbols.task_type_declaration;
   --# return Node => Syntax_Node_Type (Node, STree.Table) = SP_Symbols.moded_global_definition;
   is
      Result : STree.SyntaxNode;
   begin
      Result := Get_Discriminant_Node (Task_Type_Declaration_Node => Task_Type_Declaration_Node);
      -- ASSUME Result = known_discriminant_part OR task_type_annotation
      if Syntax_Node_Type (Node => Result) = SP_Symbols.known_discriminant_part then
         -- ASSUME Result = known_discriminant_part
         Result := Next_Sibling (Current_Node => Result);
      end if;
      -- ASSUME Result = task_type_annotation
      SystemErrors.RT_Assert
        (C       => Syntax_Node_Type (Node => Result) = SP_Symbols.task_type_annotation,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Result = task_type_annotation in Get_Anno_Node");
      Result := Child_Node (Current_Node => Result);
      -- ASSUME Result = moded_global_definition
      SystemErrors.RT_Assert
        (C       => Syntax_Node_Type (Node => Result) = SP_Symbols.moded_global_definition,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Result = moded_global_definition in Get_Anno_Node");
      return Result;
   end Get_Anno_Node;

   ----------

   function Get_Task_Definition_Node (Task_Type_Declaration_Node : STree.SyntaxNode) return STree.SyntaxNode
   --# global in STree.Table;
   --# pre Syntax_Node_Type (Task_Type_Declaration_Node, STree.Table) = SP_Symbols.task_type_declaration;
   --# return Node => Syntax_Node_Type (Node, STree.Table) = SP_Symbols.task_definition;
   is
      Result : STree.SyntaxNode;
   begin
      Result := Last_Sibling_Of (Start_Node => Child_Node (Current_Node => Task_Type_Declaration_Node));
      -- ASSUME Result = task_definition
      SystemErrors.RT_Assert
        (C       => Syntax_Node_Type (Node => Result) = SP_Symbols.task_definition,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Result = task_definition in Get_Task_Definition_Node");
      return Result;
   end Get_Task_Definition_Node;

   ----------

   function Get_Closing_Ident_Node (Task_Type_Declaration_Node : STree.SyntaxNode) return STree.SyntaxNode
   --# global in STree.Table;
   --# pre Syntax_Node_Type (Task_Type_Declaration_Node, STree.Table) = SP_Symbols.task_type_declaration;
   --# return Node => Syntax_Node_Type (Node, STree.Table) = SP_Symbols.identifier;
   is
      Result : STree.SyntaxNode;
   begin
      Result :=
        Next_Sibling
        (Current_Node => Child_Node (Current_Node => Get_Task_Definition_Node (Task_Type_Declaration_Node => Task_Type_Declaration_Node)));
      -- ASSUME Result = identifier
      SystemErrors.RT_Assert
        (C       => Syntax_Node_Type (Node => Result) = SP_Symbols.identifier,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Result = identifier in Get_Closing_Ident_Node");
      return Result;
   end Get_Closing_Ident_Node;

   ----------

   function Get_Priority_Pragma_Node (Task_Type_Declaration_Node : STree.SyntaxNode) return STree.SyntaxNode
   --# global in STree.Table;
   --# pre Syntax_Node_Type (Task_Type_Declaration_Node, STree.Table) = SP_Symbols.task_type_declaration;
   --# return Node => Syntax_Node_Type (Node, STree.Table) = SP_Symbols.priority_pragma;
   is
      Result : STree.SyntaxNode;
   begin
      Result :=
        Parent_Node
        (Current_Node => Last_Child_Of (Start_Node => Get_Task_Definition_Node (Task_Type_Declaration_Node => Task_Type_Declaration_Node)));
      -- ASSUME Result = priority_pragma
      SystemErrors.RT_Assert
        (C       => Syntax_Node_Type (Node => Result) = SP_Symbols.priority_pragma,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Result = priority_pragma in Get_Priority_Pragma_Node");
      return Result;
   end Get_Priority_Pragma_Node;

   ----------

   procedure Check_Pragma_Validity (End_Node_Position : in LexTokenManager.Token_Position;
                                    Task_Type_Sym     : in Dictionary.Symbol)
   --# 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,
   --#                                         End_Node_Position,
   --#                                         ErrorHandler.Error_Context,
   --#                                         LexTokenManager.State,
   --#                                         SPARK_IO.File_Sys,
   --#                                         Task_Type_Sym;
   is
      Priority_Found, Interrupt_Priority_Found : Boolean;
   begin
      Priority_Found           := Dictionary.GetTypeHasPragma (Task_Type_Sym, Dictionary.Priority);
      Interrupt_Priority_Found := Dictionary.GetTypeHasPragma (Task_Type_Sym, Dictionary.InterruptPriority);

      -- There must be either Priority or Interrupt_Priority
      if not (Priority_Found or else Interrupt_Priority_Found) then
         ErrorHandler.Semantic_Error
           (Err_Num   => 876,
            Reference => ErrorHandler.No_Reference,
            Position  => End_Node_Position,
            Id_Str    => LexTokenManager.Null_String);
      end if;
   end Check_Pragma_Validity;

begin -- Wf_Task_Type_Declaration
   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_Type_Declaration");
   Ident_Str         := Node_Lex_String (Node => Ident_Node);
   Discriminant_Node := Get_Discriminant_Node (Task_Type_Declaration_Node => Node);
   Sym               :=
     Dictionary.LookupItem (Name              => Ident_Str,
                            Scope             => Scope,
                            Context           => Dictionary.ProofContext,
                            Full_Package_Name => False);

   if Dictionary.Is_Null_Symbol (Sym)
     or else (Dictionary.IsTypeMark (Sym)
                and then Dictionary.TypeIsAnnounced (TheType => Sym)
                and then not Dictionary.Is_Declared (Item => Sym)) then
      if not Dictionary.Is_Null_Symbol (Sym) then
         STree.Set_Node_Lex_String (Sym  => Sym,
                                    Node => Ident_Node);
      end if;
      Dictionary.Add_Task_Type
        (Name        => Ident_Str,
         Comp_Unit   => ContextManager.Ops.Current_Unit,
         Declaration => Dictionary.Location'(Start_Position => Node_Position (Node => Node),
                                             End_Position   => Node_Position (Node => Node)),
         Scope       => Scope,
         Context     => Dictionary.ProgramContext,
         Constrained => (Syntax_Node_Type (Node => Discriminant_Node) /= SP_Symbols.known_discriminant_part),
         The_Type    => Task_Type_Sym);
      STree.Add_Node_Symbol (Node => Ident_Node,
                             Sym  => Task_Type_Sym);
      if ErrorHandler.Generate_SLI then
         SLI.Generate_Xref_Symbol
           (Comp_Unit      => ContextManager.Ops.Current_Unit,
            Parse_Tree     => Ident_Node,
            Symbol         => Task_Type_Sym,
            Is_Declaration => True);
      end if;
      Task_Scope := Dictionary.Set_Visibility (The_Visibility => Dictionary.Visible,
                                               The_Unit       => Task_Type_Sym);

      -- wff discriminants here
      if Syntax_Node_Type (Node => Discriminant_Node) = SP_Symbols.known_discriminant_part then
         -- ASSUME Discriminant_Node = known_discriminant_part
         Wf_Known_Discriminant_Part (Node               => Discriminant_Node,
                                     Protected_Type_Sym => Task_Type_Sym,
                                     Scope              => Scope);
      end if;

      --# assert STree.Table = STree.Table~ and
      --#   Syntax_Node_Type (Node, STree.Table) = SP_Symbols.task_type_declaration;

      -- handle annotation
      -- global
      Anno_Node := Get_Anno_Node (Task_Type_Declaration_Node => Node);
      Wf_Global_Definition
        (Node          => Anno_Node,
         Scope         => Scope,
         Subprog_Sym   => Task_Type_Sym,
         First_Seen    => True,
         Sem_Err_Found => Global_Error);

      -- In data-flow mode the full dependency is always synthesised from the moded globals
      if CommandLineData.Content.Flow_Option = CommandLineData.Data_Flow then
         Dependency_Relation.Create_Full_Subprog_Dependency
           (Node_Pos    => Node_Position (Node => Node),
            Subprog_Sym => Task_Type_Sym,
            Abstraction => Dictionary.IsAbstract,
            The_Heap    => The_Heap);
      end if;

      -- derives
      Anno_Node := Next_Sibling (Current_Node => Anno_Node);
      -- ASSUME Anno_Node = dependency_relation OR declare_annotation OR NULL
      if Syntax_Node_Type (Node => Anno_Node) = SP_Symbols.dependency_relation then
         -- ASSUME Anno_Node = dependency_relation
         Dependency_Relation.Wf_Dependency_Relation
           (Node         => Anno_Node,
            Scope        => Task_Scope,
            Subprog_Sym  => Task_Type_Sym,
            First_Seen   => True,
            Glob_Def_Err => Global_Error,
            The_Heap     => The_Heap);
         Anno_Node := Next_Sibling (Current_Node => Anno_Node);
      elsif Anno_Node = STree.NullNode or else Syntax_Node_Type (Node => Anno_Node) = SP_Symbols.declare_annotation then
         -- ASSUME Anno_Node = declare_annotation OR NULL
         -- No derives annotation
         if CommandLineData.Content.Flow_Option = CommandLineData.Info_Flow then
            -- In information-flow mode this is a semantic error - there must always be a derives annotation
            Derives_Error := True;
            ErrorHandler.Semantic_Error
              (Err_Num   => 501,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Get_Anno_Node (Task_Type_Declaration_Node => Node)),
               Id_Str    => LexTokenManager.Null_String);
         elsif CommandLineData.Content.Flow_Option = CommandLineData.Auto_Flow then
            -- In auto-flow mode, synthesise the dependency from the moded globals.
            -- It seems obvious to also check for data-flow mode here and remove
            -- the earlier call to CreateFullSubProgDependency but that won't work.
            Dependency_Relation.Create_Full_Subprog_Dependency
              (Node_Pos    => Node_Position (Node => Node),
               Subprog_Sym => Task_Type_Sym,
               Abstraction => Dictionary.IsAbstract,
               The_Heap    => The_Heap);
         end if;
      else
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Anno_Node = dependency_relation OR declare_annotation OR NULL in Wf_Task_Type_Declaration");
      end if;

      -- ASSUME Anno_Node = declare_annotation OR NULL
      if Syntax_Node_Type (Node => Anno_Node) = SP_Symbols.declare_annotation then
         -- ASSUME Anno_Node = declare_annotation
         Wf_Declare_Annotation
           (Node         => Anno_Node,
            Scope        => Task_Scope,
            Task_Or_Proc => Task_Type_Sym,
            First_Seen   => True,
            The_Heap     => The_Heap);
      elsif Anno_Node /= STree.NullNode then
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Anno_Node = declare_annotation OR NULL in Wf_Task_Type_Declaration");
      end if;

      -- if there are errors in the task type signature then mark it as malformed
      if Global_Error or else Derives_Error then
         Dictionary.SetSubprogramSignatureNotWellformed (Dictionary.IsAbstract, Task_Type_Sym);
      end if;

      --# assert STree.Table = STree.Table~ and
      --#   Syntax_Node_Type (Node, STree.Table) = SP_Symbols.task_type_declaration;

      Pragma_Node := Get_Priority_Pragma_Node (Task_Type_Declaration_Node => Node);

      -- deal with priority pragma which should be first
      Wf_Priority_Pragma (Node     => Pragma_Node,
                          Scope    => Task_Scope,
                          The_Heap => The_Heap);

      -- check any other pragmas
      loop
         Pragma_Node := Next_Sibling (Current_Node => Parent_Node (Current_Node => Pragma_Node));
         -- ASSUME Pragma_Node = apragma OR identifier
         SystemErrors.RT_Assert
           (C       => Syntax_Node_Type (Node => Pragma_Node) = SP_Symbols.apragma
              or else Syntax_Node_Type (Node => Pragma_Node) = SP_Symbols.identifier,
            Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Pragma_Node = apragma OR identifier in Wf_Task_Type_Declaration");
         exit when Syntax_Node_Type (Node => Pragma_Node) = SP_Symbols.identifier;
         --# assert STree.Table = STree.Table~ and
         --#   Syntax_Node_Type (Node, STree.Table) = SP_Symbols.task_type_declaration and
         --#   Syntax_Node_Type (Pragma_Node, STree.Table) = SP_Symbols.apragma;
         Wf_Pragma (Node  => Pragma_Node,
                    Scope => Task_Scope);
      end loop;

      -- closing identifier must match initial
      Closing_Ident_Node := Get_Closing_Ident_Node (Task_Type_Declaration_Node => Node);
      if LexTokenManager.Lex_String_Case_Insensitive_Compare
        (Lex_Str1 => Ident_Str,
         Lex_Str2 => Node_Lex_String (Node => Closing_Ident_Node)) /=
        LexTokenManager.Str_Eq then
         ErrorHandler.Semantic_Error
           (Err_Num   => 58,
            Reference => ErrorHandler.No_Reference,
            Position  => Node_Position (Node => Closing_Ident_Node),
            Id_Str    => Ident_Str);
      end if;
      Check_Pragma_Validity (End_Node_Position => Node_Position (Node => Closing_Ident_Node),
                             Task_Type_Sym     => Task_Type_Sym);
   else -- illegal redeclaration
      ErrorHandler.Semantic_Error
        (Err_Num   => 10,
         Reference => ErrorHandler.No_Reference,
         Position  => Node_Position (Node => Ident_Node),
         Id_Str    => Ident_Str);
   end if;
end Wf_Task_Type_Declaration;
