-------------------------------------------------------------------------------
-- (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_Entry_Body
  (Node           : in     STree.SyntaxNode;
   Scope          : in out Dictionary.Scopes;
   Component_Data : in out ComponentManager.ComponentData;
   Next_Node      :    out STree.SyntaxNode)
is
   -- Actions:
   -- (1) First identifier must be name of (sole) entry declared in spec
   -- (2) Second identifier must be Boolean and must be protected element
   -- (3) If valid, add body, set up a local scope
   -- (4) wff annotation; note FirstSeen is False by definition; however, second anno may not be needed
   -- (5) Allow main tree walk to continue in new scope
   -- (6) Check end designator matches if not hidden

   Entry_Sym, Guard_Sym           : Dictionary.Symbol;
   Entry_Spec_Node                : STree.SyntaxNode;
   Formal_Part_Node               : STree.SyntaxNode;
   Ident_Node                     : STree.SyntaxNode;
   Guard_Node                     : STree.SyntaxNode;
   Anno_Node                      : STree.SyntaxNode;
   Subprogram_Implementation_Node : STree.SyntaxNode;
   Pragma_Rep_Node                : STree.SyntaxNode;
   End_Node                       : STree.SyntaxNode;
   Hidden                         : Hidden_Class;

   -- check whether a second anno is needed, if it is present, and process it if necessary
   procedure Check_Annotation
     (Node_Pos       : in     LexTokenManager.Token_Position;
      Anno_Node      : in     STree.SyntaxNode;
      Entry_Sym      : in     Dictionary.Symbol;
      Scope          : in     Dictionary.Scopes;
      Component_Data : in out ComponentManager.ComponentData)
   --# 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,
   --#         Component_Data,
   --#         LexTokenManager.State,
   --#         STree.Table                from *,
   --#                                         Anno_Node,
   --#                                         CommandLineData.Content,
   --#                                         Component_Data,
   --#                                         ContextManager.Ops.Unit_Stack,
   --#                                         Dictionary.Dict,
   --#                                         Entry_Sym,
   --#                                         LexTokenManager.State,
   --#                                         Scope,
   --#                                         STree.Table,
   --#                                         TheHeap &
   --#         Dictionary.Dict,
   --#         Statistics.TableUsage,
   --#         TheHeap                    from *,
   --#                                         Anno_Node,
   --#                                         CommandLineData.Content,
   --#                                         Component_Data,
   --#                                         ContextManager.Ops.Unit_Stack,
   --#                                         Dictionary.Dict,
   --#                                         Entry_Sym,
   --#                                         LexTokenManager.State,
   --#                                         Node_Pos,
   --#                                         Scope,
   --#                                         STree.Table,
   --#                                         TheHeap &
   --#         ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from Anno_Node,
   --#                                         CommandLineData.Content,
   --#                                         Component_Data,
   --#                                         ContextManager.Ops.File_Heap,
   --#                                         ContextManager.Ops.Unit_Heap,
   --#                                         ContextManager.Ops.Unit_Stack,
   --#                                         Dictionary.Dict,
   --#                                         Entry_Sym,
   --#                                         ErrorHandler.Error_Context,
   --#                                         LexTokenManager.State,
   --#                                         Node_Pos,
   --#                                         Scope,
   --#                                         SLI.State,
   --#                                         SPARK_IO.File_Sys,
   --#                                         STree.Table,
   --#                                         TheHeap &
   --#         SLI.State                  from *,
   --#                                         Anno_Node,
   --#                                         CommandLineData.Content,
   --#                                         Component_Data,
   --#                                         ContextManager.Ops.File_Heap,
   --#                                         ContextManager.Ops.Unit_Heap,
   --#                                         ContextManager.Ops.Unit_Stack,
   --#                                         Dictionary.Dict,
   --#                                         Entry_Sym,
   --#                                         ErrorHandler.Error_Context,
   --#                                         LexTokenManager.State,
   --#                                         Scope,
   --#                                         SPARK_IO.File_Sys,
   --#                                         STree.Table,
   --#                                         TheHeap;
   --# pre Syntax_Node_Type (Anno_Node, STree.Table) = SP_Symbols.procedure_annotation;
   --# post STree.Table = STree.Table~;
   is
      Constraint_Node : STree.SyntaxNode;

      -- A second annotation is only needed if the abstract global anno contains
      -- the implicitly-declared "own variable" that shares the name of the type.
      function Requires_Second_Annotation (Entry_Sym : Dictionary.Symbol) return Boolean
      --# global in Dictionary.Dict;
      is
         Result  : Boolean := False;
         Own_Var : Dictionary.Symbol;
         It      : Dictionary.Iterator;
      begin
         Own_Var := Dictionary.GetProtectedTypeOwnVariable (Dictionary.GetRegion (Dictionary.GetScope (Entry_Sym)));
         It      := Dictionary.FirstGlobalVariable (Dictionary.IsAbstract, Entry_Sym);
         while not Dictionary.IsNullIterator (It) loop
            Result := Dictionary.Variables_Are_Equal (Left_Symbol  => Dictionary.CurrentSymbol (It),
                                                      Right_Symbol => Own_Var);
            exit when Result;
            It := Dictionary.NextSymbol (It);
         end loop;
         return Result;
      end Requires_Second_Annotation;

      function Has_Second_Annotation (Anno_Node : STree.SyntaxNode) return Boolean
      --# global in STree.Table;
      --# pre Syntax_Node_Type (Anno_Node, STree.Table) = SP_Symbols.procedure_annotation;
      is
         Child_Anno_Node : STree.SyntaxNode;
      begin
         Child_Anno_Node := Child_Node (Current_Node => Anno_Node);
         -- ASSUME Child_Anno_Node = moded_global_definition OR dependency_relation OR declare_annotation OR
         --                          procedure_constraint
         SystemErrors.RT_Assert
           (C       => Syntax_Node_Type (Node => Child_Anno_Node) = SP_Symbols.moded_global_definition
              or else Syntax_Node_Type (Node => Child_Anno_Node) = SP_Symbols.dependency_relation
              or else Syntax_Node_Type (Node => Child_Anno_Node) = SP_Symbols.declare_annotation
              or else Syntax_Node_Type (Node => Child_Anno_Node) = SP_Symbols.procedure_constraint,
            Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Child_Anno_Node = moded_global_definition OR dependency_relation OR " &
              "declare_annotation OR procedure_constraint in Has_Second_Annotation");
         return Syntax_Node_Type (Node => Child_Anno_Node) = SP_Symbols.moded_global_definition
           or else Syntax_Node_Type (Node => Child_Anno_Node) = SP_Symbols.dependency_relation;
      end Has_Second_Annotation;

   begin -- Check_Annotation
      if Has_Second_Annotation (Anno_Node => Anno_Node) then
         if Requires_Second_Annotation (Entry_Sym => Entry_Sym) then
            -- wanted and present so process it
            Wf_Subprogram_Annotation
              (Node          => Anno_Node,
               Current_Scope => Scope,
               Subprog_Sym   => Entry_Sym,
               First_Seen    => False,
               The_Heap      => TheHeap);

            -- check for and handle second, concrete constraint
            Constraint_Node := Last_Sibling_Of (Start_Node => Child_Node (Current_Node => Anno_Node));
            -- ASSUME Constraint_Node = procedure_constraint
            SystemErrors.RT_Assert
              (C       => Syntax_Node_Type (Node => Constraint_Node) = SP_Symbols.procedure_constraint,
               Sys_Err => SystemErrors.Invalid_Syntax_Tree,
               Msg     => "Expect Constraint_Node = procedure_constraint in Check_Annotation");
            Wf_Subprogram_Constraint
              (Node           => Constraint_Node,
               Subprogram_Sym => Entry_Sym,
               First_Seen     => False,
               Component_Data => Component_Data,
               The_Heap       => TheHeap);

            -- Synthesise 'all from all' dependency if necessary.
            if Needs_Synthetic_Dependency (Proc_Task_Or_Entry => Entry_Sym) then
               Dependency_Relation.Create_Full_Subprog_Dependency
                 (Node_Pos    => Node_Pos,
                  Subprog_Sym => Entry_Sym,
                  Abstraction => Dictionary.IsRefined,
                  The_Heap    => TheHeap);
            end if;

         else -- anno found but not needed
            ErrorHandler.Semantic_Error
              (Err_Num   => 155,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Anno_Node),
               Id_Str    => Dictionary.GetSimpleName (Entry_Sym));
            Dictionary.SetSubprogramSignatureNotWellformed (Dictionary.IsAbstract, Entry_Sym);
         end if;
      else -- no anno
         if Requires_Second_Annotation (Entry_Sym => Entry_Sym) then
            -- anno missing
            ErrorHandler.Semantic_Error
              (Err_Num   => 87,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Pos,
               Id_Str    => Dictionary.GetSimpleName (Entry_Sym));
            Dictionary.SetSubprogramSignatureNotWellformed (Dictionary.IsRefined, Entry_Sym);
         end if;
      end if;
   end Check_Annotation;

