admin/expertcad
1
0
Fork 0
mirror of http://gitlab.expertsoft.com.ua/git/expertcad synced 2026-01-11 22:45:39 +02:00
Code Issues Packages Projects Releases Wiki Activity
expertcad/POWERCAD30/UNITS/Delphin.pas
ShevaIV 00e2ad8635 initial commit
2025-05-12 10:07:51 +03:00

5776 lines
140 KiB
ObjectPascal
Raw Blame History

{*******************************************************}
{ }
{ Delphi Interpreter }
{ Copyright (c) 1996-1998 S.Kurinny & S.Kostinsky }
{ }
{*******************************************************}
Unit delphin;
Interface
Uses
classes, sysutils, forms, windows, dialogs, typinfo, controls,
Variants,
// {$ifdef DELPHI7}
// Variants,
// {$endif}
stdctrls;
{-------------------------------------------------------------------------}
Const
{ maximal number of procedure parameters allowed in the interpreter}
maxparams = 100;
SErrFunDefined='Function %s is already defined';
eofincom_ERR = 'Unexpected EOF in comment block';
delimeter_expected = 'Operator delimeter expected';
eofinstring_ERR ='Unexpected EOF in string constant declaration';
need_opbr ='( expected';
comma_expected= 'Comma expected';
need_clbr= ') expected';
begin_expected= 'BEGIN expected';
unk_macrotype= 'Unknown macro type %S';
par_notfound= 'Parameter %S not found';
unkn_id= 'Unknown identifier: %s';
unexp_writer= 'Unknown variable type during writing program';
do_exp= 'DO expected';
down_to_exp= 'TO or DOWNTO expected';
unit_declared= 'Unit %s already defined';
bad_unit= 'Unit declaration error';
fun_notfound= 'Function %s not found';
until_exp= 'UNTIL Expected';
linker_error= 'Link Error';
labname_exp= 'Label name expected';
label_already= 'Label <%s> already defined';
delim_or_coma= 'Comma or delimeter expected';
err_declpart= 'Error in declaration block';
lab_notdef= 'Label <%s> not defined';
progname_exp= 'Program name expected';
varname_exp= 'Variable name expected';
var_already= 'Variable <%s> already defined';
bad_varblock= 'Error in variable declaration block';
var_NotDef= 'Variable <%s> not defined';
else_exp= 'ELSE expected';
then_exp= 'THEN expected';
id_expected= 'Identifier expected';
meth_decerr= 'Method declaration error';
bad_methparam= 'Method parameters declaration error';
no_props= 'Properties not implemented';
need_par= 'Parent name expected';
clbr_exp= ') Expected';
only_class= 'Only class declarations allowed';
err_decl= '%s declaration error';
p2_exp= 'Colon expected';
synt_err='Syntax error in (%s): %s.';
bad_idName= 'Bad identifier name <%s>';
bad_id= 'Bad identifier <%s>';
opsq_exp= '[ expected but %s found';
clsq_exp= '] expected but %s found';
in_funuse= 'Invalid function usage';
in_procuse= 'Invalid procedure usage';
bad_hex= 'Hex constant declaration error';
file_not_found= 'File %S not found';
compile_before= 'Compile before run';
bad_realconst= 'Real constant declaration error';
bad_charconst= 'String constant declaration error';
unsup_partype= 'Unsupported parameter type';
no_resvar= 'Variable Result not found for %s';
proc_notfound= 'Procedure %s not found';
eq_exp= '= expected';
end_expected= 'END expected';
SErrCircularVarRef='Circular variable %S reference';
SErrUnknReaderType='Unknown reader type';
type
// tproctype = Function(slf: tobject; Var s: Array of variant): variant; register;
TProcType = Function(slf: tobject; var APropName: String; Var s: Array of variant): variant; register;
tbytearray = Array[0..maxparams] of byte;
TFunListItem = Class
PropName: String;
ProcAddr: tproctype;
ParCount: integer;
Fun: boolean;
Params: tbytearray; {0-stack param 1-var param 2-no param
3-open array param}
IsProp: Boolean;
IsPropSet: Boolean;
End;
TFunList = Class(TStringList)
Public
Constructor Create;
Procedure AddItem(Const Aname,APropName: String; ProcAddr: TProcType;
Fun, IsProp, IsPropSet: Boolean; Const Params: Array of byte);
Destructor Destroy; override;
End;
Var
Funs: TFunList;
{-------------------------------------------------------------------------}
{Converts object to variant. Used when writing interface functions
for importing Delphi objects and functions to interpreter.}
Function ObjToVar(S: TObject): Variant;
{Converts variant to object. Used when writing interface functions
for importing Delphi objects and functions to interpreter.}
Function VarToObj(S: Variant): TObject;
{@see ObjToVar}
Function OV(S: TObject): Variant;
{@see VarToObj}
Function VO(S: Variant): TObject;
{ Use this function to call previously registered in interpreter procedure or function.
@param ProcName function name
@param SLF pointer to object instance if called function is object method
@param S parameters
@return return value (for functions)}
{Function CallHalProc(Const procName: String; slf: tobject;
Var s: Array of variant): variant;}
{ Returns address of registered in interpreter function or procedure
Returns nil if item not found
}
//Function GetHalProcAddr(Const FunName: String): tproctype;
{ Calls interpreter procedure or function without parameters
If procedure or function with ProcName not found does nothing
}
//function SimpleCallHalProc(Const ProcName:String):Variant;
{Registers Delphi's procedure in interpreter
@param AName Procedure name. For registration object method use qualified name
('TOBJECT.FREE')
@param ProcAddr Import function address. @see TProcType
@param Params Array of parameters definitions.
If =[2] - no parameters, otherwise type of each parameter should be specified.
Parameter types: 0 - stack parameter, 1 - var parameter, 3 - open array.
Open array is passed to import function in variant with array type.
V[0] - array size. V[1]..V[V[0]] - array items. Use convert functions
for converting to array of const of to other array types
}
Procedure AddProc(Const Aname: String; ProcAddr: TProcType; Const Params: Array of byte);
{ Same as AddProc, but for registering functions
@see AddProc
}
Procedure AddFun(Const Aname: String; ProcAddr: TProcType; Const Params: Array of byte);
{ Registers object properties. Interface functions for reading and
writing property value should be specified.
If Property is read-only then pass SETPROCADDR=nil}
Procedure AddProp(Const Aname: String; ProcAddr, SetProcAddr: TProcType);
{ Registers array properties.
ADIM- array dimension. ( 3 ---> A[1,2,2] 1 --> A[6])}
Procedure AddArrayProp(Const Aname: String; ADim: Integer; ProcAddr, SetProcAddr: TProcType);
{ Deletes previously registered in the interpreter procedure or function
If item with ProcName not found does nothing
}
procedure DelProc(Const ProcName:String);
{----------------------------------------------}
Const
conotifyevent = 'TNotifyEvent'; // don't resource
cocloseevent = 'TCloseEvent'; // don't resource
coprocResult = '.Result'; // don't resource
StackSize=1000;
Type
// Functions of this type are used for converting external variable
// names to ids
TDynaVarNameTOId = Function(Const S: String): Integer of Object;
// Procedures of this type are called to set value to external variable by id.
TDynaSetVar = Procedure(ID: Integer; Value: Variant) of Object;
// Functions of this type are used to get values of external variables
TDynaGetVar = Function(ID: Integer): Variant of Object;
Type
ECompilerError = Class(Exception);
{-------------------}
Type
TToken = Record
ID: Integer;
Data: Variant;
End;
Type TCharSet = Set of char;
Const
WhiteSpaces: TCharSet = ['+', '-', '/', '*', '(', ')', ':', '=', ',', ';', '>', '<',
'$', '.', '#', '[', ']', '^', '@', '&', '~', '|', '%'];
BlackSpaces: TCharSet = [#1..#32];
StopChars: TCharSet = [#0..#32, '+', '-', '/', '*', '(', ')', ':', '=', ',', '''',
'{', '}', ';', '>', '<', '$', '.', '#', '[', ']', '"', '^', '@', '&', '~', '|', '%'];
FirstIdentChar: TCharSet = ['A'..'Z', '<27>'..'<27>', '_'];
IdentBackChars: TCharSet = ['A'..'Z', '_', '0'..'9', '<27>'..'<27>'];
Digit: TCharSet = ['0'..'9'];
HexDigit: TCharSet = ['0'..'9', 'A'..'F'];
{----------------------------------------------}
{ Writer types }
Const
wInteger = 1;
wDouble = 2;
wString = 3;
WBoolean = 4;
{----------------------------------------------}
Const
ocAdd = 0;
ocSub = 1;
ocMul = 2;
ocDiv = 3;
ocMod = 4;
ocSlash = 5;
ocShl = 6;
ocShr = 7;
ocNot = 8;
ocOr = 9;
ocXor = 10;
ocAnd = 11;
ocGreaterEqual = 12;
ocEqual = 13;
ocLessEqual = 14;
ocNotEqual = 15;
ocGreater = 16;
ocLess = 17;
ocNeg = 18;
ocGoto = 19;
ocIF = 20;
ocloadconst = 23;
ochalt = 26;
ocincvar = 29;
ocdecvar = 30;
ocbackcode = 34;
ocextfun = 42;
ocextproc = 43;
ocsetself = 44;
ocloadextvar = 45;
ocstoreextvar = 46;
ocselffromvar = 47;
ocmov = 48;
occall = 49;
ocreturn = 50;
ocvarraycreate = 51;
ocsetvarray = 52;
{ Character IDs}
idEndOfFile = 0;
idNewLine = $0a;
idpower = Integer('^');
idPoint = Integer('.');
idDelimeter = Integer(';');
idgreater = Integer('>');
idless = Integer('<');
idComma = Integer(',');
idPlus = Integer('+');
idMinus = Integer('-');
idSlash = Integer('/');
idStar = Integer('*');
idOpenBracket = Integer('(');
idCloseBracket = Integer(')');
idOpenComment = Integer('{');
idCloseComment = Integer('}');
idEqual = Integer('=');
idnotequal = integer('#');
id2Points = Integer(':');
idStringChar = Integer('''');
id2StringChar = Integer('"');
idsqopenbracket = integer('[');
idsqclosebracket = integer(']');
{ ID Bases and ID ends }
idBase = 256;
idReservedBase = 1000;
idReservedEnd = 1999;
{ Other IDs }
idIdentifier = idBase + 0;
idStringConst = idBase + 1;
idNumberConst = idBase + 2;
idresconst = idbase + 5;
idhexConst = idbase + 6;
{ Reserverd Words [idReservedBase,idReservedEnd] }
id_Program = idReservedBase + 0;
id_Label = idReservedBase + 1;
id_Goto = idReservedBase + 2;
id_Var = idReservedBase + 3;
id_begin = idReservedBase + 4;
id_end = idReservedBase + 5;
id_and = idReservedBase + 6;
id_or = idReservedBase + 7;
id_xor = idReservedBase + 8;
id_not = idReservedBase + 9;
id_shl = idReservedBase + 10;
id_shr = idReservedBase + 11;
id_div = idReservedBase + 12;
id_mod = idReservedBase + 13;
id_true = idReservedBase + 14;
id_false = idReservedBase + 15;
id_if = idReservedBase + 16;
id_then = idReservedBase + 17;
Id_else = idReservedBase + 18;
id_while = idReservedBase + 19;
id_repeat = idReservedBase + 20;
id_until = idReservedBase + 21;
id_for = idReservedBase + 22;
id_to = idReservedBase + 23;
id_downto = idReservedBase + 24;
id_do = idReservedBase + 25;
id_nil = idReservedBase + 27;
id_unitinit = idReservedBase + 31;
id_unitfinal = idReservedBase + 32;
id_class = idReservedBase + 33;
id_type = idReservedBase + 34;
id_constr = idReservedBase + 35;
id_destr = idReservedBase + 36;
id_uses = idReservedBase + 37;
id_unit = idReservedBase + 38;
id_interface = idReservedBase + 39;
id_implement = idReservedBase + 40;
id_procedure = idReservedBase + 41;
id_private = idReservedBase + 42;
id_public = idReservedBase + 43;
id_protected = idReservedBase + 44;
id_published = idReservedBase + 45;
id_function = idReservedBase + 46;
id_const = idReservedBase + 47;
id_property = idReservedBase + 48;
id_virtual = idReservedBase + 49;
id_override = idReservedBase + 50;
id_dynamic = idReservedBase + 51;
id_record = idReservedBase + 52;
id_forward = idReservedBase + 53;
id_index = idReservedBase + 54;
id_read = idReservedBase + 55;
id_write = idReservedBase + 56;
id_stored = idReservedBase + 57;
id_default = idReservedBase + 58;
id_abstract = idReservedBase + 59;
id_stdcall=idReservedBase + 69;
{------------------------------}
Type
TResConstListItem = Class
public
Value: Variant;
End;
TResConstList = Class(TStringList)
Public
Constructor Create;
Procedure AddConst(Const AName: String; Var V: Variant);
Destructor Destroy; override;
End;
TDynaVarItem = Class
public
VarNameTOID: TDynaVarNameToID;
SetVar: TDYnaSetVar;
GetVar: TDynaGetVar;
LocalVar: Boolean;
OwnerSelf: TObject;
End;
TDynaVars = Class(TStringlist)
Public
Function GetDynaObject(Const vname: String; AOwnerSelf: TObject;
Var varid, funid: integer): boolean;
Procedure AddDyna(Const name: String;
Avarnametoid: TDynaVarNameTOID;
ASetVar: TDYnaSetVar;
AGetVar: TDynaGetVar; LocalVars: Boolean; AOwnerSelf: TObject);
Procedure DelDyna(Const name: String);
Destructor Destroy; override;
End;
TObjectListItem = Class
public
Pearent: String;
End;
tobjitem = Class
public
objtype: String;
tobj: tobject;
End;
tobjcollect = Class(tstringlist)
Public
Constructor Create;
Destructor Destroy; override;
Function ObjbyName(Const aname: String; Var tob: tobjitem): boolean;
End;
pvariantarray = ^tvariantarray;
tvariantarray = Array[0..StackSize] of variant;
Const
tifunction = 2;
tivariable = 0;
tiprocedure = 1;
Type
TIdentListItem = Class
Public
ID: Integer;
VType: String;
IdentType: Integer; {0-Variable 1-procedure 2-function}
ParCount: Integer;
Params: tbytearray;
ParamNames: TStringList;
Constructor Create;
Destructor Destroy; override;
Procedure Assign(Source: TIdentlistItem);
End;
tbinprogitem = Record
a, b, opcode: integer;
End;
tprogarray = Array[0..1000] of tbinprogitem;
pprogarray = ^tprogarray;
pintarray = ^tintarray;
tintarray = Array[0..1000] of integer;
TIdentList = Class(TStringList)
private
Function AddItem(Const Aname: String; ID: Integer): Integer;
Function IDByName(Const AName: String; Var AID: integer): boolean;
Function ItemByName(Const Aname: String; Var Ident: TIdentListItem): boolean;
Public
Constructor Create;
Destructor Destroy; override;
Procedure Assign(Source: TPersistent); override;
End;
TConstItem = Class(TCollectionItem)
Public
Data: Variant;
End;
TConstList = Class(TCollection)
Public
Function newitem(adata: variant): integer;
End;
TIDLabelItem = Class(TCollectionItem)
Public
referenced: boolean;
exist: boolean;
Place: integer;
End;
TIDLabelList = Class(TCollection)
Public
Function newitem: integer;
Procedure SetPlace(index, aplace: integer);
Procedure SetReference(index: integer);
Function existlabels: boolean;
End;
TProgItem = Class(TCollectionItem)
Public
OpCode: integer;
A: integer;
B: integer;
End;
TProgCollect = Class(TCollection)
Public
Procedure putop(ID, AA, AB: integer);
End;
{------------------------------}
Var
ResWords: TIdentList;
DynaVars: TDynaVars;
ResConsts: TResConstList;
{------------------------------}
Function GetClassParent(C:TClass):String;
Function GetPearent(Const objname: String): String;
// Releases memory occupied by array of constants, converted using
// function VARTOCONSTS.
Procedure disposeconsts(Var c: Array of tvarrec; size: integer);
Procedure setnotifyevent(ControlLink: TObject; Const eventlink: String; fmynotifyevent: TNotifyEvent);
Function SetToken(ID: integer; V: Variant): TToken;
Function Hex2Dec(Const S: String): Longint;
{ Same as AddDynaVar, but variables will be visible only in script
of HalComp=AOwnerSelf}
Procedure AddLocalVar(Const name: String;
Avarnametoid: TDynaVarNameTOID;
ASetVar: TDYnaSetVar;
AGetVar: TDynaGetVar; AOwnerSelf: TObject);
{ Registers external variables (your Delphi programs variables) in interpreter.
These variables will be visible in all scripts.
Name - Name of the DYNA definition. This name can be used
later for deleting DYNA definitions.
AVARNAMETOID
- function for converting variable names to ids
TDYNAVARNAMETOID= FUNCTION(CONST S:STRING):INTEGER OF OBJECT;
Interpreter calls functions AVARNAMETOID of all DYNA definitions.
If S is yours variable return its ID (it's up to you to decide what ID,
variables of different DYNA definitions could have same IDs).
If S is not your's variable return -1
ASETVAR
- procedure for writing value to DYNA variable.
TDYNASETVAR=PROCEDURE (ID: INTEGER; VALUE: VARIANT) OF OBJECT;
AGETVAR - procedure for reading DYNA variable value
TDYNAGETVAR=FUNCTION (ID: INTEGER): VARIANT OF OBJECT;
}
Procedure AddDynaVar(Const name: String;
Avarnametoid: TDynaVarNameTOID;
ASetVar: TDYnaSetVar;
AGetVar: TDynaGetVar);
// Deletes DYNA definition with Name
Procedure deldynavar(Const name: String);
{ Converts variant to array of constants. Returns Maxp - high bound of array.
Use only in interface functions.}
Procedure VarToConsts(Var V: Variant; Var P: Array of tvarrec; Var MaxP: Integer);
{ Registers constant with name ANAME and with value V
Example: AddConst('Pi',pi);}
Procedure AddConst(Const AName: String; V: Variant);
{ Converts variant to array of string. Returns Maxp - high bound of array.
Use only in interface functions.}
Procedure VarToStringS(Var V: Variant; Var P: Array of String; Var MaxP: Integer);
{ Clears array of HAL parameters}
Procedure ClearHalParams;
{ Returns value of HAL parameter with name PARAMNAME.
HAL parameters are "virtual" variables accessible from any place
in program}
Function GetHalParam(Const ParamName: String): Variant;
// Write value to HAL parameter with name PARAMNAME.
// HAL parameters are "virtual" variables accessible from any place
// in program
Procedure SetHalParam(Const ParamName: String; Value: Variant);
{------------------------------}
Type
TInternalVarItem = Class
public
Value: Variant;
End;
TInternalVar = Class(TStringList)
Private
MyResult: Variant;
Function DynaGetVar(ID: Integer): Variant;
Procedure DynaSetVar(ID: Integer; Value: Variant);
Function DynaVarNameTOId(Const S: String): Integer;
Public
Constructor Create;
Destructor Destroy; override;
End;
{------------------------------}
Const
stintvar = '__InternalVar';
Var
InternalVariables: TInternalVar;
{----------------------------------------------}
Type
tbuf = Array[1..12000] of char;
pbuf = ^tbuf;
THalCompiler = Class
Private
DolEnabled: Boolean;
HalOwner: TObject;
IdentPrefix: String;
spoint: integer;
fout: tstream;
Labels, Variables: TIdentList;
Consts: TConstList;
IDLabels: TIDLabelList;
Prog: TProgCollect;
lastvar: TIdentListItem;
lastobject: TObject;
mobjects: tobjcollect;
notfromobj: boolean;
FLastClassType: String;
nextstate: boolean;
Function NextByte: byte;
Function getinternalfun(Const sname: String; ident: tidentlistitem): integer;
Function VarIDByName(Const AName: String; Var Id: Integer): boolean;
Procedure getprocbody(i: integer);
Procedure getvartype;
Function getprocdef(askip: boolean): Integer;
Procedure getclassdefblock(b: boolean);
Procedure getmyvariables(b: boolean);
Function ReadByte: byte;
Procedure findobject(Var s: String);
Procedure gettypeidentifier;
Procedure BackBytes(a: integer);
Function getvar: integer;
Procedure putcode(aid, a, b: integer);
Function iexpression: integer;
Function isimpleexpression: integer;
Function GetOpenArray(NeedSq: boolean): Integer;
Procedure getuserfunction(Const name: String; scope, fik: boolean);
Procedure getcoma;
Procedure getidentifier;
Function iterm: integer;
Function ifactor: integer;
Function VarByName(Const AName: String; Var Ident: TIdentListItem): boolean;
Function AddVars(Const Aname: String; ID: Integer): Integer;
Function myexpress: integer;
Procedure equaldispath(Const VarName: String);
Procedure labeldispatch(Const labelname: String);
Procedure getprogramname;
Procedure getclassdef(Const cname: String);
Procedure getdeclarations;
Procedure myinit;
Procedure mydone;
Procedure getoperatorcoma;
Procedure getwhileoperator;
Procedure getrepeatoperator;
Procedure getforoperator;
Procedure getifoperator;
Procedure getoperator;
Procedure getoperatorblock;
Procedure compileprogram;
Procedure writeprogram;
public
inbuf: ^tbuf;
curread, numread: integer;
Token: TToken;
// Converts curent stream position into Line number and char position in line
// (1 based)
procedure ConvertCurPos(Var ALine,AChar:Integer);
Constructor Create(afin: TMemoryStream; afout: TStream);
Procedure compile; virtual;
Destructor Destroy; override;
Procedure getclosebracket;
Procedure getafterproc;
Procedure getopenbracket;
Procedure getdelimeter;
function GetLineNumber:Integer;
Function ReadToken: TToken;
Procedure error(Const s: String);
Function NextToken: TToken;
End;
{------------------------------}
Type
TBinProg = Class
Private
TempVars: Array[0..maxparams] of variant;
curpos: integer;
CallStack: Array[0..1000] of integer;
CallMax: Integer;
ConstSize: integer;
ProgSize: integer;
LabelSize: integer;
c: pvariantarray;
prog: pprogarray;
lastobject: tobject;
l: pintarray;
s: tvariantarray;
Procedure _ocstoreextvar(b, a: integer; Var V: Variant);
Procedure _ocsetself(A: TObject); register;
Procedure _ocselffromvar(Var A: Variant); register;
Procedure _ocloadextvar(Var V: Variant; b, a: integer); register;
Procedure _CallExtFun(Var V: Variant; var PropName:String; ProcAddr: TProcType); register;
Function _dispatch(opcode, a, b: integer): boolean;
Procedure Error(Const s: String);
Public
Procedure RunFrom(Acurpos: Integer);
Constructor Create(Fin: TStream);
Procedure Run;
Destructor Destroy; override;
End;
THalRuner = Class
Private
instream: tmemorystream;
Compiled: boolean;
mymem: TMemoryStream;
HalOwner: TObject;
myobjects: tobjcollect;
FBinProg: TBinProg;
loadtemp: boolean; { set true to copy Variables to TempVarList}
dontrun: boolean; { set true if you need to compile only}
TempVarList: TIdentList;
FLastClassType: String;
Procedure AddObject(Const objname, objtype: String; tobj: tobject);
Procedure AddObjectbyRef(Const objname: String; tobj: tobject);
Public
Constructor Create(T: TMemoryStream);
Procedure Run;
Destructor Destroy; override;
End;
{---------------------------------------------------}
Var
OutMemo: TMemo = Nil;
ErrorMemo: TMemo = Nil;
ErrorPrinted: Boolean = false;
OutLabel: TLabel = Nil;
Type
// Main component for visual work with interpreter. Specify script in
// property SCRIPT and use property Result for executing script and
// obtaining result. Script will be compiled only once or if you set
// property FSCRIPTCHANGED to true.
// You can "hook" event with name EventLink of component ControlLink
// and script will be executed instead of previously set event.
// (only TnotifyEvent supported for now + variably Sender can be used
// in the script).
THalComp = Class(TComponent)
Private
FVarNameTOID: TDynaVarNameTOID;
FGetVar: TDynaGetVar;
FSetVar: TDYnaSetVar;
FExpression, fobname: String;
fob: tobject;
FMyStream: TMemoryStream;
FControl: TComponent;
FEventLink: String;
FScript: TStrings;
Procedure SetExpression(Const S: String);
Procedure MyOnCHange(Sender: TObject);
Procedure SetScript(Value: TStrings);
Protected
DelOnFree: Boolean;
Procedure Notification(AComponent: TComponent;
Operation: TOperation); override;
Function getresult: variant;
Public
EventDispatcher:boolean; // true if this instance of halcomp is event dispatcher
FScriptChanged: boolean;
FHalRuner: THalRuner;
FLastClassType: String;
// This form components will be accessible from script body.
// Set only if THALCOMP has no owner (if there is owner then it's
// components accessible).
Friend: TForm;
Procedure Loaded; override;
Procedure FMyNotifyEvent(Sender: TObject);
Procedure FOnFOrmClose(Sender: TObject; Var Action: TCloseAction);
Constructor Create(AOwner: TComponent); override;
Destructor Destroy; override;
Procedure Run;
Procedure Compile(Const obname: String; ob: tobject);
// Use for execuiting script and for obtaining result
// (Script will be compiled if neccessary)
// (main property)
Property Result: Variant Read getResult;
Published
Property Script: TStrings Read FScript Write SetScript;
// Formula can be specified here (Use EXPRESSION or SCRIPT but not both)
Property Expression: String Read FExpression Write SetExpression;
// Component which will be hooked
Property ControlLink: TComponent Read FControl Write FControl;
// Event name
Property EventLink: String Read FEventLink Write FEventLink;
// Events for specifying external variables.
// These variables will be accessible only in this macros
// Read in the TDynaVarNameTOID type declaration about these events
Property VarNameTOID: TDynaVarNameTOID Read FVarNameTOID Write FVarNameTOID;
Property GetVar: TDynaGetVar Read FGetVar Write FGetVar;
Property SetVar: TDYnaSetVar Read FSetVar Write FSetVar;
End;
{------------------------------}
// Object for calculation of connected formulas. Example: A=B+C B=C-5 C=4
(*
TFormulaListItem = Class
public
Formula: String;
Value: Variant;
NeedCalc: Boolean;
End;
*)
(*
TFormulaList = Class(TStringList)
Private
IntStack: TIntStack;
Function HVarNameTOId(Const S: String): Integer;
Procedure HSetVar(ID: Integer; Value: Variant);
Function HGetVar(ID: Integer): Variant;
Public
// Calculate formula. Previously defined constants and calculatable
// variables could be used in the formula body.
Function CalcFormula(Const AFormula: String): Variant;
// Define constant
Procedure AddValue(Const VarName: String; AValue: Variant);
// Define variable
// (A=B+4 ---> ADDFORMULA('A','B+4');
Procedure AddFormula(Const VarName, AFormula: String);
Procedure AddVF(Const VarName, AFormula: String; AValue: Variant;
ACalc: Boolean);
// Get variable value.Formulas will be recalculated only once.
Function GetValue(Const VarName: String): Variant;
Constructor Create;
Destructor Destroy; override;
End;
*)
{------------------------------}
TQRNotifyOperation = (qrMasterDataAdvance, qrBandPrinted, qrBandSizeChange);
TMethodNameHolder = Class
Public
MethodName: String;
End;
PVarDataList = ^TVarDataList;
TVarDataList = array[0..65535] of TVarData;
THalEvent = Class(TComponent)
Protected
it: tidentlistitem;
PrName, ProcName: String;
HR: THalRuner;
Function GetParam(Const ParName: String): Variant;
Function GetProcItem: TIdentListItem;
Procedure SetParam(Const ParName: String; Value: Variant);
Public
Procedure ExecProc(F:TObject;ParCount:Integer;Params:PVarDataList);
Procedure MCloseEvent(Sender: TObject; Var Action: TCloseAction);
Procedure MNotifyEvent(Sender: TObject);
Procedure MDragDropEvent(Sender, Source: TObject; X, Y: Integer);
Procedure MDragOverEvent(Sender, Source: TObject; X, Y: Integer; State: TDragState; Var Accept: Boolean);
Procedure MEndDragEvent(Sender, Target: TObject; X, Y: Integer);
Procedure MStartDragEvent(Sender: TObject; Var DragObject: TDragObject);
Procedure MKeyPressEvent(Sender: TObject; Var Key: Char);
procedure mQROnNeedDataEvent(Sender : TObject; var MoreData : Boolean);
procedure mQRNotifyOperationEvent(Sender : TObject; Operation : TQRNotifyOperation);
procedure mQRBandBeforePrintEvent(Sender : TObject; var PrintBand : Boolean);
procedure mQRBandAfterPrintEvent(Sender : TObject; BandPrinted : Boolean);
procedure mQRReportBeforePrintEvent(Sender : TObject; var PrintReport : Boolean);
procedure mQRFilterEvent(var PrintRecord : boolean);
function MHelpEvent(Command: Word; Data: Longint;var CallHelp: Boolean): Boolean;
procedure MCloseQueryEvent(Sender: TObject;var CanClose: Boolean);
procedure mQRLabelOnPrintEvent(sender : TObject; var Value : string);
procedure mQRProgressUpdateEvent(Sender : TObject; Progress : integer);
procedure mQRPageAvailableEvent(Sender : TObject; PageNum : integer);
procedure MMouseEvent(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure MMouseMoveEvent(Sender: TObject; Shift: TShiftState;X, Y: Integer);
procedure MKeyEvent(Sender: TObject; var Key: Word;Shift: TShiftState);
End;
THalEventClass = Class of THalEvent;
TMyReader = Class(TReader)
Public
Constructor Create(Stream: TStream; BufSize: Integer);
Function FindMethod(Root: TComponent;
Const MethodName: String): Pointer; Override;
End;
TMyStream = Class(TFileStream)
Public
Function ReadComponent(Instance: TComponent): TComponent;
Function ReadComponentRes(Instance: TComponent): TComponent;
End;
{------------------------------}
TEventListItem = Class
Address: Pointer;
EventClass: THalEventClass;
End;
TEventList = Class(TStringList)
Public
Constructor Create;
Function ItemByName(Const AEventType: String): TEventListItem;
Procedure AddItem(Const AEventType: String; AAddress: Pointer;
AEventClass: THalEventClass);
Destructor Destroy; override;
End;
{------------------------------------------------------------------}
Type
TPosListItem=Class(TCollectionItem)
public
LinePos:Integer;
CharPos:Integer;
end;
TPosList=class(TCollection)
public
constructor Create;
Function AddPos(ALine,AChar:Integer):TPosListItem;
end;
{------------------------------}
// Register event if interpreter. Example in HALINIT.PAS
Procedure RegisterEvent(Const AEventType: String; AAddress: Pointer;
AEventClass: THalEventClass);
// Call this function to check is event with particular type registered in interpreter
// or not
Function RegisteredEvent(Const EventType: String): Boolean;
// Run script from file MACRONAME
Function RunMacro(Const MacroName: String): Variant;
// Run script from file MACRONAME Additionally you will be able to use
// all form AFORM components in the script body
Function RunMacroFriend(Const MacroName: String; AForm: TForm): Variant;
// Run form with name FORMPATH
function RunForm(Const FormPath: String):TForm;
// Run DFM+PAS. Form will be showed modal.
Function RunFormModal(Const FormPath: String): Integer;
// Run script or form (depends from extension)
// Mpath -path to script or form
// Modal - true if show form modal
Function RunFormMacro(Const MPath: String; Modal: Boolean): Variant;
Function MyReadComponentResFile(Const FileName: String; Instance: TComponent): TComponent;
// --------------------- code designer procedures -----------------
Function FindFormInVarDecl(S:TMemoryStream;Const FormName:String;
Var BegLine,BegPos,EndLine,EndPos:Integer):Boolean;
// Searches for "implementation" and return True if was found
// ALine,Apos contain line and char positions (1 based)
Function ImplFound(M:TMemoryStream;Var ALine,APos:Integer):Boolean;
procedure FindFormInEventNames(S:TMemoryStream;Const FormName:String;PosList:TPosList);
Function FindFormInTypeDecl(S:TMemoryStream;Const FormName:String;
Var ALine,APos:Integer):Boolean;
{ Searches for the event with EventName in codegen section and returns True if
event was found and position of the event name in the code
}
function FindEventInCodeGen(S:TMemoryStream;Const EventName:String;
Var ALine,AChar:Integer):Boolean;
{ Searches for code designer "special section"
(before "private" clause in class definition)
Returns True if found and false otherwise
FormClassName - class name of the form (= TForm1 or smth )
}
Function GetCodegenSection(S:TMemoryStream; Const FormClassName:String;
Var BegLine,BegPos,EndLine,EndPos:Integer):Boolean;
{ Searches for the position of the unit name
Returns true if such position was found
ALine - line number where unit name was found
APos - position of unit name
}
Function GetUnitNamePos(S:TMemoryStream; Var ALine,APos,Aleng:Integer):Boolean;
{ Searches for 'uses' clause. Returns true if found and false otherwise
Example:
Uses*
Classes,Forms,Dialogs,
chUtils**;
* - BegLine,BegPos (all 1 based)
** - EndLine,EndPos (all 1 based)
If there is no extra space between ; and last unit name then returns coma position
(so Endpos should be decremented in any case)
}
Function GetUsesPos(S:TMemoryStream;Var BegLine,BegPos,EndLine,EndPos:Integer;
AfterImpl:Boolean):Boolean;
{ Searches stream for method name occurence and returns true if method name
was found and false if not found
}
Function GetMethodLine(S:TMemoryStream;Const AMethodName:String;
Var BegLine,BegPos,EndLine,EndPos:Integer):boolean;
{ Searches stream for 'end.' occurence (or 'initialization') returns True if found
and False otherwise
Aline - line where something before 'end.' can be inserted (1 based)
AChar - char position in Aline where smth. can be inserted
}
Function FindProgramEnd(S:TMemoryStream; Var ALine,AChar:Integer):Boolean;
Procedure DelphinRegister;
function GetEventDispatcher(F:TComponent):THalComp;
procedure CallEvent(F:TComponent;Const EventName:String;ParamCount:Integer;Params:Pointer);
function IsDelphinForm(F:TComponent):boolean;
{----------------------------------------------}
Implementation
{------------------------------------------------------------------}
constructor TPosList.Create;
begin
Inherited Create(TPosListitem);
end;
{------------------------------------------------------------------}
function TPosList.AddPos(ALine,AChar:Integer):TPosListItem;
begin
Result:=TPoslistItem(Add);
Result.LinePos:=ALine;
Result.Charpos:=AChar;
end;
{-------------------------------}
Procedure outdouble(s: TStream; c: double);
Begin
s.Writebuffer(c, sizeof(double));
End;
{------------------------------}
Procedure outint(s: TStream; c: integer);
Begin
s.Writebuffer(c, sizeof(integer));
End;
{------------------------------}
Procedure outbyte(s: TStream; c: byte);
Begin
s.Writebuffer(c, sizeof(byte));
End;
{------------------------------}
Procedure outstring(s: TStream; Const mys: String);
Var
b: byte;
Begin
b := length(mys);
outbyte(s, b);
s.WriteBuffer(mys[1], b);
End;
{------------------------------}
Procedure outboolean(s: TStream; b: boolean);
Begin
s.Writebuffer(b, sizeof(boolean));
End;
{------------------------------}
Function getbyte(S: Tstream): byte;
Begin
s.ReadBuffer(Result, sizeof(byte));
End;
{------------------------------}
Function getstring(S: Tstream): String;
Var
b: byte;
t: String[255];
Begin
b := getbyte(s);
SetLength(t, b);
s.ReadBuffer(t[1], b);
Result := t;
End;
{------------------------------}
Function getboolean(S: Tstream): boolean;
Begin
s.ReadBuffer(Result, sizeof(boolean));
End;
{------------------------------}
Function getdouble(S: Tstream): double;
Begin
s.ReadBuffer(Result, sizeof(double));
End;
{------------------------------}
Function getint(S: Tstream): integer;
Begin
s.ReadBuffer(Result, sizeof(integer));
End;
{------------------------------------}
Procedure setnotifyevent(ControlLink: TObject; Const eventlink: String; fmynotifyevent: TNotifyEvent);
Var
oldpropinfo: PPropInfo;
// tm: tmethod;
tn: tnotifyevent;
Begin
If (ControlLink = Nil) or (EventLink = '') then exit;
oldpropinfo := GetPropInfo(ControlLink.Classinfo, EventLink);
If CompareText(oldpropinfo^.proptype^.name, coNotifyEvent) = 0 then
Begin
tn := fMyNotifyEvent;
SetMethodProp(ControlLink, oldpropinfo, tmethod(tn));
End;
End;
{------------------------------------}
Function Hex2Dec(Const S: String): Longint;
Var
HexStr: String;
Begin
If Pos('$', S) = 0
then
HexStr := '$' + S
Else
HexStr := S;
Result := StrToIntDef(HexStr, 0);
End;
{---------------------------------------------------}
Procedure _ocsetvarray(Var V, V1: Variant; a: Integer);
Begin
V[a] := V1;
End;
{---------------------------------------------------}
Procedure _ocmov(Var A, B: Variant); register;
Begin
a := b;
End;
{---------------------------------------------------}
Procedure _ocvarraycreate(Var A: Variant; B: Integer); register;
Begin
a := VarArrayCreate([0, b], varVariant);
End;
{---------------------------------------------------}
Procedure _ocincvar(Var A: Variant); register;
Begin
a := a + 1;
End;
{---------------------------------------------------}
Procedure _ocdecvar(Var A: Variant); register;
Begin
a := a - 1;
End;
{---------------------------------------------------}
Procedure _ocAdd(Var A, B: Variant); register;
Begin
A := a + b;
End;
{---------------------------------------------------}
Procedure _ocSub(Var A, B: Variant); register;
Begin
a := a - b;
End;
{---------------------------------------------------}
Procedure _ocMul(Var A, B: Variant); register;
Begin
a := a * b;
End;
{---------------------------------------------------}
Procedure _ocDiv(Var A, B: Variant); register;
Begin
a := a div b;
End;
{---------------------------------------------------}
Procedure _ocMod(Var A, B: Variant); register;
Begin
a := a mod b;
End;
{---------------------------------------------------}
Procedure _ocSlash(Var A, B: Variant); register;
Begin
a := a / b;
End;
{---------------------------------------------------}
Procedure _ocShl(Var A, B: Variant); register;
Begin
a := a shl b;
End;
{---------------------------------------------------}
Procedure _ocShr(Var A, B: Variant); register;
Begin
a := a shr b;
End;
{---------------------------------------------------}
Procedure _ocNot(Var A: Variant); register;
Begin
a := not a;
End;
{---------------------------------------------------}
Procedure _ocOr(Var A, B: Variant); register;
Begin
a := a or b;
End;
{---------------------------------------------------}
Procedure _ocXor(Var A, B: Variant); register;
Begin
a := a xor b;
End;
{---------------------------------------------------}
Procedure _ocAnd(Var A, B: Variant); register;
Begin
a := a and b;
End;
{---------------------------------------------------}
Procedure _ocGreaterEqual(Var A, B: Variant); register;
Begin
a := a >= b;
End;
{---------------------------------------------------}
Procedure _ocEqual(Var A, B: Variant); register;
Begin
a := (vartype(a) = vartype(b)) and (a = b);
End;
{---------------------------------------------------}
Procedure _ocLessEqual(Var A, B: Variant); register;
Begin
a := a <= b;
End;
{---------------------------------------------------}
Procedure _ocNotEqual(Var A, B: Variant); register;
Begin
a := (vartype(a) <> vartype(b)) or (a <> b);
End;
{---------------------------------------------------}
Procedure _ocGreater(Var A, B: Variant); register;
Begin
a := a > b;
End;
{---------------------------------------------------}
Procedure _ocLess(Var A, B: Variant); register;
Begin
a := a < b;
End;
{---------------------------------------------------}
Procedure _ocNeg(Var A: Variant); register;
Begin
a := -a;
End;
{----------------------------------------------}
Procedure THalCompiler.myinit;
Begin
Labels := TIdentList.Create;
variables := TIdentList.Create;
consts := TConstList.Create(tconstitem);
IDLabels := TIDLabelList.Create(tidlabelitem);
Prog := TProgCollect.Create(tprogitem);
End;
{----------------------------------------------}
Procedure THalCompiler.mydone;
Begin
Variables.Free;
Consts.Free;
Labels.Free;
IDLabels.Free;
Prog.Free;
End;
{----------------------------------------}
procedure THalCompiler.ConvertCurPos(Var ALine,AChar:Integer);
begin
ALine:=GetLineNumber;
AChar:=CurRead;
While (AChar>0) and (not (inbuf[AChar] in [#13,#10])) do dec(AChar);
AChar:=CurRead-AChar+1;
end;
{----------------------------------------}
function THalCompiler.GetLineNumber:Integer;
Var
i:integer;
begin
Result:=1;
For i := 1 to curread do
If inbuf[i] = char(idnewline)
then
inc(Result);
end;
{----------------------------------------}
Procedure THalCompiler.Error(Const s: String);
Var
linenumber: integer;
sa: String;
Begin
linenumber := GetLineNumber;
sa := Format(synt_err, [InttoStr(linenumber), #13#10 + s]);
{ If AllowPrint then
myerrorout(sa);}
Raise ECompilerError.Create(sa);
End;
{------------------------------}
Function THalCompiler.ReadByte: byte;
Begin
inc(curread);
If curread > numread then
Begin
Result := idEndOfFile;
exit;
End;
Result := byte(Inbuf[curread]);
End;
{------------------------------}
Function THalCompiler.NextByte: byte;
Var
i: integer;
Begin
i := curread;
Result := ReadByte;
curread := i;
End;
{------------------------------}
Procedure THalCompiler.BackBytes(a: integer);
Begin
If curread - a >= 0 then dec(curread, a);
End;
{------------------------------}
Function THalCompiler.ReadToken: TToken;
Var
b, begst, a: byte;
s: String;
i: integer;
Label
label2, label1, l9, l8, l10, l11;
Begin
Application.ProcessMessages;
label1:
a := ReadByte;
If char(a) in BlackSpaces then Goto label1;
{--}
If a = idslash then
Begin
If ReadByte <> idslash then
Begin
backbytes(1);
a := idslash;
Goto l9;
End;
l8: a := readbyte;
If a = idEndOFFile then
Goto l9;
If not (a < 32) then
Goto l8;
Goto label1;
End;
l9:
{-----}
If a = idminus then
Begin
If ReadByte <> idminus then
Begin
backbytes(1);
a := idminus;
Goto l11;
End;
s := '';
l10: a := readbyte;
If a = idEndOFFile then
Goto l11;
If not (a < 32) then
Begin
s := s + Char(a);
Goto l10;
End {else
If (length(S) > 0) and (nextstate = false) and (AllowPrint)
then
MyStdOut(s)};
Goto label1;
End;
l11:
{-----}
If ((a = idopenbracket) or (a = idslash)) and (nextbyte = idstar) then
Begin
b := a;
Repeat
a := ReadByte;
Case a of
idstar:
If nextbyte = b then
Begin
readbyte;
Goto label1;
End;
idEndOfFile:
Error(eofincom_ERR);
End;
Until false;
End;
{----}
If char(a) in WhiteSpaces then
Begin
DolEnabled := (a = Integer('$'));
Result := SetToken(a, 0);
exit;
End;
Case a of
idOpenComment:
Begin
Repeat
a := ReadByte;
Case a of
idCloseComment: Goto label1;
idEndOfFile: Error(eofincom_ERR);
End;
Until false;
End;
IdStringChar, Id2StringChar:
Begin
s := ''; begst := a;
Repeat
a := ReadByte;
If a = begst then
Begin
Result := SetToken(idStringConst, s);
exit;
End
Else
If a = idEndOfFile
then
Error(eofinstring_ERR)
Else
s := s + char(a);
Until false;
End;
idEndOFFile:
Begin
Result := SetToken(idEndOFFile, 0);
exit;
End;
End;
S := '';
label2:
S := S + char(a);
a := ReadByte;
If not (char(a) in StopChars) then
Goto label2;
BackBytes(1);
s := AnsiUpperCase(s);
If s[1] in FirstIdentChar then
Begin
If length(s) > 1 then
For i := 2 to length(s) do
If not (s[i] in identbackchars) then Error(Format(bad_idName, [s]));
If ResWords.IDByName(s, i)
then
Result := SetToken(i, s)
Else
If ResConsts.Find(s, i)
then
Result := SetToken(idresconst, i)
else
Result := SetToken(idIdentifier, s);
End else
Begin
If s[2] = 'X' then
Begin
Result := SetToken(idHexConst, copy(s, 3, length(s)));
End else
Begin
For i := 1 to length(s) do
If not ((s[i] in Digit) or ((DolEnabled) and (S[i] in HExDIgit)))
Then Error(Format(bad_id, [s]));
Result := SetToken(idNumberConst, s);
End;
End;
End;
{------------------------------}
Function THalCompiler.NextToken: TToken;
Var
i: integer;
Begin
nextstate := true;
i := curread;
Result := ReadToken;
curread := i;
nextstate := false;
End;
{----------------------------------------}
Procedure THalCompiler.putcode(aid, a, b: integer);
Begin
prog.putop(aid, a, b);
End;
{------------------------------}
Procedure THalCompiler.getdelimeter;
Var
Token: TToken;
Begin Token := ReadToken;
If (Token.id <> iddelimeter)
then
Error(delimeter_expected);
End;
{------------------------------}
Function THalCompiler.iexpression: integer;
Var
i: integer;
Begin
Result := isimpleexpression;
Case nexttoken.id of
{ = }
idequal:
Begin
token := readtoken;
i := isimpleexpression;
putcode(ocequal, Result, i);
End;
{ > >= }
idgreater:
Begin
token := readtoken;
If nexttoken.id = idequal then
Begin
token := readtoken;
i := isimpleexpression;
putcode(ocgreaterequal, Result, i);
End else
Begin
i := isimpleexpression;
putcode(ocgreater, Result, i);
End;
End;
{ < <= <> }
idless:
Begin
token := readtoken;
Case nexttoken.id of
idequal:
Begin
token := readtoken;
i := isimpleexpression;
putcode(oclessequal, Result, i);
End;
idgreater:
Begin
token := readtoken;
i := isimpleexpression;
putcode(ocnotequal, Result, i);
End;
Else
Begin
i := isimpleexpression;
putcode(ocless, Result, i);
End;
End;
End;
End;
End;
{------------------------------}
Function THalCompiler.isimpleexpression: integer;
Label
l1;
Var
i: integer;
Begin
Result := iterm;
l1:
Case nexttoken.id of
idPlus:
Begin
Token := ReadToken;
i := iterm;
putcode(ocadd, Result, i);
Goto l1;
End;
idMinus:
Begin
Token := ReadToken;
i := iterm;
putcode(ocsub, Result, i);
Goto l1;
End;
id_Or:
Begin
Token := ReadToken;
i := iterm;
putcode(ocor, Result, i);
Goto l1;
End;
id_Xor:
Begin
Token := ReadToken;
i := iterm;
putcode(ocxor, Result, i);
Goto l1;
End;
End;
End;
{------------------------------}
Function THalCompiler.iterm: integer;
Var
i: integer;
Label
l1;
Begin
Result := ifactor;
l1:
Case nexttoken.id of
id_shl:
Begin
Token := ReadToken;
i := ifactor;
putcode(ocshl, Result, i);
Goto l1;
End;
id_shr:
Begin
Token := ReadToken;
i := ifactor;
putcode(ocshr, Result, i);
Goto l1;
End;
id_And:
Begin
Token := ReadToken;
i := ifactor;
putcode(ocand, Result, i);
Goto l1;
End;
idStar:
Begin
Token := ReadToken;
i := ifactor;
putcode(ocmul, Result, i);
Goto l1;
End;
idSlash:
Begin
Token := ReadToken;
i := ifactor;
putcode(ocslash, Result, i);
Goto l1;
End;
id_div:
Begin
Token := ReadToken;
i := ifactor;
putcode(ocdiv, Result, i);
Goto l1;
End;
id_mod:
Begin
Token := ReadToken;
i := ifactor;
putcode(ocmod, Result, i);
Goto l1;
End;
End;
End;
{------------------------------}
Procedure THalCompiler.getopenbracket;
Begin
token := ReadToken;
If (token.id <> idOpenBracket) and (token.id <> idsqOpenBracket)
Then Error(need_opbr);
End;
{------------------------------}
Procedure THalCompiler.getclosebracket;
Begin
token := ReadToken;
If (token.id <> idcloseBracket) and (token.id <> idsqcloseBracket)
Then Error(need_clbr);
End;
{------------------------------}
Procedure THalCompiler.getcoma;
Begin
token := readtoken;
If token.id <> idcomma then Error(comma_expected);
End;
{------------------------------}
Function THalCompiler.GetOpenArray(NeedSq: boolean): Integer;
Var
ints: Array[0..200] of integer;
i, maxints: integer;
ospoint: integer;
Begin
If (NeedSq) or (nexttoken.id = idsqopenbracket) then
Begin
token := readtoken;
If token.id <> idsqopenbracket then Error(Format(opsq_exp, [token.data]));
End;
{----}
maxints := 0;
ospoint := spoint;
inc(spoint);
While (nexttoken.id <> idsqclosebracket) and
(nexttoken.id <> idclosebracket) do
Begin
If maxints > 0 then getcoma;
ints[maxints] := iexpression;
inc(maxints);
End;
putcode(ocvarraycreate, ospoint, maxints);
putcode(ocloadconst, spoint, Consts.newitem(maxints));
putcode(ocsetvarray, 0, spoint);
inc(spoint);
putcode(0, ospoint, 0);
For i := 0 to maxints - 1 do
Begin
putcode(ocsetvarray, i + 1, ints[i]);
putcode(0, ospoint, 0);
End;
Result := ospoint;
{----}
If (NeedSq) or (nexttoken.id = idsqclosebracket) then
Begin
token := readtoken;
If token.id <> idsqclosebracket then
Error(Format(clsq_exp, [token.data]));
End;
End;
{------------------------------}
Procedure THalCompiler.getuserfunction(Const name: String; scope, fik: boolean);
Var
oldstack, i, index: integer;
f: TFunListItem;
ia: Array[0..maxparams] of integer;
sname, sname1: String;
ident: tidentlistitem;
olastobj: TObject;
onotfromobj: boolean;
Label lt, lr, lr1;
Begin
olastobj := lastobject; onotfromobj := notfromobj;
If varbyname(name, ident) then
Begin
i := getinternalfun(name, ident);
putcode(ocmov, spoint, i);
exit;
End;
// If (Not assigned(Funs)) then Error(Format(unkn_id, [name]));
If Fik then
Begin
sname := name + '_VET';
While (Funs.Find(sname, index) = false) Do
Begin
i := pos('.', sname);
If i = 0 then Goto lr1;
sname1 := GetPearent(copy(sname, 1, i - 1));
If sname1 = '' then Goto lr1;
delete(sname, 1, i - 1);
sname := sname1 + sname;
End;
Goto lr;
End;
lr1: sname := name;
While (Funs.Find(sname, index) = false) Do
Begin
i := pos('.', sname);
If i = 0 then Error(Format(unkn_id, [name]));
sname1 := GetPearent(copy(sname, 1, i - 1));
If sname1 = '' then Error(Format(unkn_id, [name]));
delete(sname, 1, i - 1);
sname := sname1 + sname;
End;
lr:
f := TFunListItem(Funs.Objects[index]);
If f.parcount > 0 then getopenbracket;
If (f.fun <> scope) and (f.fun) then
Begin
If scope then Error(in_funuse) else Error(in_procuse);
End;
If f.parcount > 0 then
Begin
oldstack := spoint;
For i := 0 to F.Parcount - 1 do
Begin
Case f.Params[i] of
0: ia[i] := iexpression;
1: ia[i] := getvar;
3: ia[i] := getopenarray(F.ParCount <> 1);
4: Begin
getclosebracket;
token := readtoken;
If token.id <> id2points then Error(p2_exp);
token := readtoken;
If token.id <> idequal then Error(eq_exp);
ia[i] := iexpression;
Goto lt;
End;
Else Error(unsup_partype);
End;
If (i < f.parcount - 1) and (f.params[i + 1] <> 4) then getcoma;
End;
lt:
spoint := oldstack;
End;
If (olastobj <> Nil) or (onotfromobj) then
Begin
If oNotFromObj
then
putcode(ocselffromvar, Integer(olastobj), 0)
else
putcode(ocsetself, integer(olastobj), 0);
End;
putcode(ocextfun, spoint, index);
If f.parcount > 0 then
Begin
i := 0;
While i <= f.parcount - 1 do
Begin
putcode(ia[i], ia[i + 1], ia[i + 2]);
inc(i, 3);
End;
End;
If (f.parcount > 0) and (F.Params[f.parcount - 1] <> 4) then
getclosebracket;
End;
{------------------------------}
Function THalCompiler.AddVars(Const Aname: String; ID: Integer): Integer;
Begin
Result := Variables.additem(IdentPrefix + Aname, ID);
End;
{------------------------------}
Function THalCompiler.VarIDByName(Const AName: String; Var Id: Integer): boolean;
Var
S: String;
i: integer;
Label l1;
Begin
S := IdentPrefix;
l1:
Result := Variables.Find(s + Aname, id);
If (result) or (s = '') then
exit;
i := length(s);
If S[i] = '.' then dec(i);
While (S[i] <> '.') and (i > 0) do
dec(i);
setlength(s, i);
Goto l1;
End;
{------------------------------}
Function THalCompiler.VarByName(Const AName: String; Var Ident: TIdentListItem): boolean;
Var
i: integer;
Begin
Result := VarIDByName(aname, i);
If result then ident := (Variables.Objects[i] as tidentlistitem)
Else ident := Nil;
End;
{------------------------------}
Procedure THalCompiler.findobject(Var s: String);
Var
tob: tobjitem;
ident: tIdentListItem;
Begin
notfromobj := false;
If mobjects.objbyname(s, tob) then
Begin
lastobject := tob.tobj; s := tob.objtype;
End
Else
If (varbyname(s, ident)) and (GetClass(ident.vtype)<>nil)
Then
Begin
notfromobj := true; lastobject := TObject(ident.id);
s := ident.vtype;
End
Else lastobject := Nil;
End;
{------------------------------}
Function THalCompiler.getinternalfun(
Const sname: String; ident: tidentlistitem): integer;
Var
i: integer;
pind: Array[0..100] of integer;
im: tidentlistitem;
temp: String;
Begin
Result:=0;
With ident do
Begin
If parcount > 0 then
Begin
getopenbracket;
For i := 0 to parcount - 1 do
Begin
If params[i] = 0 then
pind[i] := iexpression
Else
pind[i] := getvar;
temp := sname + '.' + paramnames.strings[i];
If varbyname(temp, im) = false then
Error(Format(proc_notfound, [temp]));
putcode(ocmov, im.id, pind[i]);
If i < parcount - 1 then
getcoma;
End;
getclosebracket;
End;
If varbyname(sname + coprocresult, im)
then
Result := im.id
Else
Error(Format(no_resvar, [sname]));
If varbyname(sname, im)
then
putcode(occall, im.id, 0)
Else
error(Format(proc_notfound, [sname]));
For i := 0 to parcount - 1 do If params[i] <> 0 then
Begin
varbyname(sname + '.' + paramnames.strings[i], im);
putcode(ocmov, pind[i], im.id);
End;
End;
End;
{------------------------------}
Function THalCompiler.ifactor: integer;
Var
v, code, l: integer;
s: String;
funid, varid: integer;
ident: TIdentListItem;
mextended: extended;
tob: tobjitem;
Label
label1, lab1, lop;
Begin
Result:=0;
Token := ReadToken; l := token.id;
Case l of
idsqopenbracket:
Begin
Result := GetOpenArray(false);
token := readtoken;
If token.id <> idsqclosebracket then
Error(Format(clsq_exp, [token.data]));
End;
ididentifier:
Begin
s := token.data;
If nexttoken.id = idpoint then
Begin
findobject(s);
End;
While nexttoken.id = idpoint do
Begin
token := readtoken;
token := readtoken;
If token.id <> ididentifier then Error(id_expected);
s := s + '.' + token.data;
End;
If (nexttoken.id = idopenbracket) or (nexttoken.id = idsqopenbracket) Then
Begin
lab1:
getuserfunction(s, false, false);
Result := spoint;
inc(spoint);
End else
Begin
If Mobjects.ObjbyName(s, tob) then
Begin
putcode(ocloadconst, spoint, Consts.newitem(Integer(tob.tobj)));
Result := spoint;
inc(spoint);
End else
If DynaVars.GetDynaObject(s, HalOwner, varid, funid) then
Begin
putcode(ocloadextvar, varid, funid);
putcode(ocbackcode, spoint, 0);
Result := spoint;
inc(spoint);
End else
Begin
If varbyname(s, ident) then
Begin
Case ident.identtype of
tivariable:
Begin
putcode(ocmov, spoint, ident.id);
Result := spoint;
inc(Spoint);
End;
Else
Error(in_procuse);
End;
End
else Goto lab1;
End;
End;
End;
idresconst:
Begin
putcode(ocloadconst, spoint, Consts.newitem(
TResConstListItem(ResConsts.Objects[token.data]).Value));
Result := spoint;
inc(spoint);
End;
id_false:
Begin
putcode(ocloadconst, spoint, Consts.newitem(FALSE));
Result := spoint;
inc(spoint);
End;
id_true:
Begin
putcode(ocloadconst, spoint, Consts.newitem(TRUE));
Result := spoint;
inc(spoint);
End;
id_nil:
Begin
putcode(ocloadconst, spoint, Consts.newitem(0));
Result := spoint;
inc(spoint);
End;
Integer('$'):
Begin
token := readtoken;
If token.id <> idnumberconst
then
Error(bad_hex);
lop:
v := Hex2Dec(token.data);
putcode(ocloadconst, spoint, Consts.newitem(v));
Result := spoint;
inc(spoint);
End;
idhexconst:
Begin
Goto lop;
End;
idnumberconst:
Begin
If nexttoken.id = idpoint then
Begin
s := token.data;
token := readtoken;
token := readtoken;
If token.id <> idnumberconst then
Error(bad_realconst);
s := s + '.' + token.data;
val(s, mextended, code);
putcode(ocloadconst, spoint, Consts.newitem(mextended));
End else
Begin
val(token.data, v, code);
putcode(ocloadconst, spoint, Consts.newitem(v));
End;
Result := spoint;
inc(spoint);
End;
idnotequal:
Begin
token := readtoken;
If token.id <> idnumberconst then
Error(bad_charconst);
val(token.data, v, code);
putcode(ocloadconst, spoint, Consts.newitem(Char(v)));
Result := spoint;
inc(spoint);
End;
idstringconst:
Begin
S := token.data;
label1:
Case nexttoken.id of
idnotequal:
Begin
token := readtoken;
token := readtoken;
If token.id <> idnumberconst then
Error(bad_charconst);
val(token.data, v, code);
s := s + char(v);
Goto label1;
End;
idstringconst:
Begin
token := readtoken; S := S + token.data;
Goto label1;
End;
End;
putcode(ocloadconst, spoint, Consts.newitem(s));
Result := spoint;
inc(spoint);
End;
idopenbracket:
Begin
Result := iexpression;
getclosebracket;
End;
idplus:
Begin
Result := ifactor;
End;
idminus:
Begin
Result := ifactor;
putcode(ocneg, Result, 0);
End;
id_not:
Begin
Result := ifactor;
putcode(ocnot, Result, 0);
End;
End;
End;
{------------------------------}
Function THalCompiler.myexpress: integer;
Var
i: integer;
Begin
i := spoint;
Result := iexpression;
spoint := i;
End;
{------------------------------}
Procedure THalCompiler.equaldispath(Const VarName: String);
Var
i, j: integer;
index: integer;
vname: String;
{-----------------------------}
Function getobjfuns(Var idx: integer): boolean;
Var
i: integer;
sname1: String;
Begin
Result := false;
While Funs.Find(vname + '_SET', idx) = false do
Begin
i := pos('.', vname); If i = 0 then exit;
sname1 := GetPearent(copy(vname, 1, i - 1)); If sname1 = '' then exit;
delete(vname, 1, i - 1);
vname := sname1 + vname;
End;
Result := True;
End;
Function getDefObjFuns(Var idx: integer): boolean;
Var
i: integer;
sname1: String;
Begin
Result := false;
result := Funs.Find(vname + '_SET', idx);
End;
{-----------------------------}
Var
varid, funid: integer;
Ident: TIdentListItem;
olastobj: tobject;
onotfromobj: boolean;
Begin
vname := varname;
If (varbyname(vname, ident)) and (ident.identtype = 0) then
Begin
i := myexpress;
j := ident.id;
putcode(ocmov, j, i);
End
Else
If DynaVars.GetDynaObject(vname, HalOwner, varid, funid) then
Begin
i := myexpress;
putcode(ocstoreextvar, varid, funid);
putcode(ocbackcode, i, 0);
End
Else
If (assigned(Funs)) and (pos('.', vname) <> 0) and (getobjfuns(index)) then
Begin
olastobj := lastobject; onotfromobj := notfromobj;
i := myexpress;
If (olastobj <> Nil) or (onotfromobj) then
Begin
If oNotFromObj then putcode(ocselffromvar, Integer(olastobj), 0) else
putcode(ocsetself, integer(olastobj), 0);
End;
putcode(ocextfun, spoint, index);
putcode(i, 0, 0);
End
Else
If (assigned(Funs)) and (pos('.', vname) = 0) and (getdefobjfuns(index)) then
begin
i := myexpress;
putcode(ocextfun, spoint, index);
putcode(i, 0, 0);
End
else
Error(Format(var_NotDef, [varname]));
End;
{------------------------------}
Procedure THalCompiler.labeldispatch(Const labelname: String);
Var
pl, i: integer;
Begin
If Labels.IDByName(labelname, i) = false then
Error(Format(lab_notdef, [labelname]));
pl := prog.count;
IDLabels.setplace(i, pl);
End;
{------------------------------}
Procedure THalCompiler.getprogramname;
Var
i: integer;
Begin
i := nexttoken.id;
If (i = id_Program) or (i = id_unit) then
Begin
Token := ReadToken;
Token := ReadToken;
If Token.Id <> idIdentifier then
Error(progname_exp);
getdelimeter;
End;
End;
{------------------------------}
Procedure THalCompiler.getidentifier;
Begin
token := readtoken;
If token.id <> ididentifier then Error(id_expected);
End;
{------------------------------}
Function THalCompiler.getprocdef(askip: boolean): Integer;
Var
ProcName: String;
k, AParamCount: Integer;
AParams: tbytearray;
MAdd: Boolean;
ident: integer;
EResult: TIdentListItem;
{--}
Procedure getprocparams;
Label
l1, l2;
Var
k, curtp, st: integer;
il: Array[1..100] of integer;
sname: String;
Begin
l1: curtp := 0; st := 0;
Case nexttoken.id of
ididentifier:
Begin
l2:
getidentifier;
If madd = false then
Begin
inc(st);
sname := ProcName + '.' + Token.Data;
il[st] := AddVars(sname, spoint);
EResult.ParamNames.Add(Token.Data);
inc(spoint);
AParams[AParamCount] := curtp;
inc(AParamCount);
End;
Case nexttoken.id of
idcomma:
Begin
token := readtoken;
Goto l2;
End;
id2points:
Begin
token := readtoken;
token := Readtoken;
If madd = false then
For k := 1 to st do
Tidentlistitem(Variables.Objects[il[k]]).VType := token.data;
If nexttoken.id <> idclosebracket then
getdelimeter;
End;
Else
error(meth_decerr);
End;
End;
idclosebracket:
exit;
id_var:
Begin
token := readtoken;
curtp := 1;
Goto l2;
End;
id_const:
Begin
token := readtoken;
Goto l2;
End;
Else
Error(bad_methparam);
End;
Goto l1;
End;
{--}
Begin
getidentifier; ProcName := token.data;
While nexttoken.id = idpoint do
Begin
token := readtoken;
getidentifier;
ProcName := ProcName + '.' + token.data;
End;
Madd := varidbyname(ProcName, ident);
AParamCount := 0;
If madd = false then
Begin
k := IDLabels.newitem;
Result := AddVars(ProcName, k);
EResult := tidentlistitem(Variables.Objects[Result]);
End;
If nexttoken.id = idopenbracket then
Begin
getopenbracket;
getprocparams;
getclosebracket;
End;
If Madd = false then
Begin
With EResult do
Begin
Params := AParams;
ParCount := AParamCount;
IdentType := 1;
End;
If nexttoken.id = id2points then
Begin
Token := ReadToken;
getvartype;
EResult.VType := token.data;
End;
AddVars(ProcName + coProcResult, spoint);
inc(spoint);
End;
varidbyname(ProcName, Result);
getdelimeter;
getafterproc;
End;
{------------------------------}
Procedure THalCompiler.getafterproc;
Var
i: integer;
s: boolean;
Label
l1;
Begin
s := true;
l1:
i := Nexttoken.id;
If (i = id_virtual) or (i = id_override) or (i = id_dynamic) or (i = id_abstract) or
(i=id_stdcall)
Then
Begin
Token := Readtoken;
getdelimeter;
If s then
Begin
s := false;
Goto l1;
End;
End;
End;
{------------------------------}
Procedure THalCompiler.getclassdefblock(b: boolean);
Label
l1;
Begin
l1:
Case nexttoken.id of
ididentifier:
Begin
getmyvariables(b);
End;
id_property:
Begin
Error(no_props);
End;
id_procedure, id_function:
Begin
Token := ReadToken;
getprocdef(false);
End;
Else exit;
End;
Goto l1;
End;
{------------------------------}
Procedure THalCompiler.getclassdef(Const cname: String);
Var
ParName: String;
Label
l1;
Begin
ParName := '';
IdentPrefix := cname + '.';
If NextToken.ID = idopenbracket then
Begin
Token := ReadToken;
Token := ReadToken;
If Token.ID <> ididentifier then
Error(need_par);
ParName := Token.Data;
Token := ReadToken;
If Token.ID <> idclosebracket then
Error(clbr_exp);
End;
FLastClassType := ParName;
l1:
Case NextToken.id of
iddelimeter:
Begin
Token := Readtoken;
IdentPrefix := '';
exit;
End;
id_private, id_public, id_published, id_protected:
Begin
Token := ReadToken;
getclassdefblock(true);
End;
id_end:
Begin
Token := ReadToken;
getdelimeter;
IdentPrefix := '';
exit;
End;
Else
getclassdefblock(true);
End;
Goto l1;
End;
{------------------------------}
Procedure THalCompiler.gettypeidentifier;
Var
s: String;
Begin
Token := ReadToken;
S := Token.Data;
Token := ReadToken;
If Token.ID <> idequal then
Error(Format(err_decl, [s]));
Token := ReadToken;
Case Token.ID of
id_record, id_class: getclassdef(s);
Else
Error(only_class);
End;
End;
{------------------------------}
Procedure THalCompiler.getvartype;
Begin
Token := ReadToken;
End;
{------------------------------}
Procedure THalCompiler.getmyvariables(b: boolean);
Label
l6, l5;
Var
vcurent, ad, mid: integer;
vc: Array[0..200] of tidentlistitem;
s: String;
ident: tidentlistitem;
tob: tobjitem;
ob: boolean;
Begin
ob := b;
l6:
vcurent := 0;
l5: b := ob;
Token := ReadToken;
If Token.ID <> idIdentifier then
Error(varname_exp);
s := Token.Data;
If varbyname(s, ident) then
Error(Format(var_already, [s]));
If b then
Begin
If mobjects.objbyname(s, tob) then b := false;
If B then
Begin
mid := AddVars(s, spoint);
vc[vcurent] := tidentlistitem(Variables.Objects[mid]);
inc(vcurent);
inc(spoint);
End;
End;
Token := ReadToken;
Case Token.ID of
idcomma: Goto l5;
id2points:
Begin
getvartype;
If b then
For ad := 0 to vcurent - 1 do vc[ad].VType := token.data;
getdelimeter;
If (NextToken.ID <= idReservedEnd) and
(NextToken.ID >= idReservedBase)
Then exit
Else Goto l6;
End;
Else Error(bad_varblock);
End;
End;
{------------------------------}
Procedure THalCompiler.getprocbody(i: integer);
Var
oidentpref: String;
l1: integer;
Begin
If nexttoken.id = id_forward then
Begin
token := readtoken;
getdelimeter;
exit;
End;
oidentpref := identprefix;
identprefix := variables.strings[i] + '.';
getdeclarations;
l1 := (variables.objects[i] as tidentlistitem).id;
IDLabels.setplace(l1, prog.count);
IDLabels.SetReference(l1);
getoperatorblock;
getdelimeter;
identprefix := oidentpref;
putcode(ocreturn, 0, 0);
End;
{------------------------------}
Procedure THalCompiler.getdeclarations;
Label l8, l3, l6;
Var
s: String;
i, k: integer;
Begin
l8:
Case nexttoken.id of
id_uses:
Begin
Token := ReadToken;
l6:
getidentifier;
Token := ReadToken;
If token.id = idcomma
then
Goto l6
else
Goto l8;
End;
id_interface, id_implement:
Begin
Token := ReadToken;
Goto l8;
End;
id_begin, id_end:
Begin end;
id_procedure, id_function:
Begin
Token := ReadToken;
getprocbody(getprocdef(true));
Goto l8;
End;
id_label:
Begin
Token := ReadToken;
l3:
Token := ReadToken;
If Token.ID <> idIdentifier then
Error(labname_exp);
S := Token.Data;
If labels.idbyname(s, i) then
Error(Format(label_already, [s]));
k := IDLabels.newitem;
labels.additem(s, k);
Token := ReadToken;
Case Token.Id of
idDelimeter: Goto l8;
idComma: Goto l3;
Else
Error(delim_or_coma);
End;
End;
id_type:
Begin
Token := ReadToken;
While NextToken.ID = ididentifier do
gettypeidentifier;
Goto l8;
End;
id_var:
Begin
token := readtoken;
getmyvariables(true);
Goto l8;
End;
Else
Error(err_declpart);
End;
End;
{------------------------------}
Procedure THalCompiler.getoperatorcoma;
Begin
getoperator;
If (nexttoken.id = iddelimeter) or
((token.id <> id2points) and (nexttoken.id <> id_end) and (nexttoken.id <> id_until))
Then getdelimeter;
End;
{------------------------------}
Procedure THalCompiler.getwhileoperator;
Var
a, i, l2, l1: integer;
Begin
Token := ReadToken;
l1 := IDLabels.newitem;
IDLabels.SetReference(l1);
IDLabels.setplace(l1, prog.count);
l2 := IDLabels.newitem;
IDLabels.SetReference(l2);
i := spoint;
a := iexpression;
spoint := i;
putcode(ocif, a, l2);
token := readtoken;
If Token.id <> id_do then
Error(do_exp);
getoperator;
putcode(ocgoto, l1, 0);
IDLabels.setplace(l2, prog.count);
End;
{------------------------------}
Procedure THalCompiler.getrepeatoperator;
Var
i, a, l1: integer;
Begin
token := readtoken;
l1 := IDLabels.newitem;
IDLabels.SetReference(l1);
IDLabels.setplace(l1, prog.count);
While (nexttoken.id <> id_until) and (nexttoken.id <> idendoffile) do
getoperatorcoma;
token := readtoken;
If token.id <> id_until then
Error(until_exp);
i := spoint;
a := iexpression;
spoint := i;
putcode(ocif, a, l1);
End;
{------------------------------}
Procedure THalCompiler.getforoperator;
Var
mi, a, l, l2, l1, vid, i: integer;
ident: tidentlistitem;
Begin
token := ReadToken;
token := readtoken;
If token.id <> ididentifier then
Error(varname_exp);
If varbyname(token.data, ident) = false then
Error(Format(var_NotDef, [token.data]));
vid := ident.id;
token := readtoken;
If token.id <> id2points then
Error(p2_exp);
token := readtoken;
If token.id <> idequal then
Error(eq_exp);
i := myexpress;
putcode(ocmov, vid, i);
token := readtoken;
l1 := IDLabels.newitem;
IDLabels.SetReference(l1);
l2 := IDLabels.newitem;
IDLabels.SetReference(l2);
IDLabels.setplace(l1, prog.count);
l := token.id;
mi := spoint;
a := iexpression;
putcode(ocmov, spoint, vid);
token := readtoken; If token.id <> id_do then Error(do_exp);
Case l of
id_to:
Begin
putcode(oclessequal, spoint, a);
putcode(ocif, spoint, l2);
spoint := mi;
getoperator;
putcode(ocincvar, vid, 0);
End;
id_downto:
Begin
putcode(ocgreaterequal, spoint, a);
putcode(ocif, spoint, l2);
spoint := mi;
getoperator;
putcode(ocdecvar, vid, 0);
End;
Else
Error(down_to_exp);
End;
putcode(ocgoto, l1, 0);
IDLabels.setplace(l2, prog.count);
End;
{------------------------------}
Procedure THalCompiler.getifoperator;
Var
i, a: integer;
l1, l2: integer;
NToken:TToken;
Begin
Token := ReadToken;
i := spoint;
a := iexpression;
spoint := i;
l1 := IDLabels.newitem;
IDLabels.SetReference(l1);
putcode(ocif, a, l1);
token := readtoken;
If token.id <> id_then then
Error(then_exp);
getoperator;
NToken:=NextToken;
If (NToken.id = iddelimeter) or (Ntoken.id=id_End) then
Begin
IDLabels.setplace(l1, prog.count);
exit;
End;
token := readtoken;
If token.id <> id_else then
Error(else_exp);
l2 := IDLabels.newitem;
IDLabels.SetReference(l2);
putcode(ocgoto, l2, 0);
IDLabels.setplace(l1, prog.count);
getoperator;
IDLabels.setplace(l2, prog.count);
End;
{------------------------------}
Function THalCompiler.getvar: integer;
Var
t: tidentlistitem;
Begin
token := readtoken;
If token.id <> ididentifier then Error(varname_exp);
If varbyname(token.data, t) = false then
Error(Format(var_NotDef, [token.data]));
result := t.id;
Lastvar := t;
End;
{------------------------------}
Procedure THalCompiler.getoperator;
Var
l, i: integer;
s: String;
Label l23;
Begin
l := NextToken.Id;
Case l of
id_begin:
getoperatorblock;
id_if:
getifoperator;
id_while:
getwhileoperator;
id_repeat:
getrepeatoperator;
id_for:
getforoperator;
id_Goto:
Begin
Token := ReadToken;
Token := ReadToken;
If Token.ID <> idIdentifier then Error(labname_exp);
S := Token.Data;
If Labels.IDByName(s, i) = false
Then Error(Format(lab_notdef, [s]));
IDLabels.SetReference(i);
putcode(ocgoto, i, 0);
End;
idIdentifier:
Begin
Token := ReadToken;
s := Token.Data;
If nexttoken.id = idpoint then
Begin
findobject(s);
End;
While nexttoken.id = idpoint do
Begin
token := readtoken;
token := readtoken;
If token.id <> ididentifier then
Error(id_expected);
s := s + '.' + token.data;
End;
Case nexttoken.id of
idopenbracket, idsqopenbracket: l23: getuserfunction(s, true, true);
id2points:
Begin
Token := ReadToken;
Case nexttoken.id of
idequal:
Begin
Token := ReadToken;
equaldispath(s);
End;
Else
labeldispatch(s);
End;
End;
Else
Goto l23;
End;
End;
Else
Error(Format(unkn_id, [nexttoken.data]));
End;
End;
{------------------------------}
Procedure THalCompiler.getoperatorblock;
Begin
Token := ReadToken;
If token.id = id_end then exit;
If token.id <> id_begin then Error(begin_expected);
While (nexttoken.id <> idEndOFFile) and (nexttoken.id <> id_end) do
getoperatorcoma;
token := ReadToken;
If token.id <> id_end
then
Error(end_expected);
End;
{------------------------------}
Procedure THalCompiler.compileprogram;
Var
i: integer;
Begin
i := IDLabels.newitem;
IDLabels.SetReference(i);
putcode(ocgoto, i, 0);
getprogramname;
getdeclarations;
IDLabels.setplace(i, prog.count);
getoperatorblock;
Token := ReadToken;
putcode(ochalt, 0, 0);
End;
{-----------------------------------------------------------------------}
Procedure THalCompiler.writeprogram;
{-----------}
Procedure writeconsts;
Var
i: integer;
v: variant;
Begin
outint(fout, consts.count);
For i := 0 to consts.count - 1 do
Begin
v := tconstitem(consts.items[i]).data;
Case Vartype(v) of
varBoolean:
Begin
outbyte(fout, wboolean);
outboolean(fout, v);
End;
varSingle, varDouble:
Begin
outbyte(fout, wdouble);
outdouble(fout, v);
End;
varSmallint, varbyte, varinteger:
Begin
outbyte(fout, winteger); outint(fout, v);
End;
varstring:
Begin
outbyte(fout, wstring);
outstring(fout, v);
End;
Else
Error(unexp_writer);
End;
End;
End;
{-----------}
Procedure writelabels;
Var
i, c: integer;
Begin
outint(fout, idlabels.count);
For i := 0 to idlabels.count - 1 do
Begin
c := tidlabelitem(idlabels.items[i]).Place;
outint(fout, c);
End;
End;
{-----------}
Procedure writeprog;
Var
i: integer;
v: tprogitem;
Begin
outint(fout, prog.count);
For i := 0 to prog.count - 1 do
Begin
v := tprogitem(prog.items[i]);
outint(fout, v.a);
outint(fout, v.b);
outint(fout, v.opcode);
End;
End;
{-----------}
Begin
writeconsts;
writelabels;
writeprog;
End;
{------------------------------}
Constructor THalCompiler.Create(afin: TMemoryStream; afout: TStream);
Begin
Inherited create;
myinit;
fout := afout;
inbuf := afin.memory;
numread := afin.size;
End;
{------------------------------}
Destructor THalCompiler.Destroy;
Begin
mydone;
Inherited;
End;
{------------------------------}
Procedure THalCompiler.compile;
Begin
compileprogram;
If idlabels.existlabels = false then
Error(linker_error);
WriteProgram;
End;
{=======================================================}
Procedure TBinProg.Error(Const s: String);
Begin
Raise ECompilerError.Create(s);
End;
{------------------------------}
Destructor TBinProg.Destroy;
Begin
If assigned(prog) then
freemem(prog, progsize * sizeof(tbinprogitem));
If assigned(c) then
freemem(c, constsize * sizeof(variant));
If assigned(l) then
freemem(l, labelsize * sizeof(integer));
Inherited destroy;
End;
{------------------------------}
Constructor TBinProg.Create(Fin: TStream);
{--}
Procedure readconsts;
Var
i: integer;
b: byte;
v: variant;
Begin
constsize := getint(fin);
getmem(c, constsize * sizeof(variant));
fillchar(c^, constsize * sizeof(variant), 0);
For i := 0 to constsize - 1 do
Begin
b := getbyte(fin);
Case b of
wInteger: v := getint(fin);
wDouble: v := getdouble(fin);
wString: v := getstring(fin);
WBoolean: v := getboolean(fin);
Else Error(SErrUnknReaderType);
End;
c^[i] := v;
End;
End;
{--}
Procedure readprogram;
Begin
progsize := getint(fin);
getmem(prog, progsize * sizeof(tbinprogitem));
Fin.ReadBuffer(Prog^, progsize * sizeof(tbinprogitem));
End;
{--}
Procedure readlabels;
Begin
labelsize := getint(fin);
getmem(l, labelsize * sizeof(integer));
Fin.ReadBuffer(L^, LabelSize * sizeof(integer));
End;
{--}
Var
i: integer;
Begin
Inherited create;
{ getmem(s, stacksize * sizeof(variant));
fillchar(s^, stacksize * sizeof(variant), 0);}
For i:=0 to StackSize do
With TVarData(S[i]) do
vType:=varInteger;
readconsts;
readlabels;
readprogram;
End;
{------------------------------}
Procedure TBinProg._ocloadextvar(Var V: Variant; b, a: integer); register;
Begin
V := (DynaVars.Objects[b] as TDynaVarItem).GetVar(a);
End;
{------------------------------}
Procedure TBinProg._ocsetself(A: TObject); register;
Begin
lastobject := a;
End;
{------------------------------}
Procedure TBinProg._CallExtFun(Var V: Variant; var PropName:String; ProcAddr: TProcType); register;
Begin
V := ProcAddr(lastobject, PropName,TempVars);
End;
{------------------------------}
Procedure TBinProg._ocselffromvar(Var A: Variant); register;
Begin
lastobject := tobject(VarToObj(a));
End;
{------------------------------}
Procedure TBinProg._ocstoreextvar(b, a: integer; Var V: Variant);
Begin
(DynaVars.Objects[b] as TDynaVarItem).SetVar(a, V);
End;
{------------------------------}
Function TBinProg._dispatch(opcode, a, b: integer): boolean;
Var
PCount, ik, a1: integer;
mint: Array[0..maxparams] of integer;
myfun: TFunListItem;
Begin
inc(curpos); Result := true;
Case opcode of
{------------------------------}
{general functions}
ocincvar: _ocincvar(S[a]);
ocdecvar: _ocdecvar(S[a]);
ocAdd: _ocAdd(S[a], s[b]);
ocSub: _ocSub(S[a], s[b]);
ocMul: _ocMul(S[a], s[b]);
ocDiv: _ocDiv(S[a], s[b]);
ocMod: _ocMod(S[a], s[b]);
ocSlash: _ocSlash(S[a], s[b]);
ocShl: _ocShl(S[a], s[b]);
ocShr: _ocShr(S[a], s[b]);
ocNot: _ocNot(S[a]);
ocOr: _ocOr(S[a], s[b]);
ocXor: _ocXor(S[a], s[b]);
ocAnd: _ocAnd(S[a], s[b]);
ocGreaterEqual: _ocGreaterEqual(S[a], s[b]);
ocEqual: _ocEqual(S[a], s[b]);
ocLessEqual: _ocLessEqual(S[a], s[b]);
ocNotEqual: _ocNotEqual(S[a], s[b]);
ocGreater: _ocGreater(S[a], s[b]);
ocLess: _ocLess(S[a], s[b]);
ocNeg: _ocNeg(S[a]);
ocmov: _ocmov(S[a], S[b]);
ocloadconst: _ocmov(S[a], c[b]);
ocvarraycreate: _ocvarraycreate(S[a], b);
ocsetvarray:
Begin
a1 := prog^[curpos].a;
inc(curpos);
_ocsetvarray(S[a1], S[b], a);
End;
{---------------------------------------}
ocsetself:
_ocsetself(TOBject(a));
ocselffromvar:
_ocselffromvar(s[a]);
ocloadextvar:
Begin
a1 := prog^[curpos].a;
inc(curpos);
_ocloadextvar(S[a1], b, a);
End;
ocstoreextvar:
Begin
a1 := prog^[curpos].a;
inc(curpos);
_ocstoreextvar(b, a, S[a1]);
End;
{---------------------------------------}
occall:
Begin
CallStack[CallMax] := curpos;
inc(CallMax);
Curpos := L^[a];
exit;
End;
ocGoto:
curpos := L^[a];
ocIF:
If s[a] = false
then
curpos := L^[B];
ochalt:
Begin
Result := false;
exit;
End;
ocreturn:
Begin
If CallMax = 0 then
Begin
Result := false;
exit;
End;
dec(callmax);
Curpos := CallStack[callmax];
exit;
End;
{---------------------------------------}
ocextfun:
Begin
myfun := tfunlistitem(Funs.Objects[b]);
PCount := myfun.parcount;
If PCount = 0 then
S[a] := myfun.ProcAddr(lastobject, myFun.PropName, TempVars)
Else
Begin
Dec(PCount);
ik := 0;
While ik <= PCount do
Begin
mint[ik] := prog[curpos].opcode;
mint[ik + 1] := prog[curpos].a;
mint[ik + 2] := prog[curpos].b;
inc(curpos);
inc(ik, 3);
End;
For ik := 0 to PCount do
TempVars[ik] := S[mint[ik]];
_CallExtFun(S[a], MyFun.PropName, MyFun.ProcAddr);
For ik := 0 to PCount do
If myfun.params[ik] = 1 then S[mint[ik]] := TempVars[ik];
End;
End;
Else Error('Invalid opcode');
End; End;
{------------------------------}
Procedure TBinProg.Run;
Begin
RunFrom(0);
End;
{------------------------------}
Procedure TBinProg.RunFrom(Acurpos: Integer);
Begin
curpos := ACurPos;
While
_dispatch(prog^[curpos].opcode, prog^[curpos].a, prog^[curpos].b)
Do Begin end;
End;
{============================================================}
Procedure thalRuner.AddObjectbyRef(Const objname: String; tobj: tobject);
Begin
AddObject(ObjName, tobj.ClassName, tobj);
End;
{------------------------------}
Procedure thalRuner.AddObject(Const objname, objtype: String; tobj: tobject);
Var
t: tobjitem;
Begin
t := tobjitem.create;
t.objtype := ansiuppercase(objtype);
t.tobj := tobj;
myobjects.addobject(ansiuppercase(objname), t);
End;
{-------------------}
Constructor THalRuner.Create(T: TMemoryStream);
Begin
Inherited Create;
instream := t;
myobjects := Tobjcollect.create;
TempVarList := TIdentList.Create;
End;
{-------------------}
Procedure THalRuner.Run;
Var
FHalCompiler: THalCompiler;
Begin
If compiled = false then
Begin
mymem := TmemoryStream.create;
FHalCompiler := THalCompiler.Create(instream, mymem);
Try
FHalCOmpiler.HALOWNER := HalOwner;
FHalCompiler.mobjects := myobjects;
FHalCompiler.compile;
Finally
FLastClassType := FHalCompiler.FLastClassType;
If loadtemp then TempVarList.Assign(FHalCompiler.Variables);
FHalCompiler.free;
End;
mymem.seek(0, 0);
FBinProg := TBinProg.Create(mymem);
compiled := true;
End;
If dontrun then exit;
FBinProg.Run;
End;
{-------------------}
Destructor THalRuner.Destroy;
Begin
If compiled then
Begin
mymem.free;
FBinProg.Free;
myobjects.free;
End;
TempVarList.Free;
Inherited;
End;
{-------------------------------------------}
Function UnUniqName(Const Name: String): String;
Var
i, Code, k: integer;
Begin
i := length(Name);
While (I > 0) and (Name[i] <> '_') do dec(i);
If (i = 0) then Result := Name else
Begin
Val(Copy(Name, i + 1, MaxInt), k, Code);
If Code <> 0 then Result := Name else Result := Copy(Name, 1, i - 1);
If k>0 then begin end;
End;
End;
{------------------------------}
Procedure disposeconsts(Var c: Array of tvarrec; size: integer);
Var
i: integer;
Begin
For i := 0 to size do
If C[i].Vtype = VTVariant
then
FreeMem(C[i].VVariant, SizeOf(Variant));
End;
{--------------------------------}
Procedure ClearHalParams;
Begin
InternalVariables.Clear;
End;
{--------------------------------}
Function GetHalParam(Const ParamName: String): Variant;
Var
i: integer;
Begin
Result := 0;
With InternalVariables do
Begin
If Find(AnsiUpperCase(ParamName), i) = false then exit;
Result := (Objects[i] as TInternalVarItem).Value;
End;
End;
{--------------------------------}
Procedure SetHalParam(Const ParamName: String; Value: Variant);
Var
R: TInternalVarItem;
S: String;
i: integer;
Begin
S := AnsiUpperCase(ParamName);
With InternalVariables do
Begin
If Find(S, i) then (Objects[i] as TInternalVarItem).Value := Value
Else
Begin
R := TInternalVarItem.Create;
R.Value := Value;
AddObject(S, R);
End;
End;
End;
{--------------------------------}
Procedure AddConst(Const AName: String; V: Variant);
Begin
ResConsts.AddConst(AName, V);
End;
{--------------------------------}
Constructor TResConstList.Create;
Begin
Inherited;
sorted := true;
duplicates := dupignore;
End;
{--------------------------------}
Procedure TResConstList.AddConst(Const AName: String; Var V: Variant);
Var
t: tresconstlistitem;
Begin
t := tresconstlistitem.Create;
t.Value := V;
AddObject(AnsiUpperCase(AName), t);
End;
{--------------------------------}
Destructor TResConstList.Destroy;
Var
i: integer;
Begin
For i := 0 to Count - 1 do
Objects[i].Free;
Inherited;
End;
{--------------------------------}
Procedure VarToStringS(Var V: Variant; Var P: Array of String; Var MaxP: Integer);
Var
i: integer;
Begin
MaxP := V[0];
For i := 1 to V[0] do P[i - 1] := V[i];
End;
{--------------------------------}
Procedure VarToConsts(Var V: Variant; Var P: Array of tvarrec; Var MaxP: Integer);
Var
i: integer;
PV: PVariant;
Begin
MaxP := V[0];
For i := 1 to MaxP do
Begin
GetMem(PV, Sizeof(Variant));
PV^ := V[i];
P[i - 1].VVariant := PV;
p[i - 1].Vtype := VtVariant;
End;
End;
{--------------------------------}
Procedure TIdentList.Assign(Source: TPersistent);
Var
i: integer;
P1: TIdentListItem;
Begin
Inherited;
For i := 0 to Count - 1 do
Begin
P1 := tidentlistitem(Objects[i]);
Objects[i] := TObject(TIdentListitem.Create);
(Objects[i] as tidentlistitem).Assign(P1);
End;
End;
{--------------------------------}
Procedure TIdentListItem.Assign(Source: TIdentlistItem);
Begin
ID := Source.ID;
VType := Source.Vtype;
IdentType := Source.IdentType;
ParCount := Source.ParCount;
Params := Source.Params;
ParamNames.Assign(Source.ParamNames);
End;
{--------------------------------}
Constructor TIdentListItem.Create;
Begin
Inherited;
ParamNames := TStringList.Create;
End;
{--------------------------------}
Destructor TIdentListItem.Destroy;
Begin
ParamNames.Free;
Inherited;
End;
{--------------------------------}
Constructor TInternalVar.Create;
Begin
Inherited;
AddDynaVar(stintvar, DynaVarNameToID, DynaSetVAR, dynagetvar);
End;
{--------------------------------}
Destructor TInternalVar.Destroy;
Var
i: integer;
Begin
DelDynaVar(stintvar);
For i := 0 to Count - 1 do
Objects[i].Free;
Inherited;
End;
{--------------------------------}
Function TInternalVar.DynaVarNameTOId(Const S: String): Integer;
Var
i: integer;
Begin
If CompareText(s, 'Result') = 0
then
Result := 0
Else
If Find(s, i)
then
Result := i + 1
Else
Result := -1;
End;
{--------------------------------}
Procedure TInternalVar.DynaSetVar(ID: Integer; Value: Variant);
Begin
If ID = 0
then
MyResult := Value
else
If ID - 1 <= Count then
(Objects[ID - 1] as TInternalVarItem).Value := Value;
End;
{--------------------------------}
Function TInternalVar.DynaGetVar(ID: Integer): Variant;
Begin
If ID = 0 then Result := MyResult else
Begin
If ID - 1 <= Count then Result := (Objects[ID - 1] as TInternalVarItem).Value
Else Result := 0;
End;
End;
{------------------------------}
Procedure AddLocalVar(Const name: String;
Avarnametoid: TDynaVarNameTOID;
ASetVar: TDYnaSetVar;
AGetVar: TDynaGetVar; AOwnerSelf: TObject);
Begin
DynaVars.AddDyna(name, Avarnametoid, ASetVar, AGetVar, true, AOwnerSelf);
End;
{------------------------------}
Procedure AddDynaVar(Const name: String;
Avarnametoid: TDynaVarNameTOID;
ASetVar: TDYnaSetVar;
AGetVar: TDynaGetVar);
Begin
DynaVars.AddDyna(name, Avarnametoid, ASetVar, AGetVar, false, DynaVars);
End;
{------------------------------}
Procedure deldynavar(Const name: String);
Begin
Dynavars.DelDyna(name);
End;
{------------------------------}
Procedure TDynaVars.AddDyna(Const name: String;
Avarnametoid: TDynaVarNameTOID;
ASetVar: TDYnaSetVar;
AGetVar: TDynaGetVar; LocalVars: Boolean; AOwnerSelf: TObject);
Var
t: tdynavaritem;
Begin
t := tdynavaritem.create;
With t do
Begin
varnametoid := Avarnametoid;
SetVar := ASetVar;
GetVar := AGetVar;
LocalVar := LocalVars;
OwnerSelf := AOwnerSelf;
End;
AddObject(AnsiUpperCase(name), t);
End;
{------------------------------}
Function TDynaVars.GetDynaObject(Const vname: String; AOwnerSelf: TObject;
Var varid, funid: integer): boolean;
Var
i: integer;
Begin
Result := false;
For i := count - 1 downto 0 do
If ((Objects[i] as TDynaVarItem).LocalVar = false)
Or
(AOwnerSelf = (Objects[i] as TDynaVarItem).OwnerSelf) then
Begin
varid := (Objects[i] as TDynaVarItem).VarNameToID(vname);
If (varid <> -1) then
Begin
funid := i;
Result := true;
exit;
End;
End;
End;
{------------------------------}
Procedure TDynaVars.DelDyna(Const name: String);
Var
i: integer;
Begin
i := IndexOF(AnsiUpperCase(name));
If i <> -1 then
Delete(i);
End;
{------------------------------}
Destructor TDynaVars.Destroy;
Var
i: integer;
Begin
For i := 0 to Count - 1 do
Objects[i].Free;
Inherited;
End;
{------------------------------}
Function GetClassParent(C:TClass):String;
begin
C:=C.ClassParent;
If C=nil
then
Result:=''
else
Result:=C.ClassName;
end;
{------------------------------}
Function GetPearent(Const objname: String): String;
Var
C:TClass;
Begin
C:=GetClass(ObjName);
If (C=nil)
then
Result:=''
else
Result:=GetClassParent(C);
End;
{------------------------------}
Constructor TObjCollect.Create;
Begin
Inherited;
sorted := true;
End;
{------------------------------}
Destructor TObjCollect.Destroy;
Var
i: integer;
Begin
For i := 0 to Count - 1 do If assigned(Objects[i]) then Objects[i].Free;
Inherited;
End;
{------------------------------}
Function TObjCollect.ObjbyName(Const aname: String; Var tob: tobjitem): boolean;
Var
i: integer;
Begin
tob := Nil;
Result := Find(aname, i);
If result then tob := Tobjitem(Objects[i]);
End;
{------------------------------}
Procedure TProgCollect.putop(ID, AA, AB: integer);
Var
s: tprogitem;
Begin
s := tprogitem(add);
s.opcode := id;
s.a := aa;
s.b := ab;
End;
{------------------------------}
Function TIDLabelList.newitem: integer;
Begin
Result := TIDLabelItem(Add).Index;
End;
{------------------------------}
Function TIdLabelList.existlabels: boolean;
Var
i: integer;
s: tidlabelitem;
Begin
Result := false;
For i := 0 to count - 1 do
Begin
s := tidlabelitem(items[i]);
If s.exist <> s.referenced then exit;
End;
Result := true;
End;
{------------------------------}
Procedure TIdLabelList.SetReference(index: integer);
Begin
tidlabelitem(items[index]).referenced := true;
End;
{------------------------------}
Procedure TIdLabelList.SetPlace(index, aplace: integer);
Var
s: tidlabelitem;
Begin
s := tidlabelitem(items[index]);
s.place := aplace;
s.exist := true;
End;
{------------------------------}
Function tconstlist.newitem(adata: variant): integer;
Var
t: tconstitem;
Begin
t := tconstitem(Add);
t.data := adata;
Result := t.index;
End;
{------------------------------}
Function TIdentList.IDByName(Const AName: String; Var AID: integer): boolean;
Var
i: integer;
Begin
Result := Find(aname, i);
If result then AID := TIdentListItem(Objects[i]).ID;
End;
{-------------------}
Constructor TIdentList.Create;
Begin
Inherited Create;
Sorted := true;
End;
{-------------------}
Function TIdentList.AddItem(Const Aname: String; ID: Integer): Integer;
Var
t: TIdentListItem;
Begin
t := TIdentListItem.Create;
t.Id := id;
Result := addobject(AnsiUpperCase(aname), t);
End;
{-------------------}
Destructor TIdentList.Destroy;
Var
i: integer;
Begin
For i := 0 to Count - 1 do If assigned(Objects[i]) then Objects[i].Free;
Inherited destroy;
End;
{----------------------------------------------}
Procedure NewR(Const AName: String; AID: Integer);
Begin
ResWords.AddItem(AName, AID);
End;
{----------------------------------------------}
Procedure InitReservedWords;
Begin
NewR('Program', id_Program);
NewR('Label', id_Label);
NewR('Goto', id_Goto);
NewR('Var', id_Var);
NewR('Begin', id_begin);
NewR('End', id_end);
Newr('And', id_and);
Newr('Or', id_or);
Newr('Xor', id_xor);
Newr('Not', id_not);
Newr('Shl', id_shl);
Newr('Shr', id_shr);
Newr('Div', id_div);
Newr('Mod', id_mod);
Newr('True', id_true);
Newr('False', id_false);
Newr('Nil', id_nil);
Newr('If', id_if);
Newr('then', id_then);
Newr('else', id_else);
Newr('While', id_while);
Newr('Repeat', id_repeat);
Newr('Until', id_until);
Newr('For', id_for);
Newr('To', id_to);
Newr('DownTo', id_downto);
Newr('Do', id_do);
{------}
Newr('initialization', id_unitinit);
Newr('finalization', id_unitfinal);
Newr('class', id_class);
Newr('type', id_type);
Newr('constructor', id_constr);
Newr('destructor', id_destr);
Newr('uses', id_uses);
Newr('unit', id_unit);
Newr('interface', id_interface);
Newr('implementation', id_implement);
Newr('procedure', id_procedure);
Newr('private', id_private);
Newr('public', id_public);
Newr('protected', id_protected);
Newr('published', id_published);
Newr('function', id_function);
Newr('const', id_const);
Newr('property', id_property);
Newr('virtual', id_virtual);
Newr('override', id_override);
Newr('dynamic', id_dynamic);
Newr('record', id_record);
Newr('forward', id_forward);
Newr('index', id_index);
Newr('read', id_read);
Newr('write', id_write);
Newr('stored', id_stored);
Newr('default', id_default);
Newr('abstract', id_abstract);
Newr('stdcall', id_stdcall);
{------}
End;
{------------------------------}
Function SetToken(ID: integer; V: Variant): TToken;
Begin
Result.ID := ID; Result.Data := V;
End;
{------------------------------}
Var
FLMethods: TList;
EventList: TEventList;
{-------------------------------------------}
Constructor TEventList.Create;
Begin
Inherited;
Sorted := True;
Duplicates := dupIgnore;
End;
{-------------------------------------------}
Function TEventList.ItemByName(Const AEventType: String): TEventListItem;
Var
i: Integer;
Begin
Result := Nil;
If Find(AnsiUpperCase(AEventType), i)
then
Result := TEventListItem(Objects[i]);
End;
{-------------------------------------------}
Procedure RegisterEvent(Const AEventType: String; AAddress: Pointer;
AEventClass: THalEventClass);
Begin
EventList.AddItem(AEventType, AAddress, AEventClass);
End;
{-------------------------------------------}
Procedure TEventList.AddItem(Const AEventType: String; AAddress: Pointer;
AEventClass: THalEventClass);
Var
F: TEventListItem;
Begin
F := TEventListItem.Create;
F.Address := AAddress;
F.EventClass := AEventClass;
AddObject(AnsiUpperCase(AEventType), F);
End;
{-------------------------------------------}
Destructor TEventList.Destroy;
Var
i: Integer;
Begin
For i := 0 to Count - 1 do
Objects[i].Free;
Inherited;
End;
{-------------------------------------------}
Function RegisteredEvent(Const EventType: String): Boolean;
Begin
Result := (EventList.ItemByName(Eventtype)) <> Nil;
End;
{-------------------------------------------}
Function RunFormMacro(Const MPath: String; Modal: Boolean): Variant;
Var
s: String;
Begin
Result := NULL;
s := AnsiUpperCase(ExtractFileExt(MPath));
If S = '.DFM' then Begin
If modal
then
Result := RunFormModal(MPath)
else
RunForm(MPath);
End else
If (S = '.PAS') or (S = '.HAL')
then
Result := RunMacro(MPath)
else
Raise Exception.Create(Format(unk_macrotype, [AnsiUpperCase(MPath)]));
End;
{---------------------------------}
function IsDelphinForm(F:TComponent):boolean;
begin
Result:=GetEventDispatcher(F)<>nil;
end;
{---------------------------------}
function GetEventDispatcher(F:TComponent):THalComp;
Var
i:Integer;
begin
Result:=nil;
With F do
for I:=0 to ComponentCount-1 do
if (Components[i] is THalComp) and (THalComp(Components[i]).EventDispatcher) then
begin
Result:=THalComp(Components[i]);
exit;
end;
end;
{---------------------------------}
procedure CallEvent(F:TComponent;Const EventName:String;ParamCount:Integer;Params:Pointer);
Var
H:THalEvent;
HCo:THalComp;
begin
HCo:=GetEventDispatcher(F.Owner);
If HCo=nil then
exit;
H:=THalEvent.Create(F.Owner);
try
H.HR := HCo.FHalRuner;
H.ProcName := EventName;
H.ExecProc(F,ParamCount,Params);
finally
H.Free;
end;
end;
{-------------------------------------------}
Function THalEvent.GetProcItem: TIdentListItem;
Var
OName:String;
Begin
Result:=nil;
OName:=UnUniqName(Owner.Name);
PrName := AnsiUpperCase('T' + OName + '.' + ProcName);
If HR.TempVarList.ItemByname(prname, Result) then
exit;
If OName=Owner.Name then
raise Exception.CreateFmt(proc_notfound, [prname]);
PrName := AnsiUpperCase('T' + Owner.Name + '.' + ProcName);
if HR.TempVarList.ItemByname(prname, Result) = false then
raise Exception.CreateFmt(proc_notfound, [prname]);
End;
{-------------------------------------------}
Procedure THalEvent.SetParam(Const ParName: String; Value: Variant);
Var
iw: TIdentListItem;
Begin
If HR.TempVarList.ItemByname(ParName, iw) = false
Then
showmessage(Format(par_notfound, [ParName]))
Else
HR.FBinProg.S[iw.id] := Value;
End;
{-------------------------------------------}
Function THalEvent.GetParam(Const ParName: String): Variant;
Var
iw: TIdentListItem;
Begin
Result := 0;
If HR.TempVarList.ItemByname(ParName, iw) = false
Then
showmessage(Format(par_notfound, [ParName]))
Else
Result := HR.FBinProg.S[iw.id];
End;
{-------------------------------------------}
Procedure THalEvent.ExecProc(F:TObject;ParCount:Integer;Params:PVarDataList);
Var
k,I: Integer;
Begin
If not assigned(it) then
it := GetProcItem;
If it=nil then
exit;
If F<>nil then
SetParam(PrName + '.Sender' , OV(F));
K:=1;
For i := ParCount-1 downto 0 do
begin
SetParam(PrName + '.' + it.Paramnames[K], Variant(Params[i]));
inc(k);
end;
HR.FBinProg.RunFrom(HR.FBinProg.L^[it.id]);
K:=1;
For i :=ParCount-1 downto 0 do
begin
Variant(Params[i]) := GetParam(PrName + '.' + it.Paramnames[k]);
inc(k);
end;
End;
{-------------------------------------------}
Procedure THalEvent.MDragDropEvent(Sender, Source: TObject; X, Y: Integer);
Var
V: Array[0..2] of Variant;
Begin
V[2] := OV(Source);
V[1] := X;
V[0] := Y;
ExecProc(Sender,3,@V);
End;
{-------------------------------------------}
function SetToInt(const aSet;const Size:integer):Integer;
begin
Result := 0;
Move(aSet, Result, Size);
end;
procedure IntToSet(const Value:integer; var aSet;const Size:integer);
begin
Move(Value, aSet, Size);
end;
procedure THalEvent.MMouseEvent(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
Var
V:Array[0..3] of variant;
begin
V[3]:= Button;
V[2]:= Byte(SetToInt(Shift, SizeOf(TShiftState)));
V[1]:= X;
V[0]:= Y;
ExecProc(Sender,4,@V);
end;
{-------------------------------------------}
procedure THalEvent.MMouseMoveEvent(Sender: TObject; Shift: TShiftState;X, Y: Integer);
Var
V:Array[0..2] of Variant;
begin
V[2]:=Byte(SetToInt(Shift, SizeOf(TShiftState)));
V[1]:=X;
V[0]:=Y;
ExecProc(Sender,3,@V);
end;
{-------------------------------------------}
procedure THalEvent.MKeyEvent(Sender: TObject; var Key: Word;Shift: TShiftState);
Var
V:Array[0..1] of variant;
begin
V[1]:=Key;
V[0]:=Byte(SetToInt(Shift, SizeOf(TShiftState)));
ExecProc(Sender,2,@V);
Key:=V[1];
end;
{-------------------------------------------}
Procedure THalEvent.MDragOverEvent(Sender, Source: TObject; X, Y: Integer; State: TDragState; Var Accept: Boolean);
Var
V: Array[0..4] of Variant;
Begin
V[4] := OV(Source);
V[3] := X;
V[2] := Y;
V[1] := Ord(State);
V[0] := Accept;
ExecProc(Sender,5,@V);
Accept := V[4];
End;
{-------------------------------------------}
Procedure THalEvent.MEndDragEvent(Sender, Target: TObject; X, Y: Integer);
Var
V: Array[0..2] of Variant;
Begin
V[2] := OV(target);
V[1] := X;
V[0] := Y;
ExecProc(Sender,3,@V);
End;
{-------------------------------------------}
Procedure THalEvent.MStartDragEvent(Sender: TObject; Var DragObject: TDragObject);
Var
V: Array[0..0] of Variant;
Begin
V[0] := OV(DragObject);
ExecProc(Sender,1,@V);
DragObject := TDragObject(VO(V[0]));
End;
{-------------------------------------------}
procedure THalEvent.mQROnNeedDataEvent(Sender : TObject; var MoreData : Boolean);
Var
V: Array[0..0] of Variant;
begin
v[0]:=MoreData;
ExecProc(Sender,1,@V);
MoreData:=v[0];
end;
{-------------------------------------------}
procedure THalEvent.mQRNotifyOperationEvent(Sender : TObject; Operation : TQRNotifyOperation);
Var
V: Array[0..0] of Variant;
begin
v[0]:=Integer(Operation);
ExecProc(Sender,1,@V);
end;
{-------------------------------------------}
procedure THalEvent.mQRBandBeforePrintEvent(Sender : TObject; var PrintBand : Boolean);
Var
V: Array[0..0] of Variant;
begin
v[0]:=PrintBand;
ExecProc(Sender,1,@V);
PrintBand:=v[0];
end;
{-------------------------------------------}
procedure THalEvent.mQRBandAfterPrintEvent(Sender : TObject; BandPrinted : Boolean);
Var
V: Array[0..0] of Variant;
begin
v[0]:=BandPrinted;
ExecProc(Sender,1,@V);
end;
{-------------------------------------------}
procedure THalEvent.mQRReportBeforePrintEvent(Sender : TObject; var PrintReport : Boolean);
Var
V: Array[0..0] of Variant;
begin
v[0]:=PrintReport;
ExecProc(Sender,1,@V);
PrintReport:=v[0];
end;
{-------------------------------------------}
procedure THalEvent.mQRFilterEvent(var PrintRecord : boolean);
Var
V: Array[0..0] of Variant;
begin
v[0]:=PrintRecord;
ExecProc(nil,1,@V);
PrintRecord:=v[0];
end;
{-------------------------------------------}
// this event return results
// it's probably not implemented yet
function THalEvent.MHelpEvent(Command: Word; Data: Longint;var CallHelp: Boolean): Boolean;
Var
V: Array[0..2] of Variant;
begin
v[2]:=Command;
v[1]:=Data;
v[0]:=CallHelp;
ExecProc(nil,3,@V);
CallHelp:=v[2];
Result:=True;
end;
{-------------------------------------------}
procedure THalEvent.MCloseQueryEvent(Sender: TObject;var CanClose: Boolean);
Var
V: Array[0..0] of Variant;
begin
v[0]:=CanClose;
ExecProc(Sender,1,@V);
CanClose:=v[0];
end;
{-------------------------------------------}
procedure THalEvent.mQRLabelOnPrintEvent(sender : TObject; var Value : string);
Var
V: Array[0..0] of Variant;
begin
v[0] := Value;
ExecProc(Sender,1,@V);
Value:=v[0];
end;
{-------------------------------------------}
procedure THalEvent.mQRProgressUpdateEvent(Sender : TObject; Progress : integer);
Var
V: Array[0..0] of Variant;
begin
V[0]:=Progress;
ExecProc(Sender,1,@V);
end;
{-------------------------------------------}
procedure THalEvent.mQRPageAvailableEvent(Sender : TObject; PageNum : integer);
Var
V: Array[0..0] of Variant;
begin
V[0]:=PageNum;
ExecProc(Sender,1,@V);
end;
{-------------------------------------------}
Procedure THalEvent.MKeyPressEvent(Sender: TObject; Var Key: Char);
Var
V: Array[0..0] of Variant;
S: String;
Begin
V[0] := Key;
ExecProc(Sender,1,@V);
S := V[0];
Key := S[1];
End;
{-------------------------------------------}
Procedure THalEvent.MCloseEvent(Sender: TObject; Var Action: TCloseAction);
Var
V: Array[0..0] of Variant;
Begin
V[0] := Action;
ExecProc(Sender,1,@V);
Action := V[0];
End;
{-------------------------------------------}
Procedure THalEvent.MNotifyEvent(Sender: TObject);
Begin
ExecProc(Sender,0,nil);
End;
{-------------------------------------------}
Constructor TMyReader.Create(Stream: TStream; BufSize: Integer);
Begin
Inherited;
End;
{-------------------------------------------}
Function TMyReader.FindMethod(Root: TComponent;
Const MethodName: String): Pointer;
Var
A: TMethodNameHolder;
Begin
a := TMethodNameHolder.Create;
FLMethods.Add(a);
a.MethodName := MethodName;
Result := Pointer(FlMethods.Count);
End;
{-------------------------------------------}
Function TMyStream.ReadComponent(Instance: TComponent): TComponent;
Var
Reader: TMyReader;
Begin
Reader := TMyReader.Create(Self, 4096);
Try
Result := Reader.ReadRootComponent(Instance);
Finally
Reader.Free;
End;
End;
{-------------------------------------------}
Function TMyStream.ReadComponentRes(Instance: TComponent): TComponent;
Begin
ReadResHeader;
Result := ReadComponent(Instance);
End;
{-------------------------------------------}
function RunForm(Const FormPath: String):TForm;
Begin
Result := TForm.Create(Application);
MyReadComponentResFile(FormPath, Result);
Result.Show;
End;
{-------------------------------------------}
Function RunFormModal(Const FormPath: String): Integer;
Var
Form: TForm;
Begin
Form := TForm.Create(Application);
try
MyReadComponentResFile(FormPath, Form);
Form.Hide;
Result := Form.ShowModal;
finally
Form.Free;
end;
End;
{-------------------------------------------}
Function MyReadComponentResFile(Const FileName: String;
Instance: TComponent): TComponent;
Label
lexit;
Var
Stream: TMyStream;
j: integer;
HCo: THalComp;
PasFileName: String;
{---}
Procedure updateprops(Instan, MyOwner: TComponent);
Var
maxp, i: integer;
proplist: Array[0..1000] of PPropInfo;
s: TMethodNameHolder;
p: TMethod;
si: TEventListItem;
TempObj: THalEvent;
Begin
maxp := GetPropList(Instan.classinfo, tkmethods, @PropList);
For i := 0 to maxp - 1 do
Begin
P := getmethodprop(Instan, proplist[i]);
If (Integer(P.Code)>0) and (Integer(P.Code)<=FLMethods.Count) then
Begin
S := TMethodNameHolder(FLMethods.Items[Integer(P.Code)-1]);
si := EventList.ItemByName(proplist[i]^.PropType^.Name);
If Assigned(si) then
Begin
TempObj := Si.EventClass.Create(Nil);
MyOwner.InsertComponent(TempObj);
P.Data := TempObj;
P.Code := Si.Address;
TempObj.HR := HCo.FHalRuner;
TempObj.ProcName := S.MethodName;
End else
P.Code := Nil;
S.Free;
SetMethodProp(Instan, proplist[i], p);
End;
End;
End;
{---}
Begin
FLMethods.Clear;
Stream := TMyStream.Create(FileName, fmOpenRead);
Try
Result := Stream.ReadComponentRes(Instance);
If Result is TForm then
TForm(Result).Visible:=False;
Finally
Stream.Free;
End;
PasFileName := ChangeFIleExt(Filename, '.PAS');
If Fileexists(PasFileName) then
begin
HCo := THalComp.Create(Result);
HCo.EventDispatcher:=True;
HCo.Script.LoadFromFile(PasFileName);
HCo.Compile('', Nil);
HCo.FHalRuner.LoadTemp := true;
HCo.FHalRuner.dontrun := true;
HCo.Run;
UpdateProps(Result, Result);
j := 0;
While j <= Instance.ComponentCount - 1 do
Begin
UpdateProps(Result.Components[j], Result);
inc(j);
End;
end;
{------------}
lexit:
If (Result is TForm) then
Begin
If (Assigned(TForm(Result).OnCreate)) then
TForm(Result).OnCreate(Result);
If (Not Assigned(TForm(Result).OnClose)) then
TForm(Result).OnClose := HCo.FOnFormClose;
End;
End;
{------------------------------}
(*
Procedure TFormulaList.AddValue(Const VarName: String; AValue: Variant);
Begin
AddVF(VarName, '', AValue, false);
End;
{------------------------------}
Procedure TFormulaList.AddFormula(Const VarName, AFormula: String);
Begin
AddVF(VarName, AFormula, NULL, true);
End;
{------------------------------}
Procedure TFormulaList.AddVF(Const VarName, AFormula: String;
AValue: Variant; ACalc: Boolean);
Var
F: TFormulaListItem;
Begin
F := TFormulaListItem.Create;
F.Formula := AFormula;
F.Value := AValue;
F.NeedCalc := ACalc;
AddObject(AnsiUpperCase(VarName), F);
End;
{------------------------------}
Function TFormulaList.HVarNameTOId(Const S: String): Integer;
Begin
If Find(AnsiUpperCase(S), Result) = false then Result := -1;
End;
{------------------------------}
Procedure TFormulaList.HSetVar(ID: Integer; Value: Variant);
Begin
End;
{------------------------------}
Function TFormulaList.HGetVar(ID: Integer): Variant;
Begin
If IntStack.IndexOf(Pointer(ID)) <> -1
then
Raise Exception.CreateFMT(SErrCircularVarRef, [Strings[ID]]);
Result := GetValue(Strings[ID]);
End;
{------------------------------}
Function TFormulaList.CalcFormula(Const AFormula: String): Variant;
Var
H: THalComp;
Begin
H := THalComp.Create(Nil);
With H do
Begin
VarNameTOID := HVarNameTOID;
GetVar := HGetVar;
SetVar := HSetVar;
Loaded;
Expression := AFormula;
End;
Try
Result := H.Result;
Finally
H.Free;
End;
End;
{------------------------------}
Function TFormulaList.GetValue(Const VarName: String): Variant;
Var
i: integer;
F: TFormulaListItem;
Begin
Result := NULL;
If Find(AnsiUpperCase(VarName), i) = false
then
Raise Exception.CreateFMT('Variable %S not found', [VARName]);
F := Objects[i] as TFormulaListItem;
With f do
Begin
If NeedCalc = false
then
Result := Value
else
Begin
Try
IntStack.Push(i);
Value := CalcFormula(Formula);
NeedCalc := False;
Result := Value;
Finally
IntStack.Pop;
End;
End;
End;
End;
{------------------------------}
Constructor TFormulaList.Create;
Begin
Inherited;
Sorted := True;
Duplicates := dupError;
IntStack := TIntStack.Create;
End;
{------------------------------}
Destructor TFormulaList.Destroy;
Var
i: integer;
Begin
For i := 0 to Count - 1 do
Objects[i].Free;
IntStack.Free;
Inherited;
End;
*)
{------------------------------}
Function RunMacro(Const MacroName: String): Variant;
Begin
Result := RunMacroFriend(MacroName, Nil);
End;
{------------------------------}
Function RunMacroFriend(Const MacroName: String; AForm: TForm): Variant;
Var
HC: THalComp;
Begin
If not FileExists(MacroName) then
Begin
ShowMessage(Format(file_not_found, [MacroName])); exit;
End;
HC := THalComp.Create(AForm);
Try
HC.Script.LoadFromFile(MacroName);
HC.FScriptChanged := true;
Result := NULL;
Result := HC.Result;
Finally
HC.Free;
End;
End;
{------------------------------}
Procedure THalCOmp.FOnFOrmClose(Sender: TObject; Var Action: TCloseAction);
Begin
Action := caFree;
End;
{------------------------------}
Procedure THalCOmp.Loaded;
Begin
Inherited;
If assigned(FVarNameTOID) and assigned(FGetVar) and assigned(FSetVar)
Then
Begin
AddLocalVar(Name, Fvarnametoid, FSetVar, FGetVar, Self);
DelOnFree := true;
End;
If componentstate = [csdesigning] then exit;
SetNotifyEvent(ControlLink, EventLink, fmyNotifyEvent);
End;
{------------------------------------}
Destructor THalComp.Destroy;
Begin
If assigned(fhalruner) then FHalRuner.Free;
If assigned(Fmystream) then FMyStream.Free;
If delonfree then DelDynaVar(Name);
FScript.Free;
Inherited;
End;
{------------------------------}
Function THalCOmp.getresult: variant;
Begin
Compile('', Nil);
Run;
getresult := InternalVariables.MyResult;
End;
{------------------------------}
Procedure THalComp.FMyNotifyEvent(Sender: TObject);
Begin
Compile('Sender', sender);
Run;
End;
{------------------------------------}
Procedure THalComp.Compile(Const obname: String; ob: tobject);
Var
Temp: TStringList;
Begin
If FScriptChanged then
Begin
FScriptChanged := false;
If assigned(fhalruner) then FHalRuner.Free;
If assigned(fMyStream) then FMyStream.Free;
FHalRuner := Nil;
End;
If not assigned(fhalruner) then
Begin
FMyStream := TMemoryStream.Create;
Temp := TStringList.Create;
Temp.Assign(FScript);
Temp.SaveToStream(FMyStream);
Temp.Free;
FHalRuner := THalRuner.Create(FMyStream);
FhalRuner.HALOwner := Self;
End;
FOB := ob; Fobname := obname;
End;
{------------------------------------}
Procedure THalComp.Run;
{----------------}
Procedure addobj(V: TObject);
Var j: integer;
Begin
With V as TForm do
For j := 0 to ComponentCount - 1 do
FhalRuner.AddObjectBYRef(Components[j].Name, Components[j]);
FhalRuner.AddObjectBYRef('Self', TForm(V));
End;
{----------------}
Begin
If not assigned(fhalruner) then
Raise Exception.Create(compile_before);
FhalRuner.MyObjects.Clear;
If Friend <> Nil
then
AddObj(Friend)
else
If Owner <> Nil
then
AddObj(Owner);
FhalRuner.AddObjectBYRef('Screen', Screen);
FhalRuner.AddObjectBYRef('Application', Application);
If fob <> Nil then
FhalRuner.AddObjectbyRef(fobname, fob);
FMyStream.Seek(0, 0);
Try
FHalRuner.Run;
Finally
FLastClassType := FHalRuner.FLastClassType;
End;
End;
{------------------------------------}
Procedure THalComp.Notification(AComponent: TComponent;
Operation: TOperation);
Begin
Inherited;
If (Operation = opRemove) and (AComponent = FControl) then
Begin
FControl := Nil;
EventLink := '';
End;
End;
{------------------------------------}
Constructor THalComp.Create(AOwner: TComponent);
Begin
Inherited;
FScript := TStringList.Create;
TStringList(FScript).OnCHange := MyOnChange;
FScript.Add('begin');
FScript.Add('end.');
End;
{-------------------------------}
Procedure THalComp.SetExpression(Const S: String);
Var
t: String;
Begin
FExpression := S;
If S = '' then exit;
t := s;
FScriptChanged := true;
FScript.Clear;
FSCript.Add('begin');
If t[length(t)] <> ';'
then
t := t + ';';
FSCript.Add('Result:=' + t);
FSCript.Add('end.');
End;
{--------------------------------------}
Procedure THalComp.SetScript(Value: TStrings);
Begin
FScript.Assign(Value);
FScriptChanged := true;
End;
{------------------------------------}
Procedure THalComp.MyOnCHange(Sender: TObject);
Begin
FScriptCHanged := True;
End;
{--------------------}
Procedure InitHalUnit;
Begin
AddConst('qrMasterDataAdvance',qrMasterDataAdvance);
AddConst('qrBandPrinted',qrBandPrinted);
AddConst('qrBandSizeChange',qrBandSizeChange);
AddConst('mbLeft',mbLeft);
AddConst('mbRight',mbRight);
AddConst('mbMiddle',mbMiddle);
AddConst('ssShift',ssShift);
AddConst('ssAlt',ssAlt);
AddConst('ssCtrl',ssCtrl);
AddConst('ssLeft',ssLeft);
AddConst('ssRight',ssRight);
AddConst('ssMiddle',ssMiddle);
AddConst('ssDouble',ssDouble);
End;
{-----------------------------}
Procedure RegisterEvents;
Begin
RegisterEvent('TQRAfterPrintEvent', @THalEvent.MNotifyEvent, THalEvent);
RegisterEvent('TQRAfterPreviewEvent', @THalEvent.MNotifyEvent, THalEvent);
RegisterEvent('TQRNotifyEvent', @THalEvent.MNotifyEvent, THalEvent);
RegisterEvent(coNotifyEvent, @THalEvent.MNotifyEvent, THalEvent);
RegisterEvent(coCloseEvent, @THalEvent.MCloseEvent, THalEvent);
RegisterEvent('TDragDropEvent', @THalEvent.MDragDropEvent, THalEvent);
RegisterEvent('TDragOverEvent', @THalEvent.MDragOverEvent, THalEvent);
RegisterEvent('TEndDragEvent', @THalEvent.MEndDragEvent, THalEvent);
RegisterEvent('TStartDragEvent', @THalEvent.MStartDragEvent, THalEvent);
RegisterEvent('TKeyPressEvent', @THalEvent.MKeyPressEvent, THalEvent);
RegisterEvent('TQROnNeedDataEvent', @THalEvent.mQROnNeedDataEvent, THalEvent);
RegisterEvent('TQRNotifyOperationEvent', @THalEvent.mQRNotifyOperationEvent, THalEvent);
RegisterEvent('TQRBandBeforePrintEvent', @THalEvent.mQRBandBeforePrintEvent, THalEvent);
RegisterEvent('TQRBandAfterPrintEvent', @THalEvent.mQRBandAfterPrintEvent, THalEvent);
RegisterEvent('TQRReportBeforePrintEvent', @THalEvent.mQRReportBeforePrintEvent, THalEvent);
RegisterEvent('TQRFilterEvent', @THalEvent.mQRFilterEvent, THalEvent);
RegisterEvent('THelpEvent', @THalEvent.MHelpEvent, THalEvent);
RegisterEvent('TCloseQueryEvent', @THalEvent.MCloseQueryEvent, THalEvent);
RegisterEvent('TQRLabelOnPrintEvent', @THalEvent.mQRLabelOnPrintEvent, THalEvent);
RegisterEvent('TQRProgressUpdateEvent', @THalEvent.mQRProgressUpdateEvent, THalEvent);
RegisterEvent('TQRPageAvailableEvent', @THalEvent.mQRPageAvailableEvent, THalEvent);
RegisterEvent('TMouseEvent', @THalEvent.MMouseEvent, THalEvent);
RegisterEvent('TMouseMoveEvent', @THalEvent.MMouseMoveEvent, THalEvent);
RegisterEvent('TKeyEvent', @THalEvent.MKeyEvent, THalEvent);
End;
{---------------------------------}
(*
Type
TMethodsProperty = Class(TStringProperty)
Public
Function GetAttributes: TPropertyAttributes; override;
Procedure GetValueList(List: TStrings); virtual;
Procedure GetValues(Proc: TGetStrProc); override;
Function Getvname: String; virtual;
End;
{------------------------------------}
Function TMethodsProperty.Getvname: String;
Begin
Result := 'ControlLink';
End;
{------------------------------------}
Procedure TMethodsProperty.GetValueList(List: TStrings);
Var
Instance: TComponent;
PropInfo: PPropInfo;
mc: tcomponent;
maxp, i: integer;
proplist: Array[0..1000] of PPropInfo;
Begin
List.BeginUpdate;
List.Clear;
Instance := TComponent(GetComponent(0));
PropInfo := TypInfo.GetPropInfo(Instance.ClassInfo, getvname);
If (PropInfo <> Nil) and (PropInfo^.PropType^.Kind = tkClass) then
Begin
mc := TObject(GetOrdProp(Instance, PropInfo)) as TComponent;
If (mc = Nil) then mc := Instance.Owner;
If (mc <> Nil) then
Begin
maxp := GetPropList(mc.classinfo, tkmethods, @PropList);
For i := 0 to maxp - 1 do
If CompareText(proplist[i]^.proptype^.name, 'TNotifyEvent') = 0 then
List.Add(proplist[i]^.name);
End;
End;
List.EndUpdate;
End;
{------------------------------}
*)
Function TIdentList.ItemByName(Const Aname: String; Var Ident: TIdentListItem): boolean;
Var
i: integer;
Begin
ident := Nil;
Result := Find(aname, i);
If result then Ident := TIdentListItem(Objects[i]);
End;
(*
{------------------------------------}
Function TMethodsProperty.GetAttributes: TPropertyAttributes;
Begin
Result := [paValueList, paSortList, paMultiSelect];
End;
{------------------------------------}
Procedure TMethodsProperty.GetValues(Proc: TGetStrProc);
Var
I: Integer;
Values: TStringList;
Begin
Values := TStringList.Create;
Try
GetValueList(Values);
For I := 0 to Values.Count - 1 do
Proc(Values[I]);
Finally
Values.Free;
End;
End;
{------------------------------------------------------------------}
*)
Function FindFormInVarDecl(S:TMemoryStream;Const FormName:String;
Var BegLine,BegPos,EndLine,EndPos:Integer):Boolean;
Var
HAL:THALCompiler;
A:Integer;
begin
Result:=False;
HAL:=THALCompiler.Create(S,nil);
With HAL do
try
While true do
begin
Token:=ReadToken;
If (Token.ID=idEndOfFile) or (Token.ID=id_implement) then break;
If Token.ID=id_var then
begin
Token:=ReadToken;
If (Token.ID=ididentifier) and (CompareText(Token.Data,FormName)=0) then
begin
A:=CurRead-Length(FormName);
Token:=ReadToken;
If Token.ID<>id2points then continue;
Token:=ReadToken;
If (Token.id<>ididentifier) or (CompareText(Token.Data,'T'+FormName)<>0) then continue;
ConvertCurPos(EndLine,EndPos);
CurRead:=A;
ConvertCurPos(BegLine,BegPos);
Result:=True;
break;
end;
end;
end;
finally
HAL.Free;
end;
end;
{------------------------------------------------------------------}
Function FindFormInTypeDecl(S:TMemoryStream;Const FormName:String;
Var ALine,APos:Integer):Boolean;
Var
HAL:THalCompiler;
FName:String;
begin
HAL:=THalCompiler.Create(S,nil);
Fname:='T'+FormName;
Result:=False;
With HAL do
Try
While true do
begin
Token:=ReadToken;
If Token.ID=idendoffile then break;
If Token.ID=id_type then
begin
Token:=ReadToken;
If (Token.ID=ididentifier) and (CompareText(Token.Data,FName)=0) then
begin
Result:=True;
CurRead:=CurRead-Length(FName);
ConvertCurPos(ALine,APos);
break;
end;
end;
end;
finally
HAL.Free;
end;
end;
{------------------------------------------------------------------}
procedure FindFormInEventNames(S:TMemoryStream;Const FormName:String;PosList:TPosList);
Var
HAL:THalCompiler;
Skip:Boolean;
ALine,AChar:Integer;
FName:String;
begin
HAL:=THalCompiler.Create(s,nil);
Skip:=True;
FName:='T'+FormName;
With HAL do
Try
While True do
begin
Token:=ReadToken;
If Token.ID=idEndOfFile then break;
If (Token.id=id_implement) then
begin
Skip:=False;
continue;
end;
If Skip then continue;
If (Token.ID=ididentifier) and (CompareText(FName,Token.Data)=0)
and (NextToken.ID=idpoint) then
begin
Dec(CurRead,Length(FName));
ConvertCurPos(ALine,AChar);
Inc(CurRead,Length(FName));
PosList.AddPos(ALine,AChar);
end;
end;
finally
HAL.Free;
end;
end;
{------------------------------------------------------------------}
Function ImplFound(M:TMemoryStream;Var ALine,APos:Integer):Boolean;
Var
HAL:THalCompiler;
begin
Result:=False;
HAl:=THalCompiler.Create(M,nil);
With HAL do
Try
While True do
begin
Token:=ReadToken;
If Token.id=idEndOfFile then break;
If Token.id=id_Implement then
begin
ConvertCurPos(ALine,APos);
Result:=True;
break;
end;
end;
finally
HAL.Free;
end;
end;
{------------------------------------------------------------------}
function FindEventInCodeGen(S:TMemoryStream;Const EventName:String;
Var ALine,AChar:Integer):Boolean;
Var
HAL:THalCompiler;
begin
Result:=False;
HAL:=THalCompiler.Create(S,nil);
Try
With HAL do
While True do
begin
Token:=ReadToken;
If Token.ID=idendoffile then break;
IF (Token.id =id_procedure) or (Token.ID=id_function) then
begin
Token:=ReadToken;
If (Token.id=ididentifier) and (CompareText(Token.Data,EventName)=0)
and (NextToken.ID=idOpenBracket) then
begin
CurRead:=CurRead-Length(EventName);
ConvertCurPos(ALine,AChar);
Result:=True;
break;
end;
end;
end;
finally
HAL.Free;
end;
end;
{-----------------------------------------------------------}
Function GetCodegenSection(S:TMemoryStream; Const FormClassName:String;
Var BegLine,BegPos,EndLine,EndPos:Integer):Boolean;
Var
HAL:THalCompiler;
sPos:Integer;
//----------
function CheckToken(ID:Integer):Boolean;
begin
With HAL do
begin
Token:=ReadToken;
Result:=Token.ID=ID;
end;
end;
//----------
begin
Result:=False;
HAL:=THalCompiler.Create(s,nil);
try
With Hal do
While True do
begin
Token:=ReadToken;
If Token.ID=idendoffile then break;
If (Token.id=ididentifier) and (CompareText(FormClassName,Token.Data)=0) then
begin
if CheckToken(idequal)=False then continue;
if CheckToken(id_class)=False then continue;
if CheckToken(idopenbracket)=False then continue;
if CheckToken(ididentifier)=False then continue;
if CheckToken(idclosebracket)=False then continue;
ConvertCurPos(BegLine,BegPos);
While True do
begin
sPos:=CurRead;
Token:=ReadToken;
If Token.ID=idendoffile then break;
if Token.id=id_private then
begin
CurRead:=sPos;
ConvertCurPos(EndLine,EndPos);
Result:=True;
break;
end;
end;
break;
end;
end;
finally
HAL.Free;
end;
end;
{-----------------------------------------------------------}
Function GetUnitNamePos(S:TMemoryStream; Var ALine,APos,Aleng:Integer):Boolean;
Var
HAL:THalCompiler;
OCurread:Integer;
begin
Result:=False;
HAL:=THalCompiler.Create(s,nil);
Try
With HAl do
While True do
begin
Token:=ReadToken;
if token.id=idendoffile then break;
if token.id=id_unit then
begin
Token:=ReadToken;
OCurRead:=CurRead;
While InBuf[CurRead]<>' ' do dec(CurRead);
ALeng:=OCurRead-CurRead;
ConvertCurPos(ALine,APos);
Result:=True;
break;
end;
end;
finally
HAl.Free;
end;
end;
{-----------------------------------------------------------}
Function GetUsesPos(S:TMemoryStream;Var BegLine,BegPos,EndLine,EndPos:Integer;
AfterImpl:Boolean):Boolean;
Var
HAL:THalCompiler;
sPos:Integer;
label
l1;
begin
Result:=False;
HAL:=THalCompiler.Create(S,nil);
Try
With HAL do
While True do
begin
Token:=ReadToken;
if Token.ID=idendoffile then break;
If (Token.ID=id_implement) and (AfterImpl) then
begin
AfterImpl:=False;
continue;
end;
IF AfterImpl then continue;
if Token.ID=id_uses then
begin
ConvertCurPos(BegLine,BegPos);
While True do
begin
sPos:=CurRead;
Token:=ReadToken;
If Token.ID=idendoffile then goto l1;
if token.id=idDelimeter then
begin
CurRead:=sPos;
Result:=True;
ConvertCurPos(EndLine,EndPos);
Goto L1;
end;
end;
end;
end;
l1:
finally
HAL.Free;
end;
end;
{-----------------------------------------------------------}
Function GetMethodLine(S:TMemoryStream;Const AMethodName:String;
Var BegLine,BegPos,EndLine,EndPos:Integer):boolean;
Var
TypeName,FMethodName:String;
i:integer;
HAL:THalCompiler;
//----------------
procedure FindMethod;
Var
BPos:Integer;
begin
With HAL do
While True do
begin
Token:=ReadToken;
BPos:=CurRead;
if Token.id=idEndOfFile then break;
if (Token.id=idIdentifier) and (CompareText(Token.Data,TypeName)=0) then
begin
Token:=ReadToken;
If Token.id=idpoint then
begin
Token:=ReadToken;
If (Token.id=idIdentifier) and (CompareText(Token.Data,FMethodName)=0) then
begin
ConvertCurPos(EndLine,EndPos);
CurRead:=BPos-Length(TypeName);
ConvertCurPos(BegLine,BegPos);
Result:=True;
break;
end;
end;
end;
end;
end;
//----------------
begin
Result:=False;
i:=Pos('.',AMethodName);
TypeName:=Copy(AMethodName,1,i-1);
FMethodName:=Copy(AMethodName,i+1,MaxInt);
try
HAL:=THalCompiler.Create(S,nil);
FindMethod;
finally
HAl.Free;
end;
end;
{-----------------------------------------------------------}
Function FindProgramEnd(S:TMemoryStream; Var ALine,AChar:Integer):Boolean;
Var
HAL:THalCompiler;
sPos:Integer;
begin
Result:=False;
HAL:=THalCompiler.Create(S,nil);
Try
With HAL do
While True do
begin
Token:=ReadToken;
If Token.ID=idendoffile then break;
If Token.ID=id_unitinit then
begin
CurRead:=CurRead-Length('initialization');
ConvertCurPos(ALine,AChar);
Result:=True;
break;
end;
IF Token.ID=id_end then
begin
sPos:=CurRead;
Token:=ReadToken;
If Token.ID=idpoint then
begin
CurRead:=sPos-3;
ConvertCurPos(ALine,AChar);
Result:=True;
break;
end;
end;
end;
finally
HAL.Free;
end;
end;
{---------------------------------}
Procedure DelphinRegister;
Begin
RegisterComponents('Dream Controls', [THalComp]);
//RegisterPropertyEditor(typeinfo(String), thalcomp, 'EventLink', TMethodsProperty);
End;
{---------------------------------}
Procedure AddProc(Const Aname: String; ProcAddr: TProcType; Const Params: Array of byte);
var
APropName : String;
Begin
APropName := copy(AName,pos('.',AName)+1,length(AName));
Funs.AddItem(Aname, APropName, ProcAddr, true, false, false, Params);
End;
{--------------------------------}
Procedure AddFun(Const Aname: String; ProcAddr: TProcType;
Const Params: Array of byte);
var
APropName : String;
Begin
APropName := copy(AName,pos('.',AName)+1,length(AName));
Funs.AddItem(Aname, APropName, ProcAddr, false, false, false, Params);
End;
{--------------------------------}
Procedure AddArrayProp(Const Aname: String; ADim: Integer; ProcAddr, SetProcAddr: TProcType);
Var
A: Array[0..100] of byte;
i: integer;
APropName : String;
Begin
For i := 0 to ADim - 1 do
A[i] := 0; A[ADim] := 4;
APropName := copy(AName,pos('.',AName)+1,length(AName));
Funs.AddItem(Aname, APropName, ProcAddr, false, true, false, Slice(A, ADim));
If Assigned(SetProcAddr) then
Funs.AddItem(Aname + '_VET', APropName, SetProcAddr, false, true, true, Slice(A, ADim + 1));
End;
{--------------------------------}
Procedure AddProp(Const Aname: String; ProcAddr, SetProcAddr: TProcType);
var
APropName : String;
Begin
APropName := copy(AName,pos('.',AName)+1,length(AName));
Funs.AddItem(Aname, APropName, ProcAddr, false, true, false, [2]);
If Assigned(SetProcAddr) then
Funs.AddItem(Aname + '_SET', APropName, SetProcAddr, false, true, true, [0]);
End;
{--------------------------------}
{function SimpleCallHalProc(Const ProcName:String):Variant;
Var
s: Array[0..1] of variant;
begin
Result:=CallHalProc(ProcName,nil,S);
end;}
{--------------------------------}
(*
Function CallHalProc(Const procName: String;
slf: tobject; Var s: Array of variant): variant;
Var
R: TProcType;
Begin
Result := NULL;
R := GetHalProcAddr(procname);
If Assigned(R) then
Result := R(slf, s)
{ Else Raise
Exception.CreateFmt(fun_notfound, [AnsiUpperCase(procname)]);}
End;
*)
{------------------------------}
Constructor TFunList.Create;
Begin
Inherited Create;
Sorted := true;
Duplicates := dupIgnore;
End;
{-----------------------------------------------------------}
function Min(A,B:Integer):Integer;
begin
If A<B
then
Result:=A
else
Result:=B;
end;
{------------------------------}
Destructor TFunList.Destroy;
Var
i: integer;
Begin
For i := 0 to Count - 1 do
Objects[i].Free;
Inherited destroy;
End;
{------------------------------}
Procedure TFunList.AddItem(Const Aname,APropName: String; ProcAddr: TProcType;
Fun, IsProp, IsPropSet: Boolean; Const Params: Array of byte);
Var
t: TFunListItem;
i: integer;
Begin
Try
t := TFunListItem.Create;
If params[0] = 2 then
t.parcount := 0
else
t.ParCount := min(maxparams, high(Params) + 1);
t.Fun := Fun;
t.PropName := APropName;
t.IsProp := IsProp;
t.IsPropSet := IsPropSet;
t.procaddr := procaddr;
If params[0] <> 2 then
For i := 0 to min(high(Params), maxparams) do t.Params[i] := Params[i];
addobject(AnsiUpperCase(aname), t)
Except
Raise Exception.CreateFmt(SErrFunDefined, [ANAme]);
End;
End;
{------------------------------------------------------------------}
procedure DelProc(Const ProcName:String);
Var
i:Integer;
begin
With Funs do
If Find(AnsiUpperCase(ProcName),i) then
begin
Objects[i].Free;
Delete(i);
end{ else
Raise Exception.CreateFmt('Procedure %s not found',[ProcName])};
end;
{--------------------------------}
Function OV(S: TObject): Variant;
Begin
Result := ObjToVar(S);
End;
{--------------------------------}
Function VO(S: Variant): TObject;
Begin
Result := VarToObj(S);
End;
{--------------------------------}
Function ObjToVar(S: TObject): Variant;
Begin
TVarData(Result).VPointer := Pointer(s);
TVarData(Result).VType := vtinteger;
End;
{--------------------------------}
Function VarToObj(S: Variant): TObject;
Begin
Result := TObject(TVarData(S).VPointer);
End;
{--------------------------------}
{Function GetHalProcAddr(Const FunName: String): tproctype;
Var
i: integer;
Begin
Result := Nil;
If Funs.Find(AnsiUpperCase(FunName), i) then
Result := TFunListItem(Funs.Objects[i]).ProcAddr;
End;}
{----------------------------------------------}
Initialization
// addconst('pp',ssDouble);
Funs := TFunList.Create;
ResWords := TIdentList.Create;
InitReservedWords;
Dynavars := TDynaVars.Create;
InternalVariables := TInternalVar.Create;
ResConsts := TResConstList.Create;
RegisterClasses([THAlComp]);
InitHalUnit;
FLMethods := TList.Create;
EventList := TEventList.Create;
RegisterEvents;
// EventDispatcher:=CallEvent;
// ExecuteProgram:=RunFormModal;
Finalization
FLMethods.Free;
EventList.Free;
InternalVariables.Free;
ResWords.Free;
DynaVars.Free;
ResConsts.Free;
Funs.Free;
End.
Reference in New Issue View Git Blame Copy Permalink