ada/templates-parser
0
0
Fork 0
mirror of https://github.com/AdaCore/templates-parser.git synced 2026-02-12 12:29:55 -08:00
Code Issues Packages Projects Releases Wiki Activity
Files
24.2
templates-parser/src/templates_parser-expr.adb
Pascal Obry c90201a13a Add report callbacks when parsing. 
The callback is used to report Unused and/or Undefined tags. This make
it possible to implement some safety checks while parsing a template.

Add correspoinding regression test.

For RC04-043.
2019-06-13 22:46:07 +02:00

850 lines
24 KiB
Ada
Raw Permalink Blame History

------------------------------------------------------------------------------
-- 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 --
-- <http://www.gnu.org/licenses/>. --
-- --
-- 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:
--
-- <expr> ::= <relation> {<Logic_Op> <relation>}
-- <relation> ::= <term> {<comp_op> <term>}
-- <term> ::= ["not"] <primary>
-- <primary> ::= <valvar> | "(" <expr> ")"
-- <varval> ::= {<value> | <var>} [ "&" <varval>]
-- <logic_op> ::= "and" | "or" | "xor"
-- <comp_op> ::= "<" | "<=" | "=" | ">=" | ">" | "/="
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;
Reference in New Issue View Git Blame Copy Permalink