------------------------------------------------------------------------------
-- --
-- ASIS Tester And iNTerpreter (ASIStant) COMPONENTS --
-- --
-- A S I S T A N T . C A L L --
-- --
-- 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 Asis; use Asis;
with Asis.Compilation_Units.Relations;
use Asis.Compilation_Units.Relations;
with Asis.Data_Decomposition;
with Asis.Errors;
with Asis.Exceptions; use Asis.Exceptions;
with Asis.Implementation;
with ASIStant.Common; use ASIStant.Common;
with ASIStant.S_Parser; use ASIStant.S_Parser;
with ASIStant.XTable; use ASIStant.XTable;
with ASIStant.Text_IO; use ASIStant.Text_IO;
with ASIStant.Ambiguous_Mapping; use ASIStant.Ambiguous_Mapping;
with ASIStant.Add_Ons; use ASIStant.Add_Ons;
with ASIStant.XTable; use ASIStant.XTable;
with ASIStant.String_Handling;
with ASIStant.FuncArr; use ASIStant.FuncArr;
with ASIStant.FuncEnum; use ASIStant.FuncEnum;
package body ASIStant.Call is
------------------------------------------------------------------------------
-- Package for calling of ASIS queries
------------------------------------------------------------------------------
procedure Resolve_Ambiguous (sw : in out Switch_Index; PS : Parameter_Set);
-- Local subprogram:
-- Attempts to find a current name/profile in the ambiguous queries list
-- (also see asistant.ambiguous_mapping)
function Identify_Function (N : Node_Position)
return Function_Type is
begin
return Function_Type'Wide_Value ("FT_" & CurStat.Tree (N).SValue.all);
exception
when Constraint_Error => return FT_CALL;
end Identify_Function;
procedure Resolve_Ambiguous
(sw : in out Switch_Index;
PS : Parameter_Set)
is
Amb : Amb_Index;
Match : Boolean;
begin
Amb := Amb_Index'Value (Switch_Index'Image (sw));
for i in 1 .. AI_LENGTH loop
exit when Amb_Info (Amb, i).New_Index = Invalid_Index;
Match := True;
for j in Parameter_Range loop
if Amb_Info (Amb, i).Synt (j) /= PS (j).RType then
Match := False;
exit;
end if;
end loop;
if Match then
sw := Amb_Info (Amb, i).New_Index;
return;
end if;
end loop;
Error (ERR_UNKNOWNSYNTAX, Switch_Index'Wide_Image (sw));
exception
when Constraint_Error => null;
-- it just means no overloading for a given query
end Resolve_Ambiguous;
function Call_ASIStant_Function
(N : Wide_String;
PS : Parameter_Set)
return Query_Result
is
sw : Switch_Index;
Match : Boolean;
Local : Boolean := True;
Key : Natural;
Name : Wide_String (N'Range) := N;
begin
ASIStant.String_Handling.To_Upper (Name);
begin
if Name = "AND" then
return (Par_Boolean, PS (1).B and PS (2).B);
elsif Name = "OR" then
return (Par_Boolean, PS (1).B or PS (2).B);
elsif Name = "NOT" then
return (Par_Boolean, not PS (1).B);
elsif Name = "LENGTH" then
return (Par_Integer, Length (PS (1)));
else
Local := False;
sw := Switch_Index'Wide_Value (Name);
end if;
exception
when Constraint_Error =>
if Local then
Error (ERR_BADPARAM, "for query " & Name);
else
Error (ERR_UNKNOWNQUERY, Name);
end if;
end;
ATIPut_Line ("Calling query " & Name, 0);
Resolve_Ambiguous (sw, PS);
-- Determine key and check syntax
for i in Switch_Info'Range loop
if sw in Switch_Info (i).From .. Switch_Info (i).To then
Key := Switch_Info (i).SelectID;
Match := True;
for j in Parameter_Range loop
if Switch_Info (i).Synt (j) /= PS (j).RType then
Match := False;
exit;
end if;
end loop;
if not Match then
Error (ERR_UNKNOWNSYNTAX, Name);
end if;
exit;
end if;
end loop;
case Key is
when 10 => -- CtxRetBool
return (Par_Boolean,
FCtxRetBool (sw) (ATIContext (PS (1).I))
);
when 20 => -- CtxRetCUnitList
return
(Par_CUnitList,
Save_CUnitList (FCtxRetCUnitList (sw) (ATIContext (PS (1).I))));
when 30 => -- CtxRetElemList
return
(Par_ElemList,
Save_ElemList (FCtxRetElemList (sw) (ATIContext (PS (1).I))));
when 40 => -- CtxRetNull
FCtxRetNull (sw) (ATIContext (PS (1).I));
return (RType => Par_Absent);
when 50 => -- CtxRetString
return (Par_String,
Save_String (FCtxRetString (sw) (ATIContext (PS (1).I))));
when 60 => -- CtxStringStringRetNull
FCtxStringStringRetNull (sw)
(ATIContext (PS (1).I), PS (2).S.all, PS (3).S.all);
return (RType => Par_Absent);
when 70 => -- CUnitBoolRetElemList
return (Par_ElemList,
Save_ElemList (FCUnitBoolRetElemList (sw)
(PS (1).C, PS (2).B)));
when 80 => -- CUnitCtxRetCUnit
return (Par_CUnit,
FCUnitCtxRetCUnit (sw) (PS (1).C, ATIContext (PS (2).I)));
when 90 => -- CUnitCtxRetCUnitList
return (Par_CUnitList,
Save_CUnitList (FCUnitCtxRetCUnitList (sw)
(PS (1).C, ATIContext (PS (2).I))));
when 93 => -- CUnitCUnitRetBool
return (Par_Boolean,
FCUnitCUnitRetBool (sw) (PS (1).C, PS (2).C));
when 95 => -- CUnitIntIntRetElem
return (Par_Element,
FCUnitIntIntRetElem (sw) (PS (1).C, PS (2).I, PS (3).I));
when 97 => -- CUnitListCtxRetRelship
return (Par_Relationship,
Save_Relship (FCUnitListCtxRetRelship (sw)
(PS (1).CL.all, ATIContext (PS (2).I))));
when 98 => -- CUnitListCUnitListCtxStringRetRelship
return (Par_Relationship,
Save_Relship (FCUnitListCUnitListCtxStringRetRelship (sw)
(PS (1).CL.all, PS (2).CL.all, ATIContext (PS (3).I),
PS (4).S.all)));
when 100 => -- CUnitListRetBool
return (Par_Boolean,
FCUnitListRetBool (sw) (PS (1).CL.all));
-- when 105 => -- CUnitListRetInt
-- return (Par_Integer,
-- FCUnitListRetInt (sw) (PS (1).CL.all));
when 110 => -- CUnitRetBool
return (Par_Boolean,
FCUnitRetBool (sw) (PS (1).C));
when 130 => -- CUnitRetCUnit
return (Par_CUnit,
FCUnitRetCUnit (sw) (PS (1).C));
when 140 => -- CUnitRetCUnitList
return (Par_CUnitList,
Save_CUnitList (FCUnitRetCUnitList (sw) (PS (1).C)));
when 150 => -- CUnitRetElem
return (Par_Element,
FCUnitRetElem (sw) (PS (1).C));
when 160 => -- CUnitRetElemList
return (Par_ElemList,
Save_ElemList (FCUnitRetElemList (sw) (PS (1).C)));
when 180 => -- CUnitRetString
return (Par_String,
Save_String (FCUnitRetString (sw) (PS (1).C)));
when 200 => -- CUnitStringRetBool
return (Par_Boolean,
FCUnitStringRetBool (sw) (PS (1).C, PS (2).S.all)
);
when 210 => -- CUnitStringRetString
return (Par_String,
Save_String (FCUnitStringRetString (sw)
(PS (1).C, PS (2).S.all)));
when 212 => -- DDA_ArrCRetDDA_ArrC
return (Par_DDA_Array_Component,
FDDA_ArrCRetDDA_ArrC (sw) (PS (1).AC));
when 214 => -- DDA_ArrCRetDDA_RecCList
return (Par_DDA_Record_Component_List,
Save_DDA_RecCList
(FDDA_ArrCRetDDA_RecCList (sw) (PS (1).AC)));
when 216 => -- DDA_ArrCRetElem
return (Par_Element,
FDDA_ArrCRetElem (sw) (PS (1).AC));
when 217 => -- DDA_RecCRetDDA_ArrC
return (Par_DDA_Array_Component,
FDDA_RecCRetDDA_ArrC (sw) (PS (1).RC));
when 218 => -- DDA_RecCRetDDA_RecCList
return (Par_DDA_Record_Component_List,
Save_DDA_RecCList
(FDDA_RecCRetDDA_RecCList (sw) (PS (1).RC)));
when 219 => -- DDA_RecCRetElem
return (Par_Element,
FDDA_RecCRetElem (sw) (PS (1).RC));
when 220 => -- ElemBoolRetElemList
return (Par_ElemList,
Save_ElemList (FElemBoolRetElemList (sw)
(PS (1).E, PS (2).B)));
when 230 => -- ElemCtxRetElem
return (Par_Element,
FElemCtxRetElem (sw) (PS (1).E, ATIContext (PS (2).I)));
when 240 => -- ElemElemBoolRetBool
return (Par_Boolean,
FElemElemBoolRetBool (sw) (PS (1).E, PS (2).E, PS (3).B));
when 250 => -- ElemElemBoolRetElemList
return (Par_ElemList,
Save_ElemList (FElemElemBoolRetElemList (sw)
(PS (1).E, PS (2).E, PS (3).B)));
when 255 => -- ElemElemRetBool
return (Par_Boolean,
FElemElemRetBool (sw) (PS (1).E, PS (2).E));
when 260 => -- ElemElemRetElem
return (Par_Element,
FElemElemRetElem (sw) (PS (1).E, PS (2).E));
when 265 => -- ElemIntIntRetLineList
return (Par_Line_List,
Save_LineList (FElemIntIntRetLineList (sw)
(PS (1).E, PS (2).I, PS (3).I)));
when 270 => -- ElemListRetBool
return (Par_Boolean,
FElemListRetBool (sw) (PS (1).EL.all));
-- when 275 => -- ElemListRetInt
-- return (Par_Integer,
-- FElemListRetInt (sw) (PS (1).EL.all));
when 280 => -- ElemRetBool
return (Par_Boolean,
FElemRetBool (sw) (PS (1).E));
when 290 => -- ElemRetCUnit
return (Par_CUnit,
FElemRetCUnit (sw) (PS (1).E));
when 293 => -- ElemRetDDA_ArrC
return (Par_DDA_Array_Component,
FElemRetDDA_ArrC (sw) (PS (1).E));
when 295 => -- ElemRetDDA_RecCList
return (Par_DDA_Record_Component_List,
Save_DDA_RecCList (FElemRetDDA_RecCList (sw) (PS (1).E)));
when 300 => -- ElemRetElem
return (Par_Element,
FElemRetElem (sw) (PS (1).E));
when 310 => -- ElemRetElemList
return (Par_ElemList,
Save_ElemList (FElemRetElemList (sw) (PS (1).E)));
when 320 => -- ElemRetInt
return (Par_Integer,
FElemRetInt (sw) (PS (1).E));
when 325 => -- ElemRetLineList
return (Par_Line_List,
Save_LineList (FElemRetLineList (sw) (PS (1).E)));
when 330 => -- ElemRetSpan
return (Par_Span,
FElemRetSpan (sw) (PS (1).E));
when 340 => -- ElemRetString
return (Par_String,
Save_String (Wide_String (FElemRetString (sw)
(PS (1).E))));
when 343 => -- IntIntRetBool
return (Par_Boolean,
FIntIntRetBool (sw) (PS (1).I, PS (2).I));
when 346 => -- IntIntRetInt
return (Par_Integer,
FIntIntRetInt (sw) (PS (1).I, PS (2).I));
when 347 => -- LineRetString
return (Par_String,
Save_String (FLineRetString (sw) (PS (1).L)));
when 348 => -- RelshipRetCUnitList
return (Par_CUnitList,
Save_CUnitList (
FRelshipRetCUnitList (sw) (PS (1).R.all)));
when 350 => -- RetBool
return (Par_Boolean,
FRetBool (sw).all);
when 360 => -- RetCUnit
return (Par_CUnit,
FRetCUnit (sw).all);
when 370 => -- RetCUnitList
return (Par_CUnitList,
Save_CUnitList (Compilation_Unit_List
(FRetCUnitList (sw).all)));
when 380 => -- RetElem
return (Par_Element,
FRetElem (sw).all);
when 390 => -- RetElemList
return (Par_ElemList,
Save_ElemList (Element_List (FRetElemList (sw).all)));
when 405 => -- RetRelship
return (Par_Relationship,
Save_Relship (Relationship (FRetRelship (sw).all)));
when 420 => -- RetString
return (Par_String,
Save_String (Wide_String (FRetString (sw).all)));
when 430 => -- SpanRetBool
return (Par_Boolean,
FSpanRetBool (sw) (PS (1).Sp));
when 435 => -- SpanRetInt
return (Par_Integer,
FSpanRetInt (sw) (PS (1).Sp));
when 440 => -- StringCtxRetCUnit
return (Par_CUnit,
FStringCtxRetCUnit (sw)
(PS (1).S.all, ATIContext (PS (2).I)));
when 450 => -- StringRetNull
FStringRetNull (sw) (PS (1).S.all);
return (RType => Par_Absent);
when 460 => -- StringStringRetBool
return (Par_Boolean,
FStringStringRetBool (sw) (PS (1).S.all, PS (2).S.all));
when 470 => -- StringStringRetString
return (Par_String,
Save_String (FStringStringRetString (sw)
(PS (1).S.all, PS (2).S.all)));
when others => Error (ERR_NOTSUPPORTED, Switch_Index'Wide_Image (sw));
end case;
exception
when ASIStant_ERROR =>
raise ASIStant_ERROR;
when ASIS_Inappropriate_Context |
ASIS_Inappropriate_Container |
ASIS_Inappropriate_Compilation_Unit |
ASIS_Inappropriate_Element |
ASIS_Inappropriate_Line |
ASIS_Inappropriate_Line_Number |
ASIS_Failed =>
ATIPut_Line ("Exception is raised by ASIS query "
& Name & ".", 5);
ATIPut_Line ("Status : " &
Asis.Errors.Error_Kinds'Wide_Image (Asis.Implementation.Status), 5);
ATIPut_Line ("Diagnosis : ", 5);
ATIPut_Line (Asis.Implementation.Diagnosis, 5);
raise ASIStant_ASIS_ERROR;
when others =>
raise;
end Call_ASIStant_Function;
function Save_CUnitList (C : Asis.Compilation_Unit_List)
return CUnitList_Ptr
is
begin
return new Asis.Compilation_Unit_List'(C);
end Save_CUnitList;
function Save_ElemList (E : Asis.Element_List) return ElemList_Ptr is
begin
return new Asis.Element_List'(E);
end Save_ElemList;
function Save_LineList (L : Asis.Text.Line_List) return LineList_Ptr is
begin
return new Asis.Text.Line_List'(L);
end Save_LineList;
function Save_DDA_ArrCList (A : DDA.Array_Component_List)
return DDA_ArrCList_Ptr is
begin
return new DDA.Array_Component_List'(A);
end Save_DDA_ArrCList;
function Save_DDA_RecCList (R : DDA.Record_Component_List)
return DDA_RecCList_Ptr is
begin
return new DDA.Record_Component_List'(R);
end Save_DDA_RecCList;
function Save_String (S : Wide_String) return String_Ptr is
begin
return new Wide_String'(S);
end Save_String;
function Save_Relship (R : Asis.Compilation_Units.Relations.Relationship)
return Relship_Ptr is
begin
return new Asis.Compilation_Units.Relations.Relationship'(R);
end Save_Relship;
end ASIStant.Call;
syntax highlighted by Code2HTML, v. 0.9.1