-------------------------------------------------------------------------------
-- (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 E_Strings;

separate (Sem.Wf_Basic_Declarative_Item.Wf_Basic_Declaration.Wf_Full_Type_Declaration)
procedure Wf_Priority_Pragma (Node     : in     STree.SyntaxNode;
                              Scope    : in     Dictionary.Scopes;
                              The_Heap : in out Heap.HeapRecord) is
   -- Rules:
   --         1.  Priority may appear in Task, PT or main_program
   --         2.  Interrupt_Priority may only appear in PT or task
   --         3.  Only one may appear
   --         4.  Only priority or interrupt_priority is valid here
   --
   -- Grammar rules ensure that we only call this check from locations where
   -- some form of priority pragma is expected.

   The_Region               : Dictionary.Symbol;
   Is_Protected_Type        : Boolean;
   Is_Task_Type             : Boolean;
   Pragma_Kind              : Dictionary.RavenscarPragmasWithValue;
   Id_Node                  : STree.SyntaxNode;
   Argument_Expression_Node : STree.SyntaxNode;
   Value_Rep                : LexTokenManager.Lex_String; -- storage rep of value supplied for pragma
   Compatible               : Boolean;

   function Valid_Location (Is_Protected_Type : Boolean;
                            Is_Task_Type      : Boolean) return Boolean is
   begin
      -- Location must be SYNTACTICALLY correct: we need only worry about things like
      -- Interrupt_Priority in main_program

      -- FOR NOW ALLOW PROTECTED TYPES ONLY - NEEDS EXTENDING FOR TASKS & MAIN PROGRAMS
      return Is_Protected_Type or else Is_Task_Type;
   end Valid_Location;

   ----

   procedure Check_Discriminant (Node  : in STree.SyntaxNode;
                                 Scope : in Dictionary.Scopes)
   --# global in     CommandLineData.Content;
   --#        in     LexTokenManager.State;
   --#        in out Dictionary.Dict;
   --#        in out ErrorHandler.Error_Context;
   --#        in out SPARK_IO.File_Sys;
   --#        in out STree.Table;
   --# derives Dictionary.Dict,
   --#         STree.Table                from CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         Scope,
   --#                                         STree.Table &
   --#         ErrorHandler.Error_Context,
   --#         SPARK_IO.File_Sys          from CommandLineData.Content,
   --#                                         Dictionary.Dict,
   --#                                         ErrorHandler.Error_Context,
   --#                                         LexTokenManager.State,
   --#                                         Node,
   --#                                         Scope,
   --#                                         SPARK_IO.File_Sys,
   --#                                         STree.Table;
   --# pre Syntax_Node_Type (Node, STree.Table) = SP_Symbols.expression;
   --# post STree.Table = STree.Table~;
   is
      Id_Node : STree.SyntaxNode;
      Sym     : Dictionary.Symbol;

      function Is_Chain (Node : STree.SyntaxNode) return Boolean
      --# global in STree.Table;
      --# pre Syntax_Node_Type (Node, STree.Table) = SP_Symbols.identifier;
      is
         Current_Node : STree.SyntaxNode;
         Result       : Boolean := True;
      begin
         Current_Node := Node;
         while Syntax_Node_Type (Node => Current_Node) /= SP_Symbols.expression loop
            --# assert Syntax_Node_Type (Current_Node, STree.Table) /= SP_Symbols.expression;
            Result := Next_Sibling (Current_Node => Current_Node) = STree.NullNode;
            exit when not Result; -- fail
            Current_Node := Parent_Node (Current_Node => Current_Node);
         end loop;
         return Result;
      end Is_Chain;

   begin -- Check_Discriminant

      -- Check that if a discriminant is used, it is not in an expression.
      -- If it is valid mark it as being used to set priority
      Id_Node := Last_Child_Of (Start_Node => Node);
      if Syntax_Node_Type (Node => Id_Node) = SP_Symbols.identifier then
         -- ASSUME Id_Node = identifier
         -- may be a discriminant
         Sym :=
           Dictionary.LookupItem
           (Name              => Node_Lex_String (Id_Node),
            Scope             => Scope,
            Context           => Dictionary.ProgramContext,
            Full_Package_Name => False);
         if Dictionary.IsKnownDiscriminant (Sym) then
            if Is_Chain (Node => Id_Node) then
               STree.Set_Node_Lex_String (Sym  => Sym,
                                          Node => Id_Node);
               Dictionary.SetDiscriminantSetsPriority (Sym);
            else
               ErrorHandler.Semantic_Error (887, ErrorHandler.No_Reference, Node_Position (Id_Node), LexTokenManager.Null_String);
            end if;
         end if;
      end if;
   end Check_Discriminant;

begin -- Wf_Priority_Pragma
   Id_Node := Child_Node (Current_Node => Node);
   -- ASSUME Id_Node = identifier
   SystemErrors.RT_Assert
     (C       => Syntax_Node_Type (Node => Id_Node) = SP_Symbols.identifier,
      Sys_Err => SystemErrors.Invalid_Syntax_Tree,
      Msg     => "Expect Id_Node = identifier in Wf_Priority_Pragma");
   if LexTokenManager.Lex_String_Case_Insensitive_Compare
     (Lex_Str1 => Node_Lex_String (Id_Node),
      Lex_Str2 => LexTokenManager.Priority_Token) =
     LexTokenManager.Str_Eq
     or else LexTokenManager.Lex_String_Case_Insensitive_Compare
     (Lex_Str1 => Node_Lex_String (Id_Node),
      Lex_Str2 => LexTokenManager.Interrupt_Priority_Token) =
     LexTokenManager.Str_Eq then
      -- right sort of pragma
      Argument_Expression_Node := Next_Sibling (Current_Node => Id_Node);
      -- ASSUME Argument_Expression_Node = expression
      SystemErrors.RT_Assert
        (C       => Syntax_Node_Type (Node => Argument_Expression_Node) = SP_Symbols.expression,
         Sys_Err => SystemErrors.Invalid_Syntax_Tree,
         Msg     => "Expect Argument_Expression_Node = expression in Wf_Priority_Pragma");
      The_Region        := Dictionary.GetRegion (Scope);
      Is_Protected_Type := Dictionary.IsType (The_Region) and then Dictionary.IsProtectedTypeMark (The_Region);
      Is_Task_Type      := Dictionary.IsType (The_Region) and then Dictionary.TypeIsTask (The_Region);
      if LexTokenManager.Lex_String_Case_Insensitive_Compare
        (Lex_Str1 => Node_Lex_String (Id_Node),
         Lex_Str2 => LexTokenManager.Priority_Token) =
        LexTokenManager.Str_Eq then
         Pragma_Kind := Dictionary.Priority;
      else
         Pragma_Kind := Dictionary.InterruptPriority;
      end if;
      if Valid_Location (Is_Protected_Type => Is_Protected_Type,
                         Is_Task_Type      => Is_Task_Type) then
         Dictionary.SetTypeHasPragma (The_Region, Pragma_Kind);
         Wf_Priority_Value
           (Node        => Argument_Expression_Node,
            Pragma_Kind => Pragma_Kind,
            Error_Sym   => The_Region,
            Scope       => Scope,
            The_Heap    => The_Heap,
            Value_Rep   => Value_Rep,
            Compatible  => Compatible);
         if Compatible then
            -- return Value_Rep will either be a valid static value or NullString so we can add it safely
            Dictionary.SetTypePragmaValue (The_Region, Pragma_Kind, Value_Rep);
            -- see if argument is a discriminant and, if it is, mark it in the dicitonary as being
            -- used to set priority (so that we can do checks on actuals supplied in subtypes)
            Check_Discriminant (Node  => Argument_Expression_Node,
                                Scope => Scope);
         end if;
      else -- Invalid location
         ErrorHandler.Semantic_Error (879, ErrorHandler.No_Reference, Node_Position (Node), Node_Lex_String (Id_Node));
      end if;
   else -- not pragma [Interrupt_]Priority
      ErrorHandler.Semantic_Error (880, ErrorHandler.No_Reference, Node_Position (Node), LexTokenManager.Null_String);
   end if;
end Wf_Priority_Pragma;
