------------------------------------------------------------------------------ -- Templates Parser -- -- -- -- Copyright (C) 1999-2019, AdaCore -- -- -- -- This library 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. This library 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. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are -- -- granted additional permissions described in the GCC Runtime Library -- -- Exception, version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- ------------------------------------------------------------------------------ pragma Ada_2012; with Ada.Text_IO; separate (Templates_Parser) package body Expr is use Ada.Strings.Maps; -- BNF definition of the expression language: -- -- ::= { } -- ::= { } -- ::= ["not"] -- ::= | "(" ")" -- ::= { | } [ "&" ] -- ::= "and" | "or" | "xor" -- ::= "<" | "<=" | "=" | ">=" | ">" | "/=" subtype Comp_Op is Ops range O_Sup .. O_In; subtype Logic_Op is Ops range O_And .. O_Cat; Separator : constant Character_Set := Blank or To_Set ("<>=/()"); ------------- -- Analyze -- ------------- function Analyze (E : Expr.Tree) return String is type Ops_Fct is access function (L, R : Expr.Tree) return String; function F_And (L, R : Expr.Tree) return String; function F_Or (L, R : Expr.Tree) return String; function F_Xor (L, R : Expr.Tree) return String; function F_Sup (L, R : Expr.Tree) return String; function F_Esup (L, R : Expr.Tree) return String; function F_Einf (L, R : Expr.Tree) return String; function F_Inf (L, R : Expr.Tree) return String; function F_Equ (L, R : Expr.Tree) return String; function F_Diff (L, R : Expr.Tree) return String; function F_In (L, R : Expr.Tree) return String; function F_Cat (L, R : Expr.Tree) return String; type U_Ops_Fct is access function (N : Expr.Tree) return String; function F_Not (N : Expr.Tree) return String; ----------- -- F_And -- ----------- function F_And (L, R : Expr.Tree) return String is LV : constant String := Analyze (L); RV : constant String := Analyze (R); begin if LV = Unknown or else RV = Unknown then return Unknown; elsif Is_True (LV) and then Is_True (RV) then return "TRUE"; else return "FALSE"; end if; end F_And; ----------- -- F_Cat -- ----------- function F_Cat (L, R : Expr.Tree) return String is LV : constant String := Analyze (L); RV : constant String := Analyze (R); begin if LV = Unknown or else RV = Unknown then return Unknown; else return LV & RV; end if; end F_Cat; ------------ -- F_Diff -- ------------ function F_Diff (L, R : Expr.Tree) return String is LV : constant String := Analyze (L); RV : constant String := Analyze (R); begin if LV = Unknown or else RV = Unknown then return Unknown; elsif Analyze (L) /= Analyze (R) then return "TRUE"; else return "FALSE"; end if; end F_Diff; ------------ -- F_Einf -- ------------ function F_Einf (L, R : Expr.Tree) return String is LV : constant String := Analyze (L); RV : constant String := Analyze (R); begin if LV = Unknown or else RV = Unknown then return Unknown; elsif Utils.Is_Number (LV) and then Utils.Is_Number (RV) then if Integer'Value (LV) <= Integer'Value (RV) then return "TRUE"; else return "FALSE"; end if; else if LV <= RV then return "TRUE"; else return "FALSE"; end if; end if; end F_Einf; ----------- -- F_Equ -- ----------- function F_Equ (L, R : Expr.Tree) return String is LV : constant String := Analyze (L); RV : constant String := Analyze (R); begin if LV = Unknown or else RV = Unknown then return Unknown; elsif LV = RV then return "TRUE"; else return "FALSE"; end if; end F_Equ; ------------ -- F_Esup -- ------------ function F_Esup (L, R : Expr.Tree) return String is LV : constant String := Analyze (L); RV : constant String := Analyze (R); begin if LV = Unknown or else RV = Unknown then return Unknown; elsif Utils.Is_Number (LV) and then Utils.Is_Number (RV) then if Integer'Value (LV) >= Integer'Value (RV) then return "TRUE"; else return "FALSE"; end if; else if LV >= RV then return "TRUE"; else return "FALSE"; end if; end if; end F_Esup; ---------- -- F_In -- ---------- function F_In (L, R : Expr.Tree) return String is pragma Unreferenced (L, R); begin -- Always unknown as an in expression contains a variable return Unknown; end F_In; ----------- -- F_Inf -- ----------- function F_Inf (L, R : Expr.Tree) return String is LV : constant String := Analyze (L); RV : constant String := Analyze (R); begin if LV = Unknown or else RV = Unknown then return Unknown; elsif Utils.Is_Number (LV) and then Utils.Is_Number (RV) then if Integer'Value (LV) < Integer'Value (RV) then return "TRUE"; else return "FALSE"; end if; else if LV < RV then return "TRUE"; else return "FALSE"; end if; end if; end F_Inf; ----------- -- F_Not -- ----------- function F_Not (N : Expr.Tree) return String is NV : constant String := Analyze (N); begin if NV = Unknown then return Unknown; elsif Is_True (NV) then return "FALSE"; else return "TRUE"; end if; end F_Not; ---------- -- F_Or -- ---------- function F_Or (L, R : Expr.Tree) return String is LV : constant String := Analyze (L); RV : constant String := Analyze (R); begin if LV = Unknown or else RV = Unknown then return Unknown; elsif Is_True (LV) or else Is_True (RV) then return "TRUE"; else return "FALSE"; end if; end F_Or; ----------- -- F_Sup -- ----------- function F_Sup (L, R : Expr.Tree) return String is LV : constant String := Analyze (L); RV : constant String := Analyze (R); begin if LV = Unknown or else RV = Unknown then return Unknown; elsif Utils.Is_Number (LV) and then Utils.Is_Number (RV) then if Integer'Value (LV) > Integer'Value (RV) then return "TRUE"; else return "FALSE"; end if; else if LV > RV then return "TRUE"; else return "FALSE"; end if; end if; end F_Sup; ----------- -- F_Xor -- ----------- function F_Xor (L, R : Expr.Tree) return String is LV : constant String := Analyze (L); RV : constant String := Analyze (R); begin if LV = Unknown or else RV = Unknown then return Unknown; elsif Is_True (LV) xor Is_True (RV) then return "TRUE"; else return "FALSE"; end if; end F_Xor; Op_Table : constant array (Expr.Ops) of Ops_Fct := (Expr.O_And => F_And'Access, Expr.O_Or => F_Or'Access, Expr.O_Xor => F_Xor'Access, Expr.O_Sup => F_Sup'Access, Expr.O_Inf => F_Inf'Access, Expr.O_Esup => F_Esup'Access, Expr.O_Einf => F_Einf'Access, Expr.O_Equal => F_Equ'Access, Expr.O_Diff => F_Diff'Access, Expr.O_In => F_In'Access, Expr.O_Cat => F_Cat'Access); U_Op_Table : constant array (Expr.U_Ops) of U_Ops_Fct := (Expr.O_Not => F_Not'Access); begin case E.Kind is when Expr.Value => return To_String (E.V); when Expr.Var => return Unknown; when Expr.Op => return Op_Table (E.O) (E.Left, E.Right); when Expr.U_Op => return U_Op_Table (E.U_O) (E.Next); end case; end Analyze; ----------- -- Clone -- ----------- function Clone (E : Tree) return Tree is N : Tree; begin if E = null then return null; else N := new Node'(E.all); end if; case E.Kind is when Value => null; when Var => N.Var := Data.Clone (E.Var); when Op => N.Left := Clone (N.Left); N.Right := Clone (N.Right); when U_Op => N.Next := Clone (N.Next); end case; return N; end Clone; ----------- -- Image -- ----------- function Image (O : Ops) return String is begin case O is when O_And => return "and"; when O_Or => return "or"; when O_Xor => return "xor"; when O_Sup => return ">"; when O_Inf => return "<"; when O_Esup => return ">="; when O_Einf => return "<="; when O_Equal => return "="; when O_Diff => return "/="; when O_In => return "in"; when O_Cat => return "&"; end case; end Image; function Image (O : U_Ops) return String is begin case O is when O_Not => return "not"; end case; end Image; ------------- -- Is_True -- ------------- function Is_True (Str : String) return Boolean is L_Str : constant String := Characters.Handling.To_Upper (Str); begin return L_Str = "TRUE" or else L_Str = "T" or else L_Str = "1"; end Is_True; ----------- -- Parse -- ----------- function Parse (Expression : String; Line : Natural) return Tree is Start_Index : Natural := Expression'First; Index : Natural := Expression'First; type Token_Kind is (Open_Par, Close_Par, Binary_Op, Unary_Op, Value, Var, End_Expr); type Token (Kind : Token_Kind := Var) is record case Kind is when Open_Par | Close_Par | End_Expr => null; when Binary_Op => Bin_Op : Ops; when Unary_Op => Un_Op : U_Ops; when Value | Var => Start : Positive; -- range of the token Stop : Positive; -- in Expression string end case; end record; Current_Token : Token; procedure Error (Mess : String) with No_Return; -- Raises Internal_Error with the column of the condition function Expr return Tree; -- Parse a logical operator function Term return Tree; -- Parse a term (unary operator) function Relation return Tree; -- Parse a relational operator function Primary return Tree; -- ??? ----------- -- Error -- ----------- procedure Error (Mess : String) is begin raise Internal_Error with "col" & Integer'Image (Start_Index) & " condition, " & Mess; end Error; procedure Next_Token; -- Moves Current_Token to next token. Set Index after the last analysed -- consumed from expression. ---------- -- Expr -- ---------- function Expr return Tree is N : Tree; O : Ops; begin N := Relation; while Current_Token.Kind = Binary_Op and then Current_Token.Bin_Op in Logic_Op loop O := Current_Token.Bin_Op; Next_Token; N := new Node'(Op, Line, O, N, Relation); end loop; return N; end Expr; ---------------- -- Next_Token -- ---------------- procedure Next_Token is use Ada.Characters.Handling; I : Natural; begin -- Skip blanks while Index <= Expression'Last and then Is_In (Expression (Index), Blank) loop Index := Index + 1; end loop; Start_Index := Index; if Index > Expression'Last then -- No more data to read Current_Token := (Kind => End_Expr); -- Check symbolic operators elsif Expression (Index) = '(' then Current_Token := (Kind => Open_Par); Index := Index + 1; elsif Expression (Index) = ')' then Current_Token := (Kind => Close_Par); Index := Index + 1; elsif Expression (Index) = '=' then Current_Token := (Kind => Binary_Op, Bin_Op => O_Equal); Index := Index + 1; elsif Expression (Index) = '/' and then Index < Expression'Last and then Expression (Index + 1) = '=' then Current_Token := (Kind => Binary_Op, Bin_Op => O_Diff); Index := Index + 2; elsif Expression (Index) = '<' then Index := Index + 1; if Expression (Index) = '=' then Current_Token := (Kind => Binary_Op, Bin_Op => O_Einf); Index := Index + 1; else Current_Token := (Kind => Binary_Op, Bin_Op => O_Inf); end if; elsif Expression (Index) = '>' then Index := Index + 1; if Expression (Index) = '=' then Current_Token := (Kind => Binary_Op, Bin_Op => O_Esup); Index := Index + 1; else Current_Token := (Kind => Binary_Op, Bin_Op => O_Sup); end if; elsif Expression (Index) = '"' then -- This is a string, return it Current_Token := (Kind => Value, Start => Index + 1, Stop => Index); loop if Current_Token.Stop = Expression'Last then Error ("condition, no matching closing quote string"); elsif Expression (Current_Token.Stop + 1) = '"' then exit; else Current_Token.Stop := Current_Token.Stop + 1; end if; end loop; Index := Current_Token.Stop + 2; else -- We have found the start of a string token, look for end of it I := Index; loop Index := Fixed.Index (Expression (Index .. Expression'Last), Separator); if Index = 0 then -- Token end is the end of Expression Index := Expression'Last + 1; exit; end if; -- Special case for '/': it is a separator only if appearing -- in '/='. Without this test, the "/" filter is not recognized -- Moreover, this allows comparisons of file paths (with '/') exit when Expression (Index) /= '/' or else Expression (Index + 1) = '='; Index := Index + 1; end loop; declare Token_Image : constant String := To_Lower (Expression (I .. Index - 1)); begin if Token_Image = "not" then Current_Token := (Kind => Unary_Op, Un_Op => O_Not); elsif Token_Image = "and" then Current_Token := (Kind => Binary_Op, Bin_Op => O_And); elsif Token_Image = "or" then Current_Token := (Kind => Binary_Op, Bin_Op => O_Or); elsif Token_Image = "xor" then Current_Token := (Kind => Binary_Op, Bin_Op => O_Xor); elsif Token_Image = "in" then Current_Token := (Kind => Binary_Op, Bin_Op => O_In); elsif Token_Image = "&" then Current_Token := (Kind => Binary_Op, Bin_Op => O_Cat); elsif Token_Image'Length > Length (Begin_Tag) and then Token_Image (Token_Image'First .. Token_Image'First + Length (Begin_Tag) - 1) = Begin_Tag then -- This is a variable, we have the start of it, now look -- for the end of the variable. if Index <= Expression'Last and then Expression (Index) = '(' then -- This is not the end of the tag variable but the -- start of the tag parameters. Look for tag variable -- end. Index := Fixed.Index (Expression (Index .. Expression'Last), To_String (End_Tag)); Index := Index + Length (End_Tag); end if; if Index = 0 then Error ("variable end not found"); else Current_Token := (Kind => Var, Start => I, Stop => Index - 1); end if; else Current_Token := (Kind => Value, Start => I, Stop => Index - 1); end if; end; end if; end Next_Token; ------------- -- Primary -- ------------- function Primary return Tree is function Var_Val return Tree; -- Handles a set of catenated values and variables ------------- -- Var_Val -- ------------- function Var_Val return Tree is N : Tree; Start, Stop : Natural; begin case Current_Token.Kind is when Value => Start := Current_Token.Start; Stop := Current_Token.Stop; N := new Node' (Value, Line, V => To_Unbounded_String (Expression (Start .. Stop))); when Var => Start := Current_Token.Start; Stop := Current_Token.Stop; N := new Node' (Var, Line, Var => Data.Build (Expression (Start .. Stop))); when others => return null; end case; Next_Token; if Current_Token.Kind = Binary_Op and then Current_Token.Bin_Op = O_Cat then -- We have a &, let's catenate the result Next_Token; return new Node'(Op, Line, O_Cat, N, Var_Val); else return N; end if; end Var_Val; Result : Tree; begin case Current_Token.Kind is -- Normal cases when Open_Par => Next_Token; Result := Expr; if Current_Token.Kind = Close_Par then Next_Token; return Result; else Error ("missing closing parenthesis"); end if; when Value | Var => return Var_Val; -- Errors when Unary_Op => Error ("misplaced operator """ & Image (Current_Token.Un_Op) & '"'); when Binary_Op => Error ("misplaced operator """ & Image (Current_Token.Bin_Op) & '"'); when Close_Par => Error ("unexpected right parenthesis"); when End_Expr => Error ("missing operand"); end case; end Primary; -------------- -- Relation -- -------------- function Relation return Tree is N : Tree; O : Ops; begin N := Term; while Current_Token.Kind = Binary_Op and then Current_Token.Bin_Op in Comp_Op loop O := Current_Token.Bin_Op; Next_Token; N := new Node'(Op, Line, O, N, Term); end loop; return N; end Relation; ---------- -- Term -- ---------- function Term return Tree is O : U_Ops; begin if Current_Token.Kind = Unary_Op then O := Current_Token.Un_Op; Next_Token; return new Node'(U_Op, Line, U_O => O, Next => Primary); else return Primary; end if; end Term; Result : Tree; begin Next_Token; Result := Expr; case Current_Token.Kind is when End_Expr => null; when Open_Par | Close_Par | Value | Var => Error ("Missing operator"); when Binary_Op | Unary_Op => Error ("Missing operand"); end case; return Result; end Parse; ---------------- -- Print_Tree -- ---------------- procedure Print_Tree (E : Tree) is begin case E.Kind is when Value => Text_IO.Put (Quote (To_String (E.V))); when Var => Text_IO.Put (Data.Image (E.Var)); when Op => Text_IO.Put ('('); Print_Tree (E.Left); Text_IO.Put (' ' & Image (E.O) & ' '); Print_Tree (E.Right); Text_IO.Put (')'); when U_Op => Text_IO.Put ('('); Text_IO.Put (Image (E.U_O) & ' '); Print_Tree (E.Next); Text_IO.Put (')'); end case; end Print_Tree; ------------- -- Release -- ------------- procedure Release (E : in out Tree; Single : Boolean := False) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Node, Tree); begin case E.Kind is when Value => null; when Var => Data.Release (E.Var); when Op => if not Single then Release (E.Left); Release (E.Right); end if; when U_Op => if not Single then Release (E.Next); end if; end case; Unchecked_Free (E); end Release; end Expr;