File : templates_parser-expr.adb
------------------------------------------------------------------------------
-- Templates Parser --
-- --
-- Copyright (C) 1999 - 2002 --
-- Pascal Obry --
-- --
-- This library 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 of the License, 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. See the GNU --
-- General Public License for more details. --
-- --
-- You should have received a copy of the GNU General Public License --
-- along with this library; if not, write to the Free Software Foundation, --
-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. --
-- --
-- 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. --
------------------------------------------------------------------------------
-- $Id: templates_parser-expr.adb,v 1.2 2004/02/24 15:40:19 Jano Exp $
with Ada.Text_IO;
separate (Templates_Parser)
package body Expr is
function Is_Op (O : in String) return Boolean;
-- Returns True is O is a binary operator.
function Is_U_Op (O : in String) return Boolean;
-- Returns True is O is an unary operator.
-----------
-- Image --
-----------
function Image (O : in 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 "/=";
end case;
end Image;
function Image (O : in U_Ops) return String is
begin
case O is
when O_Not => return "not";
end case;
end Image;
-----------
-- Is_Op --
-----------
function Is_Op (O : in String) return Boolean is
begin
if O = "and" then
return True;
elsif O = "or" then
return True;
elsif O = "xor" then
return True;
elsif O = ">" then
return True;
elsif O = "<" then
return True;
elsif O = ">=" then
return True;
elsif O = "<=" then
return True;
elsif O = "=" then
return True;
elsif O = "/=" then
return True;
else
return False;
end if;
end Is_Op;
-------------
-- Is_U_Op --
-------------
function Is_U_Op (O : in String) return Boolean is
begin
if O = "not" then
return True;
else
return False;
end if;
end Is_U_Op;
-----------
-- Parse --
-----------
function Parse (Expression : in String) return Tree is
Index : Natural := Expression'First;
function Get_Token return String;
-- Returns next token. Set Index to the last analysed position in
-- Expression.
---------------
-- Get_Token --
---------------
function Get_Token return String is
use Strings;
K, I : Natural;
begin
if Index > Expression'Last then
-- No more data to read.
return "";
end if;
Index := Fixed.Index
(Expression (Index .. Expression'Last), Blank, Outside);
if Index = 0 then
-- There is only one token, return the whole string.
Index := Expression'Last + 1;
return Expression (Index .. Expression'Last);
elsif Expression (Index) = '(' then
-- This is a sub-expression, returns it.
K := 0;
declare
L : Natural := 1;
begin
Look_For_Sub_Exp : for I in Index + 1 .. Expression'Last loop
if Expression (I) = '(' then
L := L + 1;
elsif Expression (I) = ')' then
K := I;
L := L - 1;
end if;
exit Look_For_Sub_Exp when L = 0;
end loop Look_For_Sub_Exp;
end;
if K = 0 then
-- No matching closing parenthesis.
Exceptions.Raise_Exception
(Internal_Error'Identity,
"condition, no matching parenthesis for parent at pos "
& Natural'Image (Index));
else
I := Index;
Index := K + 1;
return Expression (I .. K);
end if;
elsif Expression (Index) = '"' then
-- This is a string, returns it.
K := 0;
Look_For_String : for I in Index + 1 .. Expression'Last loop
if Expression (I) = '"' then
K := I;
exit;
end if;
end loop Look_For_String;
if K = 0 then
-- No matching closing quote
Exceptions.Raise_Exception
(Internal_Error'Identity,
"condition, no matching closing quote string at pos "
& Natural'Image (Index));
else
I := Index;
Index := K + 1;
return Expression (I .. K);
end if;
else
-- We have found the start of a token, look for end of it.
K := Fixed.Index (Expression (Index .. Expression'Last), Blank);
if K = 0 then
-- Token end is the end of Expression.
I := Index;
Index := Expression'Last + 1;
return Expression (I .. Expression'Last);
else
I := Index;
Index := K + 1;
return Expression (I .. K - 1);
end if;
end if;
end Get_Token;
L_Tok : constant String := Get_Token; -- left operand
O_Tok : constant String := Get_Token; -- operator
R_Tok : constant String := Get_Token; -- right operand
begin
if Is_U_Op (L_Tok) then
if R_Tok = "" then
-- This is "not expr"
return new Node'
(U_Op, Value (L_Tok),
Parse (O_Tok & ' ' & R_Tok & ' '
& Expression (Index .. Expression'Last)));
else
-- This is "not expr op expr", parse again with
-- "(not expr) op expr"
return Parse ('(' & L_Tok & ' ' & O_Tok & ") "
& R_Tok & ' '
& Expression (Index .. Expression'Last));
end if;
elsif Is_Op (O_Tok) and then Is_U_Op (R_Tok) then
-- We have "expr op u_op expr", parse again with
-- "expr op (u_op expr)"
return Parse (L_Tok & ' ' & O_Tok
& " (" & R_Tok & ' '
& Expression (Index .. Expression'Last) & ')');
elsif O_Tok = "" then
-- No more operator, this is a leaf. It is either a variable or a
-- value.
if L_Tok (L_Tok'First) = '(' then
-- an expression
return Parse (L_Tok (L_Tok'First + 1 .. L_Tok'Last - 1));
elsif Strings.Fixed.Index (L_Tok, To_String (Begin_Tag)) = 0 then
-- a value
return new Node'(Value, To_Unbounded_String (No_Quote (L_Tok)));
else
-- a variable
return new Node'(Var, Build (No_Quote (L_Tok)));
end if;
else
if Index > Expression'Last then
-- This is the latest token
return new Node'(Op, Value (O_Tok),
Parse (L_Tok), Parse (R_Tok));
else
declare
NO_Tok : constant String := Get_Token;
begin
return new Node'
(Op, Value (NO_Tok),
Parse (L_Tok & ' ' & O_Tok & ' ' & R_Tok),
Parse (Expression (Index .. Expression'Last)));
end;
end if;
end if;
end Parse;
----------------
-- Print_Tree --
----------------
procedure Print_Tree (E : in Tree) is
begin
case E.Kind is
when Value =>
declare
Val : constant String := To_String (E.V);
K : constant Natural := Fixed.Index (Val, " ");
begin
if K = 0 then
Text_IO.Put (Val);
else
Text_IO.Put ('"' & Val & '"');
end if;
end;
when Var =>
Text_IO.Put (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) is
procedure Free is new Ada.Unchecked_Deallocation (Node, Tree);
begin
case E.Kind is
when Value =>
null;
when Var =>
Release (E.Var);
when Op =>
Release (E.Left);
Release (E.Right);
when U_Op =>
Release (E.Next);
end case;
Free (E);
end Release;
-----------
-- Value --
-----------
function Value (O : in String) return Ops is
begin
if O = "and" then
return O_And;
elsif O = "or" then
return O_Or;
elsif O = "xor" then
return O_Xor;
elsif O = ">" then
return O_Sup;
elsif O = "<" then
return O_Inf;
elsif O = ">=" then
return O_Esup;
elsif O = "<=" then
return O_Einf;
elsif O = "=" then
return O_Equal;
elsif O = "/=" then
return O_Diff;
else
Exceptions.Raise_Exception
(Internal_Error'Identity, "condition, unknown operator " & O);
end if;
end Value;
function Value (O : in String) return U_Ops is
begin
if O = "not" then
return O_Not;
else
Exceptions.Raise_Exception
(Internal_Error'Identity, "condition, unknown operator " & O);
end if;
end Value;
end Expr;