-------------------------------------------------------------------------------
--
--  This file is part of AdaBrowse.
--
-- <STRONG>Copyright (c) 2002 by Thomas Wolf.</STRONG>
-- <BLOCKQUOTE>
--    AdaBrowse is free software; you can redistribute it and/or modify it
--    under the terms of the  GNU General Public License as published by the
--    Free Software  Foundation; either version 2, or (at your option) any
--    later version. AdaBrowse is distributed in the hope that it will be
--    useful, but <EM>without any warranty</EM>; without even the implied
--    warranty of <EM>merchantability or fitness for a particular purpose.</EM>
--    See the GNU General Public License for  more details. You should have
--    received a copy of the GNU General Public License with this distribution,
--    see file "<A HREF="GPL.txt">GPL.txt</A>". If not, write to the Free
--    Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307,
--    USA.
-- </BLOCKQUOTE>
--
-- <DL><DT><STRONG>
-- Author:</STRONG><DD>
--   Thomas Wolf  (TW)
--   <ADDRESS><A HREF="mailto:twolf@acm.org">twolf@acm.org</A></ADDRESS></DL>
--
-- <DL><DT><STRONG>
-- Purpose:</STRONG><DD>
--   Parsing and evaluation of expressions; storage of expressions.</DL>
--
-- <!--
-- Revision History
--
--   18-JUN-2003   TW  Initial version.
--   08-JUL-2003   TW  Added the "package" predefined predicate and the @
--                     prefix operator.
-- -->
-------------------------------------------------------------------------------

pragma License (GPL);

with Ada.Characters.Handling;
with Ada.Exceptions;
with Ada.Unchecked_Deallocation;

with AD.Predicates;

with GAL.ADT.Hash_Tables;
with GAL.Storage.Standard;
with GAL.Support.Hashing;

with Util.Strings;

pragma Elaborate_All (GAL.ADT.Hash_Tables);

