{----------------------------------------------------------------------------- The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL/MPL-1.1.html Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for the specific language governing rights and limitations under the License. The Original Code is: JvInterpreter.PAS, released on 2002-07-04. The Initial Developers of the Original Code are: Andrei Prygounkov Copyright (c) 1999, 2002 Andrei Prygounkov All Rights Reserved. Contributor(s): Dmitry Osinovsky, Peter Thornqvist, Olga Kobzar Peter Schraut (http://www.console-de.de) Portions created by Dmitry Osinovsky and Olga Kobzar are Copyright (C) 2003 ProgramBank Ltd. All Rights Reserved. You may retrieve the latest version of this file at the Project JEDI's JVCL home page, located at http://jvcl.sourceforge.net component : JvInterpreterProgram and more.. description : JVCL Interpreter version 2 Known Issues: String fields in records binded from Delphi don't work -----------------------------------------------------------------------------} // $Id: JvInterpreter.pas,v 1.60 2004/12/28 14:14:19 ahuser Exp $ { history (JVCL Library versions): 1.10: - first release; 1.12: - method HandleException removed as bugged; - method UpdateExceptionPos now fill error message with error Unit name and Line pos; - fixed bug in TJvInterpreterUnit.Assignment method; - new public property BaseErrLine used in UpdateExceptionPos; 1.17.7: - local "const" statement for functions; - global variables and constants - scope on all units - not normal !; - OnGetValue and OnSetValue now called before call to Adapter; - fixed bug with "Break" statement inside "for" loop; 1.17.10: - fixed(?) bug with "begin/end" statement in "else" part of "if" statement; - fixed few bugs in ole automation support; 1.21.2 (RALib 1.21 Update 2): - fixed bug with multiple external functions defintions (greetings to Peter Fischer-Haaser) - fixed AV-bug in TJvInterpreterFunction.InFunction if errors in source occured (greetings to Andre N Belokon) 1.21.4 (RALib 1.21 Update 4): - fixed bugs in "if" and "while" with "begin" statements; - "div" and "mod" now working; 1.21.6 (RALib 1.21 Update 6): - fixed bug with incorrect error line and unit name if erorr occured in used unit (greetings to Dmitry Mokrushin) - add parameters check (not fully functional - only count checked) in source fucntion calls; 1.31.2 (RALib 1.31 Update 2): - fixed bug: sometimes compare-operators ('=', '>', ...) in expressions do not working. 1.31.4 (RALib 1.31 Update 4): - fixed bug: plus and minus operators after symbol ']' not working. 1.31.5 (RALib 1.31 Update 5): - function Statement1 is changed; this remove many bugs and add new ones. - fixed many bug in exception handling statements and in nested "begin/end" statements; - fixed error with source function with TObject (and descendants) returning values; 1.41.1: - another fix for bug with incorrect error line and unit name if erorr occurred in used unit; - fixed bug with "Break" statement; - "exit" statement; - "repeat" loop; 1.50: - behavior of "UseGlobalAdapter" property was changed; in previous versions each TJvInterpreterExpression component creates its own copy of GlobalAdapter and then manage it own copy, but now TJvInterpreterExpression manages two adapters: own and global, so GlobalJvInterpreterAdapter now is used by all TJvInterpreterExpressions; performance of "Compile" function increased (there is no necessity more to Assign adapters) (20 msec on my machine with JvInterpreter_all unit) and memory requirement decreased; - sorting in TJvInterpreterAdapter dramatically increase its performance speed; - fixed bug in "except/on" statement; 1.51: - arrays as local and global variables. supports simple types (Integer, double, string, tdatetime, object). Added by Andrej Olejnik (olej att asset dott sk); - type conversion with Integer, string, TObject,... keywords; 1.51.2: - array support was rewritten; enhanced indexes support: default indexed properties, access to chars in strings. Many changes are made to make this possible: new methods: GetElement, SetElement; - record support is simplified; - new property TJvInterpreterExpression.Error provide extended error information about non-interpreter errors. - "case" statement; not fully implemented - only one expression for one block. 1.52: - TJvInterpreterExpression.JvInterpreterAdapter property renamed to Adapter; - new public property TJvInterpreterExpression.SharedAdapter, setting to GlobalJvInterpreterAdapter by default. This allows to create set of global adapters, shared between TJvInterpreterExpression components; - property TJvInterpreterExpression.GlobalAdapter removed; setting SharedAdapter to nil has same effect as GlobalAdapter := False; - fixed memory bug in event handling; - new: unit name in uses list can be placed in quotes and contains any symbols; - fixed bug: selector in case-statement not working with variables (only constants) 1.53: - fixed bug: "Type mistmatch error" in expressions with OleAutomation objects; - fixed bug: error while assign function's result to object's published property; - call to external functions (placed in dll) in previous versions always return Integer, now it can return Boolean, if declared so; 1.54: - new: in call to external function var-parameters are supported for Integer type; - new: after call to external function (placed in dll) last win32 error is restored correctly; in previous versions it was overriden by call to FreeLibrary; - fixed bug: memory leak: global variables and constants not allways be freed; 1.60: - bug fixed in case-statement; - new: global variables and constants in different units now can have identical names; - new: constants, variables and functions can have prefix with unit name and point to determine appropriate unit; - new: class declaration for forms (needed for TJvInterpreterFm component); - bug fixed: record variables do not work; 1.61: - bug fixed: variable types are not always kept the same when assigning values to them; thanks to Ritchie Annand (RitchieA att malibugroup dott com); - bug fixed: exceptions, raised in dll calls produce AV. fix: exception of class Exception is raised. - new internal: LocalVars property in TJvInterpreterFunction (it is used in TJvInterpreterFm). 2.00: - Delphi 6 compatibility; - Kylix 1 compatibility; - exception handling was rewriten in more portable way, ChangeTopException function is not used anymore; - fixed bug: intefrace section was not processed correct (Thanks to Ivan Ravin); Upcoming JVCL 3.00 - major code cleanups - introduced data type system for variables and record fields initializations - interface (IInterface, IUnknown) method call support, see AddIntfGet - record declaration support - arrays of records, arrays of arrays - dynamic arrays - variant array support - arrays as parameters to Delphi procedures (sorry, no support for arrays as procedure parameters) - fixed record bugs with Delphi 6 - fixed OLE bugs - (rom) added fix for default properties from ivan_ra 26 Dec 2003 - (wap) fixed bug: memory leak in local-function LeaveFunction, part of TJvInterpreterFunction.InFunction. See code marker VARLEAKFIX. (Fix suggested by ivan_ra att mail dott ru) - bug fixed: exceptions, raised in Assign nil to Method property - dejoy-2004-3-13 - fixed Character '"' error in SkipToEnd from dejoy 2004-5-25; - peter schraut added shl, shr and xor support } unit JvInterpreter; {$I jvcl.inc} {.$DEFINE JvInterpreter_DEBUG} interface uses SysUtils, Classes, {$IFDEF MSWINDOWS} Windows, {$ENDIF MSWINDOWS} {$IFDEF HAS_UNIT_VARIANTS} Variants, {$ENDIF HAS_UNIT_VARIANTS} JvInterpreterParser, JvComponent; const // (rom) renamed to longer names { max arguments to functions - small values increase performance } cJvInterpreterMaxArgs = 32; { max fields allowed in records } cJvInterpreterMaxRecFields = 32; // (rom) added cJvInterpreterStackMax = 199; { Max available dimensions for arrays } JvInterpreter_MAX_ARRAY_DIMENSION = 10; type { argument definition } PValueArray = ^TValueArray; TValueArray = array [0..cJvInterpreterMaxArgs] of Variant; PTypeArray = ^TTypeArray; TTypeArray = array [0..cJvInterpreterMaxArgs] of Word; PNameArray = ^TNameArray; TNameArray = array [0..cJvInterpreterMaxArgs] of string; {$IFNDEF COMPILER6_UP} TVarType = Word; {$ENDIF COMPILER6_UP} TJvInterpreterArgs = class; IJvInterpreterDataType = interface; TJvInterpreterGetValue = procedure(Sender: TObject; Identifier: string; var Value: Variant; Args: TJvInterpreterArgs; var Done: Boolean) of object; TJvInterpreterSetValue = procedure(Sender: TObject; Identifier: string; const Value: Variant; Args: TJvInterpreterArgs; var Done: Boolean) of object; TJvInterpreterGetUnitSource = procedure(UnitName: string; var Source: string; var Done: Boolean) of object; TJvInterpreterAdapterGetValue = procedure(var Value: Variant; Args: TJvInterpreterArgs); TJvInterpreterAdapterSetValue = procedure(const Value: Variant; Args: TJvInterpreterArgs); TJvInterpreterAdapterNewRecord = procedure(var Value: Pointer); TJvInterpreterAdapterDisposeRecord = procedure(const Value: Pointer); TJvInterpreterAdapterCopyRecord = procedure(var Dest: Pointer; const Source: Pointer); POpenArray = ^TOpenArray; TOpenArray = array [0..cJvInterpreterMaxArgs] of TVarRec; TJvInterpreterRecField = record Identifier: string; Offset: Integer; Typ: Word; DataType: IJvInterpreterDataType; end; TJvInterpreterArgs = class(TObject) private FVarNames: TNameArray; FHasVars: Boolean; { open array parameter support } { allocates memory only if necessary } FOAV: PValueArray; { open array values } public Identifier: string; Count: Integer; Types: TTypeArray; Values: TValueArray; Names: TNameArray; HasResult: Boolean; { = False, if result not needed - used by calls to OLE automation servers } Assignment: Boolean; { internal } Obj: TObject; ObjTyp: Word; { varObject, varClass, varUnknown } ObjRefHolder: Variant; { if ObjType is varDispatch or varUnknown, then we need to hold a reference to it } Indexed: Boolean; // if True then Args contain Indexes to Identifier ReturnIndexed: Boolean; // established by GetValue function, indicating // what Args used as indexed (matters only if Indexed = True) public { open array parameter support } OA: POpenArray; { open array } OAS: Integer; { open array size } destructor Destroy; override; procedure Clear; procedure OpenArray(const Index: Integer); procedure Delete(const Index: Integer); end; { function descriptor } TJvInterpreterFunctionDesc = class(TObject) private FUnitName: string; FIdentifier: string; FClassIdentifier: string; { class name, if function declared as TClassIdentifier.Identifier} FParamCount: Integer; { - 1..cJvInterpreterMaxArgs } FParamTypes: TTypeArray; FParamTypeNames: TNameArray; //dejoy added FParamNames: TNameArray; FResTyp: Word; FResTypName: string; FResDataType: IJvInterpreterDataType; FPosBeg: Integer; { position in source } FPosEnd: Integer; function GetParamName(Index: Integer): string; function GetParamType(Index: Integer): Word; function GetParamTypeNames(Index: Integer): string; function GetDefine: string; public property UnitName: string read FUnitName; property Identifier: string read FIdentifier; property ClassIdentifier: string read FClassIdentifier; property Define: string read GetDefine; property ParamCount: Integer read FParamCount; property ParamTypes[Index: Integer]: Word read GetParamType; property ParamNames[Index: Integer]: string read GetParamName; property ParamTypeNames[Index: Integer]: string read GetParamTypeNames; //dejoy added property ResTyp: Word read FResTyp; property ResTypName: string read FResTypName; property ResDataType: IJvInterpreterDataType read FResDataType; property PosBeg: Integer read FPosBeg; property PosEnd: Integer read FPosEnd; end; TSimpleEvent = procedure of object; TJvInterpreterExpression = class; EJvInterpreterError = class; TJvInterpreterEvent = class(TObject) private FOwner: TJvInterpreterExpression; FInstance: TObject; FUnitName: string; FFunctionName: string; FPropName: string; FArgs: TJvInterpreterArgs; function GetArgs: TJvInterpreterArgs; protected constructor Create(AOwner: TJvInterpreterExpression; AInstance: TObject; const AUnitName, AFunctionName, APropName: string); virtual; function CallFunction(Args: TJvInterpreterArgs; Params: array of Variant): Variant; property Args: TJvInterpreterArgs read GetArgs; property Owner: TJvInterpreterExpression read FOwner; property Instance: TObject read FInstance; property UnitName: string read FUnitName; property FunctionName: string read FFunctionName; property PropName: string read FPropName; public destructor Destroy; override; end; TJvInterpreterEventClass = class of TJvInterpreterEvent; { variable holder } TJvInterpreterVar = class(TObject) public UnitName: string; Identifier: string; Typ: string; VTyp: Word; Value: Variant; public destructor Destroy; override; end; { variables list } TJvInterpreterVarList = class(TList) public destructor Destroy; override; procedure Clear; override; procedure AddVar(const UnitName, Identifier, Typ: string; VTyp: Word; const Value: Variant; DataType: IJvInterpreterDataType); function FindVar(const UnitName, Identifier: string): TJvInterpreterVar; procedure DeleteVar(const UnitName, Identifier: string); function GetValue(const Identifier: string; var Value: Variant; Args: TJvInterpreterArgs): Boolean; function SetValue(const Identifier: string; const Value: Variant; Args: TJvInterpreterArgs): Boolean; end; { notes about TJvInterpreterVarList implementation: - list must allow to contain more than one Var with same name; - FindVar must return last added Var with given name; - DeleteVar must delete last added Var with given name; } TJvInterpreterIdentifier = class(TObject) public UnitName: string; Identifier: string; Data: Pointer; // provided by user when call to adapter's addxxx methods end; TJvInterpreterIdentifierList = class(TList) private FDuplicates: TDuplicates; public function IndexOf(const UnitName, Identifier: string): TJvInterpreterIdentifier; function Find(const Identifier: string; var Index: Integer): Boolean; procedure Sort(Compare: TListSortCompare = nil); virtual; property Duplicates: TDuplicates read FDuplicates write FDuplicates; end; TJvInterpreterMethodList = class(TJvInterpreterIdentifierList) public procedure Sort(Compare: TListSortCompare = nil); override; end; IJvInterpreterDataType = interface ['{8C5E4071-65AB-11D7-B235-00A0D2043DC7}'] procedure Init(var V: Variant); function GetTyp: Word; end; //dejoy change begin //move from implementation section to interface section TParamCount = -1..cJvInterpreterMaxArgs; TCallConvention = set of (ccFastCall, ccStdCall, ccCDecl, ccDynamic, ccVirtual, ccClass); { Adapter classes - translates data from JvInterpreter calls to Delphi functions } TJvInterpreterSrcUnit = class(TJvInterpreterIdentifier) private FSource: string; FUsesList: TNameArray; public function UsesList: TNameArray; property Source: string read FSource; // Removed because BCB doesn't support it //property UsesList: TNameArray read FUsesList; end; TJvInterpreterMethod = class(TJvInterpreterIdentifier) protected FClassType: TClass; ParamCount: TParamCount; ParamTypes: TTypeArray; { varInteger, varString, .. } ResTyp: Word; { varInteger, varString, .. } Func: Pointer; { TJvInterpreterAdapterGetValue or TJvInterpreterAdapterSetValue } end; TJvInterpreterIntfMethod = class(TJvInterpreterIdentifier) protected IID: TGUID; ParamCount: TParamCount; ParamTypes: TTypeArray; { varInteger, varString, .. } ResTyp: Word; { varInteger, varString, .. } Func: Pointer; { TJvInterpreterAdapterGetValue or TJvInterpreterAdapterSetValue } end; TJvInterpreterDMethod = class(TJvInterpreterMethod) protected ResTyp: Word; CallConvention: TCallConvention; end; TJvInterpreterClass = class(TJvInterpreterIdentifier) protected FClassType: TClass; end; TJvInterpreterConst = class(TJvInterpreterIdentifier) protected Value: Variant; end; TJvInterpreterRecFields = array [0..cJvInterpreterMaxRecFields] of TJvInterpreterRecField; TJvInterpreterRecord = class(TJvInterpreterIdentifier) protected RecordSize: Integer; { SizeOf(Rec^) } FieldCount: Integer; Fields: TJvInterpreterRecFields; CreateFunc: TJvInterpreterAdapterNewRecord; DestroyFunc: TJvInterpreterAdapterDisposeRecord; CopyFunc: TJvInterpreterAdapterCopyRecord; procedure AddField(const UnitName, Identifier, Typ: string; VTyp: Word; const Value: Variant; DataType: IJvInterpreterDataType); procedure NewRecord(var Value: Variant); end; TJvInterpreterRecMethod = class(TJvInterpreterIdentifier) protected JvInterpreterRecord: TJvInterpreterRecord; ParamCount: TParamCount; ParamTypes: TTypeArray; { varInteger, varString and so one .. } ResTyp: Word; { varInteger, varString, .. } Func: Pointer; { TJvInterpreterAdapterGetValue or TJvInterpreterAdapterSetValue } end; TJvInterpreterRecHolder = class(TJvInterpreterIdentifier) protected FRecordType: string; JvInterpreterRecord: TJvInterpreterRecord; Rec: Pointer; { data } public constructor Create(const ARecordType: string; ARec: Pointer); destructor Destroy; override; property RecordType: string read FRecordType; end; TJvInterpreterArrayValues = array [0..JvInterpreter_MAX_ARRAY_DIMENSION - 1] of Integer; PJvInterpreterArrayRec = ^TJvInterpreterArrayRec; TJvInterpreterArrayRec = packed record Dimension: Integer; {number of dimensions} BeginPos: TJvInterpreterArrayValues; {starting range for all dimensions} EndPos: TJvInterpreterArrayValues; {ending range for all dimensions} ItemType: Integer; {array type} DT: IJvInterpreterDataType; ElementSize: Integer; {size of element in bytes} Size: Integer; {number of elements in array} Memory: Pointer; {pointer to memory representation of array} end; { interpreter function } TJvInterpreterSrcFunction = class(TJvInterpreterIdentifier) private FFunctionDesc: TJvInterpreterFunctionDesc; public constructor Create; destructor Destroy; override; property FunctionDesc: TJvInterpreterFunctionDesc read FFunctionDesc; //Move From Private section end; { external function } TJvInterpreterExtFunction = class(TJvInterpreterSrcFunction) protected DllInstance: HINST; DllName: string; FunctionName: string; {or} FunctionIndex: Integer; function CallDll(Args: TJvInterpreterArgs): Variant; end; TJvInterpreterEventDesc = class(TJvInterpreterIdentifier) protected EventClass: TJvInterpreterEventClass; Code: Pointer; end; TJvInterpreterRecordDataType = class(TInterfacedObject, IJvInterpreterDataType) protected FRecordDesc: TJvInterpreterRecord; public constructor Create(ARecordDesc: TJvInterpreterRecord); procedure Init(var V: Variant); function GetTyp: Word; end; TJvInterpreterArrayDataType = class(TInterfacedObject, IJvInterpreterDataType) protected FArrayBegin, FArrayEnd: TJvInterpreterArrayValues; FDimension: Integer; FArrayType: Integer; FDT: IJvInterpreterDataType; public constructor Create(AArrayBegin, AArrayEnd: TJvInterpreterArrayValues; ADimension: Integer; AArrayType: Integer; ADT: IJvInterpreterDataType); procedure Init(var V: Variant); function GetTyp: Word; end; TJvInterpreterSimpleDataType = class(TInterfacedObject, IJvInterpreterDataType) protected FTyp: TVarType; public constructor Create(ATyp: TVarType); procedure Init(var V: Variant); function GetTyp: Word; end; PMethod = ^TMethod; { function context - stack } PFunctionContext = ^TFunctionContext; TFunctionContext = record PrevFunContext: PFunctionContext; LocalVars: TJvInterpreterVarList; Fun: TJvInterpreterSrcFunction; end; //dejoy change end { TJvInterpreterAdapter - route JvInterpreter calls to Delphi functions } TJvInterpreterAdapter = class(TObject) private FOwner: TJvInterpreterExpression; FSrcUnitList: TJvInterpreterIdentifierList; // JvInterpreter-units sources FExtUnitList: TJvInterpreterIdentifierList; // internal units; like "system" in delphi FGetList: TJvInterpreterIdentifierList; // methods FSetList: TJvInterpreterIdentifierList; // write properties FIGetList: TJvInterpreterIdentifierList; // read indexed properties FISetList: TJvInterpreterIdentifierList; // write indexed properties FIDGetList: TJvInterpreterIdentifierList; // read default indexed properties FIDSetList: TJvInterpreterIdentifierList; // write default indexed properties FIntfGetList: TJvInterpreterIdentifierList; // interface methods FDirectGetList: TJvInterpreterIdentifierList; // direct get list FClassList: TJvInterpreterIdentifierList; // delphi classes FConstList: TJvInterpreterIdentifierList; // delphi consts FFunctionList: TJvInterpreterIdentifierList; // functions, procedures FRecordList: TJvInterpreterIdentifierList; // records FRecordGetList: TJvInterpreterIdentifierList; // read record field FRecordSetList: TJvInterpreterIdentifierList; // write record field FOnGetList: TJvInterpreterIdentifierList; // chain FOnSetList: TJvInterpreterIdentifierList; // chain FSrcFunctionList: TJvInterpreterIdentifierList; // functions, procedures in JvInterpreter-source FExtFunctionList: TJvInterpreterIdentifierList; FEventHandlerList: TJvInterpreterIdentifierList; FEventList: TJvInterpreterIdentifierList; FSrcVarList: TJvInterpreterVarList; // variables, constants in JvInterpreter-source FSrcClassList: TJvInterpreterIdentifierList; // JvInterpreter-source classes FDisableExternalFunctions: Boolean; FSorted: Boolean; procedure CheckArgs(var Args: TJvInterpreterArgs; ParamCount: Integer; var ParamTypes: TTypeArray); function GetRec(const RecordType: string): TObject; {$IFDEF JvInterpreter_OLEAUTO} function DispatchCall(const Identifier: string; var Value: Variant; Args: TJvInterpreterArgs; Get: Boolean): Boolean; stdcall; {$ENDIF JvInterpreter_OLEAUTO} function GetValueRTTI(const Identifier: string; var Value: Variant; Args: TJvInterpreterArgs): Boolean; function SetValueRTTI(const Identifier: string; const Value: Variant; Args: TJvInterpreterArgs): Boolean; protected procedure CheckAction(Expression: TJvInterpreterExpression; Args: TJvInterpreterArgs; Data: Pointer); virtual; function GetValue(Expression: TJvInterpreterExpression; const Identifier: string; var Value: Variant; Args: TJvInterpreterArgs): Boolean; virtual; function SetValue(Expression: TJvInterpreterExpression; const Identifier: string; const Value: Variant; Args: TJvInterpreterArgs): Boolean; virtual; function GetElement(Expression: TJvInterpreterExpression; const Variable: Variant; var Value: Variant; var Args: TJvInterpreterArgs): Boolean; virtual; function SetElement(Expression: TJvInterpreterExpression; var Variable: Variant; const Value: Variant; var Args: TJvInterpreterArgs): Boolean; virtual; function NewRecord(const RecordType: string; var Value: Variant): Boolean; virtual; function FindFunDesc(const UnitName, Identifier: string): TJvInterpreterFunctionDesc; virtual; procedure CurUnitChanged(const NewUnitName: string; var Source: string); virtual; function UnitExists(const Identifier: string): Boolean; virtual; function IsEvent(Obj: TObject; const Identifier: string): Boolean; virtual; function NewEvent(const UnitName, FunctionName, EventType: string; AOwner: TJvInterpreterExpression; AObject: TObject; const APropName: string): TSimpleEvent; virtual; procedure ClearSource; dynamic; procedure ClearNonSource; dynamic; procedure Sort; dynamic; protected { for internal use } procedure AddSrcClass(JvInterpreterSrcClass: TJvInterpreterIdentifier); virtual; function GetSrcClass(const Identifier: string): TJvInterpreterIdentifier; virtual; public constructor Create(AOwner: TJvInterpreterExpression); destructor Destroy; override; function SetRecord(var Value: Variant): Boolean; virtual; procedure Clear; dynamic; procedure Assign(Source: TJvInterpreterAdapter); dynamic; procedure AddSrcUnit(const Identifier, Source, UsesList: string); dynamic; procedure AddSrcUnitEx(const Identifier, Source, UsesList: string; Data: Pointer); dynamic; procedure AddExtUnit(const Identifier: string); dynamic; procedure AddExtUnitEx(const Identifier: string; Data: Pointer); dynamic; procedure AddClass(const UnitName: string; AClassType: TClass; const Identifier: string); dynamic; procedure AddClassEx(const UnitName: string; AClassType: TClass; const Identifier: string; Data: Pointer); dynamic; procedure AddIntfGet(IID: TGUID; const Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word); procedure AddIntfGetEx(IID: TGUID; const Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word; Data: Pointer); procedure AddGet(AClassType: TClass; const Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word); dynamic; procedure AddGetEx(AClassType: TClass; const Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word; Data: Pointer); dynamic; procedure AddSet(AClassType: TClass; const Identifier: string; SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word); dynamic; procedure AddSetEx(AClassType: TClass; const Identifier: string; SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word; Data: Pointer); dynamic; procedure AddIGet(AClassType: TClass; const Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word); dynamic; procedure AddIGetEx(AClassType: TClass; const Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word; Data: Pointer); dynamic; procedure AddISet(AClassType: TClass; const Identifier: string; SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word); dynamic; procedure AddISetEx(AClassType: TClass; const Identifier: string; SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word; Data: Pointer); dynamic; procedure AddIDGet(AClassType: TClass; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word); dynamic; procedure AddIDGetEx(AClassType: TClass; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word; Data: Pointer); dynamic; procedure AddIDSet(AClassType: TClass; SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word); dynamic; procedure AddIDSetEx(AClassType: TClass; SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word; Data: Pointer); dynamic; procedure AddFunction(const UnitName, Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word); dynamic; procedure AddFunctionEx(const UnitName, Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word; Data: Pointer); dynamic; { function AddDGet under construction - don't use it } procedure AddDGet(AClassType: TClass; const Identifier: string; GetFunc: Pointer; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word; CallConvention: TCallConvention); dynamic; procedure AddDGetEx(AClassType: TClass; const Identifier: string; GetFunc: Pointer; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word; CallConvention: TCallConvention; Data: Pointer); dynamic; procedure AddRec(const UnitName, Identifier: string; RecordSize: Integer; Fields: array of TJvInterpreterRecField; CreateFunc: TJvInterpreterAdapterNewRecord; DestroyFunc: TJvInterpreterAdapterDisposeRecord; CopyFunc: TJvInterpreterAdapterCopyRecord); dynamic; procedure AddRecEx(const UnitName, Identifier: string; RecordSize: Integer; Fields: array of TJvInterpreterRecField; CreateFunc: TJvInterpreterAdapterNewRecord; DestroyFunc: TJvInterpreterAdapterDisposeRecord; CopyFunc: TJvInterpreterAdapterCopyRecord; Data: Pointer); dynamic; procedure AddRecGet(const UnitName, RecordType, Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word); dynamic; procedure AddRecGetEx(const UnitName, RecordType, Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word; Data: Pointer); dynamic; procedure AddRecSet(const UnitName, RecordType, Identifier: string; SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word); dynamic; procedure AddRecSetEx(const UnitName, RecordType, Identifier: string; SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word; Data: Pointer); dynamic; procedure AddConst(const UnitName, Identifier: string; Value: Variant); dynamic; procedure AddConstEx(const AUnitName, AIdentifier: string; AValue: Variant; AData: Pointer); dynamic; procedure AddExtFun(const UnitName, Identifier: string; DllInstance: HINST; const DllName, FunctionName: string; FunctionIndex: Integer; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word); dynamic; procedure AddExtFunEx(const AUnitName, AIdentifier: string; ADllInstance: HINST; const ADllName, AFunctionName: string; AFunIndex: Integer; AParamCount: Integer; AParamTypes: array of Word; AResTyp: Word; AData: Pointer); dynamic; procedure AddSrcFun(const UnitName, Identifier: string; PosBeg, PosEnd: Integer; ParamCount: Integer; ParamTypes: array of Word; ParamTypeNames: array of string; //dejoy added ParamNames: array of string; ResTyp: Word; const AResTypName: string; AResDataType: IJvInterpreterDataType; Data: Pointer); dynamic; procedure AddSrcFunEx(const AUnitName, AIdentifier: string; APosBeg, APosEnd: Integer; AParamCount: Integer; AParamTypes: array of Word; AParamTypeNames: array of string; //dejoy added AParamNames: array of string; AResTyp: Word; const AResTypName: string; AResDataType: IJvInterpreterDataType; AData: Pointer); dynamic; procedure AddHandler(const UnitName, Identifier: string; EventClass: TJvInterpreterEventClass; Code: Pointer); dynamic; procedure AddHandlerEx(const AUnitName, AIdentifier: string; AEventClass: TJvInterpreterEventClass; ACode: Pointer; AData: Pointer); dynamic; procedure AddEvent(const UnitName: string; AClassType: TClass; const Identifier: string); dynamic; procedure AddEventEx(const AUnitName: string; AClassType: TClass; const AIdentifier: string; AData: Pointer); dynamic; procedure AddSrcVar(const UnitName, Identifier, Typ: string; VTyp: Word; const Value: Variant; DataType: IJvInterpreterDataType); dynamic; procedure AddOnGet(Method: TJvInterpreterGetValue); dynamic; procedure AddOnSet(Method: TJvInterpreterSetValue); dynamic; public property DisableExternalFunctions: Boolean read FDisableExternalFunctions write FDisableExternalFunctions; //dejoy added begin property SrcUnitList: TJvInterpreterIdentifierList read FSrcUnitList; property ExtUnitList: TJvInterpreterIdentifierList read FExtUnitList; property GetList: TJvInterpreterIdentifierList read FGetList; property SetList: TJvInterpreterIdentifierList read FSetList; property IGetList: TJvInterpreterIdentifierList read FIGetList; property ISetList: TJvInterpreterIdentifierList read FISetList; property IDGetList: TJvInterpreterIdentifierList read FIDGetList; property IDSetList: TJvInterpreterIdentifierList read FIDSetList; property IntfGetList: TJvInterpreterIdentifierList read FIntfGetList; property DirectGetList: TJvInterpreterIdentifierList read FDirectGetList; property ClassList: TJvInterpreterIdentifierList read FClassList; property ConstList: TJvInterpreterIdentifierList read FConstList; property FunctionList: TJvInterpreterIdentifierList read FFunctionList; property RecordList: TJvInterpreterIdentifierList read FRecordList; property RecordGetList: TJvInterpreterIdentifierList read FRecordGetList; property RecordSetList: TJvInterpreterIdentifierList read FRecordSetList; property OnGetList: TJvInterpreterIdentifierList read FOnGetList; property OnSetList: TJvInterpreterIdentifierList read FOnSetList; property SrcFunctionList: TJvInterpreterIdentifierList read FSrcFunctionList; property ExtFunctionList: TJvInterpreterIdentifierList read FExtFunctionList; property EventHandlerList: TJvInterpreterIdentifierList read FEventHandlerList; property EventList: TJvInterpreterIdentifierList read FEventList; property SrcVarList: TJvInterpreterVarList read FSrcVarList; property SrcClassList: TJvInterpreterIdentifierList read FSrcClassList; //dejoy added end end; TStackPtr = -1..cJvInterpreterStackMax; { Expression evaluator } TJvInterpreterExpression = class(TJvComponent) private FParser: TJvInterpreterParser; FVResult: Variant; FExpStack: array [0..cJvInterpreterStackMax] of Variant; FExpStackPtr: TStackPtr; FToken: Variant; FBacked: Boolean; FTTyp: TTokenKind; FTokenStr: string; FPrevTTyp: TTokenKind; FAllowAssignment: Boolean; FArgs: TJvInterpreterArgs; { data } FCurrArgs: TJvInterpreterArgs; { pointer to current } FPStream: TStream; { parsed source } FParsed: Boolean; FAdapter: TJvInterpreterAdapter; FSharedAdapter: TJvInterpreterAdapter; FCompiled: Boolean; FBaseErrLine: Integer; FOnGetValue: TJvInterpreterGetValue; FOnSetValue: TJvInterpreterSetValue; FLastError: EJvInterpreterError; FDisableExternalFunctions: Boolean; function GetSource: string; procedure SetSource(const Value: string); procedure SetCurPos(Value: Integer); function GetCurPos: Integer; function GetTokenStr: string; procedure ReadArgs; procedure InternalGetValue(Obj: Pointer; ObjTyp: Word; var Result: Variant); function CallFunction(const FunctionName: string; Args: TJvInterpreterArgs; Params: array of Variant): Variant; virtual; abstract; function CallFunctionEx(Instance: TObject; const UnitName: string; const FunctionName: string; Args: TJvInterpreterArgs; Params: array of Variant): Variant; virtual; abstract; procedure SetDisableExternalFunctions(const Value: Boolean); protected procedure UpdateExceptionPos(E: Exception; const UnitName: string); procedure Init; dynamic; procedure ErrorExpected(const Exp: string); procedure ErrorNotImplemented(const Msg: string); function PosBeg: Integer; function PosEnd: Integer; procedure Back; procedure SafeBack; {? please don't use ?} function CreateAdapter: TJvInterpreterAdapter; dynamic; procedure ParseToken; procedure ReadToken; procedure WriteToken; procedure Parse; function Expression1: Variant; function Expression2(const ExpType: Word): Variant; function SetExpression1: Variant; procedure NextToken; function GetValue(const Identifier: string; var Value: Variant; var Args: TJvInterpreterArgs): Boolean; virtual; function SetValue(const Identifier: string; const Value: Variant; var Args: TJvInterpreterArgs): Boolean; virtual; function GetElement(const Variable: Variant; var Value: Variant; var Args: TJvInterpreterArgs): Boolean; virtual; function SetElement(var Variable: Variant; const Value: Variant; var Args: TJvInterpreterArgs): Boolean; virtual; procedure SourceChanged; dynamic; procedure SetAdapter(Adapter: TJvInterpreterAdapter); property Token: Variant read FToken; property TTyp: TTokenKind read FTTyp; property PrevTTyp: TTokenKind read FPrevTTyp; property TokenStr: string read GetTokenStr; property CurPos: Integer read GetCurPos write SetCurPos; property Compiled: Boolean read FCompiled; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Run; dynamic; property Source: string read GetSource write SetSource; property VResult: Variant read FVResult; property OnGetValue: TJvInterpreterGetValue read FOnGetValue write FOnGetValue; property OnSetValue: TJvInterpreterSetValue read FOnSetValue write FOnSetValue; property Adapter: TJvInterpreterAdapter read FAdapter; property SharedAdapter: TJvInterpreterAdapter read FSharedAdapter; property BaseErrLine: Integer read FBaseErrLine write FBaseErrLine; property LastError: EJvInterpreterError read FLastError; property DisableExternalFunctions: Boolean read FDisableExternalFunctions write SetDisableExternalFunctions; end; TParserState = record CurPos: Integer; Token: Variant; TTyp: TTokenKind; PrevTTyp: TTokenKind; Backed: Boolean; AllowAssignment: Boolean; end; TJvInterpreterAddVarFunc = procedure(const UnitName, Identifier, Typ: string; VTyp: Word; const Value: Variant; ADataType: IJvInterpreterDataType) of object; { Function executor } TJvInterpreterFunction = class(TJvInterpreterExpression) private FCurUnitName: string; FCurInstance: TObject; FBreak: Boolean; FContinue: Boolean; FExit: Boolean; FFunctionStack: TList; FFunctionContext: Pointer; { PFunctionContext } FSS: TStringList; FStateStack: array [0..cJvInterpreterStackMax] of TParserState; FStateStackPtr: TStackPtr; FEventList: TList; function GetLocalVars: TJvInterpreterVarList; function GetFunStackCount: Integer; function GetDebugPointerToGlobalVars: TJvInterpreterVarList; function GetDebugPointerToFunStack: Pointer; protected procedure Init; override; procedure PushState; procedure PopState; procedure RemoveState; procedure DoOnStatement; virtual; procedure InFunction(FunctionDesc: TJvInterpreterFunctionDesc); procedure InterpretStatement; procedure SkipStatement; procedure SkipToEnd; procedure SkipToUntil; procedure SkipIdentifier; procedure FindToken(ATTyp: TTokenKind); procedure InterpretVar(AddVarFunc: TJvInterpreterAddVarFunc); procedure InterpretConst(AddVarFunc: TJvInterpreterAddVarFunc); procedure InterpretIdentifier; procedure InterpretBegin; procedure InterpretIf; procedure InterpretWhile; procedure InterpretRepeat; procedure InterpretFor; procedure InterpretCase; procedure InterpretTry; procedure InterpretRaise; function ParseDataType: IJvInterpreterDataType; function NewEvent(const UnitName, FunctionName, EventType: string; Instance: TObject; const APropName: string): TSimpleEvent; function FindEvent(const UnitName: string; Instance: TObject; const PropName: string): TJvInterpreterEvent; procedure InternalSetValue(const Identifier: string); function GetValue(const Identifier: string; var Value: Variant; var Args: TJvInterpreterArgs): Boolean; override; function SetValue(const Identifier: string; const Value: Variant; var Args: TJvInterpreterArgs): Boolean; override; property LocalVars: TJvInterpreterVarList read GetLocalVars; property EventList: TList read FEventList; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Run; override; property CurUnitName: string read FCurUnitName; property CurInstance: TObject read FCurInstance; property FunStackCount: Integer read GetFunStackCount; property DebugPointerToFunStack: Pointer read GetDebugPointerToFunStack; property DebugPointerToGlobalVars: TJvInterpreterVarList read GetDebugPointerToGlobalVars; end; TUnitSection = (usUnknown, usInterface, usImplementation, usInitialization, usFinalization); { Unit executor } TJvInterpreterUnit = class(TJvInterpreterFunction) private FClearUnits: Boolean; FEventHandlerList: TList; FOnGetUnitSource: TJvInterpreterGetUnitSource; FUnitSection: TUnitSection; protected procedure Init; override; procedure ReadFunctionHeader(FunctionDesc: TJvInterpreterFunctionDesc); procedure InterpretUses(var UsesList: string); procedure ReadUnit(const UnitName: string); procedure InterpretFunction; procedure InterpretUnit; procedure InterpretType; procedure InterpretClass(const Identifier: string); function GetValue(const Identifier: string; var Value: Variant; var Args: TJvInterpreterArgs): Boolean; override; function SetValue(const Identifier: string; const Value: Variant; var Args: TJvInterpreterArgs): Boolean; override; function GetUnitSource(const UnitName: string; var Source: string): Boolean; dynamic; procedure ExecFunction(Fun: TJvInterpreterFunctionDesc); procedure SourceChanged; override; procedure InterpretRecord(const Identifier: string); property EventHandlerList: TList read FEventHandlerList; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Run; override; procedure DeclareExternalFunction(const Declaration: string); procedure Compile; function CallFunction(const FunctionName: string; Args: TJvInterpreterArgs; Params: array of Variant): Variant; override; function CallFunctionEx(Instance: TObject; const UnitName: string; const FunctionName: string; Args: TJvInterpreterArgs; Params: array of Variant): Variant; override; function FunctionExists(const UnitName: string; const FunctionName: string): Boolean; property OnGetUnitSource: TJvInterpreterGetUnitSource read FOnGetUnitSource write FOnGetUnitSource; property UnitSection: TUnitSection read FUnitSection; end; { main JvInterpreter component } TJvInterpreterProgram = class(TJvInterpreterUnit) private FPas: TStringList; FOnStatement: TNotifyEvent; function GetPas: TStrings; procedure SetPas(Value: TStrings); protected procedure DoOnStatement; override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure Run; override; published property Pas: TStrings read GetPas write SetPas; property OnGetValue; property OnSetValue; property OnGetUnitSource; property OnStatement: TNotifyEvent read FOnStatement write FOnStatement; end; {$IFDEF COMPILER6_UP} TJvSimpleVariantType = class(TCustomVariantType) public procedure Clear(var V: TVarData); override; procedure Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); override; end; TJvRecordVariantType = class(TJvSimpleVariantType); TJvObjectVariantType = class(TJvSimpleVariantType); TJvClassVariantType = class(TJvSimpleVariantType); TJvPointerVariantType = class(TJvSimpleVariantType); TJvSetVariantType = class(TJvSimpleVariantType); TJvArrayVariantType = class(TJvSimpleVariantType); {$ENDIF COMPILER6_UP} EJvInterpreterError = class(Exception) private FExceptionPos: Boolean; FErrCode: Integer; FErrPos: Integer; FErrName1: string; FErrName2: string; FErrUnitName: string; FErrLine: Integer; FErrMessage: string; public constructor Create(const AErrCode: Integer; const AErrPos: Integer; const AErrName1, AErrName2: string); procedure Assign(E: Exception); procedure Clear; property ErrCode: Integer read FErrCode; property ErrPos: Integer read FErrPos; property ErrName1: string read FErrName1; property ErrName2: string read FErrName2; property ErrUnitName: string read FErrUnitName; property ErrLine: Integer read FErrLine; property ErrMessage: string read FErrMessage; end; {Error raising routines} procedure JvInterpreterError(const AErrCode: Integer; const AErrPos: Integer); procedure JvInterpreterErrorN(const AErrCode: Integer; const AErrPos: Integer; const AErrName: string); procedure JvInterpreterErrorN2(const AErrCode: Integer; const AErrPos: Integer; const AErrName1, AErrName2: string); {Utilities functions} //function LoadStr2(const ResID: Integer): string; { RFD - RecordFieldDefinition - return record needed for TJvInterpreterAdapter.AddRec Fields parameter } function RFD(const Identifier: string; Offset: Integer; Typ: Word): TJvInterpreterRecField; { raise error ieNotImplemented } procedure NotImplemented(const Msg: string); { clear list of TObject } procedure ClearList(List: TList); { additional variant types - TVarData.VType } {$IFDEF COMPILER6_UP} function varRecord: TVarType; function varObject: TVarType; function varClass: TVarType; function varPointer: TVarType; function varSet: TVarType; function varArray: TVarType; {$ELSE} const varRecord = $0015; varObject = $0010; varClass = $0011; varPointer = $0012; varSet = $0013; varArray = $0014; {$ENDIF COMPILER6_UP} { V2O - converts variant to object } function V2O(const V: Variant): TObject; { O2V - converts object to variant } function O2V(O: TObject): Variant; { V2C - converts variant to class } function V2C(const V: Variant): TClass; { O2V - converts class to variant } function C2V(C: TClass): Variant; { V2P - converts variant to pointer } function V2P(const V: Variant): Pointer; { P2V - converts pointer to variant } function P2V(P: Pointer): Variant; { R2V - create record holder and put it into variant } function R2V(const ARecordType: string; ARec: Pointer): Variant; { V2R - returns pointer to record from variant, containing record holder } function V2R(const V: Variant): Pointer; { P2R - returns pointer to record from record holder, typically Args.Obj } function P2R(const P: Pointer): Pointer; { S2V - converts Integer to set and put it into variant } function S2V(const I: Integer): Variant; { V2S - give a set from variant and converts it to Integer } function V2S(V: Variant): Integer; procedure V2OA(V: Variant; var OA: TOpenArray; var OAValues: TValueArray; var Size: Integer); function TypeName2VarTyp(const TypeName: string): Word; { copy variant variable with all JvInterpreter variant extension } procedure JvInterpreterVarCopy(var Dest: Variant; const Source: Variant); { copy variant variable for assignment } procedure JvInterpreterVarAssignment(var Dest: Variant; const Source: Variant); function JvInterpreterVarAsType(const V: Variant; const VarType: Integer): Variant; { properly free var variable and set it content to empty } procedure JvInterpreterVarFree(var V: Variant); { compare strings } function Cmp(const S1, S2: string): Boolean; { For dynamic array support} procedure JvInterpreterArraySetLength(AArray: Variant; ASize: Integer); function JvInterpreterArrayLength(const AArray: Variant): Integer; function JvInterpreterArrayLow(const AArray: Variant): Integer; function JvInterpreterArrayHigh(const AArray: Variant): Integer; procedure JvInterpreterArrayElementDelete(AArray: Variant; AElement: Integer); procedure JvInterpreterArrayElementInsert(AArray: Variant; AElement: Integer; Value: Variant); function GlobalJvInterpreterAdapter: TJvInterpreterAdapter; const prArgsNoCheck = -1; noInstance = HINST(0); RFDNull: TJvInterpreterRecField = (Identifier: ''; Offset: 0; Typ: 0); varByConst = $8000; {JvInterpreter error codes} ieOk = 0; { Okay - no errors } ieUnknown = 1; ieInternal = 2; ieUserBreak = 3; { internal } ieRaise = 4; { internal } ieErrorPos = 5; ieExternal = 6; { non-interpreter error } ieAccessDenied = 7; ieExpressionStackOverflow = 8; { register-time errors } ieRegisterBase = 30; ieRecordNotDefined = ieRegisterBase + 1; { run-time errors } ieRuntimeBase = 50; ieStackOverFlow = ieRuntimeBase + 2; ieTypeMistmatch = ieRuntimeBase + 3; ieIntegerOverflow = ieRuntimeBase + 4; ieMainUndefined = ieRuntimeBase + 5; ieUnitNotFound = ieRuntimeBase + 6; ieEventNotRegistered = ieRuntimeBase + 7; ieDfmNotFound = ieRuntimeBase + 8; { syntax errors (now run-timed) } ieSyntaxBase = 100; ieBadRemark = ieSyntaxBase + 1; { Bad remark - detected by parser } ieIdentifierExpected = ieSyntaxBase + 2; ieExpected = ieSyntaxBase + 3; ieUnknownIdentifier = ieSyntaxBase + 4; ieBooleanRequired = ieSyntaxBase + 5; ieClassRequired = ieSyntaxBase + 6; ieNotAllowedBeforeElse = ieSyntaxBase + 7; ieIntegerRequired = ieSyntaxBase + 8; ieROCRequired = ieSyntaxBase + 9; ieMissingOperator = ieSyntaxBase + 10; ieIdentifierRedeclared = ieSyntaxBase + 11; { array indexes } ieArrayBase = 170; ieArrayIndexOutOfBounds = ieArrayBase + 1; ieArrayTooManyParams = ieArrayBase + 2; ieArrayNotEnoughParams = ieArrayBase + 3; ieArrayBadDimension = ieArrayBase + 4; ieArrayBadRange = ieArrayBase + 5; ieArrayRequired = ieArrayBase + 6; { function call errors (now run-timed) } ieFunctionBase = 180; ieTooManyParams = ieFunctionBase + 1; ieNotEnoughParams = ieFunctionBase + 2; ieIncompatibleTypes = ieFunctionBase + 3; ieDllErrorLoadLibrary = ieFunctionBase + 4; ieDllInvalidArgument = ieFunctionBase + 5; ieDllInvalidResult = ieFunctionBase + 6; ieDllFunctionNotFound = ieFunctionBase + 7; ieDirectInvalidArgument = ieFunctionBase + 8; ieDirectInvalidResult = ieFunctionBase + 9; ieDirectInvalidConvention = ieFunctionBase + 10; {$IFDEF JvInterpreter_OLEAUTO} ieOleAuto = ieFunctionBase + 21; {$ENDIF JvInterpreter_OLEAUTO} ieUserBase = $300; irExpression = 301; irIdentifier = 302; irDeclaration = 303; irEndOfFile = 304; irClass = 305; irIntegerConstant = 306; irIntegerValue = 307; irStringConstant = 308; irStatement = 309; implementation uses {$IFDEF UNITVERSIONING} JclUnitVersioning, {$ENDIF UNITVERSIONING} TypInfo, {$IFDEF JvInterpreter_OLEAUTO} OleConst, ActiveX, ComObj, {$ENDIF JvInterpreter_OLEAUTO} JvConsts, JvInterpreterConst, JvJVCLUtils, JvJCLUtils, JvResources, JvTypes; var FieldGlobalJvInterpreterAdapter: TJvInterpreterAdapter = nil; function GlobalJvInterpreterAdapter: TJvInterpreterAdapter; begin if not Assigned(FieldGlobalJvInterpreterAdapter) then FieldGlobalJvInterpreterAdapter := TJvInterpreterAdapter.Create(nil); Result := FieldGlobalJvInterpreterAdapter; end; { internal structures } {$IFDEF VisualCLX} type DWORD = Longint; PBool = PBoolean; {$ENDIF VisualCLX} {$IFDEF JvInterpreter_DEBUG} var ObjCount: Integer = 0; {$ENDIF JvInterpreter_DEBUG} {$IFDEF COMPILER6_UP} var GlobalVariantRecordInstance: TJvRecordVariantType = nil; GlobalVariantObjectInstance: TJvObjectVariantType = nil; GlobalVariantClassInstance: TJvClassVariantType = nil; GlobalVariantPointerInstance: TJvPointerVariantType = nil; GlobalVariantSetInstance: TJvSetVariantType = nil; GlobalVariantArrayInstance: TJvArrayVariantType = nil; function VariantRecordInstance: TJvRecordVariantType; begin if not Assigned(GlobalVariantRecordInstance) then GlobalVariantRecordInstance := TJvRecordVariantType.Create; Result := GlobalVariantRecordInstance; end; function VariantObjectInstance: TJvObjectVariantType; begin if not Assigned(GlobalVariantObjectInstance) then GlobalVariantObjectInstance := TJvObjectVariantType.Create; Result := GlobalVariantObjectInstance; end; function VariantClassInstance: TJvClassVariantType; begin if not Assigned(GlobalVariantClassInstance) then GlobalVariantClassInstance := TJvClassVariantType.Create; Result := GlobalVariantClassInstance; end; function VariantPointerInstance: TJvPointerVariantType; begin if not Assigned(GlobalVariantPointerInstance) then GlobalVariantPointerInstance := TJvPointerVariantType.Create; Result := GlobalVariantPointerInstance; end; function VariantSetInstance: TJvSetVariantType; begin if not Assigned(GlobalVariantSetInstance) then GlobalVariantSetInstance := TJvSetVariantType.Create; Result := GlobalVariantSetInstance; end; function VariantArrayInstance: TJvArrayVariantType; begin if not Assigned(GlobalVariantArrayInstance) then GlobalVariantArrayInstance := TJvArrayVariantType.Create; Result := GlobalVariantArrayInstance; end; //=== { TJvSimpleVariantType } =============================================== procedure TJvSimpleVariantType.Clear(var V: TVarData); begin SimplisticClear(V); end; procedure TJvSimpleVariantType.Copy(var Dest: TVarData; const Source: TVarData; const Indirect: Boolean); begin SimplisticCopy(Dest, Source, Indirect); end; function varRecord: TVarType; begin Result := VariantRecordInstance.VarType; end; function varObject: TVarType; begin Result := VariantObjectInstance.VarType end; function varClass: TVarType; begin Result := VariantClassInstance.VarType; end; function varPointer: TVarType; begin Result := VariantPointerInstance.VarType; end; function varSet: TVarType; begin Result := VariantSetInstance.VarType; end; function varArray: TVarType; begin Result := VariantArrayInstance.VarType; end; {$ENDIF COMPILER6_UP} //=== EJvInterpreterError ==================================================== function LoadStr2(const ResID: Integer): string; var I: Integer; begin for I := Low(JvInterpreterErrors) to High(JvInterpreterErrors) do if JvInterpreterErrors[I].ID = ResID then begin Result := JvInterpreterErrors[I].Description; Break; end; end; procedure JvInterpreterError(const AErrCode: Integer; const AErrPos: Integer); begin raise EJvInterpreterError.Create(AErrCode, AErrPos, '', ''); end; procedure JvInterpreterErrorN(const AErrCode: Integer; const AErrPos: Integer; const AErrName: string); begin raise EJvInterpreterError.Create(AErrCode, AErrPos, AErrName, ''); end; procedure JvInterpreterErrorN2(const AErrCode: Integer; const AErrPos: Integer; const AErrName1, AErrName2: string); begin raise EJvInterpreterError.Create(AErrCode, AErrPos, AErrName1, AErrName2); end; constructor EJvInterpreterError.Create(const AErrCode: Integer; const AErrPos: Integer; const AErrName1, AErrName2: string); begin inherited Create(''); FErrCode := AErrCode; FErrPos := AErrPos; FErrName1 := AErrName1; FErrName2 := AErrName2; { function LoadStr don't work sometimes :-( } Message := Format(LoadStr2(ErrCode), [ErrName1, ErrName2]); FErrMessage := Message; end; procedure EJvInterpreterError.Assign(E: Exception); begin Message := E.Message; if E is EJvInterpreterError then begin FErrCode := (E as EJvInterpreterError).ErrCode; FErrPos := (E as EJvInterpreterError).ErrPos; FErrName1 := (E as EJvInterpreterError).ErrName1; FErrName2 := (E as EJvInterpreterError).ErrName2; FErrMessage := (E as EJvInterpreterError).ErrMessage; end; end; procedure EJvInterpreterError.Clear; begin FExceptionPos := False; FErrName1 := ''; FErrName2 := ''; FErrPos := -1; FErrLine := -1; FErrUnitName := ''; end; function V2O(const V: Variant): TObject; begin Result := TVarData(V).VPointer; end; function O2V(O: TObject): Variant; begin TVarData(Result).VType := varObject; TVarData(Result).VPointer := O; end; function V2C(const V: Variant): TClass; begin Result := TVarData(V).VPointer; end; function C2V(C: TClass): Variant; begin TVarData(Result).VType := varClass; TVarData(Result).VPointer := C; end; function V2P(const V: Variant): Pointer; begin Result := TVarData(V).VPointer; end; function P2V(P: Pointer): Variant; begin TVarData(Result).VType := varPointer; TVarData(Result).VPointer := P; end; function R2V(const ARecordType: string; ARec: Pointer): Variant; begin TVarData(Result).VPointer := TJvInterpreterRecHolder.Create(ARecordType, ARec); TVarData(Result).VType := varRecord; end; function V2R(const V: Variant): Pointer; begin if (TVarData(V).VType <> varRecord) or not (TObject(TVarData(V).VPointer) is TJvInterpreterRecHolder) then JvInterpreterError(ieROCRequired, -1); Result := TJvInterpreterRecHolder(TVarData(V).VPointer).Rec; end; function P2R(const P: Pointer): Pointer; begin if not (TObject(P) is TJvInterpreterRecHolder) then JvInterpreterError(ieROCRequired, -1); Result := TJvInterpreterRecHolder(P).Rec; end; function S2V(const I: Integer): Variant; begin Result := I; TVarData(Result).VType := varSet; end; function V2S(V: Variant): Integer; var I: Integer; begin if (TVarData(V).VType and System.varArray) = 0 then Result := TVarData(V).VInteger else begin { JvInterpreter thinks about all function parameters, started with '[' symbol that they are open arrays; but it may be set constant, so we must convert it now } Result := 0; for I := VarArrayLowBound(V, 1) to VarArrayHighBound(V, 1) do Result := Result or 1 shl Integer(V[I]); end; end; function RFD(const Identifier: string; Offset: Integer; Typ: Word): TJvInterpreterRecField; begin Result.Identifier := Identifier; Result.Offset := Offset; Result.Typ := Typ; end; procedure NotImplemented(const Msg: string); begin JvInterpreterErrorN(ieInternal, -1, Msg + RsENotImplemented); end; //RWare: added check for "char", otherwise function with ref variable //of type char causes AV, like KeyPress event handler function Typ2Size(ATyp: Word): Integer; begin Result := 0; case ATyp of varInteger: Result := SizeOf(Integer); varDouble: Result := SizeOf(Double); varByte: Result := SizeOf(Byte); varSmallint: Result := SizeOf(Smallint); varDate: Result := SizeOf(Double); varEmpty: Result := SizeOf(TVarData); else if ATyp = varObject then Result := SizeOf(Integer); end; end; function TypeName2VarTyp(const TypeName: string): Word; begin // (rom) reimplemented for speed // (rom) LongBool added (untested) Result := varEmpty; if TypeName <> '' then begin case TypeName[1] of 'A', 'a': if Cmp(TypeName, 'AnsiString') then Result := varString; 'B', 'b': if Cmp(TypeName, 'boolean') or Cmp(TypeName, 'bool') then Result := varBoolean else if Cmp(TypeName, 'byte') then Result := varByte; 'C', 'c': if Cmp(TypeName, 'char') then {+RWare} Result := varString; 'D', 'd': if Cmp(TypeName, 'dword') then Result := varInteger else if Cmp(TypeName, 'double') then Result := varDouble; 'I', 'i': if Cmp(TypeName, 'integer') then Result := varInteger; 'L', 'l': if Cmp(TypeName, 'longint') then Result := varInteger else if Cmp(TypeName, 'longbool') then Result := varBoolean; 'P', 'p': if Cmp(TypeName, 'PChar') then Result := varString; 'S', 's': if Cmp(TypeName, 'string') or Cmp(TypeName, 'ShortString') then Result := varString else if Cmp(TypeName, 'smallint') then Result := varSmallint; 'T', 't': if Cmp(TypeName, 'TObject') then Result := varObject else if Cmp(TypeName, 'tdatetime') then Result := varDate; 'W', 'w': if Cmp(TypeName, 'word') then Result := varSmallint else if Cmp(TypeName, 'wordbool') then Result := varBoolean; end; end; end; procedure ClearList(List: TList); var I: Integer; begin if Assigned(List) then begin for I := 0 to List.Count - 1 do TObject(List[I]).Free; List.Clear; end; end; procedure ClearMethodList(List: TList); var I: Integer; begin for I := 0 to List.Count - 1 do Dispose(PMethod(List[I])); List.Clear; end; // (rom) JvUtil added to uses and functions deleted function Cmp(const S1, S2: string): Boolean; begin {$IFDEF VCL} // Direct call to CompareString is faster than AnsiCompareText. Result := (Length(S1) = Length(S2)) and (CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PChar(S1), -1, PChar(S2), -1) = 2); {$ENDIF VCL} {$IFDEF VisualCLX} Result := AnsiCompareText(S1, S2) = 0; {$ENDIF VisualCLX} end; {************* Some code from RAStream unit **************} procedure StringSaveToStream(Stream: TStream; const S: string); var L: Integer; P: PChar; begin L := Length(S); Stream.WriteBuffer(L, SizeOf(L)); P := PChar(S); Stream.WriteBuffer(P^, L); end; function StringLoadFromStream(Stream: TStream): string; var L: Integer; P: PChar; begin Stream.ReadBuffer(L, SizeOf(L)); SetLength(Result, L); P := PChar(Result); Stream.ReadBuffer(P^, L); end; procedure IntSaveToStream(Stream: TStream; AInt: Integer); begin Stream.WriteBuffer(AInt, SizeOf(AInt)); end; function IntLoadFromStream(Stream: TStream): Integer; begin Stream.ReadBuffer(Result, SizeOf(Result)); end; procedure WordSaveToStream(Stream: TStream; AWord: Word); begin Stream.WriteBuffer(AWord, SizeOf(AWord)); end; function WordLoadFromStream(Stream: TStream): Word; begin Stream.ReadBuffer(Result, SizeOf(Result)); end; procedure ExtendedSaveToStream(Stream: TStream; AExt: Extended); begin Stream.WriteBuffer(AExt, SizeOf(AExt)); end; function ExtendedLoadFromStream(Stream: TStream): Extended; begin Stream.ReadBuffer(Result, SizeOf(Result)); end; procedure BoolSaveToStream(Stream: TStream; ABool: Boolean); var B: Integer; begin B := Ord(ABool); Stream.WriteBuffer(B, SizeOf(B)); end; function BoolLoadFromStream(Stream: TStream): Boolean; var B: Integer; begin Stream.ReadBuffer(B, SizeOf(B)); Result := (B <> 0); end; {################## from RAStream unit ##################} {$IFDEF JvInterpreter_OLEAUTO} {************* Some code from Delphi's OleAuto unit **************} const { Maximum number of dispatch arguments } MaxDispArgs = 64; { Special variant type codes } varStrArg = $0048; { Parameter type masks } atVarMask = $3F; atTypeMask = $7F; atByRef = $80; { Call GetIDsOfNames method on the given IDispatch interface } procedure GetIDsOfNames(Dispatch: IDispatch; Names: PChar; NameCount: Integer; DispIDs: PDispIDList); var I, N: Integer; Ch: WideChar; P: PWideChar; NameRefs: array [0..MaxDispArgs - 1] of PWideChar; WideNames: array [0..1023] of WideChar; R: Integer; begin I := 0; N := 0; repeat P := @WideNames[I]; if N = 0 then NameRefs[0] := P else NameRefs[NameCount - N] := P; repeat Ch := WideChar(Names[I]); WideNames[I] := Ch; Inc(I); until Char(Ch) = #0; Inc(N); until N = NameCount; { if Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount, LOCALE_SYSTEM_DEFAULT, DispIDs) <> 0 then } R := Dispatch.GetIDsOfNames(GUID_NULL, @NameRefs, NameCount, LOCALE_SYSTEM_DEFAULT, DispIDs); if R <> 0 then raise EOleError.CreateResFmt(@SNoMethod, [Names]); end; { Central call dispatcher } procedure VarDispInvoke(Result: PVariant; const Dispatch: Pointer; Names: PChar; CallDesc: PCallDesc; ParamTypes: Pointer); cdecl; var DispIDs: array [0..MaxDispArgs - 1] of Integer; begin GetIDsOfNames(IDispatch(Dispatch), Names, CallDesc^.NamedArgCount + 1, PDispIDList(@DispIDs[0])); if Result <> nil then VarClear(Result^); DispatchInvoke(IDispatch(Dispatch), CallDesc, PDispIDList(@DispIDs[0]), ParamTypes, Result); end; {################## from OleAuto unit ##################} {$ENDIF JvInterpreter_OLEAUTO} type TFunc = procedure; TiFunc = function: Integer; TfFunc = function: Boolean; TwFunc = function: Word; function CallDllIns(Ins: HINST; const FuncName: string; Args: TJvInterpreterArgs; ParamDesc: TTypeArray; ResTyp: Word): Variant; var Func: TFunc; iFunc: TiFunc; fFunc: TfFunc; wFunc: TwFunc; I: Integer; AInt: Integer; // Abyte : Byte; AWord: Word; APointer: Pointer; Str: string; begin Result := Null; Func := GetProcAddress(Ins, PChar(FuncName)); iFunc := @Func; fFunc := @Func; wFunc := @Func; if Assigned(Func) then begin try for I := Args.Count - 1 downto 0 do { 'stdcall' call conversion } begin if (ParamDesc[I] and varByRef) = 0 then case ParamDesc[I] of varInteger, { ttByte,} varBoolean: begin AInt := Args.Values[I]; asm push AInt end; end; varSmallint: begin AWord := Word(Args.Values[I]); asm push AWord end; end; varString: begin APointer := PChar(string(Args.Values[I])); asm push APointer end; end; else JvInterpreterErrorN(ieDllInvalidArgument, -1, FuncName); end else case ParamDesc[I] and not varByRef of varInteger, { ttByte,} varBoolean: begin APointer := @TVarData(Args.Values[I]).VInteger; asm push APointer end; end; varSmallint: begin APointer := @TVarData(Args.Values[I]).vSmallInt; asm push APointer end; end; else JvInterpreterErrorN(ieDllInvalidArgument, -1, FuncName); end end; case ResTyp of varSmallint: Result := wFunc; varInteger: Result := iFunc; varBoolean: Result := Boolean(Integer(fFunc)); varEmpty: Func; else JvInterpreterErrorN(ieDllInvalidResult, -1, FuncName); end; except on E: EJvInterpreterError do raise E; on E: Exception do begin Str := E.Message; UniqueString(Str); raise EJVCLException.Create(Str); end; end; end else JvInterpreterError(ieDllFunctionNotFound, -1); end; function CallDll(const DllName, FuncName: string; Args: TJvInterpreterArgs; ParamDesc: TTypeArray; ResTyp: Word): Variant; var Ins: HMODULE; LastError: DWORD; begin Result := False; Ins := LoadLibrary(PChar(DllName)); if Ins = 0 then JvInterpreterErrorN(ieDllErrorLoadLibrary, -1, DllName); try Result := CallDllIns(Ins, FuncName, Args, ParamDesc, ResTyp); LastError := GetLastError; finally FreeLibrary(Ins); end; SetLastError(LastError); end; procedure ConvertParamTypes(InParams: array of Word; var OutParams: TTypeArray); var I: Integer; begin for I := Low(InParams) to High(InParams) do OutParams[I] := InParams[I]; end; procedure ConvertParamNames(InParams: array of string; var OutParams: TNameArray); var I: Integer; begin for I := Low(InParams) to High(InParams) do OutParams[I] := InParams[I]; end; { ************************* Array support ************************* } function GetArraySize(Dimension: Integer; BeginPos, EndPos: TJvInterpreterArrayValues): Integer; var A: Integer; begin Result := 1; for A := 0 to Dimension - 1 do begin Result := Result * ((EndPos[A] - BeginPos[A]) + 1); end; end; { Calculate starting position of element in memory } function GetArrayOffset(Dimension: Integer; BeginPos, EndPos: TJvInterpreterArrayValues; Element: TJvInterpreterArrayValues): Integer; var A: Integer; LastDim: Integer; begin Result := 0; LastDim := 1; for A := 0 to Dimension - 1 do begin if (Element[A] < BeginPos[A]) or (Element[A] > EndPos[A]) then JvInterpreterError(ieArrayIndexOutOfBounds, -1); Result := Result + (LastDim * (Element[A] - BeginPos[A])); LastDim := LastDim * (EndPos[A] - BeginPos[A] + 1); end; end; {Allocate memory for new array} function JvInterpreterArrayInit(const Dimension: Integer; const BeginPos, EndPos: TJvInterpreterArrayValues; const ItemType: Integer; DataType: IJvInterpreterDataType): PJvInterpreterArrayRec; var PP: PJvInterpreterArrayRec; SS: TStringList; AA: Integer; ArraySize: Integer; I: Integer; begin if (Dimension < 1) or (Dimension > cJvInterpreterMaxArgs) then JvInterpreterError(ieArrayBadDimension, -1); for AA := 0 to Dimension - 1 do begin // For dynamic arrays BeginPos[AA] <= EndPos[AA] if (not (BeginPos[AA] <= EndPos[AA])) and (Dimension <> 1) and (BeginPos[AA] <> 0) and (EndPos[AA] <> -1) then JvInterpreterError(ieArrayBadRange, -1); end; New(PP); PP^.BeginPos := BeginPos; PP^.EndPos := EndPos; PP^.ItemType := ItemType; PP^.DT := DataType; ArraySize := GetArraySize(Dimension, BeginPos, EndPos); PP^.Size := ArraySize; PP^.Dimension := Dimension; if ItemType <> varString then PP^.ElementSize := Typ2Size(ItemType) else begin PP^.ElementSize := 0; SS := TStringList.Create; for AA := 1 to ArraySize do SS.Add(''); PP^.Memory := SS; end; if ItemType <> varString then begin GetMem(PP^.Memory, ArraySize * PP^.ElementSize); //ZeroMemory(PP^.Memory, ArraySize * PP^.ElementSize); FillChar(PP^.Memory^, ArraySize * PP^.ElementSize, 0); if ItemType = varEmpty then for I := 0 to ArraySize - 1 do PP^.DT.Init(Variant(PVarData(PChar(PP^.Memory) + I * PP^.ElementSize)^)); end; Result := PP; end; { Free memory for array } procedure JvInterpreterArrayFree(JvInterpreterArrayRec: PJvInterpreterArrayRec); var I: Integer; ArraySize: Integer; begin if not Assigned(JvInterpreterArrayRec) then Exit; ArraySize := GetArraySize(JvInterpreterArrayRec^.Dimension, JvInterpreterArrayRec^.BeginPos, JvInterpreterArrayRec^.EndPos); if JvInterpreterArrayRec^.ItemType <> varString then begin if JvInterpreterArrayRec^.ItemType = varEmpty then for I := 0 to ArraySize - 1 do JvInterpreterVarFree(Variant(PVarData(PChar(JvInterpreterArrayRec^.Memory) + I * JvInterpreterArrayRec^.ElementSize)^)); FreeMem(JvInterpreterArrayRec^.Memory, (JvInterpreterArrayRec^.Size) * JvInterpreterArrayRec^.ElementSize); Dispose(JvInterpreterArrayRec); end else begin TStringList(JvInterpreterArrayRec^.Memory).Clear; TStringList(JvInterpreterArrayRec^.Memory).Free; Dispose(JvInterpreterArrayRec); end; end; { Set element for array } procedure JvInterpreterArraySetElement(Element: TJvInterpreterArrayValues; Value: Variant; JvInterpreterArrayRec: PJvInterpreterArrayRec); var Offset: Integer; begin if JvInterpreterArrayRec^.Dimension > 1 then Offset := GetArrayOffset(JvInterpreterArrayRec^.Dimension, JvInterpreterArrayRec^.BeginPos, JvInterpreterArrayRec^.EndPos, Element) else Offset := Element[0] - JvInterpreterArrayRec^.BeginPos[0]; case JvInterpreterArrayRec^.ItemType of varInteger: PInteger(Pointer(Integer(JvInterpreterArrayRec^.Memory) + (Offset * JvInterpreterArrayRec^.ElementSize)))^ := Value; varDouble: PDouble(Pointer(Integer(JvInterpreterArrayRec^.Memory) + (Offset * JvInterpreterArrayRec^.ElementSize)))^ := Value; varByte: PByte(Pointer(Integer(JvInterpreterArrayRec^.Memory) + (Offset * JvInterpreterArrayRec^.ElementSize)))^ := Value; varSmallint: PSmallInt(Pointer(Integer(JvInterpreterArrayRec^.Memory) + (Offset * JvInterpreterArrayRec^.ElementSize)))^ := Value; varDate: PDouble(Pointer(Integer(JvInterpreterArrayRec^.Memory) + (Offset * JvInterpreterArrayRec^.ElementSize)))^ := Value; varString: begin Value := VarAsType(Value, varString); TStringList(JvInterpreterArrayRec^.Memory).Strings[Offset] := Value; end; varEmpty: JvInterpreterVarAssignment(Variant(PVarData(PChar(JvInterpreterArrayRec^.Memory) + Offset * JvInterpreterArrayRec^.ElementSize)^), Value) else if JvInterpreterArrayRec^.ItemType = varObject then PInteger(Pointer(Integer(JvInterpreterArrayRec^.Memory) + (Offset * JvInterpreterArrayRec^.ElementSize)))^ := TVarData(Value).VInteger; end; end; { Get element for array } function JvInterpreterArrayGetElement(Element: TJvInterpreterArrayValues; JvInterpreterArrayRec: PJvInterpreterArrayRec): Variant; var Offset: Integer; begin if JvInterpreterArrayRec^.Dimension > 1 then Offset := GetArrayOffset(JvInterpreterArrayRec^.Dimension, JvInterpreterArrayRec^.BeginPos, JvInterpreterArrayRec^.EndPos, Element) else Offset := Element[0] - JvInterpreterArrayRec^.BeginPos[0]; case JvInterpreterArrayRec^.ItemType of varInteger: Result := Integer(Pointer(Integer(JvInterpreterArrayRec^.Memory) + ((Offset) * JvInterpreterArrayRec^.ElementSize))^); varDouble: Result := Double(Pointer(Integer(JvInterpreterArrayRec^.Memory) + ((Offset) * JvInterpreterArrayRec^.ElementSize))^); varByte: Result := Byte(Pointer(Integer(JvInterpreterArrayRec^.Memory) + ((Offset) * JvInterpreterArrayRec^.ElementSize))^); varSmallint: Result := SmallInt(Pointer(Integer(JvInterpreterArrayRec^.Memory) + ((Offset) * JvInterpreterArrayRec^.ElementSize))^); varDate: Result := TDateTime(Pointer(Integer(JvInterpreterArrayRec^.Memory) + ((Offset) * JvInterpreterArrayRec^.ElementSize))^); varString: Result := TStringList(JvInterpreterArrayRec^.Memory).Strings[Offset]; varEmpty: JvInterpreterVarCopy(Result, Variant(PVarData(PChar(JvInterpreterArrayRec^.Memory) + Offset * JvInterpreterArrayRec^.ElementSize)^)) else if JvInterpreterArrayRec^.ItemType = varObject then begin Result := Integer(Pointer(Integer(JvInterpreterArrayRec^.Memory) + ((Offset) * JvInterpreterArrayRec^.ElementSize))^); TVarData(Result).VType := varObject; end; end; end; { For dynamic array support } procedure JvInterpreterArraySetLength(AArray: Variant; ASize: Integer); var I: Integer; OldSize: Integer; ArrayRec: PJvInterpreterArrayRec; begin ArrayRec := PJvInterpreterArrayRec(TVarData(AArray).VPointer); if ArrayRec^.Dimension > 1 then raise EJVCLException.CreateRes(@RsESorryDynamicArraysSupportIsMadeForO); OldSize := ArrayRec^.Size; if OldSize > ASize then begin for I := ASize to OldSize - 1 do if ArrayRec^.ItemType = varEmpty then JvInterpreterVarFree(Variant((PVarData(PChar(ArrayRec^.Memory) + I * ArrayRec^.ElementSize))^)); ArrayRec^.EndPos[0] := ArrayRec^.EndPos[0] - (OldSize - ASize); ArrayRec^.Size := GetArraySize(1, ArrayRec^.BeginPos, ArrayRec^.EndPos); ReallocMem(ArrayRec^.Memory, ASize * ArrayRec^.ElementSize); end else if OldSize < ASize then begin ReallocMem(ArrayRec^.Memory, ASize * ArrayRec^.ElementSize); FillChar((PChar(ArrayRec^.Memory) + OldSize * ArrayRec^.ElementSize)^, (ASize - OldSize) * ArrayRec^.ElementSize, 0); for I := OldSize to ASize - 1 do if ArrayRec^.ItemType = varEmpty then ArrayRec^.DT.Init(Variant(Pointer(PChar(ArrayRec^.Memory) + I * ArrayRec^.ElementSize)^)); ArrayRec^.EndPos[0] := ArrayRec^.EndPos[0] + (ASize - OldSize); ArrayRec^.Size := GetArraySize(ArrayRec^.Dimension, ArrayRec^.BeginPos, ArrayRec^.EndPos); end; end; function JvInterpreterArrayLength(const AArray: Variant): Integer; var ArrayRec: PJvInterpreterArrayRec; begin ArrayRec := PJvInterpreterArrayRec(TVarData(AArray).VPointer); if ArrayRec^.Dimension > 1 then raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly); Result := ArrayRec^.Size; end; function JvInterpreterArrayLow(const AArray: Variant): Integer; var ArrayRec: PJvInterpreterArrayRec; begin ArrayRec := PJvInterpreterArrayRec(TVarData(AArray).VPointer); if ArrayRec^.Dimension > 1 then raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly); Result := ArrayRec^.BeginPos[0]; end; function JvInterpreterArrayHigh(const AArray: Variant): Integer; var ArrayRec: PJvInterpreterArrayRec; begin ArrayRec := PJvInterpreterArrayRec(TVarData(AArray).VPointer); if ArrayRec^.Dimension > 1 then raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly); Result := ArrayRec^.EndPos[0]; end; procedure JvInterpreterArrayElementDelete(AArray: Variant; AElement: Integer); var ArrayRec: PJvInterpreterArrayRec; begin ArrayRec := PJvInterpreterArrayRec(TVarData(AArray).VPointer); if ArrayRec^.Dimension > 1 then raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly); if (AElement < ArrayRec^.BeginPos[0]) or (AElement > ArrayRec^.EndPos[0]) then JvInterpreterError(ieArrayIndexOutOfBounds, -1); ArrayRec^.EndPos[0] := ArrayRec^.EndPos[0] - 1; ArrayRec^.Size := GetArraySize(ArrayRec^.Dimension, ArrayRec^.BeginPos, ArrayRec^.EndPos); if ArrayRec^.ItemType = varEmpty then JvInterpreterVarFree(Variant(PVarData(PChar(ArrayRec^.Memory) + (AElement - ArrayRec^.BeginPos[0]) * ArrayRec^.ElementSize)^)); Move((PChar(ArrayRec^.Memory) + (AElement - ArrayRec^.BeginPos[0] + 1) * ArrayRec^.ElementSize)^, (PChar(ArrayRec^.Memory) + (AElement - ArrayRec^.BeginPos[0]) * ArrayRec^.ElementSize)^, (ArrayRec^.EndPos[0] - AElement + 1) * ArrayRec^.ElementSize); ReallocMem(ArrayRec^.Memory, ArrayRec^.Size * ArrayRec^.ElementSize); end; procedure JvInterpreterArrayElementInsert(AArray: Variant; AElement: Integer; Value: Variant); var ArrayRec: PJvInterpreterArrayRec; begin ArrayRec := PJvInterpreterArrayRec(TVarData(AArray).VPointer); if ArrayRec^.Dimension > 1 then raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly); if (AElement < ArrayRec^.BeginPos[0]) or (AElement > ArrayRec^.EndPos[0]) then JvInterpreterError(ieArrayIndexOutOfBounds, -1); ArrayRec^.EndPos[0] := ArrayRec^.EndPos[0] + 1; ArrayRec^.Size := GetArraySize(ArrayRec^.Dimension, ArrayRec^.BeginPos, ArrayRec^.EndPos); ReallocMem(ArrayRec^.Memory, ArrayRec^.Size * ArrayRec^.ElementSize); Move((PChar(ArrayRec^.Memory) + (AElement - ArrayRec^.BeginPos[0]) * ArrayRec^.ElementSize)^, (PChar(ArrayRec^.Memory) + (AElement - ArrayRec^.BeginPos[0] + 1) * ArrayRec^.ElementSize)^, (ArrayRec^.EndPos[0] - AElement) * ArrayRec^.ElementSize); if ArrayRec^.ItemType = varEmpty then ArrayRec^.DT.Init(Variant(PVarData(PChar(ArrayRec^.Memory) + (AElement - ArrayRec^.BeginPos[0]) * ArrayRec^.ElementSize)^)); JvInterpreterVarAssignment(Variant(PVarData(PChar(ArrayRec^.Memory) + (AElement - ArrayRec^.BeginPos[0]) * ArrayRec^.ElementSize)^), Value); end; procedure V2OA(V: Variant; var OA: TOpenArray; var OAValues: TValueArray; var Size: Integer); var I: Integer; ArrayRec: PJvInterpreterArrayRec; Element: TJvInterpreterArrayValues; ElementVariant: Variant; begin if TVarData(V).VType = varArray then //JvInterpreterError(ieTypeMistmatch, -1); begin ArrayRec := PJvInterpreterArrayRec(TVarData(V).VPointer); if ArrayRec^.Dimension > 1 then raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly); Size := ArrayRec^.Size; for I := 0 to Size - 1 do begin Element[0] := I; ElementVariant := JvInterpreterArrayGetElement(Element, ArrayRec); case TVarData(ElementVariant).VType of varInteger, varSmallint: begin OAValues[I] := ElementVariant; OA[I].VInteger := ElementVariant; OA[I].VType := vtInteger; end; varString, varOleStr: begin // OA[I].vPChar := PChar(string(V[I])); // OA[I].VType := vtPChar; OAValues[I] := ElementVariant; OA[I].VVariant := @OAValues[I]; OA[I].VType := vtVariant; end; varBoolean: begin OAValues[I] := ElementVariant; OA[I].VBoolean := ElementVariant; OA[I].VType := vtBoolean; end; varDouble, varCurrency: begin OAValues[I] := ElementVariant; OA[I].VExtended := TVarData(ElementVariant).VPointer; OA[I].VType := vtExtended; end; else OAValues[I] := ElementVariant; OA[I].VVariant := @OAValues[I]; OA[I].VType := vtVariant; end; end; end else begin Size := VarArrayHighBound(V, 1) - VarArrayLowBound(V, 1) + 1; for I := VarArrayLowBound(V, 1) to VarArrayHighBound(V, 1) do begin case TVarData(V[I]).VType of varInteger, varSmallint: begin OAValues[I] := V[I]; OA[I].VInteger := V[I]; OA[I].VType := vtInteger; end; varString, varOleStr: begin // OA[I].vPChar := PChar(string(V[I])); // OA[I].VType := vtPChar; OAValues[I] := V[I]; OA[I].VVariant := @OAValues[I]; OA[I].VType := vtVariant; end; varBoolean: begin OAValues[I] := V[I]; OA[I].VBoolean := V[I]; OA[I].VType := vtBoolean; end; varDouble, varCurrency: begin OAValues[I] := V[I]; OA[I].VExtended := TVarData(V[I]).VPointer; OA[I].VType := vtExtended; end; else OAValues[I] := V[I]; OA[I].VVariant := @OAValues[I]; OA[I].VType := vtVariant; end; end; end; end; { ########################## Array support ########################## } { ************************ extended variants ************************ } function JvInterpreterVarAsType(const V: Variant; const VarType: Integer): Variant; begin if (TVarData(V).VType = varEmpty) or (TVarData(V).VType = varNull) then begin case VarType of varString, varOleStr: Result := ''; varInteger, varSmallint, varByte: Result := 0; varBoolean: Result := False; varSingle, varDouble, varCurrency, varDate: Result := 0.0; varVariant: Result := Null; else Result := VarAsType(V, VarType); end; end else begin if TVarData(V).VType = varInteger then begin if (TVarData(V).VType = VarType) then Result := Ord(V = True) else Result := Integer(V) end else if TVarData(V).VType = varArray then begin TVarData(Result) := TVarData(V); TVarData(Result).VType := VarType; end else Result := VarAsType(V, VarType); end; end; procedure JvInterpreterVarAssignment(var Dest: Variant; const Source: Variant); var I: Integer; DestRecHolder: TJvInterpreterRecHolder; SourceRecHolder: TJvInterpreterRecHolder; begin if TVarData(Source).VType = varArray then TVarData(Dest) := TVarData(Source) else if TVarData(Source).VType = varRecord then begin DestRecHolder := TJvInterpreterRecHolder(TVarData(Dest).VPointer); SourceRecHolder := TJvInterpreterRecHolder(TVarData(Source).VPointer); for I := 0 to SourceRecHolder.JvInterpreterRecord.FieldCount - 1 do if SourceRecHolder.JvInterpreterRecord.Fields[I].Typ = varEmpty then JvInterpreterVarAssignment(Variant(PVarData(PChar(DestRecHolder.Rec) + DestRecHolder.JvInterpreterRecord.Fields[I].Offset)^), Variant(PVarData(PChar(SourceRecHolder.Rec) + SourceRecHolder.JvInterpreterRecord.Fields[I].Offset)^)) else Move((PChar(SourceRecHolder.Rec) + SourceRecHolder.JvInterpreterRecord.Fields[I].Offset)^, (PChar(DestRecHolder.Rec) + DestRecHolder.JvInterpreterRecord.Fields[I].Offset)^, Typ2Size(SourceRecHolder.JvInterpreterRecord.Fields[I].Typ)); end else Dest := Source; end; procedure JvInterpreterVarCopy(var Dest: Variant; const Source: Variant); begin if (TVarData(Source).VType = varArray) or (TVarData(Source).VType = varRecord) then TVarData(Dest) := TVarData(Source) else Dest := Source; end; procedure JvInterpreterVarFree(var V: Variant); var TempType: TVarType; begin TempType := TVarData(V).VType; if TempType = varArray then JvInterpreterArrayFree(PJvInterpreterArrayRec(TVarData(V).VPointer)) else if TempType = varRecord then TJvInterpreterRecHolder(TVarData(V).VPointer).Free; {case TVarData(V).VType of varArray: JvInterpreterArrayFree(PJvInterpreterArrayRec(TVarData(V).VPointer)); varRecord: TJvInterpreterRecHolder(TVarData(V).VPointer).Free; end;} V := Null; end; { function VarAsType2(const V: Variant; VarType: Integer): Variant; begin if TVarData(V).VType = varNull then Result := VarAsType(Unassigned,VarType) else Result := VarAsType(V,VarType); end; } function Var2Type(V: Variant; const VarType: Integer): Variant; begin if (TVarData(V).VType = varEmpty) or (TVarData(V).VType = varNull) then begin case VarType of varString, varOleStr: Result := ''; varInteger, varSmallint, varByte: Result := 0; varBoolean: Result := False; varSingle, varDouble, varCurrency, varDate: Result := 0.0; varVariant: Result := Null; else Result := VarAsType(V, VarType); end; end else Result := VarAsType(V, VarType); if (VarType = varInteger) and (TVarData(V).VType = varBoolean) then Result := Ord(V = True); end; { ######################## extended variants ######################## } //=== { TJvInterpreterVar } ================================================== destructor TJvInterpreterVar.Destroy; begin JvInterpreterVarFree(Value); inherited Destroy; end; //=== { TJvInterpreterVarList } ============================================== destructor TJvInterpreterVarList.Destroy; begin inherited Destroy; end; procedure TJvInterpreterVarList.Clear; var I: Integer; begin for I := 0 to Count - 1 do TJvInterpreterVar(Items[I]).Free; inherited Clear; end; procedure TJvInterpreterVarList.AddVar(const UnitName, Identifier, Typ: string; VTyp: Word; const Value: Variant; DataType: IJvInterpreterDataType); var VarRec: TJvInterpreterVar; begin if FindVar(UnitName, Identifier) <> nil then JvInterpreterErrorN(ieIdentifierRedeclared, -1, Identifier); VarRec := TJvInterpreterVar.Create; VarRec.Identifier := Identifier; VarRec.UnitName := UnitName; JvInterpreterVarCopy(VarRec.Value, Value); VarRec.Typ := Typ; VarRec.VTyp := VTyp; Insert(0, VarRec); end; function TJvInterpreterVarList.FindVar(const UnitName, Identifier: string): TJvInterpreterVar; var I: Integer; begin for I := 0 to Count - 1 do begin Result := TJvInterpreterVar(Items[I]); { if UnitName = '', any unit allowed } if Cmp(Result.Identifier, Identifier) and (Cmp(Result.UnitName, UnitName) or (UnitName = '')) then Exit; end; Result := nil; end; procedure TJvInterpreterVarList.DeleteVar(const UnitName, Identifier: string); var I: Integer; VarRec: TJvInterpreterVar; begin for I := 0 to Count - 1 do begin VarRec := TJvInterpreterVar(Items[I]); if Cmp(VarRec.Identifier, Identifier) and (Cmp(VarRec.UnitName, UnitName) or (UnitName = '')) then begin JvInterpreterVarFree(VarRec.Value); VarRec.Free; Delete(I); Exit; end; end; end; function TJvInterpreterVarList.GetValue(const Identifier: string; var Value: Variant; Args: TJvInterpreterArgs): Boolean; var V: TJvInterpreterVar; begin if Args.Obj = nil then V := FindVar('', Identifier) else if (Args.ObjTyp = varObject) and (Args.Obj is TJvInterpreterSrcUnit) then V := FindVar((Args.Obj as TJvInterpreterSrcUnit).Identifier, Identifier) else V := nil; Result := V <> nil; if Result then JvInterpreterVarCopy(Value, V.Value); end; (* function TJvInterpreterVarList.SetValue(Identifier: string; const Value: Variant; Args: TJvInterpreterArgs): Boolean; var V: TJvInterpreterVar; begin V := FindVar('', Identifier); Result := (V <> nil) and (Args.Obj = nil); if Result then JvInterpreterVarAssignment(V.Value, Value); end; { SetValue } *) function TJvInterpreterVarList.SetValue(const Identifier: string; const Value: Variant; Args: TJvInterpreterArgs): Boolean; var V: TJvInterpreterVar; begin V := FindVar('', Identifier); Result := (V <> nil) and (Args.Obj = nil); if Result then { If 0, then it's probably an object } { If a Variant, then we don't care about typecasting } { We only want to typecast if the types are not the same, for speed } if (V.VTyp <> 0) and (V.VTyp <> varVariant) and (TVarData(Value).VType <> V.VTyp) then begin { Is it a passed-by-reference variable? } if V.VTyp and varByRef > 0 then begin JvInterpreterVarAssignment(V.Value, JvInterpreterVarAsType(Value, V.VTyp and not varByRef)); V.VTyp := V.VTyp or varByRef; end else JvInterpreterVarAssignment(V.Value, JvInterpreterVarAsType(Value, V.VTyp)) end else JvInterpreterVarAssignment(V.Value, Value); end; //=== { TJvInterpreterFunctionDesc } ========================================= function TJvInterpreterFunctionDesc.GetParamType(Index: Integer): Word; begin Result := FParamTypes[Index]; end; //dejoy added begin function TJvInterpreterFunctionDesc.GetParamTypeNames(Index: Integer): string; begin Result := FParamTypeNames[Index]; end; function TJvInterpreterFunctionDesc.GetDefine: string; var Fun, S, t: string; Param, Ret: string; I: Integer; begin Result := ''; if FIdentifier = '' then Exit; t := '%s %s(%s)%s;'; if FResTyp = varEmpty then begin Fun := 'procedure'; Ret := ''; end else begin Fun := 'function'; Ret := ': ' + ResTypName; end; for I := 0 to ParamCount - 1 do begin if (ParamTypes[I] and varByRef) = varByRef then S := 'Var ' + ParamNames[I] else if (ParamTypes[I] and varByConst) = varByConst then S := 'Const ' + ParamNames[I] else S := ParamNames[I]; Param := Param + S + ': ' + ParamTypeNames[I]; if I <> ParamCount - 1 then Param := Param + '; '; end; Result := Format(t, [Fun, FIdentifier, Param, Ret]); end; //dejoy added end function TJvInterpreterFunctionDesc.GetParamName(Index: Integer): string; begin Result := FParamNames[Index]; end; //=== { TJvInterpreterRecHolder } ============================================ constructor TJvInterpreterRecHolder.Create(const ARecordType: string; ARec: Pointer); begin // (rom) added inherited Create inherited Create; Assert(ARecordType <> ''); FRecordType := ARecordType; Rec := ARec; {$IFDEF JvInterpreter_DEBUG} Inc(ObjCount); {$ENDIF JvInterpreter_DEBUG} end; destructor TJvInterpreterRecHolder.Destroy; var I: Integer; begin if Assigned(JvInterpreterRecord) then begin if Assigned(JvInterpreterRecord.DestroyFunc) then JvInterpreterRecord.DestroyFunc(Rec) else begin for I := 0 to JvInterpreterRecord.FieldCount - 1 do begin if JvInterpreterRecord.Fields[I].Typ = varEmpty then JvInterpreterVarFree(Variant(PVarData(PChar(Rec) + JvInterpreterRecord.Fields[I].Offset)^)); end; FreeMem(Rec, JvInterpreterRecord.RecordSize); end; end else JvInterpreterError(ieInternal, -1); inherited Destroy; {$IFDEF JvInterpreter_DEBUG} Dec(ObjCount); {$ENDIF JvInterpreter_DEBUG} end; //=== { TJvInterpreterSrcFunction } ========================================== constructor TJvInterpreterSrcFunction.Create; begin inherited Create; FFunctionDesc := TJvInterpreterFunctionDesc.Create; end; destructor TJvInterpreterSrcFunction.Destroy; begin FFunctionDesc.Free; inherited Destroy; end; //=== { TJvInterpreterExtFunction } ========================================== function TJvInterpreterExtFunction.CallDll(Args: TJvInterpreterArgs): Variant; begin if DllInstance > 0 then Result := JvInterpreter.CallDllIns(DllInstance, FunctionName, Args, FunctionDesc.FParamTypes, FunctionDesc.ResTyp) else Result := JvInterpreter.CallDll(DllName, FunctionName, Args, FunctionDesc.FParamTypes, FunctionDesc.ResTyp) end; //=== { TJvInterpreterEvent } ================================================ constructor TJvInterpreterEvent.Create(AOwner: TJvInterpreterExpression; AInstance: TObject; const AUnitName, AFunctionName, APropName: string); begin // (rom) added inherited Create inherited Create; FOwner := AOwner; FInstance := AInstance; FUnitName := AUnitName; FFunctionName := AFunctionName; FPropName := APropName; {$IFDEF JvInterpreter_DEBUG} Inc(ObjCount); {$ENDIF JvInterpreter_DEBUG} end; destructor TJvInterpreterEvent.Destroy; begin FArgs.Free; inherited Destroy; {$IFDEF JvInterpreter_DEBUG} Dec(ObjCount); {$ENDIF JvInterpreter_DEBUG} end; function TJvInterpreterEvent.GetArgs: TJvInterpreterArgs; begin if FArgs = nil then FArgs := TJvInterpreterArgs.Create; Result := FArgs; end; function TJvInterpreterEvent.CallFunction(Args: TJvInterpreterArgs; Params: array of Variant): Variant; var I: Integer; NV: Variant; begin if Args = nil then Args := Self.Args; Args.Clear; for I := Low(Params) to High(Params) do begin Args.Values[Args.Count] := Params[I]; Inc(Args.Count); end; NV := Null; Result := FOwner.CallFunctionEx(FInstance, FUnitName, FFunctionName, Args, NV); end; //=== { TJvInterpreterIdentifierList } ======================================= function TJvInterpreterIdentifierList.Find(const Identifier: string; var Index: Integer): Boolean; var L, H, I, C: Integer; begin Result := False; L := 0; H := Count - 1; while L <= H do begin I := (L + H) shr 1; C := AnsiStrIComp(PChar(TJvInterpreterIdentifier(List[I]).Identifier), PChar(Identifier)); if C < 0 then L := I + 1 else begin H := I - 1; if C = 0 then begin Result := True; if Duplicates <> dupAccept then L := I; end; end; end; Index := L; end; procedure TJvInterpreterIdentifierList.Sort(Compare: TListSortCompare = nil); function SortIdentifier(Item1, Item2: Pointer): Integer; begin { function AnsiStrIComp about 30% faster than AnsiCompareText } { Result := AnsiCompareText(TJvInterpreterIdentifier(Item1).Identifier, TJvInterpreterIdentifier(Item2).Identifier); } Result := AnsiStrIComp(PChar(TJvInterpreterIdentifier(Item1).Identifier), PChar(TJvInterpreterIdentifier(Item2).Identifier)); end; begin if Assigned(Compare) then inherited Sort(Compare) else inherited Sort(TListSortCompare(@SortIdentifier)); end; function TJvInterpreterIdentifierList.IndexOf(const UnitName, Identifier: string): TJvInterpreterIdentifier; var I: Integer; begin for I := Count - 1 downto 0 do begin Result := TJvInterpreterIdentifier(Items[I]); if Cmp(Result.Identifier, Identifier) and (Cmp(Result.UnitName, UnitName) or (UnitName = '')) then Exit; end; Result := nil; end; //=== { TJvInterpreterAdapter } ============================================== constructor TJvInterpreterAdapter.Create(AOwner: TJvInterpreterExpression); begin // (rom) added inherited Create inherited Create; FOwner := AOwner; FSrcUnitList := TJvInterpreterIdentifierList.Create; FExtUnitList := TJvInterpreterIdentifierList.Create; FIntfGetList := TJvInterpreterIdentifierList.Create; FGetList := TJvInterpreterMethodList.Create; FSetList := TJvInterpreterMethodList.Create; FIGetList := TJvInterpreterMethodList.Create; FISetList := TJvInterpreterMethodList.Create; FIDGetList := TJvInterpreterIdentifierList.Create; FIDSetList := TJvInterpreterIdentifierList.Create; FDirectGetList := TJvInterpreterIdentifierList.Create; FClassList := TJvInterpreterIdentifierList.Create; FConstList := TJvInterpreterIdentifierList.Create; FFunctionList := TJvInterpreterMethodList.Create; FRecordList := TJvInterpreterIdentifierList.Create; FRecordGetList := TJvInterpreterIdentifierList.Create; FRecordSetList := TJvInterpreterIdentifierList.Create; FOnGetList := TJvInterpreterIdentifierList.Create; FOnSetList := TJvInterpreterIdentifierList.Create; FExtFunctionList := TJvInterpreterIdentifierList.Create; FSrcFunctionList := TJvInterpreterIdentifierList.Create; FEventHandlerList := TJvInterpreterIdentifierList.Create; FEventList := TJvInterpreterIdentifierList.Create; FSrcVarList := TJvInterpreterVarList.Create; FSrcClassList := TJvInterpreterIdentifierList.Create; FIntfGetList.Duplicates := dupAccept; FGetList.Duplicates := dupAccept; FSetList.Duplicates := dupAccept; FIGetList.Duplicates := dupAccept; FISetList.Duplicates := dupAccept; FDisableExternalFunctions := False; end; destructor TJvInterpreterAdapter.Destroy; begin Clear; FSrcUnitList.Free; FExtUnitList.Free; FIntfGetList.Free; FGetList.Free; FSetList.Free; FIGetList.Free; FISetList.Free; FIDGetList.Free; FIDSetList.Free; FDirectGetList.Free; FClassList.Free; FConstList.Free; FFunctionList.Free; FRecordList.Free; FRecordGetList.Free; FRecordSetList.Free; FOnGetList.Free; FOnSetList.Free; FExtFunctionList.Free; FSrcFunctionList.Free; FEventHandlerList.Free; FEventList.Free; FSrcVarList.Free; FSrcClassList.Free; inherited Destroy; end; procedure TJvInterpreterAdapter.ClearSource; begin ClearList(FSrcUnitList); ClearList(FSrcFunctionList); FSrcVarList.Clear; ClearList(FSrcClassList); end; procedure TJvInterpreterAdapter.ClearNonSource; begin ClearList(FExtUnitList); ClearList(FIntfGetList); ClearList(FGetList); ClearList(FSetList); ClearList(FIGetList); ClearList(FISetList); ClearList(FIDGetList); ClearList(FIDSetList); ClearList(FDirectGetList); ClearList(FClassList); ClearList(FConstList); ClearList(FFunctionList); ClearList(FRecordList); ClearList(FRecordGetList); ClearList(FRecordSetList); ClearList(FExtFunctionList); ClearList(FEventHandlerList); ClearList(FEventList); ClearMethodList(FOnGetList); ClearMethodList(FOnSetList); end; procedure TJvInterpreterAdapter.Clear; begin ClearSource; ClearNonSource; end; procedure TJvInterpreterAdapter.Assign(Source: TJvInterpreterAdapter); var I: Integer; begin if Source = Self then Exit; for I := 0 to Source.FGetList.Count - 1 do with TJvInterpreterMethod(Source.FGetList[I]) do AddGetEx(FClassType, Identifier, Func, ParamCount, ParamTypes, ResTyp, Data); for I := 0 to Source.FSetList.Count - 1 do with TJvInterpreterMethod(Source.FSetList[I]) do AddSetEx(FClassType, Identifier, Func, ParamCount, ParamTypes, Data); for I := 0 to Source.FIGetList.Count - 1 do with TJvInterpreterMethod(Source.FIGetList[I]) do AddIGetEx(FClassType, Identifier, Func, ParamCount, ParamTypes, ResTyp, Data); for I := 0 to Source.FISetList.Count - 1 do with TJvInterpreterMethod(Source.FISetList[I]) do AddISetEx(FClassType, Identifier, Func, ParamCount, ParamTypes, Data); for I := 0 to Source.FIDGetList.Count - 1 do with TJvInterpreterMethod(Source.FIDGetList[I]) do AddIDGetEx(FClassType, Func, ParamCount, ParamTypes, ResTyp, Data); for I := 0 to Source.FIDSetList.Count - 1 do with TJvInterpreterMethod(Source.FIDSetList[I]) do AddIDSetEx(FClassType, Func, ParamCount, ParamTypes, Data); for I := 0 to Source.FIntfGetList.Count - 1 do with TJvInterpreterIntfMethod(Source.FIntfGetList[I]) do AddIntfGetEx(IID, Identifier, Func, ParamCount, ParamTypes, ResTyp, Data); for I := 0 to Source.FDirectGetList.Count - 1 do with TJvInterpreterDMethod(Source.FDirectGetList[I]) do AddDGetEx(FClassType, Identifier, Func, ParamCount, ParamTypes, ResTyp, CallConvention, Data); for I := 0 to Source.FFunctionList.Count - 1 do with TJvInterpreterMethod(Source.FFunctionList[I]) do AddFunctionEx(UnitName, Identifier, Func, ParamCount, ParamTypes, ResTyp, Data); for I := 0 to Source.FExtUnitList.Count - 1 do with TJvInterpreterIdentifier(Source.FExtUnitList[I]) do AddExtUnitEx(Identifier, Data); for I := 0 to Source.FClassList.Count - 1 do with TJvInterpreterClass(Source.FClassList[I]) do AddClassEx(UnitName, FClassType, Identifier, Data); for I := 0 to Source.FConstList.Count - 1 do with TJvInterpreterConst(Source.FConstList[I]) do AddConstEx(UnitName, Identifier, Value, Data); for I := 0 to Source.FRecordList.Count - 1 do with TJvInterpreterRecord(Source.FRecordList[I]) do AddRecEx(UnitName, Identifier, RecordSize, Fields, CreateFunc, DestroyFunc, CopyFunc, Data); for I := 0 to Source.FRecordGetList.Count - 1 do with TJvInterpreterRecMethod(Source.FRecordGetList[I]) do AddRecGetEx(UnitName, JvInterpreterRecord.Identifier, Identifier, Func, ParamCount, ParamTypes, ResTyp, Data); for I := 0 to Source.FRecordSetList.Count - 1 do with TJvInterpreterRecMethod(Source.FRecordSetList[I]) do AddRecSetEx(UnitName, JvInterpreterRecord.Identifier, Identifier, Func, ParamCount, ParamTypes, Data); for I := 0 to Source.FExtFunctionList.Count - 1 do with TJvInterpreterExtFunction(Source.FExtFunctionList[I]) do AddExtFunEx(UnitName, Identifier, DllInstance, DllName, FunctionName, FunctionIndex, FunctionDesc.FParamCount, FunctionDesc.FParamTypes, FunctionDesc.FResTyp, Data); for I := 0 to Source.FEventHandlerList.Count - 1 do with TJvInterpreterEventDesc(Source.FEventHandlerList[I]) do AddHandlerEx(UnitName, Identifier, EventClass, Code, Data); for I := 0 to Source.FEventList.Count - 1 do with TJvInterpreterClass(Source.FEventList[I]) do AddEventEx(UnitName, FClassType, Identifier, Data); for I := 0 to Source.FOnGetList.Count - 1 do AddOnGet(TJvInterpreterGetValue(PMethod(Source.FOnGetList[I])^)); for I := 0 to Source.FOnSetList.Count - 1 do AddOnSet(TJvInterpreterSetValue(PMethod(Source.FOnSetList[I])^)); end; procedure TJvInterpreterAdapter.AddSrcUnit(const Identifier, Source, UsesList: string); begin AddSrcUnitEx(Identifier, Source, UsesList, nil); end; { if unit with name 'Identifier' already exists its source will be replaced } procedure TJvInterpreterAdapter.AddSrcUnitEx(const Identifier, Source, UsesList: string; Data: Pointer); var JvInterpreterUnit: TJvInterpreterSrcUnit; S: string; I: Integer; JvInterpreterIdentifier: TJvInterpreterIdentifier; begin JvInterpreterUnit := nil; for I := 0 to FSrcUnitList.Count - 1 do begin JvInterpreterIdentifier := TJvInterpreterIdentifier(FSrcUnitList.Items[I]); if Cmp(JvInterpreterIdentifier.Identifier, Identifier) then begin JvInterpreterUnit := TJvInterpreterSrcUnit(FSrcUnitList.Items[I]); Break; end; end; if JvInterpreterUnit = nil then begin JvInterpreterUnit := TJvInterpreterSrcUnit.Create; FSrcUnitList.Add(JvInterpreterUnit); end; if JvInterpreterUnit.FSource = '' then begin JvInterpreterUnit.Identifier := Identifier; JvInterpreterUnit.FSource := Source; JvInterpreterUnit.Data := Data; I := 0; S := Trim(SubStr(UsesList, I, ',')); while S <> '' do begin JvInterpreterUnit.FUsesList[I] := S; Inc(I); S := Trim(SubStr(UsesList, I, ',')); end; end; end; procedure TJvInterpreterAdapter.AddExtUnit(const Identifier: string); begin AddExtUnitEx(Identifier, nil); end; procedure TJvInterpreterAdapter.AddExtUnitEx(const Identifier: string; Data: Pointer); var JvInterpreterUnit: TJvInterpreterIdentifier; begin JvInterpreterUnit := TJvInterpreterIdentifier.Create; JvInterpreterUnit.Identifier := Identifier; JvInterpreterUnit.Data := Data; FExtUnitList.Add(JvInterpreterUnit); end; procedure TJvInterpreterAdapter.AddClass(const UnitName: string; AClassType: TClass; const Identifier: string); begin AddClassEx(UnitName, AClassType, Identifier, nil); end; procedure TJvInterpreterAdapter.AddClassEx(const UnitName: string; AClassType: TClass; const Identifier: string; Data: Pointer); var JvInterpreterClass: TJvInterpreterClass; begin JvInterpreterClass := TJvInterpreterClass.Create; JvInterpreterClass.FClassType := AClassType; JvInterpreterClass.Identifier := Identifier; JvInterpreterClass.Data := Data; FClassList.Add(JvInterpreterClass); FSorted := False; // Ivan_ra end; procedure TJvInterpreterAdapter.AddGet(AClassType: TClass; const Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word); begin AddGetEx(AClassType, Identifier, GetFunc, ParamCount, ParamTypes, ResTyp, nil); end; procedure TJvInterpreterAdapter.AddGetEx(AClassType: TClass; const Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word; Data: Pointer); var JvInterpreterMethod: TJvInterpreterMethod; begin JvInterpreterMethod := TJvInterpreterMethod.Create; JvInterpreterMethod.FClassType := AClassType; JvInterpreterMethod.Identifier := Identifier; JvInterpreterMethod.Func := @GetFunc; JvInterpreterMethod.ParamCount := ParamCount; JvInterpreterMethod.ResTyp := ResTyp; JvInterpreterMethod.Data := Data; ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes); FGetList.Add(JvInterpreterMethod); FSorted := False; // Ivan_ra end; procedure TJvInterpreterAdapter.AddIGet(AClassType: TClass; const Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word); begin AddIGetEx(AClassType, Identifier, GetFunc, ParamCount, ParamTypes, ResTyp, nil); end; procedure TJvInterpreterAdapter.AddIGetEx(AClassType: TClass; const Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word; Data: Pointer); var JvInterpreterMethod: TJvInterpreterMethod; begin JvInterpreterMethod := TJvInterpreterMethod.Create; JvInterpreterMethod.FClassType := AClassType; JvInterpreterMethod.Identifier := Identifier; JvInterpreterMethod.Func := @GetFunc; JvInterpreterMethod.ParamCount := ParamCount; JvInterpreterMethod.ResTyp := ResTyp; JvInterpreterMethod.Data := Data; ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes); FIGetList.Add(JvInterpreterMethod); FSorted := False; // Ivan_ra end; procedure TJvInterpreterAdapter.AddIDGet(AClassType: TClass; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word); begin AddIDGetEx(AClassType, GetFunc, ParamCount, ParamTypes, ResTyp, nil); end; procedure TJvInterpreterAdapter.AddIDGetEx(AClassType: TClass; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word; Data: Pointer); var JvInterpreterMethod: TJvInterpreterMethod; begin JvInterpreterMethod := TJvInterpreterMethod.Create; JvInterpreterMethod.FClassType := AClassType; JvInterpreterMethod.Func := @GetFunc; JvInterpreterMethod.ParamCount := ParamCount; JvInterpreterMethod.ResTyp := ResTyp; JvInterpreterMethod.Data := Data; ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes); FIDGetList.Add(JvInterpreterMethod); end; procedure TJvInterpreterAdapter.AddIntfGet(IID: TGUID; const Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word); begin AddIntfGetEx(IID, Identifier, GetFunc, ParamCount, ParamTypes, ResTyp, nil); end; procedure TJvInterpreterAdapter.AddIntfGetEx(IID: TGUID; const Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word; Data: Pointer); var JvInterpreterMethod: TJvInterpreterIntfMethod; begin JvInterpreterMethod := TJvInterpreterIntfMethod.Create; JvInterpreterMethod.IID := IID; JvInterpreterMethod.Identifier := Identifier; JvInterpreterMethod.Func := @GetFunc; JvInterpreterMethod.ParamCount := ParamCount; JvInterpreterMethod.ResTyp := ResTyp; JvInterpreterMethod.Data := Data; ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes); FIntfGetList.Add(JvInterpreterMethod); FSorted := False; // Ivan_ra end; procedure TJvInterpreterAdapter.AddDGet(AClassType: TClass; const Identifier: string; GetFunc: Pointer; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word; CallConvention: TCallConvention); begin AddDGetEx(AClassType, Identifier, GetFunc, ParamCount, ParamTypes, ResTyp, CallConvention, nil); end; procedure TJvInterpreterAdapter.AddDGetEx(AClassType: TClass; const Identifier: string; GetFunc: Pointer; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word; CallConvention: TCallConvention; Data: Pointer); var JvInterpreterMethod: TJvInterpreterDMethod; begin JvInterpreterMethod := TJvInterpreterDMethod.Create; JvInterpreterMethod.FClassType := AClassType; JvInterpreterMethod.Identifier := Identifier; JvInterpreterMethod.Func := GetFunc; JvInterpreterMethod.ParamCount := ParamCount; JvInterpreterMethod.ResTyp := ResTyp; JvInterpreterMethod.Data := Data; ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes); JvInterpreterMethod.CallConvention := CallConvention; FDirectGetList.Add(JvInterpreterMethod); end; procedure TJvInterpreterAdapter.AddSet(AClassType: TClass; const Identifier: string; SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word); begin AddSetEx(AClassType, Identifier, SetFunc, ParamCount, ParamTypes, nil); end; procedure TJvInterpreterAdapter.AddSetEx(AClassType: TClass; const Identifier: string; SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word; Data: Pointer); var JvInterpreterMethod: TJvInterpreterMethod; begin JvInterpreterMethod := TJvInterpreterMethod.Create; JvInterpreterMethod.FClassType := AClassType; JvInterpreterMethod.Identifier := Identifier; JvInterpreterMethod.Func := @SetFunc; JvInterpreterMethod.ParamCount := ParamCount; JvInterpreterMethod.Data := Data; ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes); FSetList.Add(JvInterpreterMethod); FSorted := False; // Ivan_ra end; procedure TJvInterpreterAdapter.AddISet(AClassType: TClass; const Identifier: string; SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word); begin AddISetEx(AClassType, Identifier, SetFunc, ParamCount, ParamTypes, nil); end; procedure TJvInterpreterAdapter.AddISetEx(AClassType: TClass; const Identifier: string; SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word; Data: Pointer); var JvInterpreterMethod: TJvInterpreterMethod; begin JvInterpreterMethod := TJvInterpreterMethod.Create; JvInterpreterMethod.FClassType := AClassType; JvInterpreterMethod.Identifier := Identifier; JvInterpreterMethod.Func := @SetFunc; JvInterpreterMethod.ParamCount := ParamCount; JvInterpreterMethod.Data := Data; ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes); FISetList.Add(JvInterpreterMethod); FSorted := False; // Ivan_ra end; procedure TJvInterpreterAdapter.AddIDSet(AClassType: TClass; SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word); begin AddIDSetEx(AClassType, SetFunc, ParamCount, ParamTypes, nil); end; procedure TJvInterpreterAdapter.AddIDSetEx(AClassType: TClass; SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word; Data: Pointer); var JvInterpreterMethod: TJvInterpreterMethod; begin JvInterpreterMethod := TJvInterpreterMethod.Create; JvInterpreterMethod.FClassType := AClassType; JvInterpreterMethod.Func := @SetFunc; JvInterpreterMethod.ParamCount := ParamCount; JvInterpreterMethod.Data := Data; ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes); FIDSetList.Add(JvInterpreterMethod); end; procedure TJvInterpreterAdapter.AddFunction(const UnitName, Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word); begin AddFunctionEx(UnitName, Identifier, GetFunc, ParamCount, ParamTypes, ResTyp, nil); end; procedure TJvInterpreterAdapter.AddFunctionEx(const UnitName, Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word; Data: Pointer); var JvInterpreterMethod: TJvInterpreterMethod; begin JvInterpreterMethod := TJvInterpreterMethod.Create; JvInterpreterMethod.Identifier := Identifier; JvInterpreterMethod.Func := @GetFunc; JvInterpreterMethod.ParamCount := ParamCount; JvInterpreterMethod.ResTyp := ResTyp; JvInterpreterMethod.Data := Data; ConvertParamTypes(ParamTypes, JvInterpreterMethod.ParamTypes); FFunctionList.Add(JvInterpreterMethod); FSorted := False; // Ivan_ra end; procedure TJvInterpreterAdapter.AddRec(const UnitName, Identifier: string; RecordSize: Integer; Fields: array of TJvInterpreterRecField; CreateFunc: TJvInterpreterAdapterNewRecord; DestroyFunc: TJvInterpreterAdapterDisposeRecord; CopyFunc: TJvInterpreterAdapterCopyRecord); begin AddRecEx(UnitName, Identifier, RecordSize, Fields, CreateFunc, DestroyFunc, CopyFunc, nil); end; procedure TJvInterpreterAdapter.AddRecEx(const UnitName, Identifier: string; RecordSize: Integer; Fields: array of TJvInterpreterRecField; CreateFunc: TJvInterpreterAdapterNewRecord; DestroyFunc: TJvInterpreterAdapterDisposeRecord; CopyFunc: TJvInterpreterAdapterCopyRecord; Data: Pointer); var JvInterpreterRecord: TJvInterpreterRecord; I: Integer; begin JvInterpreterRecord := TJvInterpreterRecord.Create; JvInterpreterRecord.Identifier := Identifier; JvInterpreterRecord.RecordSize := RecordSize; JvInterpreterRecord.CreateFunc := CreateFunc; JvInterpreterRecord.DestroyFunc := DestroyFunc; JvInterpreterRecord.CopyFunc := CopyFunc; JvInterpreterRecord.Data := Data; for I := Low(Fields) to High(Fields) do begin JvInterpreterRecord.Fields[I] := Fields[I]; JvInterpreterRecord.Fields[I].DataType := nil; end; JvInterpreterRecord.FieldCount := High(Fields) - Low(Fields) + 1; FRecordList.Add(JvInterpreterRecord); end; procedure TJvInterpreterAdapter.AddRecGet(const UnitName, RecordType, Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word); begin AddRecGetEx(UnitName, RecordType, Identifier, GetFunc, ParamCount, ParamTypes, ResTyp, nil); end; procedure TJvInterpreterAdapter.AddRecGetEx(const UnitName, RecordType, Identifier: string; GetFunc: TJvInterpreterAdapterGetValue; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word; Data: Pointer); var RecMethod: TJvInterpreterRecMethod; begin RecMethod := TJvInterpreterRecMethod.Create; RecMethod.JvInterpreterRecord := GetRec(RecordType) as TJvInterpreterRecord; RecMethod.Identifier := Identifier; RecMethod.Func := @GetFunc; RecMethod.ParamCount := ParamCount; RecMethod.ResTyp := ResTyp; RecMethod.Data := Data; ConvertParamTypes(ParamTypes, RecMethod.ParamTypes); FRecordGetList.Add(RecMethod); end; procedure TJvInterpreterAdapter.AddRecSet(const UnitName, RecordType, Identifier: string; SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word); begin AddRecSetEx(UnitName, RecordType, Identifier, SetFunc, ParamCount, ParamTypes, nil); end; procedure TJvInterpreterAdapter.AddRecSetEx(const UnitName, RecordType, Identifier: string; SetFunc: TJvInterpreterAdapterSetValue; ParamCount: Integer; ParamTypes: array of Word; Data: Pointer); var RecMethod: TJvInterpreterRecMethod; begin RecMethod := TJvInterpreterRecMethod.Create; RecMethod.JvInterpreterRecord := GetRec(RecordType) as TJvInterpreterRecord; RecMethod.Identifier := Identifier; RecMethod.Func := @SetFunc; RecMethod.ParamCount := ParamCount; RecMethod.Data := Data; ConvertParamTypes(ParamTypes, RecMethod.ParamTypes); FRecordSetList.Add(RecMethod); end; procedure TJvInterpreterAdapter.AddConst(const UnitName, Identifier: string; Value: Variant); begin AddConstEx(UnitName, Identifier, Value, nil); end; procedure TJvInterpreterAdapter.AddConstEx(const AUnitName, AIdentifier: string; AValue: Variant; AData: Pointer); var JvInterpreterConst: TJvInterpreterConst; begin JvInterpreterConst := TJvInterpreterConst.Create; JvInterpreterConst.Identifier := AIdentifier; JvInterpreterConst.Value := AValue; JvInterpreterConst.Data := AData; FConstList.Add(JvInterpreterConst); FSorted := False; // Ivan_ra end; procedure TJvInterpreterAdapter.AddExtFun(const UnitName, Identifier: string; DllInstance: HINST; const DllName, FunctionName: string; FunctionIndex: Integer; ParamCount: Integer; ParamTypes: array of Word; ResTyp: Word); begin AddExtFunEx(UnitName, Identifier, DllInstance, DllName, FunctionName, FunctionIndex, ParamCount, ParamTypes, ResTyp, nil); end; procedure TJvInterpreterAdapter.AddExtFunEx(const AUnitName, AIdentifier: string; ADllInstance: HINST; const ADllName, AFunctionName: string; AFunIndex: Integer; AParamCount: Integer; AParamTypes: array of Word; AResTyp: Word; AData: Pointer); var JvInterpreterExtFun: TJvInterpreterExtFunction; begin JvInterpreterExtFun := TJvInterpreterExtFunction.Create; with JvInterpreterExtFun do begin FunctionDesc.FUnitName := AUnitName; Identifier := AIdentifier; DllInstance := ADllInstance; DllName := ADllName; FunctionName := AFunctionName; FunctionIndex := AFunIndex; FunctionDesc.FParamCount := AParamCount; FunctionDesc.FResTyp := AResTyp; Data := AData; ConvertParamTypes(AParamTypes, FunctionDesc.FParamTypes); end; FExtFunctionList.Add(JvInterpreterExtFun); end; procedure TJvInterpreterAdapter.AddSrcFun(const UnitName, Identifier: string; PosBeg, PosEnd: Integer; ParamCount: Integer; ParamTypes: array of Word; ParamTypeNames: array of string; //dejoy added ParamNames: array of string; ResTyp: Word; const AResTypName: string; AResDataType: IJvInterpreterDataType; Data: Pointer); begin AddSrcFunEx(UnitName, Identifier, PosBeg, PosEnd, ParamCount, ParamTypes, ParamTypeNames, //dejoy added ParamNames, ResTyp, AResTypName, AResDataType, nil); end; procedure TJvInterpreterAdapter.AddSrcFunEx(const AUnitName, AIdentifier: string; APosBeg, APosEnd: Integer; AParamCount: Integer; AParamTypes: array of Word; AParamTypeNames: array of string; //dejoy added AParamNames: array of string; AResTyp: Word; const AResTypName: string; AResDataType: IJvInterpreterDataType; AData: Pointer); var JvInterpreterSrcFun: TJvInterpreterSrcFunction; begin JvInterpreterSrcFun := TJvInterpreterSrcFunction.Create; with JvInterpreterSrcFun do begin FunctionDesc.FUnitName := AUnitName; FunctionDesc.FIdentifier := AIdentifier; FunctionDesc.FPosBeg := APosBeg; FunctionDesc.FPosEnd := APosEnd; FunctionDesc.FParamCount := AParamCount; FunctionDesc.FResTyp := AResTyp; FunctionDesc.FResTypName := AResTypName; FunctionDesc.FResDataType := AResDataType; Identifier := AIdentifier; Data := AData; ConvertParamTypes(AParamTypes, FunctionDesc.FParamTypes); ConvertParamNames(AParamNames, FunctionDesc.FParamNames); ConvertParamNames(AParamTypeNames, FunctionDesc.FParamTypeNames); //dejoy added for ParamTypeNames FunctionDesc.FResTyp := AResTyp; end; FSrcFunctionList.Add(JvInterpreterSrcFun); end; procedure TJvInterpreterAdapter.AddHandler(const UnitName, Identifier: string; EventClass: TJvInterpreterEventClass; Code: Pointer); begin AddHandlerEx(UnitName, Identifier, EventClass, Code, nil); end; procedure TJvInterpreterAdapter.AddHandlerEx(const AUnitName, AIdentifier: string; AEventClass: TJvInterpreterEventClass; ACode: Pointer; AData: Pointer); var JvInterpreterEventDesc: TJvInterpreterEventDesc; begin JvInterpreterEventDesc := TJvInterpreterEventDesc.Create; with JvInterpreterEventDesc do begin UnitName := AUnitName; Identifier := AIdentifier; EventClass := AEventClass; Code := ACode; Data := AData; end; FEventHandlerList.Add(JvInterpreterEventDesc); end; procedure TJvInterpreterAdapter.AddEvent(const UnitName: string; AClassType: TClass; const Identifier: string); begin AddEventEx(UnitName, AClassType, Identifier, nil); end; procedure TJvInterpreterAdapter.AddEventEx(const AUnitName: string; AClassType: TClass; const AIdentifier: string; AData: Pointer); var JvInterpreterEvent: TJvInterpreterClass; begin JvInterpreterEvent := TJvInterpreterClass.Create; with JvInterpreterEvent do begin UnitName := AUnitName; Identifier := AIdentifier; FClassType := AClassType; Data := AData; end; FEventList.Add(JvInterpreterEvent); end; procedure TJvInterpreterAdapter.AddSrcVar(const UnitName, Identifier, Typ: string; VTyp: Word; const Value: Variant; DataType: IJvInterpreterDataType); begin FSrcVarList.AddVar(UnitName, Identifier, Typ, VTyp, Value, DataType); end; procedure TJvInterpreterAdapter.AddSrcClass(JvInterpreterSrcClass: TJvInterpreterIdentifier); begin FSrcClassList.Add(JvInterpreterSrcClass); end; function TJvInterpreterAdapter.GetSrcClass(const Identifier: string): TJvInterpreterIdentifier; begin Result := FSrcClassList.IndexOf('', Identifier); end; procedure TJvInterpreterAdapter.AddOnGet(Method: TJvInterpreterGetValue); var PM: PMethod; begin New(PM); PM^ := TMethod(Method); FOnGetList.Add(PM); end; procedure TJvInterpreterAdapter.AddOnSet(Method: TJvInterpreterSetValue); var PM: PMethod; begin New(PM); PM^ := TMethod(Method); FOnSetList.Add(PM); end; function TJvInterpreterAdapter.GetRec(const RecordType: string): TObject; var I: Integer; begin for I := 0 to FRecordList.Count - 1 do begin Result := FRecordList[I]; if Cmp(TJvInterpreterRecord(Result).Identifier, RecordType) then Exit; end; Result := nil; end; procedure TJvInterpreterAdapter.CheckArgs(var Args: TJvInterpreterArgs; ParamCount: Integer; var ParamTypes: TTypeArray); var I: Integer; begin if ParamCount = prArgsNoCheck then Exit; if Args.Count > ParamCount then JvInterpreterError(ieTooManyParams, -1); if Args.Count < ParamCount then JvInterpreterError(ieNotEnoughParams, -1); Args.FHasVars := False; Args.Types := ParamTypes; for I := 0 to Args.Count - 1 do if (Args.FVarNames[I] <> '') and ((ParamTypes[I] and varByRef) <> 0) then begin Args.FHasVars := True; Break; end; end; procedure TJvInterpreterAdapter.CheckAction(Expression: TJvInterpreterExpression; Args: TJvInterpreterArgs; Data: Pointer); begin // abstract end; function TJvInterpreterAdapter.FindFunDesc(const UnitName: string; const Identifier: string): TJvInterpreterFunctionDesc; var I: Integer; begin for I := FSrcFunctionList.Count - 1 downto 0 do begin Result := TJvInterpreterSrcFunction(FSrcFunctionList.Items[I]).FunctionDesc; if Cmp(Result.Identifier, Identifier) and (Cmp(Result.UnitName, UnitName) or (UnitName = '')) then Exit; end; if UnitName <> '' then Result := FindFunDesc('', Identifier) else Result := nil; end; function TJvInterpreterAdapter.GetValue(Expression: TJvInterpreterExpression; const Identifier: string; var Value: Variant; Args: TJvInterpreterArgs): Boolean; var I: Integer; function GetMethod: Boolean; var I: Integer; JvInterpreterMethod: TJvInterpreterMethod; begin Result := GetValueRTTI(Identifier, Value, Args); if Result then Exit; if FGetList.Find(Identifier, I) then for I := I to FGetList.Count - 1 do begin JvInterpreterMethod := TJvInterpreterMethod(FGetList[I]); if not Cmp(JvInterpreterMethod.Identifier, Identifier) then // ivan_ra Break; if Assigned(JvInterpreterMethod.Func) and (((Args.ObjTyp = varObject) and (Args.Obj is JvInterpreterMethod.FClassType)) or ((Args.ObjTyp = varClass) and (TClass(Args.Obj) = JvInterpreterMethod.FClassType))) {?!} then begin Args.Identifier := Identifier; CheckAction(Expression, Args, JvInterpreterMethod.Data); CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes); TJvInterpreterAdapterGetValue(JvInterpreterMethod.Func)(Value, Args); Result := True; Exit; end; end; if Cmp(Identifier, 'Free') then begin Result := True; Args.Obj.Free; Args.Obj := nil; Value := Null; Exit; end; end; function IntfGetMethod: Boolean; var I: Integer; JvInterpreterMethod: TJvInterpreterIntfMethod; Intf: IUnknown; begin Result := False; if FIntfGetList.Find(Identifier, I) then for I := I to FIntfGetList.Count - 1 do begin JvInterpreterMethod := TJvInterpreterIntfMethod(FIntfGetList[I]); if not Cmp(JvInterpreterMethod.Identifier, Identifier) then // ivan_ra Break; if Assigned(JvInterpreterMethod.Func) and ((Args.ObjTyp = varUnknown) and (IUnknown(Pointer(Args.Obj)).QueryInterface(JvInterpreterMethod.IID, Intf) = S_OK)) then begin Args.Identifier := Identifier; CheckAction(Expression, Args, JvInterpreterMethod.Data); CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes); TJvInterpreterAdapterGetValue(JvInterpreterMethod.Func)(Value, Args); Result := True; Exit; end; end; end; function IGetMethod: Boolean; var I: Integer; JvInterpreterMethod: TJvInterpreterMethod; begin if FIGetList.Find(Identifier, I) then for I := I to FIGetList.Count - 1 do begin JvInterpreterMethod := TJvInterpreterMethod(FIGetList[I]); if not Cmp(JvInterpreterMethod.Identifier, Identifier) then // ivan_ra Break; if Assigned(JvInterpreterMethod.Func) and (((Args.ObjTyp = varObject) and (Args.Obj is JvInterpreterMethod.FClassType)) or ((Args.ObjTyp = varClass) and (TClass(Args.Obj) = JvInterpreterMethod.FClassType))) {?!} then begin Args.Identifier := Identifier; CheckAction(Expression, Args, JvInterpreterMethod.Data); CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes); TJvInterpreterAdapterGetValue(JvInterpreterMethod.Func)(Value, Args); Result := True; Args.ReturnIndexed := True; Exit; end; end; Result := False; end; { function DGetMethod is under construction } function DGetMethod: Boolean; var JvInterpreterMethod: TJvInterpreterDMethod; I, J: Integer; AInt: Integer; AWord: Word; iRes: Integer; Func: Pointer; REAX, REDX, RECX: Integer; begin Result := False; iRes := 0; for I := 0 to FDirectGetList.Count - 1 do begin JvInterpreterMethod := TJvInterpreterDMethod(FDirectGetList[I]); Func := JvInterpreterMethod.Func; if Assigned(JvInterpreterMethod.Func) and (((Args.ObjTyp = varObject) and (Args.Obj is JvInterpreterMethod.FClassType)) { or ((Args.ObjTyp = varClass) and (TClass(Args.Obj) = JvInterpreterMethod.FClassType))}) and Cmp(JvInterpreterMethod.Identifier, Identifier) then begin Args.Identifier := Identifier; CheckAction(Expression, Args, JvInterpreterMethod.Data); CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes); if ccFastCall in JvInterpreterMethod.CallConvention then begin { !!! Delphi fast-call !!! } { push parameters to stack } for J := 2 to JvInterpreterMethod.ParamCount - 1 do if (JvInterpreterMethod.ParamTypes[J] = varInteger) or (JvInterpreterMethod.ParamTypes[J] = varObject) or (JvInterpreterMethod.ParamTypes[J] = varPointer) or (JvInterpreterMethod.ParamTypes[J] = varBoolean) {?} then begin AInt := Args.Values[J]; asm push AInt end; end else if JvInterpreterMethod.ParamTypes[J] = varSmallint then begin AWord := Word(Args.Values[J]); asm push AWord end; end else JvInterpreterErrorN(ieDirectInvalidArgument, -1, Identifier); REAX := Integer(Args.Obj); if JvInterpreterMethod.ParamCount > 0 then if (JvInterpreterMethod.ParamTypes[0] = varInteger) or (JvInterpreterMethod.ParamTypes[0] = varObject) or (JvInterpreterMethod.ParamTypes[0] = varPointer) or (JvInterpreterMethod.ParamTypes[0] = varBoolean) or (JvInterpreterMethod.ParamTypes[0] = varSmallint) or (JvInterpreterMethod.ParamTypes[0] = varString) then REDX := TVarData(Args.Values[0]).VInteger else JvInterpreterErrorN(ieDirectInvalidArgument, -1, Identifier); if JvInterpreterMethod.ParamCount > 1 then if (JvInterpreterMethod.ParamTypes[1] = varInteger) or (JvInterpreterMethod.ParamTypes[1] = varObject) or (JvInterpreterMethod.ParamTypes[1] = varPointer) or (JvInterpreterMethod.ParamTypes[1] = varBoolean) or (JvInterpreterMethod.ParamTypes[1] = varSmallint) or (JvInterpreterMethod.ParamTypes[1] = varString) then RECX := TVarData(Args.Values[1]).VInteger else JvInterpreterErrorN(ieDirectInvalidArgument, -1, Identifier); if (JvInterpreterMethod.ResTyp = varSmallint) or (JvInterpreterMethod.ResTyp = varInteger) or (JvInterpreterMethod.ResTyp = varBoolean) or (JvInterpreterMethod.ResTyp = varEmpty) or (JvInterpreterMethod.ResTyp = varObject) or (JvInterpreterMethod.ResTyp = varPointer) then asm mov EAX, REAX mov EDX, REDX mov ECX, RECX call Func mov iRes, EAX end else JvInterpreterErrorN(ieDirectInvalidResult, -1, Identifier); { clear result } if (JvInterpreterMethod.ResTyp = varInteger) or (JvInterpreterMethod.ResTyp = varObject) then Value := iRes else if JvInterpreterMethod.ResTyp = varSmallint then Value := iRes and $0000FFFF else if JvInterpreterMethod.ResTyp = varBoolean then begin Value := iRes and $000000FF; TVarData(Value).VType := varBoolean; end else if JvInterpreterMethod.ResTyp = varEmpty then Value := Null; end else JvInterpreterErrorN(ieDirectInvalidConvention, -1, Identifier); Result := True; Exit; end; end; end; function GetRecord: Boolean; var I: Integer; JvInterpreterRecord: TJvInterpreterRecord; Rec: PChar; JvInterpreterRecMethod: TJvInterpreterRecMethod; begin Result := False; JvInterpreterRecord := (Args.Obj as TJvInterpreterRecHolder).JvInterpreterRecord; for I := 0 to JvInterpreterRecord.FieldCount - 1 do if Cmp(JvInterpreterRecord.Fields[I].Identifier, Identifier) then begin Rec := P2R(Args.Obj); with JvInterpreterRecord.Fields[I] do case Typ of varInteger: Value := PInteger(Rec + Offset)^; varSmallint: Value := SmallInt(PWord(Rec + Offset)^); varBoolean: Value := PBool(Rec + Offset)^; varString: Value := PString(Rec + Offset)^; varEmpty: JvInterpreterVarCopy(Value, Variant(PVarData(Rec + Offset)^)); end; Result := True; Exit; end; for I := 0 to FRecordGetList.Count - 1 do begin JvInterpreterRecMethod := TJvInterpreterRecMethod(FRecordGetList[I]); if (JvInterpreterRecMethod.JvInterpreterRecord = JvInterpreterRecord) and Cmp(JvInterpreterRecMethod.Identifier, Identifier) then begin Args.Identifier := Identifier; CheckArgs(Args, JvInterpreterRecMethod.ParamCount, JvInterpreterRecMethod.ParamTypes); TJvInterpreterAdapterGetValue(JvInterpreterRecMethod.Func)(Value, Args); Result := True; Exit; end; end end; function GetConst: Boolean; var I: Integer; JvInterpreterConst: TJvInterpreterConst; begin if Cmp(Identifier, kwNIL) then begin Value := P2V(nil); Result := True; Exit; end; if Cmp(Identifier, 'Null') then begin Value := Null; Result := True; Exit; end; Result := FConstList.Find(Identifier, I); if Result then begin JvInterpreterConst := TJvInterpreterConst(FConstList[I]); CheckAction(Expression, Args, JvInterpreterConst.Data); Value := JvInterpreterConst.Value; end; end; function GetClass: Boolean; var I: Integer; JvInterpreterClass: TJvInterpreterClass; begin Result := FClassList.Find(Identifier, I); if Result then begin JvInterpreterClass := TJvInterpreterClass(FClassList[I]); if Args.Count = 0 then Value := C2V(JvInterpreterClass.FClassType) else if Args.Count = 1 then { typecasting } begin CheckAction(Expression, Args, JvInterpreterClass.Data); Value := Args.Values[0]; if TVarData(Value).VType <> varClass then TVarData(Value).VType := varObject; end else JvInterpreterError(ieTooManyParams, -1); end; end; function GetFun: Boolean; var I: Integer; JvInterpreterMethod: TJvInterpreterMethod; begin Result := FFunctionList.Find(Identifier, I); if Result then begin JvInterpreterMethod := TJvInterpreterMethod(FFunctionList[I]); if Cmp(JvInterpreterMethod.Identifier, Identifier) then begin Args.Identifier := Identifier; CheckAction(Expression, Args, JvInterpreterMethod.Data); CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes); TJvInterpreterAdapterGetValue(JvInterpreterMethod.Func)(Value, Args); end; end; end; function GetExtFun: Boolean; var I: Integer; JvInterpreterExtFun: TJvInterpreterExtFunction; begin if DisableExternalFunctions then begin Result := False; Exit; end; for I := 0 to FExtFunctionList.Count - 1 do begin JvInterpreterExtFun := TJvInterpreterExtFunction(FExtFunctionList[I]); if Cmp(JvInterpreterExtFun.Identifier, Identifier) then begin Args.Identifier := Identifier; CheckAction(Expression, Args, JvInterpreterExtFun.Data); CheckArgs(Args, JvInterpreterExtFun.FunctionDesc.ParamCount, JvInterpreterExtFun.FunctionDesc.FParamTypes); Value := JvInterpreterExtFun.CallDll(Args); Result := True; Exit; end; end; Result := False; end; function GetSrcVar: Boolean; begin Result := FSrcVarList.GetValue(Identifier, Value, Args); end; function GetSrcUnit: Boolean; var I: Integer; JvInterpreterSrcUnit: TJvInterpreterSrcUnit; FParams: TTypeArray; begin for I := 0 to FSrcUnitList.Count - 1 do begin JvInterpreterSrcUnit := TJvInterpreterSrcUnit(FSrcUnitList[I]); if Cmp(JvInterpreterSrcUnit.Identifier, Identifier) then begin CheckArgs(Args, 0, FParams); Value := O2V(JvInterpreterSrcUnit); Result := True; Exit; end; end; Result := False; end; {$IFDEF JvInterpreter_OLEAUTO} function GetOleAutoFun: Boolean; var FParams: TTypeArray; begin Result := False; if Cmp(Identifier, 'CreateOleObject') or Cmp(Identifier, 'GetActiveOleObject') or Cmp(Identifier, 'GetOleObject') then begin FParams[0] := varString; CheckArgs(Args, 1, FParams); if Cmp(Identifier, 'CreateOleObject') then Value := CreateOleObject(Args.Values[0]) else if Cmp(Identifier, 'GetActiveOleObject') then Value := GetActiveOleObject(Args.Values[0]) else { GetOleObject } begin try Value := GetActiveOleObject(Args.Values[0]) except on E: EOleError do Value := CreateOleObject(Args.Values[0]) end; end; Result := True; Exit; end; end; {$ENDIF JvInterpreter_OLEAUTO} function TypeCast: Boolean; var VT: Word; begin VT := TypeName2VarTyp(Identifier); Result := VT <> varEmpty; if Result then begin Value := Args.Values[0]; TVarData(Value).VType := VT; end; end; begin Result := True; if not FSorted then Sort; if Args.Indexed then begin if Args.ObjTyp = varRecord then begin if (Args.Obj is TJvInterpreterRecHolder) and GetRecord then begin Args.ReturnIndexed := False; Exit; end; end else if (Args.Obj <> nil) and ((Args.ObjTyp = varObject) or (Args.ObjTyp = varClass)) then begin // ivan_ra if IGetMethod then Exit; I := Args.Count; try // try to get indexed property Args.Count := 0; Result := GetMethod or DGetMethod; finally Args.Count := I; end; if Result then Exit; end; // ivan_ra end else begin if Args.Obj <> nil then begin { methods } if (Args.ObjTyp = varObject) or (Args.ObjTyp = varClass) then begin if GetMethod or DGetMethod then Exit; end else if Args.ObjTyp = varUnknown then begin if IntfGetMethod then Exit; end else if Args.ObjTyp = varRecord then begin if (Args.Obj is TJvInterpreterRecHolder) and GetRecord then Exit; end else if Args.ObjTyp = varDispatch then { Ole automation call } begin {$IFDEF JvInterpreter_OLEAUTO} Result := DispatchCall(Identifier, Value, Args, True); if Result then Exit; {$ELSE} NotImplemented(RsOleAutomationCall); {$ENDIF JvInterpreter_OLEAUTO} end; end else begin { classes } if GetClass then Exit; { constants } if GetConst then Exit; { classless functions and procedures } if GetFun then Exit; { external functions } if GetExtFun then Exit; {$IFDEF JvInterpreter_OLEAUTO} if GetOleAutoFun then Exit; {$ENDIF JvInterpreter_OLEAUTO} if TypeCast then Exit; end; end; { source variables and constants } if GetSrcVar then Exit; if not ((Args.Obj <> nil) and ((Args.ObjTyp = varObject) or (Args.ObjTyp = varClass))) then // ivan_ra if GetSrcUnit then Exit; for I := 0 to FOnGetList.Count - 1 do { Iterate } begin TJvInterpreterGetValue(FOnGetList[I]^)(Self, Identifier, Value, Args, Result); if Result then Exit; end; Result := False; end; function TJvInterpreterAdapter.SetValue(Expression: TJvInterpreterExpression; const Identifier: string; const Value: Variant; Args: TJvInterpreterArgs): Boolean; var I: Integer; {$IFDEF JvInterpreter_OLEAUTO} V: Variant; {$ENDIF JvInterpreter_OLEAUTO} function SetMethod: Boolean; var I: Integer; JvInterpreterMethod: TJvInterpreterMethod; begin Result := SetValueRTTI(Identifier, Value, Args); if Result then Exit; for I := 0 to FSetList.Count - 1 do begin JvInterpreterMethod := TJvInterpreterMethod(FSetList[I]); if Assigned(JvInterpreterMethod.Func) and (Args.Obj is JvInterpreterMethod.FClassType) and Cmp(JvInterpreterMethod.Identifier, Identifier) then begin Args.Identifier := Identifier; CheckAction(Expression, Args, JvInterpreterMethod.Data); CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes); TJvInterpreterAdapterSetValue(JvInterpreterMethod.Func)(Value, Args); Result := True; Exit; end; end; end; function ISetMethod: Boolean; var I: Integer; JvInterpreterMethod: TJvInterpreterMethod; begin Result := False; if FISetList.Find(Identifier, I) then for I := I to FISetList.Count - 1 do begin JvInterpreterMethod := TJvInterpreterMethod(FISetList[I]); if not Cmp(JvInterpreterMethod.Identifier, Identifier) then // ivan_ra Break; if Assigned(JvInterpreterMethod.Func) and (Args.Obj is JvInterpreterMethod.FClassType) and Cmp(JvInterpreterMethod.Identifier, Identifier) then begin Args.Identifier := Identifier; CheckAction(Expression, Args, JvInterpreterMethod.Data); CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes); TJvInterpreterAdapterSetValue(JvInterpreterMethod.Func)(Value, Args); Result := True; Args.ReturnIndexed := True; Exit; end; end; end; function SetRecord: Boolean; var I: Integer; JvInterpreterRecord: TJvInterpreterRecord; JvInterpreterRecMethod: TJvInterpreterRecMethod; Rec: PChar; begin Result := False; JvInterpreterRecord := (Args.Obj as TJvInterpreterRecHolder).JvInterpreterRecord; for I := 0 to JvInterpreterRecord.FieldCount - 1 do if Cmp(JvInterpreterRecord.Fields[I].Identifier, Identifier) then begin Rec := P2R(Args.Obj); with JvInterpreterRecord.Fields[I] do case Typ of varInteger: PInteger(Rec + Offset)^ := Value; varSmallint: PWord(Rec + Offset)^ := Word(Value); varBoolean: PBool(Rec + Offset)^ := Value; varEmpty: JvInterpreterVarAssignment(Variant(PVarData(Rec + Offset)^), Value); end; Result := True; Exit; end; for I := 0 to FRecordSetList.Count - 1 do begin JvInterpreterRecMethod := TJvInterpreterRecMethod(FRecordSetList[I]); if (JvInterpreterRecMethod.JvInterpreterRecord = JvInterpreterRecord) and Cmp(JvInterpreterRecMethod.Identifier, Identifier) then begin Args.Identifier := Identifier; CheckArgs(Args, JvInterpreterRecMethod.ParamCount, JvInterpreterRecMethod.ParamTypes); TJvInterpreterAdapterSetValue(JvInterpreterRecMethod.Func)(Value, Args); Result := True; Exit; end; end; end; function SetSrcVar: Boolean; begin Result := FSrcVarList.SetValue(Identifier, Value, Args); end; begin Result := True; if not FSorted then Sort; if Args.Indexed then begin if (Args.Obj <> nil) and ((Args.ObjTyp = varObject) or (Args.ObjTyp = varClass)) then if ISetMethod then Exit; end else begin if Args.Obj <> nil then begin { methods } if (Args.ObjTyp = varObject) or (Args.ObjTyp = varClass) then begin if SetMethod then Exit; end else if Args.ObjTyp = varRecord then begin if (Args.Obj is TJvInterpreterRecHolder) and SetRecord then Exit; end else if Args.ObjTyp = varDispatch then { Ole automation call } begin {$IFDEF JvInterpreter_OLEAUTO} V := Value; Result := DispatchCall(Identifier, V, Args, False); if Result then Exit; {$ELSE} NotImplemented(RsOleAutomationCall); {$ENDIF JvInterpreter_OLEAUTO} end; end; end; { source variables and constants } if SetSrcVar then Exit; for I := 0 to FOnSetList.Count - 1 do { Iterate } begin TJvInterpreterSetValue(FOnSetList[I]^)(Self, Identifier, Value, Args, Result); if Result then Exit; end; Result := False; end; function TJvInterpreterAdapter.GetElement(Expression: TJvInterpreterExpression; const Variable: Variant; var Value: Variant; var Args: TJvInterpreterArgs): Boolean; function GetID: Boolean; var I: Integer; JvInterpreterMethod: TJvInterpreterMethod; Obj: TObject; begin Obj := V2O(Variable); for I := 0 to FIDGetList.Count - 1 do begin JvInterpreterMethod := TJvInterpreterMethod(FIDGetList[I]); if Obj is JvInterpreterMethod.FClassType then begin Args.Obj := Obj; CheckAction(Expression, Args, JvInterpreterMethod.Data); CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes); TJvInterpreterAdapterGetValue(JvInterpreterMethod.Func)(Value, Args); Result := True; Exit; end; end; Result := False; end; begin Result := True; { default indexed properties } if TVarData(Variable).VType = varObject then begin if GetID then Exit; Result := False; end else Result := False; end; function TJvInterpreterAdapter.SetElement(Expression: TJvInterpreterExpression; var Variable: Variant; const Value: Variant; var Args: TJvInterpreterArgs): Boolean; function SetID: Boolean; var I: Integer; JvInterpreterMethod: TJvInterpreterMethod; Obj: TObject; begin Obj := V2O(Variable); for I := 0 to FIDSetList.Count - 1 do begin JvInterpreterMethod := TJvInterpreterMethod(FIDSetList[I]); if Obj is JvInterpreterMethod.FClassType then begin Args.Obj := Obj; CheckAction(Expression, Args, JvInterpreterMethod.Data); CheckArgs(Args, JvInterpreterMethod.ParamCount, JvInterpreterMethod.ParamTypes); TJvInterpreterAdapterSetValue(JvInterpreterMethod.Func)(Value, Args); Result := True; Exit; end; end; Result := False; end; begin Result := True; { default indexed properties } if TVarData(Variable).VType = varObject then begin if SetID then Exit; Result := False; end else Result := False; end; function TJvInterpreterAdapter.SetRecord(var Value: Variant): Boolean; var RecHolder: TJvInterpreterRecHolder; begin if TVarData(Value).VType = varRecord then begin RecHolder := TJvInterpreterRecHolder(TVarData(Value).VPointer); RecHolder.JvInterpreterRecord := TJvInterpreterRecord(GetRec(RecHolder.RecordType)); Result := Assigned(RecHolder.JvInterpreterRecord); end else Result := False; end; function TJvInterpreterAdapter.NewRecord(const RecordType: string; var Value: Variant): Boolean; var JvInterpreterRecord: TJvInterpreterRecord; begin JvInterpreterRecord := TJvInterpreterRecord(GetRec(RecordType)); if JvInterpreterRecord = nil then Result := False else begin JvInterpreterRecord.NewRecord(Value); Result := True; end; end; {$IFDEF JvInterpreter_OLEAUTO} function TJvInterpreterAdapter.DispatchCall(const Identifier: string; var Value: Variant; Args: TJvInterpreterArgs; Get: Boolean): Boolean; stdcall; var CallDesc: TCallDesc; ParamTypes: array [0..MaxDispArgs * 4 - 1] of Byte; Ptr: Integer; TypePtr: Integer; PVRes: PVariant; Names: string; I: Integer; procedure AddParam(const Param: Variant); var Int: Integer; Wrd: WordBool; Poin: Pointer; Dbl: Double; //TempDisp : IDispatch; ComObj procedure AddParam1(Typ: Byte; ParamSize: Integer; const Param); begin { CallDesc.ArgTypes[Ptr] := Typ; Move(Param, ParamTypes[Ptr], ParamSize); Inc(Ptr, ParamSize); } CallDesc.ArgTypes[TypePtr] := Typ; Move(Param, ParamTypes[Ptr], ParamSize); Inc(Ptr, ParamSize); Inc(TypePtr); end; begin case TVarData(Param).VType of varInteger: begin Int := Param; AddParam1(varInteger, SizeOf(Int), Int); end; varDouble, varCurrency: begin Dbl := Param; AddParam1(varDouble, SizeOf(Dbl), Dbl); end; varString: begin Poin := V2P(Param); AddParam1(varStrArg, SizeOf(Poin), Poin); end; varBoolean: begin Wrd := WordBool(Param); AddParam1(varBoolean, SizeOf(Wrd), Wrd); end; { varDispatch: begin TempDisp := VarToInterface(Param.IFace); AddParam1(varDispatch, SizeOf(TempDisp), TempDisp); end; } end; end; begin Result := True; { Call method through Ole Automation } with CallDesc do begin if Get then CallType := DISPATCH_METHOD or DISPATCH_PROPERTYGET else CallType := DISPATCH_PROPERTYPUT; ArgCount := Args.Count; NamedArgCount := 0; { named args not supported by JvInterpreter } end; Names := Identifier + #00; Ptr := 0; TypePtr := 0; if not Get then begin AddParam(Value); Inc(CallDesc.ArgCount); end; for I := 0 to Args.Count - 1 do AddParam(Args.Values[I]); Value := Null; { When calling procedures(without result) PVRes must be nil } if Args.HasResult and Get then PVRes := @Value else PVRes := nil; try { call } // (rom) absolute removed VarDispInvoke(PVRes, Args.Obj, PChar(Names), @CallDesc, @ParamTypes[0]); except on E: EOleError do JvInterpreterErrorN2(ieOleAuto, -1, Identifier, E.Message); end; if Get and (TVarData(Value).VType = varOleStr) then Value := VarAsType(Value, varString); end; {$ENDIF JvInterpreter_OLEAUTO} function TJvInterpreterAdapter.GetValueRTTI(const Identifier: string; var Value: Variant; Args: TJvInterpreterArgs): Boolean; var TypeInf: PTypeInfo; PropInf: PPropInfo; PropTyp: TypInfo.TTypeKind; begin Result := False; if (Args.ObjTyp <> varObject) or (Args.Obj = nil) then Exit; TypeInf := Args.Obj.ClassInfo; if TypeInf = nil then Exit; PropInf := GetPropInfo(TypeInf, Identifier); if PropInf = nil then Exit; PropTyp := PropInf.PropType^.Kind; case PropTyp of tkInteger, tkEnumeration: Value := GetOrdProp(Args.Obj, PropInf); tkChar, tkWChar: Value := Char(GetOrdProp(Args.Obj, PropInf)); tkFloat: Value := GetFloatProp(Args.Obj, PropInf); tkString, tkLString, tkWString: Value := GetStrProp(Args.Obj, PropInf); tkClass: Value := O2V(TObject(GetOrdProp(Args.Obj, PropInf))); tkSet: Value := S2V(GetOrdProp(Args.Obj, PropInf)); {$IFDEF COMPILER6_UP} tkInterface: Value := GetInterfaceProp(Args.Obj, PropInf) {$ENDIF COMPILER6_UP} else Exit; end; if PropInf^.PropType^.Name = 'Boolean' then TVarData(Value).VType := varBoolean; Result := True; end; function TJvInterpreterAdapter.SetValueRTTI(const Identifier: string; const Value: Variant; Args: TJvInterpreterArgs): Boolean; var TypeInf: PTypeInfo; PropInf: PPropInfo; PropTyp: TypInfo.TTypeKind; Obj: TObject; begin Result := False; if (Args.ObjTyp <> varObject) or (Args.Obj = nil) then Exit; Obj := Args.Obj; TypeInf := Obj.ClassInfo; if TypeInf = nil then Exit; PropInf := GetPropInfo(TypeInf, Identifier); if PropInf = nil then Exit; PropTyp := PropInf.PropType^.Kind; case PropTyp of tkInteger, tkEnumeration: SetOrdProp(Args.Obj, PropInf, Var2Type(Value, varInteger)); tkChar, tkWChar: SetOrdProp(Args.Obj, PropInf, Integer(string(Value)[1])); tkFloat: SetFloatProp(Args.Obj, PropInf, Value); tkString, tkLString, tkWString: SetStrProp(Args.Obj, PropInf, VarToStr(Value)); tkClass: SetOrdProp(Args.Obj, PropInf, Integer(V2O(Value))); tkSet: SetOrdProp(Args.Obj, PropInf, V2S(Value)); {$IFDEF COMPILER6_UP} tkInterface: SetInterfaceProp(Args.Obj, PropInf, Value); {$ENDIF COMPILER6_UP} else Exit; end; Result := True; end; procedure TJvInterpreterAdapter.CurUnitChanged(const NewUnitName: string; var Source: string); var I: Integer; JvInterpreterUnitSource: TJvInterpreterSrcUnit; begin for I := 0 to FSrcUnitList.Count - 1 do begin JvInterpreterUnitSource := TJvInterpreterSrcUnit(FSrcUnitList.Items[I]); if Cmp(TJvInterpreterSrcUnit(JvInterpreterUnitSource).Identifier, NewUnitName) then begin Source := TJvInterpreterSrcUnit(JvInterpreterUnitSource).FSource; Exit; end; end; Source := ''; end; function TJvInterpreterAdapter.UnitExists(const Identifier: string): Boolean; var JvInterpreterIdentifier: TJvInterpreterIdentifier; I: Integer; begin Result := True; for I := 0 to FSrcUnitList.Count - 1 do begin JvInterpreterIdentifier := TJvInterpreterIdentifier(FSrcUnitList.Items[I]); if Cmp(JvInterpreterIdentifier.Identifier, Identifier) then Exit; end; for I := 0 to FExtUnitList.Count - 1 do begin JvInterpreterIdentifier := TJvInterpreterIdentifier(FExtUnitList.Items[I]); if Cmp(JvInterpreterIdentifier.Identifier, Identifier) then Exit; end; Result := False; end; function TJvInterpreterAdapter.NewEvent(const UnitName: string; const FunctionName, EventType: string; AOwner: TJvInterpreterExpression; AObject: TObject; const APropName: string): TSimpleEvent; var Event: TJvInterpreterEvent; I: Integer; JvInterpreterEventDesc: TJvInterpreterEventDesc; begin for I := 0 to FEventHandlerList.Count - 1 do begin JvInterpreterEventDesc := TJvInterpreterEventDesc(FEventHandlerList.Items[I]); if Cmp(JvInterpreterEventDesc.Identifier, EventType) then begin Event := JvInterpreterEventDesc.EventClass.Create(AOwner, AObject, UnitName, FunctionName, APropName); TMethod(Result).Code := JvInterpreterEventDesc.Code; TMethod(Result).Data := Event; Exit; end; end; Result := nil; end; function TJvInterpreterAdapter.IsEvent(Obj: TObject; const Identifier: string): Boolean; var JvInterpreterClass: TJvInterpreterClass; I: Integer; begin for I := 0 to FEventList.Count - 1 do begin JvInterpreterClass := TJvInterpreterClass(FEventList[I]); if (Obj is JvInterpreterClass.FClassType) and Cmp(JvInterpreterClass.Identifier, Identifier) then begin Result := True; Exit; end; end; Result := False; end; procedure TJvInterpreterAdapter.Sort; begin FConstList.Sort; FClassList.Sort; FFunctionList.Sort; FGetList.Sort; FIntfGetList.Sort; FSetList.Sort; FIGetList.Sort; FISetList.Sort; FSorted := True; end; //=== { TJvInterpreterArgs } ================================================= destructor TJvInterpreterArgs.Destroy; begin if OA <> nil then Dispose(OA); if FOAV <> nil then Dispose(FOAV); inherited Destroy; end; procedure TJvInterpreterArgs.Clear; begin Count := 0; Obj := nil; ObjTyp := 0; FHasVars := False; Indexed := False; ReturnIndexed := False; ObjRefHolder := Unassigned; end; procedure TJvInterpreterArgs.OpenArray(const Index: Integer); begin if OA = nil then New(OA); if FOAV = nil then New(FOAV); V2OA(Values[Index], OA^, FOAV^, OAS); end; procedure TJvInterpreterArgs.Delete(const Index: Integer); var I: Integer; begin for I := Index to Count - 2 do begin Types[I] := Types[I + 1]; Values[I] := Values[I + 1]; Names[I] := Names[I + 1]; end; Dec(Count); end; //=== { TJvInterpreterExpression } =========================================== constructor TJvInterpreterExpression.Create(AOwner: TComponent); begin inherited Create(AOwner); FParser := TJvInterpreterParser.Create; FPStream := TStringStream.Create(''); FArgs := TJvInterpreterArgs.Create; FAdapter := CreateAdapter; FDisableExternalFunctions := False; FAdapter.DisableExternalFunctions := False; FSharedAdapter := GlobalJvInterpreterAdapter; FLastError := EJvInterpreterError.Create(-1, -1, '', ''); FAllowAssignment := True; FCompiled := False; end; destructor TJvInterpreterExpression.Destroy; begin //JvInterpreterVarFree(FVResult); FAdapter.Free; FArgs.Free; FPStream.Free; FParser.Free; FLastError.Free; inherited Destroy; end; procedure TJvInterpreterExpression.UpdateExceptionPos(E: Exception; const UnitName: string); procedure NoName(E: EJvInterpreterError); begin if not E.FExceptionPos then begin if E.FErrPos = -1 then E.FErrPos := CurPos; if E.FErrUnitName = '' then E.FErrUnitName := UnitName; if E.FErrUnitName <> '' then begin { first line has number 1 } E.FErrLine := GetLineByPos(FParser.Source, E.FErrPos) + BaseErrLine + 1; E.Message := Format(LoadStr2(ieErrorPos), [E.FErrUnitName, E.FErrLine, E.FErrMessage]); E.FExceptionPos := True; end; end; end; begin if E is EJvInterpreterError then begin NoName(E as EJvInterpreterError); FLastError.Assign(E as EJvInterpreterError); end else if not FLastError.FExceptionPos then begin FLastError.FErrCode := ieExternal; FLastError.Message := E.Message; FLastError.FErrMessage := E.Message; NoName(FLastError); end; end; procedure TJvInterpreterExpression.Init; begin FVResult := Null; FExpStackPtr := -1; // Parse; FParser.Init; FBacked := False; FCurrArgs := FArgs; FAdapter.ClearNonSource; FLastError.Clear; end; function TJvInterpreterExpression.GetSource: string; begin Result := FParser.Source; end; procedure TJvInterpreterExpression.SetSource(const Value: string); begin FParser.Source := Value; SourceChanged; end; procedure TJvInterpreterExpression.SourceChanged; begin end; procedure TJvInterpreterExpression.SetAdapter(Adapter: TJvInterpreterAdapter); begin FAdapter := Adapter; end; procedure TJvInterpreterExpression.SetCurPos(Value: Integer); begin if FParsed then FPStream.Position := Value else FParser.Pos := Value; FBacked := False; end; function TJvInterpreterExpression.GetCurPos: Integer; begin if FParsed then Result := FPStream.Position else Result := FParser.Pos; end; procedure TJvInterpreterExpression.ErrorExpected(const Exp: string); begin if TokenStr <> '' then JvInterpreterErrorN2(ieExpected, PosBeg, Exp, '''' + TokenStr + '''') else JvInterpreterErrorN2(ieExpected, PosBeg, Exp, LoadStr2(irEndOfFile)); end; procedure TJvInterpreterExpression.ErrorNotImplemented(const Msg: string); begin JvInterpreterErrorN(ieInternal, PosBeg, Msg + RsENotImplemented); end; function TJvInterpreterExpression.PosBeg: Integer; begin Result := CurPos - Length(TokenStr); end; function TJvInterpreterExpression.PosEnd: Integer; begin Result := CurPos; end; function TJvInterpreterExpression.GetTokenStr: string; begin if FParsed and (TTyp <> ttUnknown) then Result := TypToken(TTyp) else Result := FTokenStr; end; procedure TJvInterpreterExpression.Parse; begin FPStream.Size := 0; FPStream.Position := 0; FParser.Init; repeat ParseToken; WriteToken; until FTTyp = ttEmpty; FParsed := True; FPStream.Position := 0; end; procedure TJvInterpreterExpression.WriteToken; begin WordSaveToStream(FPStream, Word(FTTyp)); case FTTyp of ttInteger: IntSaveToStream(FPStream, FToken); ttString: StringSaveToStream(FPStream, FToken); ttTrue, ttFalse: BoolSaveToStream(FPStream, FToken); ttDouble: ExtendedSaveToStream(FPStream, FToken); ttIdentifier: StringSaveToStream(FPStream, FToken); ttUnknown: StringSaveToStream(FPStream, FTokenStr); end; end; procedure TJvInterpreterExpression.ReadToken; begin FTTyp := SmallInt(WordLoadFromStream(FPStream)); case FTTyp of ttInteger: FToken := IntLoadFromStream(FPStream); ttString: FToken := StringLoadFromStream(FPStream); ttTrue, ttFalse: FToken := BoolLoadFromStream(FPStream); ttDouble: FToken := ExtendedLoadFromStream(FPStream); ttIdentifier: FToken := StringLoadFromStream(FPStream); ttUnknown: FTokenStr := StringLoadFromStream(FPStream); end; end; procedure TJvInterpreterExpression.NextToken; begin if FBacked then FBacked := False else begin FPrevTTyp := FTTyp; if FParsed then ReadToken else ParseToken; end; end; procedure TJvInterpreterExpression.ParseToken; var OldDecimalSeparator: Char; Dob: Extended; Int: Integer; Stub: Integer; begin FTokenStr := FParser.Token; FTTyp := TokenTyp(FTokenStr); case TTyp of ttInteger: begin Val(FTokenStr, Int, Stub); FToken := Int; end; ttDouble: begin OldDecimalSeparator := DecimalSeparator; DecimalSeparator := '.'; if not TextToFloat(PChar(FTokenStr), Dob, fvExtended) then begin DecimalSeparator := OldDecimalSeparator; JvInterpreterError(ieInternal, -1); end else DecimalSeparator := OldDecimalSeparator; FToken := Dob; end; ttString: FToken := Copy(TokenStr, 2, Length(FTokenStr) - 2); ttFalse: FToken := False; ttTrue: FToken := True; ttIdentifier: FToken := FTokenStr; {-----olej-----} ttArray: FToken := FTokenStr; {-----olej-----} end; end; procedure TJvInterpreterExpression.Back; begin // JvInterpreterError(ieInternal, -2); if FBacked then JvInterpreterError(ieInternal, -1); FBacked := True; end; procedure TJvInterpreterExpression.SafeBack; begin if not FBacked then Back; end; function TJvInterpreterExpression.CreateAdapter: TJvInterpreterAdapter; begin Result := TJvInterpreterAdapter.Create(Self); end; function TJvInterpreterExpression.Expression1: Variant; var OldExpStackPtr: Integer; procedure PushExp(var Value: Variant); begin Inc(FExpStackPtr); if FExpStackPtr > High(FExpStack) then JvInterpreterError(ieExpressionStackOverflow, -1); JvInterpreterVarCopy(FExpStack[FExpStackPtr], Value); end; function PopExp: Variant; begin if FExpStackPtr = -1 then JvInterpreterError(ieInternal, -1); JvInterpreterVarCopy(Result, FExpStack[FExpStackPtr]); Dec(FExpStackPtr); end; { function Expression called recursively very often, so placing it as local function (not class method) improves performance } function Expression(const OpTyp: TTokenKind): Variant; var Tmp: Variant; begin Result := Unassigned; if OpTyp <> ttUnknown then NextToken; while True do begin case TTyp of ttInteger, ttDouble, ttString, ttFalse, ttTrue, ttIdentifier: begin Result := Token; if TTyp = ttIdentifier then begin FCurrArgs.Clear; InternalGetValue(nil, 0, Result); end; NextToken; if TTyp in [ttInteger, ttDouble, ttString, ttFalse, ttTrue, ttIdentifier] then JvInterpreterError(ieMissingOperator, PosEnd {!!}); if Prior(TTyp) < Prior(OpTyp) then Exit; end; // [peter schraut: added ttShl case on 2005/08/14] ttShl: if priorShl > Prior(OpTyp) then Result := PopExp shl Expression(TTyp) else Exit; // [peter schraut: added ttShr case on 2005/08/14] ttShr: if priorShr > Prior(OpTyp) then Result := PopExp shr Expression(TTyp) else Exit; // [peter schraut: added ttXor case on 2005/08/14] ttXor: if priorXor > Prior(OpTyp) then Result := PopExp xor Expression(TTyp) else Exit; ttMul: if priorMul > Prior(OpTyp) then Result := PopExp * Expression(TTyp) else Exit; ttPlus: { proceed differently depending on type } if not (FPrevTTyp in [ttInteger, ttDouble, ttString, ttFalse, ttTrue, ttIdentifier, ttRB, ttRS]) then { unary plus } Result := Expression(ttNot) { highest priority } else if priorPlus > Prior(OpTyp) then begin Tmp := PopExp; if TVarData(Tmp).VType = varSet then begin Result := TVarData(Tmp).VInteger or TVarData(Expression(TTyp)).VInteger; TVarData(Result).VType := varSet; end else Result := Tmp + Expression(TTyp) end else Exit; ttMinus: { proceed differently depending on type } if not (FPrevTTyp in [ttInteger, ttDouble, ttString, ttFalse, ttTrue, ttIdentifier, ttRB, ttRS]) then { unary minus } Result := -Expression(ttNot) { highest priority } else if priorMinus > Prior(OpTyp) then begin Tmp := PopExp; if TVarData(Tmp).VType = varSet then begin Result := TVarData(Tmp).VInteger and not TVarData(Expression(TTyp)).VInteger; TVarData(Result).VType := varSet; end else Result := Tmp - Expression(TTyp) end else Exit; ttDiv: if priorDiv > Prior(OpTyp) then Result := PopExp / Expression(TTyp) else Exit; ttIntDiv: if priorIntDiv > Prior(OpTyp) then Result := PopExp div Expression(TTyp) else Exit; ttMod: if priorMod > Prior(OpTyp) then Result := PopExp mod Expression(TTyp) else Exit; ttOr: if priorOr > Prior(OpTyp) then Result := PopExp or Expression(TTyp) else Exit; ttAnd: if priorAnd > Prior(OpTyp) then Result := PopExp and Expression(TTyp) else Exit; ttNot: { 'Not' has highest priority, so we have no need to check this } // if priorNot > Prior(OpTyp) then Result := not Expression(TTyp); // else Exit; ttEqu: { proceed differently depending on type } if priorEqu > Prior(OpTyp) then begin Tmp := PopExp; if (TVarData(Tmp).VType = varObject) or (TVarData(Tmp).VType = varClass) or (TVarData(Tmp).VType = varSet) or (TVarData(Tmp).VType = varPointer) then Result := TVarData(Tmp).VInteger = TVarData(Expression(TTyp)).VInteger else Result := Tmp = Expression(TTyp) end else Exit; ttNotEqu: { proceed differently depending on a types } if priorNotEqu > Prior(OpTyp) then begin Tmp := PopExp; if (TVarData(Tmp).VType = varObject) or (TVarData(Tmp).VType = varClass) or (TVarData(Tmp).VType = varSet) or (TVarData(Tmp).VType = varPointer) then Result := TVarData(Tmp).VInteger <> TVarData(Expression(TTyp)).VInteger else if TVarData(Tmp).VType = varUnknown then Result := TVarData(Tmp).VUnknown <> TVarData(Expression(TTyp)).VUnknown else Result := Tmp <> Expression(TTyp) end else Exit; ttGreater: if priorGreater > Prior(OpTyp) then Result := PopExp > Expression(TTyp) else Exit; ttLess: if priorLess > Prior(OpTyp) then Result := PopExp < Expression(TTyp) else Exit; ttEquLess: if priorEquLess > Prior(OpTyp) then Result := PopExp <= Expression(TTyp) else Exit; ttEquGreater: if priorEquGreater > Prior(OpTyp) then Result := PopExp >= Expression(TTyp) else Exit; ttLB: begin Result := Expression(TTyp); if FTTyp <> ttRB then ErrorExpected(''')'''); NextToken; end; ttRB: if TVarData(Result).VType = varEmpty then ErrorExpected(LoadStr2(irExpression)) else Exit; ttLS: begin NextToken; Result := SetExpression1; if FTTyp <> ttRS then ErrorExpected(''']'''); NextToken; end; ttRS: if TVarData(Result).VType = varEmpty then ErrorExpected(LoadStr2(irExpression)) else Exit; else if TVarData(Result).VType = varEmpty then ErrorExpected(LoadStr2(irExpression)) else Exit; end; PushExp(Result); end; end; begin Result := Null; try OldExpStackPtr := FExpStackPtr; try Expression(ttUnknown); JvInterpreterVarCopy(Result, PopExp); finally FExpStackPtr := OldExpStackPtr; end; except on E: EVariantError do JvInterpreterError(ieTypeMistmatch, CurPos); end; end; function TJvInterpreterExpression.Expression2(const ExpType: Word): Variant; var ErrPos: Integer; begin ErrPos := PosBeg; try FAllowAssignment := False; Result := Expression1; finally FAllowAssignment := True; end; if TVarData(Result).VType <> ExpType then case ExpType of varInteger: JvInterpreterError(ieIntegerRequired, ErrPos); varBoolean: JvInterpreterError(ieBooleanRequired, ErrPos); else JvInterpreterError(ieUnknown, ErrPos); end; end; { calulate set expressions, such as: [fsBold, fsItalic] } function TJvInterpreterExpression.SetExpression1: Variant; var V1: Variant; begin Result := 0; while True do begin case TTyp of ttIdentifier, ttInteger: begin if TTyp = ttInteger then Result := Result or Integer(Token) else begin FCurrArgs.Clear; InternalGetValue(nil, 0, V1); if VarType(V1) <> varInteger then JvInterpreterError(ieIntegerRequired, PosBeg); Result := Result or 1 shl Integer(V1); end; NextToken; { skip ',' } if TTyp = ttCol then NextToken else if TTyp = ttRS then Break else ErrorExpected(''']'''); end; ttRS: Break; else Break; end; end; TVarData(Result).VType := varSet; end; procedure TJvInterpreterExpression.ReadArgs; function ReadOpenArray: Variant; var Values: TValueArray; I: Integer; begin { open array or set constant } NextToken; Values[0] := Expression1; I := 1; while TTyp = ttCol do begin NextToken; FCurrArgs.Clear; Values[I] := Expression1; Inc(I); end; if TTyp <> ttRS then ErrorExpected(''']'''); Result := VarArrayCreate([0, I - 1], varVariant); for I := 0 to I - 1 do Result[I] := Values[I]; NextToken; end; var LocalArgs: TJvInterpreterArgs; I: Integer; SK: TTokenKind; begin LocalArgs := FCurrArgs; FCurrArgs := TJvInterpreterArgs.Create; FCurrArgs.Indexed := LocalArgs.Indexed; try I := 0; if TTyp = ttLB then SK := ttRB else SK := ttRS; NextToken; if TTyp = ttIdentifier then LocalArgs.FVarNames[I] := Token else LocalArgs.FVarNames[I] := ''; FCurrArgs.Clear; if TTyp = ttLS then LocalArgs.Values[I] := ReadOpenArray //added check to recognize C style (), like "NextToken()" //RWare: if token ')', skip and exit else if TTyp = ttRB then begin NextToken; Exit; end else JvInterpreterVarCopy(LocalArgs.Values[I], Expression1); while TTyp = ttCol do begin Inc(I); NextToken; if TTyp = ttIdentifier then LocalArgs.FVarNames[I] := Token else LocalArgs.FVarNames[I] := ''; FCurrArgs.Clear; if TTyp = ttLS then LocalArgs.Values[I] := ReadOpenArray else JvInterpreterVarCopy(LocalArgs.Values[I], Expression1); end; if TTyp <> SK then if SK = ttRB then ErrorExpected(''')''') else ErrorExpected(''']'''); NextToken; LocalArgs.Count := I + 1; finally FCurrArgs.Free; FCurrArgs := LocalArgs; end; end; procedure TJvInterpreterExpression.InternalGetValue(Obj: Pointer; ObjTyp: Word; var Result: Variant); var Identifier: string; V: Variant; VType: TVarType; procedure UpdateVarParams; var I, C: Integer; begin if not FCurrArgs.FHasVars then Exit; C := FCurrArgs.Count; FCurrArgs.Obj := nil; FCurrArgs.ObjTyp := 0; FCurrArgs.ObjRefHolder := Unassigned; FCurrArgs.Count := 0; for I := 0 to C - 1 do if (FCurrArgs.FVarNames[I] <> '') and ((FCurrArgs.Types[I] and varByRef) <> 0) then { if not }SetValue(FCurrArgs.FVarNames[I], FCurrArgs.Values[I], FCurrArgs); { then JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, FCurrArgs.VarNames[I])}; FCurrArgs.FHasVars := False; end; begin Identifier := Token; NextToken; FCurrArgs.Indexed := TTyp = ttLS; if TTyp in [ttLB, ttLS] then ReadArgs else FCurrArgs.Count := 0; FCurrArgs.Obj := Obj; FCurrArgs.ObjTyp := ObjTyp; if (TTyp = ttColon) and FAllowAssignment then begin if ObjTyp = varDispatch then FCurrArgs.ObjRefHolder := IDispatch(Obj) else if ObjTyp = varUnknown then FCurrArgs.ObjRefHolder := IUnknown(Obj); Back; FToken := Identifier; {!!!!!!!!!!!!!!} { FCurrArgs.Obj, FCurrArgs.ObjTyp, FCurrArgs.Count needed in caller } Exit; end; { need result if object field or method or assignment } FCurrArgs.HasResult := (TTyp in [ttPoint, ttRB, ttCol, ttNot..ttEquLess]) or FCurrArgs.Assignment; FCurrArgs.ReturnIndexed := False; if GetValue(Identifier, Result, FCurrArgs) then begin if TVarData(Result).VType = varRecord then if not (FAdapter.SetRecord(Result) or (FAdapter <> GlobalJvInterpreterAdapter) and GlobalJvInterpreterAdapter.SetRecord(Result)) then JvInterpreterErrorN(ieRecordNotDefined, -1, RsEUnknownRecordType); { Args.HasVars may be changed in previous call to GetValue } if FCurrArgs.FHasVars then UpdateVarParams; if FCurrArgs.Indexed and not FCurrArgs.ReturnIndexed then begin JvInterpreterVarCopy(V, Result); if not GetElement(V, Result, FCurrArgs) then { problem } JvInterpreterError(ieArrayRequired, PosBeg); end; end else JvInterpreterErrorN(ieUnknownIdentifier, PosBeg {?}, Identifier); FCurrArgs.Obj := nil; FCurrArgs.ObjTyp := 0; FCurrArgs.ObjRefHolder := Unassigned; FCurrArgs.Count := 0; { FCurrArgs.Obj, FCurrArgs.ObjTyp, FCurrArgs.Count NOT needed in caller } if TTyp = ttPoint then { object field or method } begin NextToken; if TTyp <> ttIdentifier then ErrorExpected(LoadStr2(irIdentifier)); VType := TVarData(Result).VType; if (VType <> varObject) and (VType <> varClass) and (VType <> varRecord) and (VType <> varDispatch) and (VType <> varUnknown) then {if not (TVarData(Result).VType in [varObject, varClass, varRecord, varDispatch, varUnknown]) then} JvInterpreterError(ieROCRequired, PosBeg); V := Null; InternalGetValue(TVarData(Result).VPointer, TVarData(Result).VType, V); JvInterpreterVarCopy(Result, V); NextToken; end; Back; end; function TJvInterpreterExpression.GetElement(const Variable: Variant; var Value: Variant; var Args: TJvInterpreterArgs): Boolean; var II2: Integer; VV: TJvInterpreterArrayValues; PP: PJvInterpreterArrayRec; Bound: Integer; {$IFDEF COMPILER6_UP} AI: array of Integer; {$ENDIF COMPILER6_UP} begin Result := False; if Args.Count <> 0 then begin if TVarData(Variable).VType = varString then begin if Args.Count > 1 then JvInterpreterError(ieArrayTooManyParams, -1); if Length(Variable) = 0 then raise ERangeError.CreateRes(@RsERangeCheckError); Value := string(Variable)[Integer(Args.Values[0])]; Result := True; end else if TVarData(Variable).VType = varArray then begin {Get array value} PP := PJvInterpreterArrayRec(Integer(JvInterpreterVarAsType(Variable, varInteger))); if Args.Count > PP.Dimension then JvInterpreterError(ieArrayTooManyParams, -1) else if Args.Count < PP.Dimension then JvInterpreterError(ieArrayNotEnoughParams, -1); for II2 := 0 to Args.Count - 1 do begin Bound := Args.Values[II2]; if Bound < PP.BeginPos[II2] then JvInterpreterError(ieArrayIndexOutOfBounds, -1) else if Bound > PP.EndPos[II2] then JvInterpreterError(ieArrayIndexOutOfBounds, -1); VV[II2] := Args.Values[II2]; end; Value := JvInterpreterArrayGetElement(VV, PP); Result := True; end else if (TVarData(Variable).VType = varObject) or (TVarData(Variable).VType = varClass) then begin Result := FAdapter.GetElement(Self, Variable, Value, Args); if not Result and Assigned(FSharedAdapter) then Result := FSharedAdapter.GetElement(Self, Variable, Value, Args); end { for Variant Arrays } {$IFDEF COMPILER6_UP} // No support for variant arrays on Delphi 5 yet, sorry else if VarIsArray(Variable) then begin if Args.Count > VarArrayDimCount(Variable) then JvInterpreterError(ieArrayTooManyParams, -1) else if Args.Count < VarArrayDimCount(Variable) then JvInterpreterError(ieArrayNotEnoughParams, -1); AI := nil; SetLength(AI, Args.Count); for II2 := 0 to Args.Count - 1 do begin Bound := Args.Values[II2]; if Bound > VarArrayHighBound(Variable, II2 + 1) then JvInterpreterError(ieArrayIndexOutOfBounds, -1); if Bound < VarArrayLowBound(Variable, II2 + 1) then JvInterpreterError(ieArrayIndexOutOfBounds, -1); AI[II2] := Bound; end; Value := VarArrayGet(Variable, AI); Result := True; end {$ENDIF COMPILER6_UP} else { problem } JvInterpreterError(ieArrayRequired, CurPos); end; end; function TJvInterpreterExpression.SetElement(var Variable: Variant; const Value: Variant; var Args: TJvInterpreterArgs): Boolean; var II2: Integer; VV: TJvInterpreterArrayValues; PP: PJvInterpreterArrayRec; Bound: Integer; {$IFDEF COMPILER6_UP} AI: array of Integer; {$ENDIF COMPILER6_UP} begin Result := False; if Args.Count <> 0 then begin if TVarData(Variable).VType = varString then begin if Args.Count > 1 then JvInterpreterError(ieArrayTooManyParams, -1); string(TVarData(Variable).vString)[Integer(Args.Values[0])] := string(Value)[1]; Result := True; end else if TVarData(Variable).VType = varArray then begin { Get array value } PP := PJvInterpreterArrayRec(Integer(JvInterpreterVarAsType(Variable, varInteger))); if Args.Count > PP.Dimension then JvInterpreterError(ieArrayTooManyParams, -1) else if Args.Count < PP.Dimension then JvInterpreterError(ieArrayNotEnoughParams, -1); for II2 := 0 to Args.Count - 1 do begin Bound := Args.Values[II2]; if Bound < PP.BeginPos[II2] then JvInterpreterError(ieArrayIndexOutOfBounds, -1) else if Bound > PP.EndPos[II2] then JvInterpreterError(ieArrayIndexOutOfBounds, -1); VV[II2] := Args.Values[II2]; end; JvInterpreterArraySetElement(VV, Value, PP); Result := True; end else if (TVarData(Variable).VType = varObject) or (TVarData(Variable).VType = varClass) then begin Result := FAdapter.SetElement(Self, Variable, Value, Args); if not Result and Assigned(FSharedAdapter) then Result := FSharedAdapter.SetElement(Self, Variable, Value, Args); end { for Variant Array } {$IFDEF COMPILER6_UP} // No support for variant arrays on Delphi 5 yet, sorry else if VarIsArray(Variable) then begin if Args.Count > VarArrayDimCount(Variable) then JvInterpreterError(ieArrayTooManyParams, -1) else if Args.Count < VarArrayDimCount(Variable) then JvInterpreterError(ieArrayNotEnoughParams, -1); AI := nil; SetLength(AI, Args.Count); for II2 := 0 to Args.Count - 1 do begin Bound := Args.Values[II2]; if Bound > VarArrayHighBound(Variable, II2 + 1) then JvInterpreterError(ieArrayIndexOutOfBounds, -1); if Bound < VarArrayLowBound(Variable, II2 + 1) then JvInterpreterError(ieArrayIndexOutOfBounds, -1); AI[II2] := Bound; end; VarArrayPut(Variable, Value, AI); Result := True; end {$ENDIF COMPILER6_UP} else { problem } JvInterpreterError(ieArrayRequired, CurPos); end; end; function TJvInterpreterExpression.GetValue(const Identifier: string; var Value: Variant; var Args: TJvInterpreterArgs): Boolean; begin try Result := FAdapter.GetValue(Self, Identifier, Value, Args); if not Result and Assigned(FSharedAdapter) then Result := FSharedAdapter.GetValue(Self, Identifier, Value, Args); except on E: Exception do begin UpdateExceptionPos(E, ''); raise; end; end; if not Result and Assigned(FOnGetValue) then FOnGetValue(Self, Identifier, Value, Args, Result); end; function TJvInterpreterExpression.SetValue(const Identifier: string; const Value: Variant; var Args: TJvInterpreterArgs): Boolean; begin try Result := FAdapter.SetValue(Self, Identifier, Value, Args); if not Result and Assigned(FSharedAdapter) then Result := FSharedAdapter.SetValue(Self, Identifier, Value, Args); except on E: EJvInterpreterError do begin E.FErrPos := PosBeg; raise; end; end; if not Result and Assigned(FOnSetValue) then FOnSetValue(Self, Identifier, Value, Args, Result); end; procedure TJvInterpreterExpression.Run; begin Init; NextToken; FVResult := Expression1; end; procedure TJvInterpreterExpression.SetDisableExternalFunctions(const Value: Boolean); begin FDisableExternalFunctions := Value; FAdapter.DisableExternalFunctions := Value; end; //=== { TJvInterpreterFunction } ============================================= constructor TJvInterpreterFunction.Create(AOwner: TComponent); begin inherited Create(AOwner); FFunctionStack := TList.Create; FSS := TStringList.Create; FEventList := TList.Create; end; destructor TJvInterpreterFunction.Destroy; begin FSS.Free; FFunctionStack.Free; ClearList(FEventList); FEventList.Free; inherited Destroy; end; procedure TJvInterpreterFunction.Init; begin inherited Init; FBreak := False; FContinue := False; FFunctionStack.Clear; FStateStackPtr := -1; FCurUnitName := ''; FCurInstance := nil; end; procedure TJvInterpreterFunction.PushState; begin Inc(FStateStackPtr); if FStateStackPtr > High(FStateStack) then JvInterpreterError(ieInternal, -1); FStateStack[FStateStackPtr].Token := FToken; FStateStack[FStateStackPtr].TTyp := FTTyp; FStateStack[FStateStackPtr].PrevTTyp := FPrevTTyp; FStateStack[FStateStackPtr].Backed := FBacked; FStateStack[FStateStackPtr].CurPos := CurPos; FStateStack[FStateStackPtr].AllowAssignment := FAllowAssignment; end; procedure TJvInterpreterFunction.PopState; begin if FStateStackPtr = -1 then JvInterpreterError(ieInternal, -1); CurPos := FStateStack[FStateStackPtr].CurPos; FToken := FStateStack[FStateStackPtr].Token; FTTyp := FStateStack[FStateStackPtr].TTyp; FPrevTTyp := FStateStack[FStateStackPtr].PrevTTyp; FBacked := FStateStack[FStateStackPtr].Backed; FAllowAssignment := FStateStack[FStateStackPtr].AllowAssignment; Dec(FStateStackPtr); end; procedure TJvInterpreterFunction.RemoveState; begin Dec(FStateStackPtr); end; function TJvInterpreterFunction.GetLocalVars: TJvInterpreterVarList; begin if FFunctionContext <> nil then Result := PFunctionContext(FFunctionContext).LocalVars else Result := nil; end; procedure TJvInterpreterFunction.InFunction(FunctionDesc: TJvInterpreterFunctionDesc); const cResult = 'Result'; var FunArgs: TJvInterpreterArgs; VarNames: PNameArray; procedure EnterFunction; { TJvInterpreterFunction.InFunction local: initialization/entry of function scope } var FC: PFunctionContext; I: Integer; V: Variant; begin New(PFunctionContext(FC)); FillChar(FC^, SizeOf(FC^), 0); New(VarNames); PFunctionContext(FC).PrevFunContext := FFunctionContext; FFunctionContext := FC; PFunctionContext(FFunctionContext).LocalVars := TJvInterpreterVarList.Create; FFunctionStack.Add(FFunctionContext); FVResult := Null; if FunctionDesc <> nil then begin FCurrArgs.FHasVars := False; FCurrArgs.Types := FunctionDesc.FParamTypes; for I := 0 to FCurrArgs.Count - 1 do begin if (FunctionDesc.FParamTypes[I] and varByRef) <> 0 then JvInterpreterVarCopy(V, FCurrArgs.Values[I]) else JvInterpreterVarAssignment(V, FCurrArgs.Values[I]); PFunctionContext(FFunctionContext).LocalVars.AddVar('', FunctionDesc.FParamNames[I], '', FunctionDesc.FParamTypes[I], V, TJvInterpreterSimpleDataType.Create(FunctionDesc.FParamTypes[I])); VarNames^ := FunctionDesc.FParamNames; FCurrArgs.FHasVars := FCurrArgs.FHasVars or ((FunctionDesc.FParamTypes[I] and varByRef) <> 0); end; if FunctionDesc.ResTyp > 0 then begin FunctionDesc.ResDataType.Init(V); PFunctionContext(FFunctionContext).LocalVars.AddVar('', cResult, '', FunctionDesc.ResTyp, V, FunctionDesc.ResDataType); end end else PFunctionContext(FFunctionContext).LocalVars.AddVar('', cResult, '', varVariant, Null, TJvInterpreterSimpleDataType.Create(varVariant)); FunArgs := FCurrArgs; FCurrArgs := TJvInterpreterArgs.Create; end; procedure LeaveFunction(Ok: Boolean); { TJvInterpreterFunction.InFunction local: finalization of function scope } var FC: PFunctionContext; C: Integer; VarList: TJvInterpreterVarList; // VARLEAKFIX procedure UpdateVarParams; { TJvInterpreterFunction.InFunction.LeaveFunction local. How bizarre. } var I, C: Integer; begin if not FCurrArgs.FHasVars then Exit; C := FCurrArgs.Count; FCurrArgs.Obj := nil; FCurrArgs.ObjTyp := 0; FCurrArgs.ObjRefHolder := Unassigned; FCurrArgs.Count := 0; for I := 0 to C - 1 do if (VarNames[I] <> '') and ((FCurrArgs.Types[I] and varByRef) <> 0) then GetValue(VarNames[I], FCurrArgs.Values[I], FCurrArgs); end; begin FCurrArgs.Free; FCurrArgs := FunArgs; if Ok then begin C := FCurrArgs.Count; UpdateVarParams; FCurrArgs.Count := 0; if (FunctionDesc = nil) or (FunctionDesc.ResTyp > 0) then begin { Return the 'result' value from the local function context to the FVResult: Variant property of the component } // PFunctionContext(FFunctionContext).LocalVars.GetValue('Result', FVResult, FCurrArgs); //LEAKY: TVarData(PFunctionContext(FFunctionContext).LocalVars.FindVar('', 'Result').Value).VType := varEmpty; //LEAKY: TVarData(PFunctionContext(FFunctionContext).LocalVars.FindVar('', 'Result').Value).VPointer := nil; //VARLEAKFIX begin - Feb 2004 - Warren Postma. Fix suggested by ivan_ra att mail dott ru VarList := PFunctionContext(FFunctionContext).LocalVars; VarList.GetValue(cResult, FVResult, FCurrArgs); VarClear(VarList.FindVar('', cResult).Value); //VARLEAKFIX end. end; FCurrArgs.Count := C; end; FC := PFunctionContext(FFunctionContext).PrevFunContext; PFunctionContext(FFunctionContext).LocalVars.Free; Dispose(PFunctionContext(FFunctionContext)); Dispose(VarNames); FFunctionStack.Delete(FFunctionStack.Count - 1); FFunctionContext := FC; end; procedure CheckNotSupportedFunctionParameters; var I: Integer; begin for I := 0 to FCurrArgs.Count - 1 do if TVarData(FCurrArgs.Values[I]).VType in [varArray, varRecord] then NotImplemented(RsEInterpreter402); end; begin CheckNotSupportedFunctionParameters; { allocate stack } EnterFunction; try FExit := False; while True do begin case TTyp of ttBegin: begin InterpretBegin; if (TTyp <> ttSemicolon) and not FExit then ErrorExpected(''';'''); Break; end; ttVar: InterpretVar(PFunctionContext(FFunctionContext).LocalVars.AddVar); ttConst: InterpretConst(PFunctionContext(FFunctionContext).LocalVars.AddVar); else ErrorExpected('''' + kwBEGIN + ''''); end; NextToken; end; LeaveFunction(True); FExit := False; except on E: Exception do begin { if (E is EJvInterpreterError) and (Fun <> nil) and ((E as EJvInterpreterError).ErrUnitName = '') then } if FunctionDesc <> nil then UpdateExceptionPos(E, FunctionDesc.UnitName) else UpdateExceptionPos(E, ''); LeaveFunction(False); FExit := False; raise; end; end; end; function TJvInterpreterFunction.GetValue(const Identifier: string; var Value: Variant; var Args: TJvInterpreterArgs): Boolean; begin Result := False; { check in local variables } try if FFunctionContext <> nil then Result := PFunctionContext(FFunctionContext).LocalVars.GetValue(Identifier, Value, Args); except on E: Exception do begin if Assigned(PFunctionContext(FFunctionContext).Fun) then UpdateExceptionPos(E, PFunctionContext(FFunctionContext).Fun.UnitName) else UpdateExceptionPos(E, ''); raise; end; end; if not Result then Result := inherited GetValue(Identifier, Value, Args); end; function TJvInterpreterFunction.SetValue(const Identifier: string; const Value: Variant; var Args: TJvInterpreterArgs): Boolean; begin Result := False; { check in local variables } try if FFunctionContext <> nil then Result := PFunctionContext(FFunctionContext).LocalVars.SetValue(Identifier, Value, Args); except on E: Exception do begin if Assigned(PFunctionContext(FFunctionContext).Fun) then UpdateExceptionPos(E, PFunctionContext(FFunctionContext).Fun.UnitName) else UpdateExceptionPos(E, ''); raise; end; end; if not Result then Result := inherited SetValue(Identifier, Value, Args); end; procedure TJvInterpreterFunction.DoOnStatement; begin end; { exit: current position set to next token } procedure TJvInterpreterFunction.InterpretStatement; begin DoOnStatement; case TTyp of ttIdentifier: { assignment or function call } begin InterpretIdentifier; if not (TTyp in [ttSemicolon, ttEnd, ttElse, ttUntil, ttFinally, ttExcept]) then ErrorExpected(''';'''); // Back; end; ttSemicolon: ; // Back; ttEnd: ; // Back; ttBegin: InterpretBegin; ttIf: InterpretIf; ttElse: Exit; ttWhile: InterpretWhile; ttRepeat: InterpretRepeat; ttFor: InterpretFor; ttBreak: FBreak := True; ttContinue: FContinue := True; ttTry: InterpretTry; ttRaise: InterpretRaise; ttExit: FExit := True; ttCase: InterpretCase; else ErrorExpected(''';'''); end; end; { exit: current position set to next token } { very simple version, many syntax errors are not found } procedure TJvInterpreterFunction.SkipStatement; begin case TTyp of ttEmpty: ErrorExpected('''' + kwEND + ''''); ttIdentifier: SkipIdentifier; ttSemicolon: NextToken; ttEnd: NextToken; ttIf: begin FindToken(ttThen); NextToken; SkipStatement; if TTyp = ttElse then begin NextToken; SkipStatement; end; Exit; end; ttElse: Exit; ttWhile, ttFor: begin FindToken(ttDo); NextToken; SkipStatement; Exit; end; ttRepeat: begin SkipToUntil; SkipIdentifier; Exit; end; ttBreak, ttContinue: NextToken; ttBegin: begin SkipToEnd; Exit; end; ttTry: begin SkipToEnd; Exit; end; ttFunction, ttProcedure: ErrorExpected('''' + kwEND + ''''); ttRaise: begin NextToken; SkipIdentifier; end; ttExit: NextToken; ttCase: begin SkipToEnd; Exit; end; end; end; { out: current position set to token after end } procedure TJvInterpreterFunction.SkipToEnd; begin while True do begin NextToken; if TTyp = ttEnd then begin NextToken; Break; end else if TTyp in [ttBegin, ttTry, ttCase] then SkipToEnd else if TTyp = ttEmpty then ErrorExpected('''' + kwEND + '''') else if TTyp = ttDoubleQuote then NextToken else SkipStatement; if TTyp = ttEnd then begin NextToken; Break; end; end; end; { out: current position set to token after end } procedure TJvInterpreterFunction.SkipToUntil; begin while True do begin NextToken; if TTyp = ttUntil then begin NextToken; Break; end else if TTyp = ttEmpty then ErrorExpected('''' + kwUNTIL + '''') else SkipStatement; if TTyp = ttUntil then begin NextToken; Break; end; end; end; {exit: current position set to next token after assignment or function call } procedure TJvInterpreterFunction.SkipIdentifier; begin while True do case TTyp of ttEmpty: ErrorExpected('''' + kwEND + ''''); ttIdentifier..ttBoolean, ttLB, ttRB, ttCol, ttPoint, ttLS, ttRS, ttNot..ttXor, // [peter schraut: replaced ttEquLess with ttXor on 2005/08/14] ttDoubleQuote, ttTrue, ttFalse: NextToken; ttSemicolon, ttEnd, ttElse, ttUntil, ttFinally, ttExcept, ttDo, ttOf: Break; ttColon: { 'case' or assignment } begin NextToken; if TTyp <> ttEqu then begin Back; Break; end; end; else ErrorExpected(LoadStr2(irExpression)); end; end; procedure TJvInterpreterFunction.FindToken(ATTyp: TTokenKind); begin while not (TTyp in [ATTyp, ttEmpty]) do NextToken; if TTyp = ttEmpty then ErrorExpected('''' + kwEND + ''''); end; function TJvInterpreterFunction.NewEvent(const UnitName: string; const FunctionName, EventType: string; Instance: TObject; const APropName: string): TSimpleEvent; begin Result := FAdapter.NewEvent(UnitName, FunctionName, EventType, Self, Instance, APropName); if not Assigned(Result) then Result := GlobalJvInterpreterAdapter.NewEvent(UnitName, FunctionName, EventType, Self, Instance, APropName); if not Assigned(Result) then JvInterpreterErrorN(ieEventNotRegistered, -1, EventType); end; function TJvInterpreterFunction.FindEvent(const UnitName: string; Instance: TObject; const PropName: string): TJvInterpreterEvent; var I: Integer; Event, Event1: TJvInterpreterEvent; Method: TMethod; begin Result := nil; Method := GetPropMethod(Instance, PropName); Event1 := TJvInterpreterEvent(Method.Data); for I := 0 to FEventList.Count - 1 do begin Event := TJvInterpreterEvent(FEventList[I]); if (Event1 = Event) or (Cmp(Event.FUnitName, UnitName) and (Event.FInstance = Instance) and Cmp(Event.FPropName, PropName)) then begin Result := Event; Exit; end; end; end; procedure TJvInterpreterFunction.InternalSetValue(const Identifier: string); var FunctionDesc: TJvInterpreterFunctionDesc; PropInf: PPropInfo; FunctionName: string; PopSt: Boolean; MyArgs: TJvInterpreterArgs; Variable: Variant; Method: TMethod; t: TObject; Event: TJvInterpreterEvent; begin { may be event assignment } if (FCurrArgs.Obj <> nil) and (FCurrArgs.ObjTyp = varObject) then begin FunctionDesc := FAdapter.FindFunDesc(FCurUnitName, Token); if (FunctionDesc <> nil) or ((FunctionDesc = nil) and Cmp(Token, kwNIL)) then begin PushState; PopSt := True; try NextToken; if not (TTyp in [ttFirstExpression..ttLastExpression] - [ttSemicolon]) then begin FunctionName := Token; PropInf := GetPropInfo(FCurrArgs.Obj.ClassInfo, Identifier); if Assigned(PropInf) and (PropInf.PropType^.Kind = tkMethod) then begin { method assignment } if not Cmp(Token, kwNIL) then begin Event := FindEvent(FCurUnitName, FCurrArgs.Obj, PropInf^.Name); if Event <> nil then begin FEventList.Remove(Event); Event.Free; end; Method := TMethod(NewEvent(FCurUnitName, FunctionName, PropInf^.PropType^.Name, FCurrArgs.Obj {FCurInstance}, PropInf^.Name)); SetMethodProp(FCurrArgs.Obj, PropInf, Method); FEventList.Add(Method.Data); end else begin //Fixed Assign nil to Method property bugs - dejoy-2004-3-13 Method := GetMethodProp(FCurrArgs.Obj, PropInf); if Method.Data <> nil then begin FEventList.Remove(Method.Data); t := Method.Data; if t is TJvInterpreterEvent then t.Free; end; Method.Code := nil; Method.Data := nil; SetMethodProp(FCurrArgs.Obj, PropInf, Method); end; PopSt := False; Exit; end else if FAdapter.IsEvent(FCurrArgs.Obj, Identifier) then { check only local adapter } begin if not SetValue(Identifier, FunctionName, FCurrArgs) then JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, Identifier); PopSt := False; Exit; end; end; finally if PopSt then PopState else RemoveState; end; //Exit; end; end; { normal (not method) assignmnent } { push args } MyArgs := FCurrArgs; FCurrArgs := TJvInterpreterArgs.Create; try FCurrArgs.Assignment := True; JvInterpreterVarCopy(FVResult, Expression1); finally { pop args } FCurrArgs.Free; FCurrArgs := MyArgs; end; if FCurrArgs.Indexed then begin MyArgs := TJvInterpreterArgs.Create; MyArgs.Obj := FCurrArgs.Obj; // ivan_ra MyArgs.ObjTyp := FCurrArgs.ObjTyp; // ivan_ra try if GetValue(Identifier, Variable, MyArgs) then begin if not SetElement(Variable, FVResult, FCurrArgs) then { problem } JvInterpreterError(ieArrayRequired, PosBeg); if (TVarData(Variable).VType = varString) and not SetValue(Identifier, Variable, MyArgs) then JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, Identifier); if VarIsArray(Variable) and not SetValue(Identifier, Variable, MyArgs) then JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, Identifier); end else if not SetValue(Identifier, FVResult, FCurrArgs) then JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, Identifier); finally MyArgs.Free; end; end else if not SetValue(Identifier, FVResult, FCurrArgs) then JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, Identifier); end; procedure TJvInterpreterFunction.InterpretIdentifier; var Identifier: string; begin Identifier := Token; FCurrArgs.Clear; NextToken; if TTyp <> ttColon then begin Back; FCurrArgs.Assignment := False; InternalGetValue(nil, 0, FVResult); Identifier := Token; { Back! } NextToken; end; if TTyp = ttColon then { assignment } begin NextToken; if TTyp <> ttEqu then ErrorExpected('''='''); NextToken; InternalSetValue(Identifier); end; end; {exit: current position set to next token after "end"} procedure TJvInterpreterFunction.InterpretBegin; begin NextToken; while True do begin case TTyp of ttEnd: begin NextToken; Exit; end; ttElse, ttDo: ErrorExpected(LoadStr2(irStatement)); ttSemicolon: begin DoOnStatement; NextToken; end; ttIdentifier, ttBegin, ttIf, ttWhile, ttFor, ttRepeat, ttBreak, ttContinue, ttTry, ttRaise, ttExit, ttCase: InterpretStatement; else ErrorExpected('''' + kwEND + ''''); end; if FBreak or FContinue or FExit then Exit; end; end; { exit: current position set to next token after if block } procedure TJvInterpreterFunction.InterpretIf; var Condition: Variant; begin NextToken; Condition := Expression2(varBoolean); if TTyp <> ttThen then ErrorExpected('''' + kwTHEN + ''''); NextToken; if TVarData(Condition).VBoolean then begin InterpretStatement; // NextToken; {!!!????} if TTyp = ttElse then begin NextToken; SkipStatement; // Back; {!!!????} end; end else begin SkipStatement; if TTyp = ttElse then begin NextToken; InterpretStatement; end { else if TTyp = ttSemicolon then begin NextToken; if TTyp = ttElse then JvInterpreterError(ieNotAllowedBeforeElse, PosBeg) end; } end; end; { exit: current position set to next token after loop } procedure TJvInterpreterFunction.InterpretWhile; var WhileCurPos: Integer; WhilePos: Integer; Condition: Variant; begin PushState; try WhilePos := PosEnd; WhileCurPos := CurPos; while True do begin NextToken; Condition := Expression1; if TVarData(Condition).VType <> varBoolean then JvInterpreterError(ieBooleanRequired, WhilePos); if TTyp <> ttDo then ErrorExpected('''' + kwDO + ''''); NextToken; if TVarData(Condition).VBoolean then begin FContinue := False; FBreak := False; InterpretStatement; if FBreak or FExit then Break; end else Break; CurPos := WhileCurPos; end; finally PopState; end; SkipStatement; FContinue := False; FBreak := False; end; { exit: current position set to next token after loop } procedure TJvInterpreterFunction.InterpretRepeat; var RepeatCurPos: Integer; Condition: Variant; begin RepeatCurPos := CurPos; while True do begin NextToken; case TTyp of ttElse, ttDo: ErrorExpected(LoadStr2(irStatement)); ttSemicolon: DoOnStatement; ttIdentifier, ttBegin, ttIf, ttWhile, ttFor, ttRepeat, ttBreak, ttContinue, ttTry, ttRaise, ttExit, ttCase: begin FContinue := False; FBreak := False; InterpretStatement; if FBreak or FExit then Break; end; ttUntil: begin NextToken; Condition := Expression1; if TVarData(Condition).VType <> varBoolean then JvInterpreterError(ieBooleanRequired, CurPos); if TVarData(Condition).VBoolean then Break else CurPos := RepeatCurPos; end; else ErrorExpected('''' + kwUNTIL + ''''); end; end; if FBreak or FExit then begin SkipToUntil; SkipIdentifier; end; FContinue := False; FBreak := False; end; { exit: current position set to next token after loop } procedure TJvInterpreterFunction.InterpretFor; var I: Integer; DoCurPos: Integer; iBeg, iEnd: Integer; LoopVariable: string; ForwardDirection: Boolean; begin NextToken; if TTyp <> ttIdentifier then ErrorExpected(LoadStr2(irIdentifier)); // CheckLocalIdentifier; LoopVariable := Token; NextToken; if TTyp <> ttColon then ErrorExpected(''':'''); NextToken; if TTyp <> ttEqu then ErrorExpected('''='''); NextToken; iBeg := Expression2(varInteger); if (TTyp <> ttTo) and (TTyp <> ttDownTo) then ErrorExpected('''' + kwTO + RsEXOrX + kwDOWNTO + ''''); ForwardDirection := TTyp = ttTo; NextToken; iEnd := Expression2(varInteger); if TTyp <> ttDo then ErrorExpected('''' + kwDO + ''''); DoCurPos := CurPos; NextToken; if ForwardDirection then begin for I := iBeg to iEnd do begin FCurrArgs.Clear; if not SetValue(LoopVariable, I, FCurrArgs) then JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, LoopVariable); FContinue := False; FBreak := False; InterpretStatement; if FBreak or FExit then begin CurPos := DoCurPos; NextToken; Break; end; CurPos := DoCurPos; NextToken; end; end else begin for I := iBeg downto iEnd do begin FCurrArgs.Clear; if not SetValue(LoopVariable, I, FCurrArgs) then JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, LoopVariable); FContinue := False; FBreak := False; InterpretStatement; if FBreak or FExit then begin CurPos := DoCurPos; NextToken; Break; end; CurPos := DoCurPos; NextToken; end; end; SkipStatement; FContinue := False; FBreak := False; end; { exit: current position set to next token after case } procedure TJvInterpreterFunction.InterpretCase; var Selector, Expression, I: Integer; ExpressionArray: array of array [0..1] of Integer; function InCase(CaseSel: Integer): Boolean; var I: Integer; begin Result := False; for I := 0 to Length(ExpressionArray) - 1 do if (CaseSel >= ExpressionArray[I][0]) and (CaseSel <= ExpressionArray[I][1]) then begin Result := True; Exit; end; end; begin NextToken; Selector := Expression2(varInteger); if TTyp <> ttOf then ErrorExpected('''' + kwOF + ''''); while True do begin NextToken; case TTyp of ttIdentifier, ttInteger: begin ExpressionArray := nil; SetLength(ExpressionArray, 1); I := 0; while True do begin Expression := Expression2(varInteger); ExpressionArray[Length(ExpressionArray) - 1][I] := Expression; if TTyp = ttDoublePoint then I := 1 else if TTyp = ttCol then begin if I = 0 then ExpressionArray[Length(ExpressionArray) - 1][1] := Expression else I := 0; SetLength(ExpressionArray, Length(ExpressionArray) + 1); end else begin if I = 0 then ExpressionArray[Length(ExpressionArray) - 1][1] := Expression; Break; end; NextToken; end; if TTyp <> ttColon then ErrorExpected('''' + ':' + ''''); NextToken; if InCase(Selector) then begin ExpressionArray := nil; InterpretStatement; SkipToEnd; Break; end else SkipStatement; end; ttElse: begin NextToken; InterpretStatement; SkipToEnd; Break; end; ttEnd: begin NextToken; Break; end; else ErrorExpected('''' + kwEND + ''''); end; end; end; procedure TJvInterpreterFunction.InterpretVar(AddVarFunc: TJvInterpreterAddVarFunc); var I: Integer; Value: Variant; TypName: string; // Typ: Word; DT: IJvInterpreterDataType; {----olej----} {Temporary for array type} // ArrayType: Integer; // Dimension: Integer; {----olej----} begin repeat FSS.Clear; repeat NextToken; if TTyp <> ttIdentifier then ErrorExpected(LoadStr2(irIdentifier)); FSS.Add(Token); NextToken; until TTyp <> ttCol; if TTyp <> ttColon then ErrorExpected(''':'''); NextToken; TypName := Token; DT := ParseDataType; for I := 0 to FSS.Count - 1 do begin DT.Init(Value); AddVarFunc(FCurUnitName, FSS[I], TypName, DT.GetTyp, Value, DT); end; FSS.Clear; NextToken; if TTyp <> ttSemicolon then ErrorExpected(''';'''); NextToken; Back; until TTyp <> ttIdentifier; end; procedure TJvInterpreterFunction.InterpretConst(AddVarFunc: TJvInterpreterAddVarFunc); var Identifier: string; Value: Variant; begin repeat NextToken; if TTyp <> ttIdentifier then ErrorExpected(LoadStr2(irIdentifier)); Identifier := Token; NextToken; if TTyp <> ttEqu then ErrorExpected('='); NextToken; Value := Expression1; AddVarFunc(FCurUnitName, Identifier, '', varEmpty, Value, TJvInterpreterSimpleDataType.Create(VarType(Value))); if TTyp <> ttSemicolon then ErrorExpected(''';'''); NextToken; Back; until TTyp <> ttIdentifier; end; procedure TJvInterpreterFunction.InterpretTry; var ReRaiseException: Boolean; procedure FindFinallyExcept; begin while True do begin case TTyp of ttEmpty: ErrorExpected('''' + kwEND + ''''); ttSemicolon: ; ttFinally, ttExcept: Exit; else SkipStatement; end; NextToken; end; end; procedure InterpretExcept(E: Exception); var ExceptionClassName, ExceptionVarName: string; ExceptionClass: TClass; V: Variant; function On1: Boolean; begin NextToken; if TTyp <> ttIdentifier then ErrorExpected(LoadStr2(irIdentifier)); ExceptionClassName := Token; NextToken; if TTyp = ttColon then begin NextToken; if TTyp <> ttIdentifier then ErrorExpected(LoadStr2(irIdentifier)); ExceptionVarName := ExceptionClassName; ExceptionClassName := Token; NextToken; end; FCurrArgs.Clear; if not GetValue(ExceptionClassName, V, FCurrArgs) then JvInterpreterErrorN(ieUnknownIdentifier, PosBeg {?}, ExceptionClassName); if VarType(V) <> varClass then JvInterpreterError(ieClassRequired, PosBeg {?}); ExceptionClass := V2C(V); if TTyp <> ttDo then ErrorExpected('''' + kwDO + ''''); Result := E is ExceptionClass; if Result then { do this 'on' section } begin NextToken; PFunctionContext(FFunctionContext).LocalVars.AddVar('', ExceptionVarName, ExceptionClassName, varObject, O2V(E), TJvInterpreterSimpleDataType.Create(varObject)); try InterpretStatement; finally PFunctionContext(FFunctionContext).LocalVars.DeleteVar('', ExceptionVarName); end; SkipToEnd; end else begin NextToken; SkipStatement; { if TTyp = ttSemicolon then NextToken; } end; end; begin NextToken; if TTyp = ttOn then begin if On1 then begin ReRaiseException := False; Exit; end; while True do begin NextToken; case TTyp of ttEmpty: ErrorExpected('''' + kwEND + ''''); ttOn: if On1 then begin ReRaiseException := False; Exit; end; ttEnd: begin ReRaiseException := True; Exit; end; ttElse: begin NextToken; InterpretStatement; NextToken; if TTyp = ttSemicolon then NextToken; if TTyp <> ttEnd then ErrorExpected('''' + kwEND + ''''); Exit; end; else ErrorExpected('''' + kwEND + ''''); end; end; end else begin Back; InterpretBegin; end; end; procedure DoFinallyExcept(E: Exception); begin case TTyp of ttFinally: { do statements up to 'end' } begin InterpretBegin; if E <> nil then begin ReRaiseException := True; end; end; ttExcept: begin if E = nil then { skip except section } SkipToEnd else { except section } begin try InterpretExcept(E); except on E1: EJvInterpreterError do if E1.ErrCode = ieRaise then ReRaiseException := True; else raise; end; end; end; end; end; begin while True do begin NextToken; case TTyp of ttFinally: begin DoFinallyExcept(nil); Exit; end; ttExcept: begin DoFinallyExcept(nil); Exit; end; ttSemicolon: DoOnStatement; ttIdentifier, ttBegin, ttIf, ttWhile, ttFor, ttRepeat, ttBreak, ttContinue, ttTry, ttRaise, ttExit, ttCase: begin try InterpretStatement; if FBreak or FContinue or FExit then begin FindFinallyExcept; DoFinallyExcept(nil); Exit; end; except on E: Exception do begin FindFinallyExcept; ReRaiseException := False; DoFinallyExcept(E); if ReRaiseException then raise else Exit; end; end; end; else ErrorExpected('''' + kwFINALLY + ''''); end; end; end; procedure TJvInterpreterFunction.InterpretRaise; var V: Variant; begin NextToken; case TTyp of ttEmpty, ttSemicolon, ttEnd, ttBegin, ttElse, ttFinally, ttExcept: { re-raising exception } raise EJvInterpreterError.Create(ieRaise, PosBeg, '', ''); ttIdentifier: begin InternalGetValue(nil, 0, V); if VarType(V) <> varObject then JvInterpreterError(ieClassRequired, PosBeg {?}); raise V2O(V); end; else JvInterpreterError(ieClassRequired, PosBeg {?}); end; end; procedure TJvInterpreterFunction.Run; begin Init; NextToken; InFunction(nil); end; function TJvInterpreterFunction.GetFunStackCount: Integer; begin Result := FFunctionStack.Count; end; function TJvInterpreterFunction.ParseDataType: IJvInterpreterDataType; var TypName: string; Typ: Word; ArrayBegin, ArrayEnd: TJvInterpreterArrayValues; TempBegin, TempEnd: Integer; ArrayType: Integer; Dimension: Integer; Minus1, Minus2: Boolean; // JvInterpreterRecord: TJvInterpreterRecord; ArrayDT: IJvInterpreterDataType; begin //NextToken; TypName := Token; Dimension := 0; if TTyp = ttIdentifier then begin Typ := TypeName2VarTyp(TypName); JvInterpreterRecord := TJvInterpreterRecord(FAdapter.GetRec(TypName)); if JvInterpreterRecord = nil then JvInterpreterRecord := TJvInterpreterRecord(GlobalJvInterpreterAdapter.GetRec(TypName)); if JvInterpreterRecord <> nil then Result := TJvInterpreterRecordDataType.Create(JvInterpreterRecord) else Result := TJvInterpreterSimpleDataType.Create(Typ); end else if TTyp = ttArray then begin { Get Array variables params } { This code is not very clear } // Typ := varArray; NextToken; if (TTyp <> ttLS) and (TTyp <> ttOf) then ErrorExpected('''[' + RsEXOrX + kwOF + ''''); { Parse Array Range } if TTyp = ttLS then begin Dimension := 0; repeat NextToken; Minus1 := False; if (Trim(FTokenStr) = '-') then begin Minus1 := True; NextToken; end; TempBegin := StrToInt(FTokenStr); try ArrayBegin[Dimension] := TempBegin; if Minus1 then ArrayBegin[Dimension] := ArrayBegin[Dimension] * (-1); except ErrorExpected(LoadStr2(irIntegerValue)); end; NextToken; if TTyp <> ttDoublePoint then ErrorExpected('''..'''); NextToken; Minus2 := False; if (Trim(FTokenStr) = '-') then begin Minus2 := True; NextToken; end; TempEnd := StrToInt(FTokenStr); try ArrayEnd[Dimension] := TempEnd; except if Minus2 then ArrayEnd[Dimension] := ArrayEnd[Dimension] * (-1); ErrorExpected(LoadStr2(irIntegerValue)); end; if (Dimension < 0) or (Dimension > cJvInterpreterMaxArgs) then JvInterpreterError(ieArrayBadDimension, CurPos); if not (ArrayBegin[Dimension] <= ArrayEnd[Dimension]) then JvInterpreterError(ieArrayBadRange, CurPos); {End Array Range} NextToken; Inc(Dimension); until TTyp <> ttCol; { , } if TTyp <> ttRS then ErrorExpected(''']'''); NextToken; if TTyp <> ttOf then ErrorExpected('''' + kwOF + ''''); end else if TTyp = ttOf then begin Dimension := 1; ArrayBegin[0] := 0; ArrayEnd[0] := -1; end; NextToken; ArrayType := TypeName2VarTyp(Token); // recursion for arrays ArrayDT := ParseDataType; Result := TJvInterpreterArrayDataType.Create(ArrayBegin, ArrayEnd, Dimension, ArrayType, ArrayDT); { end: var A: array [1..200] of Integer, parsing } end else ErrorExpected(LoadStr2(irIdentifier)); end; //=== { TJvInterpreterUnit } ================================================= constructor TJvInterpreterUnit.Create(AOwner: TComponent); begin inherited Create(AOwner); FClearUnits := True; FEventHandlerList := TList.Create; end; destructor TJvInterpreterUnit.Destroy; begin ClearList(FEventHandlerList); FEventHandlerList.Free; inherited Destroy; end; procedure TJvInterpreterUnit.Init; begin inherited Init; if FClearUnits then begin FAdapter.ClearSource; FUnitSection := usUnknown; ClearList(FEventHandlerList); end; end; procedure TJvInterpreterUnit.ReadFunctionHeader(FunctionDesc: TJvInterpreterFunctionDesc); var TypName: string; Fun: Boolean; procedure ReadParams; var VarParam, VarConst: Boolean; ParamType: string; iBeg: Integer; begin while True do begin VarParam := False; VarConst := False; NextToken; FunctionDesc.FParamNames[FunctionDesc.ParamCount] := Token; if TTyp = ttRB then Break; if TTyp = ttVar then begin VarParam := True; NextToken; end; if TTyp = ttConst then begin VarConst := True; // NextToken; end; iBeg := FunctionDesc.ParamCount; while True do begin case TTyp of ttIdentifier: FunctionDesc.FParamNames[FunctionDesc.ParamCount] := Token; ttSemicolon: Break; ttRB: Exit; ttColon: begin NextToken; if TTyp <> ttIdentifier then ErrorExpected(LoadStr2(irIdentifier)); ParamType := Token; while True do begin if TTyp = ttRB then Back; if TTyp in [ttRB, ttSemicolon] then Break; NextToken; end; FunctionDesc.FParamTypeNames[FunctionDesc.FParamCount] := ParamType; //dejoy added for ParamTypeNames Inc(FunctionDesc.FParamCount); while iBeg < FunctionDesc.FParamCount do begin FunctionDesc.FParamTypeNames[iBeg] := ParamType; //dejoy added for ParamTypeNames FunctionDesc.FParamTypes[iBeg] := TypeName2VarTyp(ParamType); if VarParam then FunctionDesc.FParamTypes[iBeg] := FunctionDesc.FParamTypes[iBeg] or varByRef; if VarConst then FunctionDesc.FParamTypes[iBeg] := FunctionDesc.FParamTypes[iBeg] or varByConst; Inc(iBeg); end; Break; end; ttCol: Inc(FunctionDesc.FParamCount); end; NextToken; end; end; end; begin Fun := TTyp = ttFunction; NextToken; if TTyp <> ttIdentifier then ErrorExpected(LoadStr2(irIdentifier)); FunctionDesc.FIdentifier := Token; NextToken; if TTyp = ttPoint then begin FunctionDesc.FClassIdentifier := FunctionDesc.FIdentifier; NextToken; if TTyp <> ttIdentifier then ErrorExpected(LoadStr2(irIdentifier)); FunctionDesc.FIdentifier := Token; NextToken; end; FunctionDesc.FResTyp := varEmpty; FunctionDesc.FParamCount := 0; if TTyp = ttLB then begin // NextToken; ReadParams; NextToken; end; if Fun then if (TTyp = ttColon) then begin NextToken; if TTyp <> ttIdentifier then ErrorExpected(LoadStr2(irIdentifier)); TypName := Token; FunctionDesc.FResDataType := ParseDataType; FunctionDesc.FResTyp := FunctionDesc.FResDataType.GetTyp; FunctionDesc.FResTypName := TypName; if FunctionDesc.FResTyp = 0 then FunctionDesc.FResTyp := varVariant; NextToken; end else ErrorExpected(''':'''); if TTyp <> ttSemicolon then ErrorExpected(''';'''); end; procedure TJvInterpreterUnit.InterpretFunction; var FunctionDesc: TJvInterpreterFunctionDesc; FunctionName: string; FunctionIndex: Integer; DllName: string; LastTTyp: TTokenKind; // Ivan_ra begin FunctionDesc := TJvInterpreterFunctionDesc.Create; try ReadFunctionHeader(FunctionDesc); FunctionDesc.FPosBeg := CurPos; LastTTyp := TTyp; // Ivan_ra NextToken; if TTyp = ttExternal then begin NextToken; if TTyp = ttString then DllName := Token else if TTyp = ttIdentifier then begin FCurrArgs.Clear; if not GetValue(Token, FVResult, FCurrArgs) then JvInterpreterErrorN(ieUnknownIdentifier, PosBeg, Token); DllName := VResult; end else ErrorExpected(LoadStr2(irStringConstant)); {DEBUG!!!} NextToken; if TTyp <> ttIdentifier then ErrorExpected('''' + drNAME + RsEXOrX + drINDEX + ''''); FunctionIndex := -1; FunctionName := ''; if Cmp(Token, drNAME) then begin NextToken; if TTyp = ttString then FunctionName := Token else ErrorExpected(LoadStr2(irStringConstant)); {DEBUG!!!} end else if Cmp(Token, drINDEX) then begin NextToken; if TTyp = ttInteger then FunctionIndex := Token else ErrorExpected(LoadStr2(irIntegerConstant)); {DEBUG!!!} end else ErrorExpected('''' + drNAME + RsEXOrX + drINDEX + ''''); with FunctionDesc do FAdapter.AddExtFun(FCurUnitName {??!!}, FIdentifier, noInstance, DllName, FunctionName, FunctionIndex, FParamCount, FParamTypes, FResTyp); NextToken; end // Ivan_ra start else if FUnitSection = usInterface then begin CurPos := FunctionDesc.FPosBeg; FTTyp := LastTTyp; end // Ivan_ra finish else begin FindToken(ttBegin); SkipToEnd; with FunctionDesc do FAdapter.AddSrcFun(FCurUnitName {??!!}, FIdentifier, FPosBeg, CurPos, FParamCount, FParamTypes, FParamTypeNames {dejoy added}, FParamNames, FResTyp, FResTypName, FResDataType, nil); end; finally FunctionDesc.Free; end; end; procedure TJvInterpreterUnit.ReadUnit(const UnitName: string); var OldUnitName: string; OldSource: string; S: string; begin if FAdapter.UnitExists(UnitName) then Exit; FAdapter.AddSrcUnit(FCurUnitName, '', ''); OldUnitName := FCurUnitName; OldSource := Source; PushState; try try if not GetUnitSource(UnitName, S) then JvInterpreterErrorN(ieUnitNotFound, PosBeg, UnitName); FCurUnitName := UnitName; Source := S; NextToken; if TTyp <> ttUnit then ErrorExpected('''' + kwUNIT + ''''); InterpretUnit; except on E: Exception do begin UpdateExceptionPos(E, FCurUnitName); raise; end; end finally FCurUnitName := OldUnitName; Source := OldSource; PopState; end; end; procedure TJvInterpreterUnit.InterpretUses(var UsesList: string); begin NextToken; if not (TTyp in [ttIdentifier, ttString]) then ErrorExpected(LoadStr2(irIdentifier)); UsesList := Token; ReadUnit(Token); while True do begin NextToken; if TTyp = ttIn then begin { ignore } NextToken; NextToken; end; if TTyp = ttSemicolon then Exit; if TTyp <> ttCol then ErrorExpected(''','''); NextToken; if not (TTyp in [ttIdentifier, ttString]) then ErrorExpected(LoadStr2(irIdentifier)); UsesList := UsesList + ','; ReadUnit(Token); end; end; procedure TJvInterpreterUnit.InterpretUnit; var UsesList: string; begin NextToken; if TTyp <> ttIdentifier then ErrorExpected(LoadStr2(irIdentifier)); FCurUnitName := Token; NextToken; if TTyp <> ttSemicolon then ErrorExpected(''';'''); UsesList := ''; NextToken; while True do begin case TTyp of ttEmpty: ErrorExpected('''' + kwEND + ''''); ttFunction, ttProcedure: begin InterpretFunction; if TTyp <> ttSemicolon then ErrorExpected(''';'''); end; ttEnd: Break; ttUses: InterpretUses(UsesList); ttVar: InterpretVar(FAdapter.AddSrcVar); ttConst: InterpretConst(FAdapter.AddSrcVar); ttInterface: FUnitSection := usInterface; ttImplementation: FUnitSection := usImplementation; ttType: InterpretType; else ErrorExpected(LoadStr2(irDeclaration)); end; NextToken; end; if TTyp <> ttEnd then ErrorExpected('''' + kwEND + ''''); NextToken; if TTyp <> ttPoint then ErrorExpected('''.'''); FAdapter.AddSrcUnit(FCurUnitName, Source, UsesList); end; procedure TJvInterpreterUnit.InterpretType; var Identifier: string; begin NextToken; if TTyp <> ttIdentifier then ErrorExpected(LoadStr2(irIdentifier)); Identifier := Token; NextToken; if TTyp <> ttEqu then ErrorExpected('''='''); NextToken; case TTyp of ttClass: InterpretClass(Identifier); ttRecord: InterpretRecord(Identifier); else { only class declaration for form is supported } ErrorExpected(LoadStr2(irClass)); end; end; procedure TJvInterpreterUnit.InterpretClass(const Identifier: string); var JvInterpreterSrcClass: TJvInterpreterIdentifier; begin NextToken; if TTyp <> ttLB then ErrorExpected('''('''); NextToken; if TTyp <> ttIdentifier then ErrorExpected(LoadStr2(irIdentifier)); NextToken; if TTyp <> ttRB then ErrorExpected(''')'''); FindToken(ttEnd); NextToken; if TTyp <> ttSemicolon then ErrorExpected(''';'''); JvInterpreterSrcClass := TJvInterpreterIdentifier.Create; JvInterpreterSrcClass.UnitName := FCurUnitName; JvInterpreterSrcClass.Identifier := Identifier; FAdapter.AddSrcClass(JvInterpreterSrcClass); end; procedure TJvInterpreterUnit.InterpretRecord(const Identifier: string); var // JvInterpreterSrcRecord: TJvInterpreterIdentifier; // Fields: array of TJvInterpreterRecField; // TempField: TJvInterpreterRecField; // TempCount: Integer; // TempTyp: Word; JvInterpreterRecord: TJvInterpreterRecord; begin JvInterpreterRecord := TJvInterpreterRecord.Create; JvInterpreterRecord.RecordSize := 0; JvInterpreterRecord.Identifier := Identifier; JvInterpreterRecord.FieldCount := 0; InterpretVar(JvInterpreterRecord.AddField); NextToken; if TTyp <> ttEnd then ErrorExpected('''' + kwEND + ''''); NextToken; if TTyp <> ttSemicolon then ErrorExpected(''';'''); // конец разбора FAdapter.FRecordList.Add(JvInterpreterRecord); end; procedure TJvInterpreterUnit.Run; var FunctionDesc: TJvInterpreterFunctionDesc; begin Init; NextToken; case TTyp of ttVar, ttBegin: InFunction(nil); ttFunction, ttProcedure: InterpretFunction; ttUnit: begin try InterpretUnit; except on E: Exception do begin UpdateExceptionPos(E, FCurUnitName); raise; end; end; FCompiled := True; { execute main function } FunctionDesc := FAdapter.FindFunDesc(FCurUnitName, 'main'); if FunctionDesc = nil then JvInterpreterError(ieMainUndefined, -1); CurPos := FunctionDesc.PosBeg; NextToken; InFunction(FunctionDesc); end; else FVResult := Expression1; end; FCompiled := True; end; procedure TJvInterpreterUnit.Compile; begin Init; try NextToken; if TTyp <> ttUnit then ErrorExpected('''' + kwUNIT + ''''); InterpretUnit; except on E: Exception do begin UpdateExceptionPos(E, FCurUnitName); raise; end; end; FCompiled := True; end; procedure TJvInterpreterUnit.SourceChanged; begin inherited SourceChanged; end; function TJvInterpreterUnit.GetValue(const Identifier: string; var Value: Variant; var Args: TJvInterpreterArgs): Boolean; var FunctionDesc: TJvInterpreterFunctionDesc; OldArgs: TJvInterpreterArgs; begin Result := inherited GetValue(Identifier, Value, Args); if Result then Exit; if Args.Obj = nil then FunctionDesc := FAdapter.FindFunDesc(FCurUnitName, Identifier) else if Args.Obj is TJvInterpreterSrcUnit then FunctionDesc := FAdapter.FindFunDesc((Args.Obj as TJvInterpreterSrcUnit).Identifier, Identifier) else FunctionDesc := nil; Result := FunctionDesc <> nil; if Result then begin FAdapter.CheckArgs(Args, FunctionDesc.FParamCount, FunctionDesc.FParamTypes); {not tested !} OldArgs := FCurrArgs; try FCurrArgs := Args; ExecFunction(FunctionDesc); finally FCurrArgs := OldArgs; end; Value := FVResult; end; end; function TJvInterpreterUnit.SetValue(const Identifier: string; const Value: Variant; var Args: TJvInterpreterArgs): Boolean; begin Result := inherited SetValue(Identifier, Value, Args); end; function TJvInterpreterUnit.GetUnitSource(const UnitName: string; var Source: string): Boolean; begin Result := False; if Assigned(FOnGetUnitSource) then FOnGetUnitSource(UnitName, Source, Result); end; procedure TJvInterpreterUnit.DeclareExternalFunction(const Declaration: string); var OldSource: string; OldPos: Integer; begin Source := Declaration; OldSource := Source; OldPos := FParser.Pos; try NextToken; if not (TTyp in [ttFunction, ttProcedure]) then ErrorExpected('''' + kwFUNCTION + RsEXOrX + kwPROCEDURE + ''''); InterpretFunction; finally Source := OldSource; FParser.Pos := OldPos; end; end; procedure TJvInterpreterUnit.ExecFunction(Fun: TJvInterpreterFunctionDesc); var OldUnitName: string; S: string; begin PushState; FAllowAssignment := True; OldUnitName := FCurUnitName; try if not Cmp(FCurUnitName, Fun.UnitName) then begin FCurUnitName := Fun.UnitName; FAdapter.CurUnitChanged(FCurUnitName, S); Source := S; end; CurPos := Fun.PosBeg; NextToken; try InFunction(Fun); except on E: Exception do begin UpdateExceptionPos(E, FCurUnitName); raise; end; end; finally if not Cmp(FCurUnitName, OldUnitName) then begin FCurUnitName := OldUnitName; FAdapter.CurUnitChanged(FCurUnitName, S); Source := S; end; PopState; end; end; function TJvInterpreterUnit.CallFunction(const FunctionName: string; Args: TJvInterpreterArgs; Params: array of Variant): Variant; begin Result := CallFunctionEx(nil, '', FunctionName, Args, Params); end; function TJvInterpreterUnit.CallFunctionEx(Instance: TObject; const UnitName: string; const FunctionName: string; Args: TJvInterpreterArgs; Params: array of Variant): Variant; var FunctionDesc: TJvInterpreterFunctionDesc; I: Integer; OldArgs: TJvInterpreterArgs; OldInstance: TObject; begin if not Compiled then Compile; OldInstance := FCurInstance; try FCurInstance := Instance; FunctionDesc := FAdapter.FindFunDesc(UnitName, FunctionName); if FunctionDesc <> nil then begin OldArgs := FCurrArgs; if Args = nil then begin FCurrArgs.Clear; for I := Low(Params) to High(Params) do begin FCurrArgs.Values[FCurrArgs.Count] := Params[I]; Inc(FCurrArgs.Count); end; end else FCurrArgs := Args; try { simple init } FBreak := False; FContinue := False; FLastError.Clear; ExecFunction(FunctionDesc); Result := FVResult; finally FCurrArgs := OldArgs; end; end else JvInterpreterErrorN(ieUnknownIdentifier, -1, FunctionName); finally FCurInstance := OldInstance; end; end; function TJvInterpreterUnit.FunctionExists(const UnitName: string; const FunctionName: string): Boolean; begin Result := FAdapter.FindFunDesc(UnitName, FunctionName) <> nil; end; //=== { TJvInterpreterProgramStrings } ======================================= type TJvInterpreterProgramStrings = class(TStringList) private FJvInterpreterProgram: TJvInterpreterProgram; protected procedure Changed; override; end; procedure TJvInterpreterProgramStrings.Changed; begin FJvInterpreterProgram.Source := Text; end; //=== { TJvInterpreterProgram } ============================================== constructor TJvInterpreterProgram.Create(AOwner: TComponent); begin inherited Create(AOwner); FPas := TJvInterpreterProgramStrings.Create; (FPas as TJvInterpreterProgramStrings).FJvInterpreterProgram := Self; end; destructor TJvInterpreterProgram.Destroy; begin FPas.Free; inherited Destroy; end; function TJvInterpreterProgram.GetPas: TStrings; begin Result := FPas; end; procedure TJvInterpreterProgram.SetPas(Value: TStrings); begin FPas.Assign(Value); end; procedure TJvInterpreterProgram.DoOnStatement; begin if Assigned(FOnStatement) then FOnStatement(Self); end; procedure TJvInterpreterProgram.Run; var UsesList: string; begin // (rom) Does this always work? After "program" a line end or tab is allowed. if AnsiStrLIComp(PChar(FParser.Source), 'program ', Length('program ')) <> 0 then begin inherited Run; Exit; end; Init; NextToken; while True do begin case TTyp of ttEmpty: ErrorExpected('''' + kwEND + ''''); ttFunction, ttProcedure: begin InterpretFunction; if TTyp <> ttSemicolon then ErrorExpected(''';'''); end; ttEnd: Break; ttUses: InterpretUses(UsesList); ttVar: InterpretVar(FAdapter.AddSrcVar); ttConst: InterpretConst(FAdapter.AddSrcVar); ttInterface: FUnitSection := usInterface; ttImplementation: FUnitSection := usImplementation; ttType: InterpretType; ttProgram: begin NextToken; FCurUnitName := Token; NextToken; if TTyp <> ttSemicolon then ErrorExpected(''';'''); end; ttBegin: Break; else ErrorExpected('''' + kwEND + ''''); end; NextToken; end; FCompiled := True; FAdapter.AddSrcUnit(FCurUnitName, Source, UsesList); { execute program function } { FunctionDesc := FAdapter.FindFunDesc(FCurUnitName, 'program'); if FunctionDesc <> nil then begin CurPos := FunctionDesc.PosBeg; NextToken; InFunction(FunctionDesc); end; } try InterpretBegin; if (TTyp <> ttPoint) then ErrorExpected('''.'''); except on E: Exception do begin UpdateExceptionPos(E, FCurUnitName); raise; end; end; end; function TJvInterpreterFunction.GetDebugPointerToGlobalVars: TJvInterpreterVarList; begin Result := Adapter.FSrcVarList; end; function TJvInterpreterFunction.GetDebugPointerToFunStack: Pointer; begin Result := FFunctionStack; end; //=== { TJvInterpreterMethodList } =========================================== procedure TJvInterpreterMethodList.Sort(Compare: TListSortCompare); function SortIdentifier(Item1, Item2: Pointer): Integer; begin { function AnsiStrIComp about 30% faster than AnsiCompareText } { Result := AnsiCompareText(TJvInterpreterIdentifier(Item1).Identifier, TJvInterpreterIdentifier(Item2).Identifier); } Result := AnsiStrIComp(PChar(TJvInterpreterIdentifier(Item1).Identifier), PChar(TJvInterpreterIdentifier(Item2).Identifier)); if (Result = 0) and (Item1 <> Item2) then begin if TJvInterpreterMethod(Item1).FClassType.InheritsFrom(TJvInterpreterMethod(Item2).FClassType) then Result := -1 else if TJvInterpreterMethod(Item2).FClassType.InheritsFrom(TJvInterpreterMethod(Item1).FClassType) then Result := 1; end; end; begin inherited Sort(@SortIdentifier); end; //=== { TJvInterpreterRecord } =============================================== procedure TJvInterpreterRecord.AddField(const UnitName, Identifier, Typ: string; VTyp: Word; const Value: Variant; DataType: IJvInterpreterDataType); begin Fields[FieldCount].Identifier := Identifier; Fields[FieldCount].Typ := varEmpty; Fields[FieldCount].Offset := RecordSize; Fields[FieldCount].DataType := DataType; Inc(RecordSize, SizeOf(TVarData)); Inc(FieldCount); end; procedure TJvInterpreterRecord.NewRecord(var Value: Variant); const EmptyStr: string = ''; var I: Integer; Rec: PChar; // Res: Boolean; RecHolder: TJvInterpreterRecHolder; begin if Assigned(CreateFunc) then CreateFunc(Pointer(Rec)) else begin GetMem(Rec, RecordSize); for I := 0 to FieldCount - 1 do begin if Fields[I].Typ = varString then PString(PString(Rec + Fields[I].Offset)^) := @EmptyStr else if Fields[I].Typ = varEmpty then begin PVarData(Rec + Fields[I].Offset)^.VType := varNull; if Fields[I].DataType <> nil then Fields[I].DataType.Init(Variant(PVarData(Rec + Fields[I].Offset)^)); end; end; end; JvInterpreterVarCopy(Value, R2V(Identifier, Rec)); RecHolder := TJvInterpreterRecHolder(TVarData(Value).VPointer); RecHolder.JvInterpreterRecord := Self; end; //=== { TJvInterpreterRecordDataType } ======================================= constructor TJvInterpreterRecordDataType.Create(ARecordDesc: TJvInterpreterRecord); begin inherited Create; FRecordDesc := ARecordDesc; end; function TJvInterpreterRecordDataType.GetTyp: Word; begin Result := varEmpty; end; procedure TJvInterpreterRecordDataType.Init(var V: Variant); begin FRecordDesc.NewRecord(V); end; //=== { TJvInterpreterArrayDataType } ======================================== constructor TJvInterpreterArrayDataType.Create(AArrayBegin, AArrayEnd: TJvInterpreterArrayValues; ADimension: Integer; AArrayType: Integer; ADT: IJvInterpreterDataType); begin inherited Create; FArrayBegin := AArrayBegin; FArrayEnd := AArrayEnd; FDimension := ADimension; FArrayType := AArrayType; FDT := ADT; end; function TJvInterpreterArrayDataType.GetTyp: Word; begin Result := varArray; end; procedure TJvInterpreterArrayDataType.Init(var V: Variant); begin V := Integer(JvInterpreterArrayInit(FDimension, FArrayBegin, FArrayEnd, FArrayType, FDT)); TVarData(V).VType := varArray; end; //=== { TJvInterpreterSimpleDataType } ======================================= constructor TJvInterpreterSimpleDataType.Create(ATyp: TVarType); begin inherited Create; FTyp := ATyp; end; function TJvInterpreterSimpleDataType.GetTyp: Word; begin Result := FTyp; end; procedure TJvInterpreterSimpleDataType.Init(var V: Variant); begin V := Null; TVarData(V).VType := varEmpty; if (FTyp <> 0) and (FTyp <> varObject) then //dejoy fixed: can't define TObject up d6 V := Var2Type(V, FTyp); end; //=== { TJvInterpreterSrcUnit } ============================================== function TJvInterpreterSrcUnit.UsesList: TNameArray; begin Result := FUsesList; end; {$IFDEF JvInterpreter_OLEAUTO} var OleInitialized: Boolean; {$ENDIF JvInterpreter_OLEAUTO} {$IFDEF UNITVERSIONING} const UnitVersioning: TUnitVersionInfo = ( RCSfile: '$RCSfile: JvInterpreter.pas,v $'; Revision: '$Revision: 1.60 $'; Date: '$Date: 2004/12/28 14:14:19 $'; LogPath: 'JVCL\run' ); {$ENDIF UNITVERSIONING} initialization {$IFDEF UNITVERSIONING} RegisterUnitVersion(HInstance, UnitVersioning); {$ENDIF UNITVERSIONING} {$IFDEF JvInterpreter_OLEAUTO} OleInitialized := OleInitialize(nil) = S_OK; {$ENDIF JvInterpreter_OLEAUTO} finalization FreeAndNil(FieldGlobalJvInterpreterAdapter); {$IFDEF COMPILER6_UP} FreeAndNil(GlobalVariantObjectInstance); FreeAndNil(GlobalVariantRecordInstance); FreeAndNil(GlobalVariantClassInstance); FreeAndNil(GlobalVariantPointerInstance); FreeAndNil(GlobalVariantSetInstance); FreeAndNil(GlobalVariantArrayInstance); {$ENDIF COMPILER6_UP} {$IFDEF JvInterpreter_OLEAUTO} if OleInitialized then OleUnInitialize; {$ENDIF JvInterpreter_OLEAUTO} {$IFDEF JvInterpreter_DEBUG} if ObjCount <> 0 then Windows.MessageBox(0, PChar('Memory leak in JvInterpreter.pas'#10 + 'ObjCount = ' + IntToStr(ObjCount)), 'JvInterpreter Internal Error', MB_ICONERROR); {$ENDIF JvInterpreter_DEBUG} {$IFDEF UNITVERSIONING} UnregisterUnitVersion(HInstance); {$ENDIF UNITVERSIONING} end.