begin -- Wf_Entry_Body
   Entry_Spec_Node := Child_Node (Current_Node => Node);
   -- ASSUME Entry_Spec_Node = entry_specification
   SystemErrors.RT_Assert
     (C       => Syntax_Node_Type (Node => Entry_Spec_Node) = SP_Symbols.entry_specification,
      Sys_Err => SystemErrors.Invalid_Syntax_Tree,
      Msg     => "Expect Entry_Spec_Node = entry_specification in Wf_Entry_Body");
   Ident_Node := Child_Node (Current_Node => Child_Node (Current_Node => Entry_Spec_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_Entry_Body");
   Formal_Part_Node := Next_Sibling (Current_Node => Child_Node (Current_Node => Entry_Spec_Node));
   -- ASSUME Formal_Part_Node = formal_part OR NULL
   Guard_Node := Next_Sibling (Current_Node => Entry_Spec_Node);
   -- ASSUME Guard_Node = identifier
   SystemErrors.RT_Assert
     (C       => Syntax_Node_Type (Node => Guard_Node) = SP_Symbols.identifier,
      Sys_Err => SystemErrors.Invalid_Syntax_Tree,
      Msg     => "Expect Guard_Node = identifier in Wf_Entry_Body");
   Anno_Node := Next_Sibling (Current_Node => Guard_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_Entry_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_Entry_Body");
   Pragma_Rep_Node := Child_Node (Current_Node => Subprogram_Implementation_Node);
   -- ASSUME Pragma_Rep_Node = pragma_rep
   SystemErrors.RT_Assert
     (C       => Syntax_Node_Type (Node => Pragma_Rep_Node) = SP_Symbols.pragma_rep,
      Sys_Err => SystemErrors.Invalid_Syntax_Tree,
      Msg     => "Expect Pragma_Rep_Node = pragma_rep in Wf_Entry_Body");
   End_Node := Last_Sibling_Of (Start_Node => Pragma_Rep_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_Entry_Body");

   Hidden := Body_Hidden_Class (Node => Subprogram_Implementation_Node);

   Entry_Sym :=
     Dictionary.LookupItem
     (Name              => Node_Lex_String (Node => Ident_Node),
      Scope             => Scope,
      Context           => Dictionary.ProgramContext,
      Full_Package_Name => False);
   -- Check that Entry_Sym is an entry 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.IsEntry (Entry_Sym) then
      -- ASSUME Formal_Part_Node = formal_part OR NULL
      if Syntax_Node_Type (Node => Formal_Part_Node) = SP_Symbols.formal_part then
         -- ASSUME Formal_Part_Node = formal_part
         STree.Set_Node_Lex_String (Sym  => Entry_Sym,
                                    Node => Ident_Node);
         Wf_Formal_Part
           (Node             => Formal_Part_Node,
            Current_Scope    => Scope,
            Subprog_Sym      => Entry_Sym,
            First_Occurrence => False,
            Context          => Dictionary.ProgramContext);
      elsif Formal_Part_Node = STree.NullNode then
         -- ASSUME Formal_Part_Node = NULL
         if Dictionary.GetNumberOfSubprogramParameters (Entry_Sym) /= 0 then
            ErrorHandler.Semantic_Error
              (Err_Num   => 152,
               Reference => ErrorHandler.No_Reference,
               Position  => Node_Position (Node => Node),
               Id_Str    => Dictionary.GetSimpleName (Entry_Sym));
         else
            STree.Set_Node_Lex_String (Sym  => Entry_Sym,
                                       Node => Ident_Node);
         end if;
      else
         SystemErrors.Fatal_Error
           (Sys_Err => SystemErrors.Invalid_Syntax_Tree,
            Msg     => "Expect Formal_Part_Node = formal_part OR NULL in Wf_Entry_Body");
      end if;
      -- ok so far
      -- now check that the Guard is valid
      Guard_Sym :=
        Dictionary.LookupItem
        (Name              => Node_Lex_String (Node => Guard_Node),
         Scope             => Scope,
         Context           => Dictionary.ProgramContext,
         Full_Package_Name => False);
      if Dictionary.Is_Variable (Guard_Sym)
        and then Dictionary.IsRefinement (Dictionary.GetProtectedTypeOwnVariable (Dictionary.GetRegion (Scope)), Guard_Sym)
        and then Dictionary.TypeIsBoolean (Dictionary.GetType (Guard_Sym)) then
         -- Guard is a protected element of type Boolean, which is OK

         -- store it for use in VCG
         Dictionary.SetSubprogramEntryBarrier (Entry_Sym, Guard_Sym);
         STree.Set_Node_Lex_String (Sym  => Guard_Sym,
                                    Node => Guard_Node);
         -- The entry is valid so far, it may be hidden or it may have a real sequence of statements
         if Hidden = All_Hidden then
            Dictionary.AddBody
              (CompilationUnit => Entry_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 => Node_Lex_String (Node => Ident_Node),
               Unit_Typ => SP_Symbols.subprogram_implementation);
            Next_Node := STree.NullNode; -- prune tree walk on hidden part
         else
            Dictionary.AddBody
              (CompilationUnit => Entry_Sym,
               Comp_Unit       => ContextManager.Ops.Current_Unit,
               TheBody         => Dictionary.Location'(Start_Position => Node_Position (Node => Node),
                                                       End_Position   => Node_Position (Node => Node)),
               Hidden          => False);

            Check_Annotation
              (Node_Pos       => Node_Position (Node => Node),
               Anno_Node      => Anno_Node,
               Entry_Sym      => Entry_Sym,
               Scope          => Scope,
               Component_Data => Component_Data);

            if Hidden = Handler_Hidden then
               ErrorHandler.Hidden_Handler
                 (Position => Node_Position (Node => End_Node),
                  Unit_Str => Node_Lex_String (Node => Ident_Node),
                  Unit_Typ => SP_Symbols.entry_body);
            end if;

            -- set up scope for rest of tree walk
            Scope := Dictionary.Set_Visibility (The_Visibility => Dictionary.Local,
                                                The_Unit       => Entry_Sym);

            -- set up next node for rest of tree walk
            Next_Node := Subprogram_Implementation_Node;
         end if;
      else
         -- Guard is not a protected element or is not Boolean
         ErrorHandler.Semantic_Error
           (Err_Num   => 994,
            Reference => ErrorHandler.No_Reference,
            Position  => Node_Position (Node => Guard_Node),
            Id_Str    => Node_Lex_String (Node => Guard_Node));
         Next_Node := STree.NullNode; -- prune tree walk on error

      end if;
   else
      -- not a valid Entry
      ErrorHandler.Semantic_Error
        (Err_Num   => 995,
         Reference => ErrorHandler.No_Reference,
         Position  => Node_Position (Node => Ident_Node),
         Id_Str    => Node_Lex_String (Node => Ident_Node));
      Next_Node := STree.NullNode; -- prune tree walk on error
   end if;

   -- check closing identifier
   if Syntax_Node_Type (Node => End_Node) = SP_Symbols.designator then
      if 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;
   end if;
end Wf_Entry_Body;
