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

   ------------------------------------------------------------------------
   -- Checks required:
   -- 1.  A protected type of declaration of the same name exists
   -- 2.  No body for it exists already (and, if subunit, a stub does exist)
   -- 3.  The closing identifier matches the initial
   -- 4.  Each operation in the spec has a body
   -- 5.  The second annotations on the operation bodies are refined correctly
   -- 6.  Add body if wellformed
   ------------------------------------------------------------------------

   Ident_Node, Protected_Operation_Item_Node, Closing_Ident_Node, With_Node : STree.SyntaxNode;
   Protected_Type_Sym                                                       : Dictionary.Symbol;
   Ident_Str, Closing_Str                                                   : LexTokenManager.Lex_String;
   In_Subunit, OK_To_Add                                                    : Boolean;
   Protected_Scope                                                          : Dictionary.Scopes;

   procedure Check_OK_To_Add
     (Type_Sym   : in     Dictionary.Symbol;
      In_Subunit : in     Boolean;
      Ident_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_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   => 997,
               Reference => ErrorHandler.No_Reference,
               Position  => Ident_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_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   => 997,
               Reference => ErrorHandler.No_Reference,
               Position  => Ident_Pos,
               Id_Str    => Ident_Str);
         end if;
      end if;
   end Check_OK_To_Add;

begin -- Wf_Protected_Body

   -- Node is set to NullNode if there is an error in the protected body declaration
   -- and so stops the Compunit tree walk at that point.  If the body is ok then we
   -- set the Node to the ProtectedOperationNode so that the main tree walk will
   -- find the various declarations.  We set Node to NullNode here as a default.
   Next_Node := STree.NullNode;

   -- Set up key nodes
   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_Protected_Body");
   Ident_Str := Node_Lex_String (Node => Ident_Node);

   Protected_Operation_Item_Node := Next_Sibling (Current_Node => Ident_Node);
   -- ASSUME Protected_Operation_Item_Node = protected_operation_item
   SystemErrors.RT_Assert
     (C       => Syntax_Node_Type (Node => Protected_Operation_Item_Node) = SP_Symbols.protected_operation_item,
      Sys_Err => SystemErrors.Invalid_Syntax_Tree,
      Msg     => "Expect Protected_Operation_Item_Node = protected_operation_item in Wf_Protected_Body");

   Closing_Ident_Node := Next_Sibling (Current_Node => Protected_Operation_Item_Node);
   -- ASSUME Closing_Ident_Node = identifier
   SystemErrors.RT_Assert
     (C       => Syntax_Node_Type (Node => Closing_Ident_Node) = SP_Symbols.identifier,
      Sys_Err => SystemErrors.Invalid_Syntax_Tree,
      Msg     => "Expect Closing_Ident_Node = identifier in Wf_Protected_Body");
   Closing_Str := Node_Lex_String (Node => Closing_Ident_Node);

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

   -- see if already declared
   if Dictionary.IsType (Protected_Type_Sym) and then Dictionary.IsProtectedTypeMark (Protected_Type_Sym) then
      -- potentially ok
      STree.Set_Node_Lex_String (Sym  => Protected_Type_Sym,
                                 Node => Ident_Node);

      -- enter local scope of newly-added protected body
      Protected_Scope := Dictionary.Set_Visibility (The_Visibility => Dictionary.Local,
                                                    The_Unit       => Protected_Type_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_Protected_Body");
            Wf_Context_Clause (Node     => With_Node,
                               Comp_Sym => Protected_Type_Sym,
                               Scope    => Protected_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_Protected_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_Protected_Body");
      end if;

      -- see if a body has already been declared etc.
      Check_OK_To_Add
        (Type_Sym   => Protected_Type_Sym,
         In_Subunit => In_Subunit,
         Ident_Pos  => Node_Position (Node => Ident_Node),
         Ident_Str  => Ident_Str,
         OK_To_Add  => OK_To_Add);

      if OK_To_Add then
         Dictionary.AddBody
           (CompilationUnit => Protected_Type_Sym,
            Comp_Unit       => ContextManager.Ops.Current_Unit,
            TheBody         => Dictionary.Location'(Start_Position => Node_Position (Node => Ident_Node),
                                                    End_Position   => Node_Position (Node => Ident_Node)),
            Hidden          => False);

         Next_Node := Protected_Operation_Item_Node;
         Scope     := Protected_Scope;
         -- now check each declared operation in main Compunit tree walk
      end if;
   else
      -- either there is no spec to match the body or it not a protected type
      ErrorHandler.Semantic_Error
        (Err_Num   => 998,
         Reference => ErrorHandler.No_Reference,
         Position  => Node_Position (Node => Ident_Node),
         Id_Str    => Ident_Str);
   end if;

   -- Closing identifier check
   if LexTokenManager.Lex_String_Case_Insensitive_Compare (Lex_Str1 => Ident_Str,
                                                           Lex_Str2 => Closing_Str) /=
     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;
end Wf_Protected_Body;
