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

package body Sparklalr_Level
--# own State is Init_Lev,
--#              Level,
--#              Term_Lev;
is

   type Level_T is array (Sparklalr_Common.Production_Index) of Lev_Struct;
   type Term_Lev_T is array (Sparklalr_Common.Term_Range) of Lev_Struct;

   Init_Lev : Lev_Struct;
   Level    : Level_T;
   Term_Lev : Term_Lev_T;

   -- Local procedures/functions
   procedure Assign (L :    out Lev_Struct;
                     M : in     Lev_Struct)
   -- ASSIGNS PRECEDENCE
   --# derives L from M;
   is
   begin
      L := Lev_Struct'(Assoc       => M.Assoc,
                       Action_Flag => M.Action_Flag,
                       Lev         => M.Lev);
   end Assign;
   -- End local procedures/functions

   procedure Initiate (L : out Lev_Struct)
   -- INITIATES PRECEDENCE
   --# global in Init_Lev;
   --# derives L from Init_Lev;
   is
   begin
      Assign (L, Init_Lev);
   end Initiate;

   procedure Initialise
   --# global out Init_Lev;
   --#        out Level;
   --#        out Term_Lev;
   --# derives Init_Lev,
   --#         Level,
   --#         Term_Lev from ;
   is
   begin
      Init_Lev := Lev_Struct'(Assoc       => Nodef,
                              Action_Flag => False,
                              Lev         => 0);
      Level    := Level_T'(others => Init_Lev);
      Term_Lev := Term_Lev_T'(others => Init_Lev);
   end Initialise;

   procedure Assign_Level (I : in Sparklalr_Common.Production_Index;
                           M : in Lev_Struct)
   --# global in out Level;
   --# derives Level from *,
   --#                    I,
   --#                    M;
   is
   begin
      Assign (Level (I), M);
   end Assign_Level;

   procedure Assign_Term_Lev (I : in Sparklalr_Common.Term_Range;
                              M : in Lev_Struct)
   --# global in out Term_Lev;
   --# derives Term_Lev from *,
   --#                       I,
   --#                       M;
   is
   begin
      Assign (Term_Lev (I), M);
   end Assign_Term_Lev;

   procedure Initiate_Level (I : in Sparklalr_Common.Production_Index)
   --# global in     Init_Lev;
   --#        in out Level;
   --# derives Level from *,
   --#                    I,
   --#                    Init_Lev;
   is
   begin
      Initiate (Level (I));
   end Initiate_Level;

   procedure Initiate_Term_Lev (I : in Sparklalr_Common.Term_Range)
   --# global in     Init_Lev;
   --#        in out Term_Lev;
   --# derives Term_Lev from *,
   --#                       I,
   --#                       Init_Lev;
   is
   begin
      Initiate (Term_Lev (I));
   end Initiate_Term_Lev;

   procedure Associativity (Symb        : in     Sparklalr_Symbol.Symbol;
                            Current_Lev : in out Lev_Struct) is
   begin
      case Symb is
         when Sparklalr_Symbol.Left =>
            Current_Lev.Assoc := Leftass;
         when Sparklalr_Symbol.Right =>
            Current_Lev.Assoc := Rightass;
         when Sparklalr_Symbol.Non =>
            Current_Lev.Assoc := Nonass;
         when others =>
            null;
      end case;
      Current_Lev.Lev := Current_Lev.Lev + 1;
   end Associativity;

   procedure Precedence
     (Is_Shred          : in     Boolean;
      A, B              : in     Integer;
      Term_Index        : in     Integer;
      Report            :    out Boolean;
      Result_Precedence :    out Integer)
   -- PRECEDENCE RETURNS A REPORT USED IN DETERMINING  WHAT
   -- WHAT ACTION TO TAKE WHEN A PARSING CONFLICT ARISES
   --# global in Level;
   --#        in Term_Lev;
   --# derives Report,
   --#         Result_Precedence from A,
   --#                                B,
   --#                                Is_Shred,
   --#                                Level,
   --#                                Term_Index,
   --#                                Term_Lev;
   is
      P, Q : Lev_Struct;
   begin
      Report := False;
      case Is_Shred is
         when True =>
            P := Term_Lev (Term_Index);
            Q := Level (A);
            if (P.Lev = 0) or else (Q.Assoc = Nodef) then
               Report            := True;
               Result_Precedence := 1;
            else
               if P.Lev = Q.Lev then
                  case P.Assoc is
                     when Leftass =>
                        Result_Precedence := 2;
                     when Rightass =>
                        Result_Precedence := 1;
                     when Nonass =>
                        Result_Precedence := 5;
                     when Nodef =>
                        Report            := True;
                        Result_Precedence := 1;
                  end case;
               else
                  if P.Lev > Q.Lev then
                     Result_Precedence := 2;
                  else
                     Result_Precedence := 1;
                  end if;
               end if;
            end if;
         when False =>
            P := Level (A);
            Q := Level (B);
            if (P.Assoc = Nodef) and then (Q.Assoc = Nodef) then
               Report := True;
               if A > B then
                  Result_Precedence := 4;
               else
                  Result_Precedence := 3;
               end if;
            else
               if P.Lev > Q.Lev then
                  Result_Precedence := 3;
               else
                  if P.Lev < Q.Lev then
                     Result_Precedence := 4;
                  else
                     if A > B then
                        Result_Precedence := 4;
                     else
                        Result_Precedence := 3;
                     end if;
                  end if;
               end if;
            end if;
      end case;
   end Precedence;

   function Get_Term_Lev (I : in Sparklalr_Common.Term_Range) return Lev_Struct
   --# global in Term_Lev;
   is
   begin
      return Term_Lev (I);
   end Get_Term_Lev;

   procedure Set_Level_Action_Flag (I     : in Sparklalr_Common.Production_Index;
                                    Value : in Boolean)
   --# global in out Level;
   --# derives Level from *,
   --#                    I,
   --#                    Value;
   is
   begin
      Level (I).Action_Flag := Value;
   end Set_Level_Action_Flag;

end Sparklalr_Level;