package body AD.Expressions is

   package ACH renames Ada.Characters.Handling;
   package ASU renames Ada.Strings.Unbounded;

   package Hashing is
      new GAL.ADT.Hash_Tables
            (Key_Type => String,
             Item     => Expression,
             Memory   => GAL.Storage.Standard,
             Hash     => GAL.Support.Hashing.Hash_Case_Insensitive,
             "="      => Util.Strings.Equal);
   --  Initial_Size is the default (23);

   Macros : Hashing.Hash_Table;
   Predef : Hashing.Hash_Table;

   function Is_Nil
     (Expr : in Expression)
     return Boolean
   is
   begin
      return Expr.Ptr = null;
   end Is_Nil;

   function Is_Boolean
     (Expr : in Expression)
     return Boolean
   is
   begin
      return Expr.Ptr /= null and then Expr.Ptr.all in Bool_Exp'Class;
   end Is_Boolean;

   function Parse
     (Text : in String)
     return Expression
   is

      Curr : Natural := Text'First;
      --  Current position in 'Text'.

      procedure Error
        (Msg : in String)
      is
      begin
         Ada.Exceptions.Raise_Exception (Parse_Error'Identity, Msg);
      end Error;

      procedure Get
        (Name  : in     String;
         Expr  :    out Expression;
         Found :    out Boolean)
      is
      begin
         Found := True;
         begin
            Expr := Hashing.Retrieve (Predef, Name);
         exception
            when Hashing.Not_Found =>
               begin
                  Expr := Hashing.Retrieve (Macros, Name);
               exception
                  when Hashing.Container_Empty |
                       Hashing.Not_Found =>
                     Found := False;
                     Expr  := Nil_Expression;
               end;
         end;
      end Get;

      procedure Skip
        (May_Fail : in Boolean := False)
      is
         Start : constant Natural := Curr;
      begin
         Curr := Util.Strings.Next_Non_Blank (Text (Curr .. Text'Last));
         if not May_Fail and then Curr = 0 then
            Error
              ("Unexpected end of expression: " & Text (Start .. Text'Last));
         end if;
         if Curr = 0 then Curr := Text'Last + 1; end if;
      end Skip;

      function Create
        (Op          : in Operator;
         Left, Right : in Expression;
         Pos         : in Natural)
        return Expression
      is
         --  Combine expressions, including semantic checks!

         function Create
           (Op          : in Operator;
            Left, Right : in Expression;
            Pos         : in Natural)
           return Expression_Ptr
         is
         begin
            case Op is
               when Op_Not =>
                  if not Is_Nil (Right) then
                     Ada.Exceptions.Raise_Exception
                       (Program_Error'Identity,
                        "Error in expression parser: binary 'not' operator?!");
                  end if;
                  if Left.Ptr.all not in Bool_Exp'Class then
                     Error ("'not' needs boolean argument: " &
                            Text (Pos .. Text'Last));
                  end if;
                  return new Not_Exp'(Exp with Arg => Left);
               when Op_Or | Op_Xor | Op_And =>
                  if Left.Ptr.all not in Bool_Exp'Class or else
                     Right.Ptr.all not in Bool_Exp'Class
                  then
                     Error ("boolean operator with string argument: " &
                            Text (Pos .. Text'Last));
                  end if;
                  if Op = Op_Or then
                     return
                       new Or_Exp'(Exp with Left => Left, Right => Right);
                  elsif Op = Op_Xor then
                     return
                       new Xor_Exp'(Exp with Left => Left, Right => Right);
                  else
                     return
                       new And_Exp'(Exp with Left => Left, Right => Right);
                  end if;
               when Op_Eq | Op_Neq =>
                  if Left.Ptr.all in Bool_Exp'Class xor
                     Right.Ptr.all in Bool_Exp'Class
                  then
                     Error ("equality operator with mixed arguments: " &
                            Text (Pos .. Text'Last));
                  end if;
                  declare
                     Expr : constant Expression_Ptr :=
                       new Eq_Exp'(Exp with Left => Left, Right => Right);
                  begin
                     if Op = Op_Neq then
                        return
                          new Not_Exp'
                            (Exp with
                               Arg => (Ada.Finalization.Controlled with
                                         Ptr => Expr));
                     else
                        return Expr;
                     end if;
                  end;
               when Op_Concat | Op_Prefix =>
                  if Left.Ptr.all not in String_Exp'Class or else
                     Right.Ptr.all not in String_Exp'Class
                  then
                     Error ("'&' and '@' need string arguments: " &
                            Text (Pos .. Text'Last));
                  end if;
                  if Op = Op_Concat then
                     return
                       new Concat_Exp'(Exp with Left => Left, Right => Right);
                  else
                     return
                       new Prefix_Exp'(Exp with Left => Left, Right => Right);
                  end if;
               when others =>
                  Ada.Exceptions.Raise_Exception
                    (Program_Error'Identity,
                     "Error in expression parser (Op_None in Create)");
            end case;
            return null;
         end Create;

      begin
         return
           (Ada.Finalization.Controlled with
              Ptr => Create (Op, Left, Right, Pos));
      end Create;

      Precedence : constant array (Operator) of Natural :=
        (Op_Not | Op_Concat => 1,
         Op_Prefix          => 2,
         Op_Eq | Op_Neq     => 3,
         Op_And             => 4,
         Op_Or | Op_Xor     => 5,
         Op_None            => 6);

      Lowest_Precedence  : constant Natural := Precedence (Op_None);

      Last_Op : Operator := Op_None;
      --  An operator precedence parser needs a one-token look-ahead. We could
      --  have implemented this by setting 'Curr' at the beginning of the last
      --  operator and later rescanning, but that would incur a higher
      --  overhead.

      Last_Pos : Natural := 0;
      --  But we still keep the position of the last operator for error
      --  reporting purposes!

      function Parse_Operator
        return Operator
      is
         --  Binary operators only!
      begin
         Skip (May_Fail => True);
         --  If nothing follows, we've hit the end of the expression.
         if Curr > Text'Last then return Op_None; end if;
         if Text (Curr) = ')' or else Text (Curr) = ';' then
            return Op_None;
         elsif Text (Curr) = '=' then
            Curr := Curr + 1;
            return Op_Eq;
         elsif Text (Curr) = '&' then
            Curr := Curr + 1;
            return Op_Concat;
         elsif Text (Curr) = '@' then
            Curr := Curr + 1;
            return Op_Prefix;
         elsif Curr < Text'Last and then
               Text (Curr .. Curr + 1) = "/=" then
            Curr := Curr + 2;
            return Op_Neq;
         else
            declare
               Found : Boolean;
               Expr  : Expression;
               I     : constant Natural :=
                 Util.Strings.Identifier (Text (Curr .. Text'Last));
               Op    : Operator := Op_None;
            begin
               if I = 0 then
                  Error ("Operator missing: " &
                         Text (Curr .. Text'Last));
               end if;
               Get (Text (Curr .. I), Expr, Found);
               if not Found then
                  Error ("Unknown function """ & Text (Curr .. I) & '"');
               end if;
               if Expr.Ptr.all in Predefined'Class then
                  Op := Predefined (Expr.Ptr.all).Op;
               else
                  Error ("Operator missing: " &
                         Text (Curr .. Text'Last));
               end if;
               if Op = Op_Not then
                  Error
                    ("'not' not allowed here: " &
                     Text (Curr .. Text'Last));
               end if;
               Curr := I + 1;
               return Op;
            end;
         end if;
      end Parse_Operator;

      function Parse_Expr
        (Max_Op : in Natural := Lowest_Precedence)
        return Expression
      is

         function Parse_Term
           return Expression
         is

            function Parse_Factor
              return Expression
            is
               Expr : Expression;
            begin
               Last_Op := Op_None;
               Skip;
               if Text (Curr) = '(' then
                  declare
                     Start : constant Natural := Curr;
                  begin
                     Expr := Parse_Expr;
                     Last_Op := Op_None;
                     Skip (May_Fail => True);
                     --  We allow failing because we want to emit a more
                     --  meaningful error message.
                     if Curr > Text'Last or else Text (Curr) /= ')' then
                        Error ("Missing ')': " & Text (Start .. Curr - 1));
                     end if;
                     Curr := Curr + 1;
                  end;
               elsif Text (Curr) = '"' then
                  --  String literal:
                  declare
                     Start : constant Natural := Curr;
                     I     : constant Natural :=
                       Util.Strings.Skip_String
                         (Text (Curr .. Text'Last), '"', '"');
                  begin
                     if I = 0 then
                        Error
                          ("String not closed: " & Text (Curr .. Text'Last));
                     end if;
                     Curr := I + 1;
                     return
                       (Ada.Finalization.Controlled with
                          Ptr => new Exp'Class'
                            (Exp'Class
                               (Literal'
                                  (Exp with
                                     Val =>
                                       ASU.To_Unbounded_String
                                         (Util.Strings.Unquote
                                            (Text (Start + 1 .. I - 1),
                                             '"', '"'))))));
                  end;
               else
                  declare
                     Found : Boolean;
                     I     : constant Natural :=
                       Util.Strings.Identifier (Text (Curr .. Text'Last));
                  begin
                     if I = 0 then
                        Error
                          ("Identifier expected: " & Text (Curr .. Text'Last));
                     end if;
                     Get (Text (Curr .. I), Expr, Found);
                     if not Found then
                        Error ("Unknown function """ & Text (Curr .. I) & '"');
                     end if;
                     if Expr.Ptr.all in Predefined'Class then
                        Error
                          ("Unexpected operator: " & Text (Curr .. Text'Last));
                     end if;
                     Curr := I + 1;
                  end;
               end if;
               return Expr;
            end Parse_Factor;

         begin
            Last_Op := Op_None;
            Skip;
            declare
               Start : constant Natural := Curr;
               I     : constant Natural :=
                 Util.Strings.Identifier (Text (Curr .. Text'Last));
            begin
               if I = Curr + 2 and then
                  Util.Strings.To_Lower (Text (Curr .. I)) = "not"
               then
                  Curr := I + 1;
                  return Create
                           (Op_Not, Parse_Factor, Nil_Expression, Start);
               end if;
            end;
            return Parse_Factor;
         end Parse_Term;

         Expr  : Expression;
         Start : Natural;
         Op    : Operator;

      begin
         --  This is an operator precedence parser.
         Expr := Parse_Term;
         while Curr <= Text'Last loop
            if Last_Op = Op_None then
               Start := Curr;
               Op    := Parse_Operator;
               if Op = Op_None then
                  --  OK if text exhausted, or at a probable expression end.
                  exit when
                    Curr > Text'Last or else
                    Text (Curr) = ')' or else
                    Text (Curr) = ';';
                  Error ("Operator expected: " & Text (Start .. Text'Last));
               end if;
            else
               Op    := Last_Op;
               Start := Last_Pos;
            end if;
            if Precedence (Op) >= Max_Op then
               Last_Op  := Op;
               Last_Pos := Start;
               return Expr;
            end if;
            Last_Op := Op_None;
            Expr :=
              Create
                (Op, Expr, Parse_Expr (Max_Op => Precedence (Op)), Start);
         end loop;
         return Expr;
      end Parse_Expr;

      Expr : Expression;

   begin
      Expr := Parse_Expr;
      if Last_Op /= Op_None then
         Error ("Spurious operator at end of expression: " &
                Text (Last_Pos .. Text'Last));
      end if;
      if Curr <= Text'Last then
         --  We allow a semicolon at the end.
         if Text (Curr) = ';' then Curr := Curr + 1; end if;
         Skip (May_Fail => True);
         --  If there's still something following, we have an error.
         if Curr <= Text'Last then
            Error
              ("Garbage following expression: " & Text (Curr .. Text'Last));
         end if;
      end if;
      return Expr;
   end Parse;

   procedure Define_Macro
     (Name      : in     String;
      Expr      : in     Expression;
      Redefined :    out Boolean)
   is
   begin
      if Hashing.Contains (Predef, Name) then
         Ada.Exceptions.Raise_Exception
           (Parse_Error'Identity,
            "Predefined functions and operators cannot be redefined!");
      end if;
      Redefined := Hashing.Contains (Macros, Name);
      Hashing.Replace (Macros, Name, Expr);
   end Define_Macro;

   function Evaluate
     (Expr     : in Expression;
      Argument : in Asis.Element)
     return Boolean
   is
   begin
      return Eval (Bool_Exp'Class (Expr.Ptr.all), Argument);
   end Evaluate;

   function Eval
     (E        : in Terminal;
      Argument : in Asis.Element)
     return Boolean
   is
   begin
      return E.P /= null and then E.P (Argument);
   end Eval;

   function Eval
     (E        : in Value;
      Argument : in Asis.Element)
     return Boolean
   is
      pragma Warnings (Off, Argument); --  silence -gnatwa
   begin
      return E.Val;
   end Eval;

   function Eval
     (E        : in And_Exp;
      Argument : in Asis.Element)
     return Boolean
   is
   begin
      return Eval (Bool_Exp'Class (E.Left.Ptr.all), Argument)
             and then
             Eval (Bool_Exp'Class (E.Right.Ptr.all), Argument);
   end Eval;

   function Eval
     (E        : in Or_Exp;
      Argument : in Asis.Element)
     return Boolean
   is
   begin
      return Eval (Bool_Exp'Class (E.Left.Ptr.all), Argument)
             or else
             Eval (Bool_Exp'Class (E.Right.Ptr.all), Argument);
   end Eval;

   function Eval
     (E        : in Xor_Exp;
      Argument : in Asis.Element)
     return Boolean
   is
   begin
      return Eval (Bool_Exp'Class (E.Left.Ptr.all), Argument)
             xor
             Eval (Bool_Exp'Class (E.Right.Ptr.all), Argument);
   end Eval;

   function Eval
     (E        : in Eq_Exp;
      Argument : in Asis.Element)
     return Boolean
   is
   begin
      if E.Left.Ptr.all in Bool_Exp'Class then
         return Eval (Bool_Exp'Class (E.Left.Ptr.all), Argument)
                =
                Eval (Bool_Exp'Class (E.Right.Ptr.all), Argument);
      else
         return Util.Strings.Equal
                  (Eval (String_Exp'Class (E.Left.Ptr.all), Argument),
                   Eval (String_Exp'Class (E.Right.Ptr.all), Argument));
      end if;
   end Eval;

   function Eval
     (E        : in Prefix_Exp;
      Argument : in Asis.Element)
     return Boolean
   is
   begin
      --  We know we have two string expressions!
      declare
         Left : constant String :=
           Util.Strings.To_Lower
             (Eval (String_Exp'Class (E.Left.Ptr.all), Argument));
         Right : constant String :=
           Util.Strings.To_Lower
             (Eval (String_Exp'Class (E.Right.Ptr.all), Argument));
      begin
         return Util.Strings.Is_Prefix (Left, Right);
      end;
   end Eval;

   function Eval
     (E        : in Not_Exp;
      Argument : in Asis.Element)
     return Boolean
   is
   begin
      return not Eval (Bool_Exp'Class (E.Arg.Ptr.all), Argument);
   end Eval;

   ----------------------------------------------------------------------------

   function Eval
     (E        : in String_Terminal;
      Argument : in Asis.Element)
     return String
   is
   begin
      if E.P = null then return ""; end if;
      return ACH.To_String (E.P (Argument));
   end Eval;

   function Eval
     (E        : in Literal;
      Argument : in Asis.Element)
     return String
   is
      pragma Warnings (Off, Argument); --  silence -gnatwa
   begin
      return ASU.To_String (E.Val);
   end Eval;

   function Eval
     (E        : in Concat_Exp;
      Argument : in Asis.Element)
     return String
   is
   begin
      return Eval (String_Exp'Class (E.Left.Ptr.all), Argument) &
             Eval (String_Exp'Class (E.Right.Ptr.all), Argument);
   end Eval;

   ----------------------------------------------------------------------------

   procedure Adjust
     (E : in out Expression)
   is
   begin
      if E.Ptr /= null then
         E.Ptr.Ref_Count := E.Ptr.Ref_Count + 1;
      end if;
   end Adjust;

   procedure Finalize
     (E : in out Expression)
   is

      procedure Free is
         new Ada.Unchecked_Deallocation (Exp'Class, Expression_Ptr);

   begin
      if E.Ptr /= null then
         E.Ptr.Ref_Count := E.Ptr.Ref_Count - 1;
         if E.Ptr.Ref_Count = 0 then
            Free (E.Ptr);
         end if;
      end if;
   end Finalize;

   ----------------------------------------------------------------------------

begin
   Hashing.Set_Resize (Macros, 0.75);
   Hashing.Set_Resize (Predef, 0.75);
   declare
      Linear_Growth : GAL.Support.Hashing.Linear_Growth_Policy (20);
   begin
      Hashing.Set_Growth_Policy (Macros, Linear_Growth);
      Hashing.Set_Growth_Policy (Predef, Linear_Growth);
   end;
   Add_Predefined :
   declare

      procedure Add_Expression
        (Name : in String;
         Expr : in Exp'Class)
      is
         E : Expression :=
           (Ada.Finalization.Controlled with Ptr => new Exp'Class'(Expr));
      begin
         Hashing.Insert (Predef, Name, E);
      end Add_Expression;

      use AD.Predicates;
   begin
      Add_Expression
        ("private", Terminal'(Exp with P => Is_Private'Access));
      Add_Expression
        ("separate", Terminal'(Exp with P => Is_Separate'Access));
      Add_Expression
        ("unit", Terminal'(Exp with P => Is_Unit'Access));
      Add_Expression
        ("package", Terminal'(Exp with P => Is_Package'Access));
      Add_Expression
        ("child", Terminal'(Exp with P => Is_Child'Access));
      Add_Expression
        ("constant", Terminal'(Exp with P => Is_Constant'Access));
      Add_Expression
        ("pragma", Terminal'(Exp with P => Is_Pragma'Access));
      Add_Expression
        ("representation", Terminal'(Exp with P => Is_Clause'Access));
      Add_Expression
        ("variable", Terminal'(Exp with P => Is_Variable'Access));
      Add_Expression
        ("type", Terminal'(Exp with P => Is_Type'Access));
      Add_Expression
        ("subtype", Terminal'(Exp with P => Is_Subtype'Access));
      Add_Expression
        ("procedure", Terminal'(Exp with P => Is_Procedure'Access));
      Add_Expression
        ("function", Terminal'(Exp with P => Is_Function'Access));
      Add_Expression
        ("subprogram", Terminal'(Exp with P => Is_Subprogram'Access));
      Add_Expression
        ("entry", Terminal'(Exp with P => Is_Entry'Access));
      Add_Expression
        ("elementary", Terminal'(Exp with P => Is_Elementary'Access));
      Add_Expression
        ("scalar", Terminal'(Exp with P => Is_Scalar'Access));
      Add_Expression
        ("discrete", Terminal'(Exp with P => Is_Discrete'Access));
      Add_Expression
        ("enum", Terminal'(Exp with P => Is_Enumeration'Access));
      Add_Expression
        ("integral", Terminal'(Exp with P => Is_Integral'Access));
      Add_Expression
        ("signed", Terminal'(Exp with P => Is_Signed'Access));
      Add_Expression
        ("modular", Terminal'(Exp with P => Is_Modular'Access));
      Add_Expression
        ("real", Terminal'(Exp with P => Is_Real'Access));
      Add_Expression
        ("float", Terminal'(Exp with P => Is_Float'Access));
      Add_Expression
        ("fixed", Terminal'(Exp with P => Is_Fixed'Access));
      Add_Expression
        ("ordinary_fixed", Terminal'(Exp with P => Is_Ordinary_Fixed'Access));
      Add_Expression
        ("decimal_fixed", Terminal'(Exp with P => Is_Decimal_Fixed'Access));
      Add_Expression
        ("numeric", Terminal'(Exp with P => Is_Numeric'Access));
      Add_Expression
        ("access", Terminal'(Exp with P => Is_Access'Access));
      Add_Expression
        ("access_object", Terminal'(Exp with P => Is_Access_To_Object'Access));
      Add_Expression
        ("access_subprogram",
         Terminal'(Exp with P => Is_Access_To_Subprogram'Access));
      Add_Expression
        ("composite", Terminal'(Exp with P => Is_Composite'Access));
      Add_Expression
        ("array", Terminal'(Exp with P => Is_Array'Access));
      Add_Expression
        ("record", Terminal'(Exp with P => Is_Record'Access));
      Add_Expression
        ("tagged", Terminal'(Exp with P => Is_Tagged'Access));
      Add_Expression
        ("task", Terminal'(Exp with P => Is_Task'Access));
      Add_Expression
        ("protected", Terminal'(Exp with P => Is_Protected'Access));
      Add_Expression
        ("limited", Terminal'(Exp with P => Is_Limited'Access));
      Add_Expression
        ("class_wide", Terminal'(Exp with P => Is_Class_Wide'Access));
      Add_Expression
        ("controlled", Terminal'(Exp with P => Is_Controlled'Access));
      Add_Expression
        ("private_type", Terminal'(Exp with P => Is_Private_Type'Access));
      Add_Expression
        ("incomplete", Terminal'(Exp with P => Is_Incomplete'Access));
      Add_Expression
        ("aliased", Terminal'(Exp with P => Is_Aliased'Access));
      Add_Expression
        ("exception", Terminal'(Exp with P => Is_Exception'Access));
      Add_Expression
        ("renaming", Terminal'(Exp with P => Is_Renaming'Access));
      Add_Expression
        ("generic", Terminal'(Exp with P => Is_Generic'Access));
      Add_Expression
        ("formal", Terminal'(Exp with P => Is_Generic_Formal'Access));
      Add_Expression
        ("instance", Terminal'(Exp with P => Is_Instance'Access));
      Add_Expression
        ("abstract", Terminal'(Exp with P => Is_Abstract'Access));
      Add_Expression
        ("full_name", String_Terminal'(Exp with P => Unique_Name'Access));
      Add_Expression
        ("name", String_Terminal'(Exp with P => Simple_Name'Access));
      Add_Expression
        ("true", Value'(Exp with Val => True));
      Add_Expression
        ("false", Value'(Exp with Val => False));
      --  Also insert the keywords (facilitates checking whether someone had
      --  the glorious idea to name a macro "not").
      Add_Expression
        ("not", Predefined'(Exp with Op => Op_Not));
      Add_Expression
        ("and", Predefined'(Exp with Op => Op_And));
      Add_Expression
        ("or",  Predefined'(Exp with Op => Op_Or));
      Add_Expression
        ("xor", Predefined'(Exp with Op => Op_Xor));
   end Add_Predefined;
end AD.Expressions;
