------------------------------------------------------------------------------
-- --
-- ASIS Tester And iNTerpreter (ASIStant) COMPONENTS --
-- --
-- A S I S T A N T . S _ P A R S E R --
-- --
-- B o d y --
-- --
-- Copyright (c) 1997-2000, Free Software Foundation, Inc. --
-- --
-- ASIStant 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 2, or (at your option) any later --
-- version. ASIStant is distributed in the hope that it will be useful, --
-- but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY 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 GNAT; see file COPYING. If --
-- not, write to the Free Software Foundation, 59 Temple Place Suite 330, --
-- Boston, MA 02111-1307, USA. --
-- --
-- ASIStant is an evolution of ASIStint tool that was created by --
-- Vasiliy Fofanov as part of a collaboration between Software Engineering --
-- Laboratory of the Swiss Federal Institute of Technology in Lausanne, --
-- Switzerland, and the Scientific Research Computer Center of the Moscow --
-- University, Russia, supported by the Swiss National Science Foundation --
-- grant #7SUPJ048247, "Development of ASIS for GNAT with industry quality" --
-- --
-- ASIStant is distributed as a part of the ASIS implementation for GNAT --
-- (ASIS-for-GNAT) and is maintained by Ada Core Technologies Inc --
-- (http://www.gnat.com). --
------------------------------------------------------------------------------
with Ada.Strings.Wide_Fixed; use Ada.Strings.Wide_Fixed;
with ASIStant.Common; use ASIStant.Common;
with ASIStant.DeAlloc; use ASIStant.DeAlloc;
package body ASIStant.S_Parser is
------------------------------------------------------------------------------
-- This package provides parsing for the ASIStant language
------------------------------------------------------------------------------
procedure Reset_Tree is
NType : Node_Type;
begin
for i in 1 .. CurStat.Free - 1 loop
NType := CurStat.Tree (i).NType;
if NType = NT_FUNCTION or NType = NT_VARIABLE or
NType = NT_STRING or NType = NT_INTEGER
then
Free (CurStat.Tree (i).SValue);
end if;
end loop;
CurStat.Free := 1;
end Reset_Tree;
procedure Get_Func (TS : in out Token_Stream) is
Cur : Node_Position;
P : Natural;
begin
-- Get function name
if not Is_ID (TS) then
Error (ERR_BADID, Cur_Token (TS));
end if;
Cur := CurStat.Free;
CurStat.Tree (Cur).NType := NT_FUNCTION;
P := Cur_Token (TS)'Length;
CurStat.Tree (Cur).SValue := new Wide_String (1 .. P);
Move (Cur_Token (TS), CurStat.Tree (Cur).SValue.all);
CurStat.Tree (Cur).NValue := 0;
CurStat.Free := CurStat.Free + 1;
Next_Token (TS);
-- Check existence of parameters
if not Is_Active (TS) or else TS.Text (TS.Cur_Token_Start) /= '(' then
return;
end if;
-- Skip '('
Next_Token (TS);
CurStat.Tree (Cur).NValue := CurStat.Free;
-- Get parameters
loop
-- Current parameter
if not Is_Active (TS) or else TS.Text (TS.Cur_Token_Start) = ')' then
Error (ERR_NEEDPARAM);
end if;
Cur := CurStat.Free;
CurStat.Free := CurStat.Free + 1;
CurStat.Tree (Cur).NType := NT_PARAMLIST;
CurStat.Tree (Cur).NValue := CurStat.Free;
Get_Expr (TS);
-- Skip parameter separator
if Is_Active (TS) and then TS.Text (TS.Cur_Token_Start) = ')' then
CurStat.Tree (Cur).Next_Node := 0;
Next_Token (TS); -- Skip ')'
exit;
else
CurStat.Tree (Cur).Next_Node := CurStat.Free;
end if;
if not Is_Active (TS) or else TS.Text (TS.Cur_Token_Start) /= ',' then
Error (ERR_BADPARAMLIST);
end if;
Next_Token (TS); -- Skip ','
end loop;
end Get_Func;
procedure Get_Expr (TS : in out Token_Stream) is
Cur : Node_Position;
P : Natural;
begin
if not Is_Active (TS) then
Error (ERR_BADEXPR);
end if;
-- Determine expression type
if Is_ID (TS) then
Next_Token (TS);
if Is_Active (TS) and then TS.Text (TS.Cur_Token_Start) = '(' then
-- Function call with parameters
Prev_Token (TS);
Get_Func (TS);
else
-- Function call without parameters or variable
Prev_Token (TS);
Cur := CurStat.Free;
begin
-- Possibly boolean
CurStat.Tree (Cur).IValue :=
Boolean'Pos (Boolean'Wide_Value (Cur_Token (TS)));
CurStat.Tree (Cur).NType := NT_BOOLEAN;
CurStat.Tree (Cur).NValue := 0;
CurStat.Tree (Cur).Next_Node := 0;
CurStat.Free := CurStat.Free + 1;
Next_Token (TS);
exception
when Constraint_Error =>
-- Value is not boolean
CurStat.Tree (Cur).NType := NT_VARIABLE;
P := Cur_Token (TS)'Length;
CurStat.Tree (Cur).SValue := new Wide_String (1 .. P);
Move (Cur_Token (TS), CurStat.Tree (Cur).SValue.all);
CurStat.Tree (Cur).NValue := 0;
CurStat.Free := CurStat.Free + 1;
Next_Token (TS);
end;
end if;
else
if Cur_Token (TS) (TS.Cur_Token_Start) = '"' then
-- String
Cur := CurStat.Free;
CurStat.Tree (Cur).NType := NT_STRING;
declare
S : Wide_String (1 .. Cur_Token (TS)'Length - 2);
C : Natural := 0;
I : Natural := TS.Cur_Token_Start + 1;
begin
loop
exit when I > TS.Cur_Token_End - 1;
C := C + 1;
S (C) := Cur_Token (TS) (I);
if Cur_Token (TS) (I) = '"' then -- Skip double quote
I := I + 1;
end if;
I := I + 1;
end loop;
CurStat.Tree (Cur).SValue := new Wide_String (1 .. C);
CurStat.Tree (Cur).SValue.all := S (1 .. C);
end;
CurStat.Tree (Cur).NValue := 0;
CurStat.Free := CurStat.Free + 1;
Next_Token (TS);
else
if Cur_Token (TS) (TS.Cur_Token_Start) in '0' .. '9' or
Cur_Token (TS) (TS.Cur_Token_Start) = '-'
then
-- Possibly integer
Cur := CurStat.Free;
CurStat.Tree (Cur).NType := NT_INTEGER;
P := Cur_Token (TS)'Length;
CurStat.Tree (Cur).SValue := new Wide_String (1 .. P);
Move (Cur_Token (TS), CurStat.Tree (Cur).SValue.all);
CurStat.Tree (Cur).NValue := 0;
CurStat.Free := CurStat.Free + 1;
Next_Token (TS);
else
-- Unknown or empty expression
Error (ERR_BADEXPR);
end if;
end if;
end if;
end Get_Expr;
procedure Get_Stmt (TS : in out Token_Stream) is
begin
if TS.Cur_Token_Start = 1 and TS.Cur_Token_End = 0 then
-- Initialize token stream
Next_Token (TS);
end if;
if not Is_Active (TS) then
return;
end if;
-- Upper level may only contain functions
Get_Func (TS);
-- The statement may or may not end with semicolon
if Is_Active (TS) and then
Cur_Token (TS) (TS.Cur_Token_Start) = ';' then
Next_Token (TS);
end if;
end Get_Stmt;
end ASIStant.S_Parser;
syntax highlighted by Code2HTML, v. 0.9.1