{*******************************************************}
{                                                       }
{  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', 'À'..'ß', '_'];
  IdentBackChars: TCharSet = ['A'..'Z', '_', '0'..'9', 'À'..'ß'];
  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.