 {
@abstract(Execute part of the script engine)
@author(Carlo Kok <ck@carlo-kok.com>)
  The execute part of the script engine
}
unit ifps3;
{$I ifps3_def.inc}
{

Innerfuse Pascal Script III
Copyright (C) 2000-2003 by Carlo Kok (ck@carlo-kok.com)

}
interface
uses
  SysUtils, ifps3utl{$IFDEF IFPS3_HAVEVARIANT}{$IFDEF IFPS3_D6PLUS}, variants{$ENDIF}{$ENDIF};

type
  TIFPSExec = class;
{ TIFError contains all possible errors }
  TIFError = (ErNoError, erCannotImport, erInvalidType, ErInternalError,
    erInvalidHeader, erInvalidOpcode, erInvalidOpcodeParameter, erNoMainProc,
    erOutOfGlobalVarsRange, erOutOfProcRange, ErOutOfRange, erOutOfStackRange,
    ErTypeMismatch, erUnexpectedEof, erVersionError, ErDivideByZero, ErMathError,
    erCouldNotCallProc, erOutofRecordRange, erOutOfMemory, erException,
    erNullPointerException, erNullVariantError, erCustomError);
{ The current status of the script }
  TIFStatus = (isNotLoaded, isLoaded, isRunning, isPaused);
{Pointer to array of bytes}
  PByteArray = ^TByteArray;
{Array of bytes}
  TByteArray = array[0..1023] of Byte;
{Pointer to array of words}
  PDWordArray = ^TDWordArray;
{Array of dwords}
  TDWordArray = array[0..1023] of Cardinal;
{@link(TProcRec)
  PProcRec is pointer to a TProcRec record}
  PProcRec = ^TProcRec;
{@link(TIFProcRec)
  PIFProcRec is a pointer to a TIProcRec record}
  PIFProcRec = ^TIFProcRec;
{
@link(TIFPSExec)
@link(PIFProcRec)
@link(TIfList)
TIFProc is is the procedure definition of all external functions
}
  TIFProc = function(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
{
@link(PProcRec)
FreeProc is called when a PProcRec is freed}
  TIFFreeProc = procedure (Caller: TIFPSExec; p: PProcRec);
{TIFProcRec contains a currently used internal or external function}
  TIFProcRec = record
    {True means the procedure is external}
    ExternalProc: Boolean;
    {The exportname/decl used to identify the procedure}
    ExportName, ExportDecl: string;
    {ExportNameHash is used to quickly find an ExportName}
    ExportNameHash: Longint;
    {$IFDEF BCB}
    Name: ShortString;
    {$ENDIF}
    case Byte of
      0: (Data: PByteArray; Length: Cardinal);
      1: (ProcPtr: TIFProc; {$IFNDEF BCB}Name: ShortString; {$ENDIF}Ext1, Ext2: Pointer);
      // ExportDecl will contain Params in case of importing with Flags := 3;
  end;
{TProcrec is used to store an external function that could be used by the script executer}
  TProcRec = record
    Name: ShortString;
    Hash: Longint;
    ProcPtr: TIFProc;
    FreeProc: TIFFreeProc;
    Ext1, Ext2: Pointer;
  end;
{@link(TBTReturnAddress)
  PBTReturnAddress is a pointer to an TBTReturnAddress record}
  PBTReturnAddress = ^TBTReturnAddress;
{TBTReturnAddress is a record used to store return information}
  TBTReturnAddress = record
    ProcNo: PIFProcRec;
    Position, StackBase: Cardinal;
  end;

{@link(TVariantResourceFreeProc)
  TVRMode is used to when the scriptengine needs to free or duplicate a resourcepointer}
  TVRFMode = (vrfFree, vrfDuplicate);
  {@link(TIFVariant) PIFVariant is a pointer to a TIFVariant}
  PIFVariant = ^TIfVariant;
{@link(TVRMode)
  TVariantResourceFreeProc is used when the scriptengine needs to free or duplicate a resourcepointer}
  TVariantResourceFreeProc = function (FMode: TVRFMode; P, IntoP: PIFVariant): Boolean;
{ Pointer to @link(TIFTypeRec)}
  PIFTypeRec = ^TIFTypeRec;
{TIFTypeRec is used to store all types inside the script}
  TIFTypeRec = record
    {Ext is used in a typecopy or array to store more information
    }
    BaseType: TIFPSBaseType;
    ExportName: string;
    ExportNameHash: Longint;
    case Byte of
      0: (Ext: Pointer);
      1: (ResFree: TVariantResourceFreeProc);
  end;
  PIFSetTypeInfo = ^TIFSetTypeInfo;
  TIFSetTypeInfo = record
    aByteSize: Longint; { (abitsize div 8) + (abitsize and 7 > 0 ? 1 : 0) }
    aBitSize: Longint;
  end;
  PIFStaticArrayInfo = ^TIFStaticArrayInfo;
  TIFStaticArrayInfo = record
    aType: PIFTypeRec;
    Size: Longint;
  end;
{TIFArrayType is a pointer to an other type}
  TIFArrayType = PIFTypeRec;
{PIFRecordType is a pointer to record information}
  PIFRecordType = ^TIFRecordType;
{TIFRecordType is used to store information about records}
  TIFRecordType = record
    Data: string;
  end;
  {PBTRecord is a pointer to a @link(TbtRecord) record}
  pbtrecord = ^TbtRecord;
{TIFvariant is variant used for storing all variables used by the script engine}
  TIFVariant = packed record
    {The type of the variant}
    FType: PIFTypeRec;
    {The number of pointers referencing this variant}
    RefCount: Cardinal; // 0 = Freeable
    case Byte of
      1: (tu8: TbtU8);
      2: (tS8: TbtS8);
      3: (tu16: TbtU16);
      4: (ts16: TbtS16);
      5: (tu32: TbtU32);
      6: (ts32: TbtS32);
      7: (tsingle: TbtSingle);
      8: (tdouble: TbtDouble);
      9: (textended: TbtExtended);
      10: (tstring: Pointer);
      11: (treturnaddress: TBTReturnAddress);
      12: (trecord: pbtrecord);
      13: (tArray: pbtrecord);
      14: (tPointer: PIfVariant);
      15: (tResourceP1, tResourceP2: Pointer);
      16: (tvariant: PIFVariant);
      {$IFNDEF IFPS3_NOINT64}
      17: (ts64: Tbts64);
      {$ENDIF}
      19: (tchar: tbtChar);
      {$IFNDEF IFPS3_NOWIDESTRING}
      18: (twidestring: Pointer);
      20: (twidechar: tbtwidechar);
      {$ENDIF}
      21: (tset: Pointer);
  end;
  {Calling conventions}
  {TbtRecord is used to store the fields in a record or array}
  TbtRecord = packed record
    FieldCount: Cardinal;
    Fields: array[0..10000] of PIfVariant;
  end;
  {TIFPSResourceFreeProc is called when a resource needs to be freed}
  TIFPSResourceFreeProc = procedure (Sender: TIFPSExec; P: Pointer);
  {@link(TIFPSResource)
    PIFPSResource is a pointer to a TIFPSResource record
  }
  PIFPSResource = ^TIFPSResource;
  { A resource in IFPS3 is stored as a pointer to the proc and a tag (p) }
  TIFPSResource = record
    Proc: Pointer;
    P: Pointer;
  end;
  {@link(pbtrecord)
    PBTRecord}
  PBTArray = pbtrecord;
  {@link(TbtRecord)
  tbtrecord}
  TBTArray = TbtRecord;

  PResourcePtrSupportFuncs = ^TResourcePtrSupportFuncs;
  TResourcePtrToStrProc = function (PSelf: PResourcePtrSupportFuncs; Sender: TIFPSExec; P: PIFVariant): string;
  TVarResourcePtrToStrProc = function (PSelf: PResourcePtrSupportFuncs; Sender: TIFPSExec; P: PIFVariant): string;
  TResultToRsourcePtr = procedure(PSelf: PResourcePtrSupportFuncs; Sender: TIFPSExec; Data: Longint; P: PIFVariant);
  TRPSupports = function (PSet: PResourcePtrSupportFuncs; P: PIFVariant): Boolean;

  TRPSResultMethod = (rmParam, rmRegister);
  TResourcePtrSupportFuncs = record
    Ptr: Pointer;
    PtrToStr: TResourcePtrToStrProc;
    VarPtrToStr: TVarResourcePtrToStrProc;
    ResultMethod: TRPSResultMethod;
    ResToPtr: TResultToRsourcePtr;
    ProcPtrToStr: TResourcePtrToStrProc;
    PtrSupports: TRPSupports;
  end;

  {See TIFPSExec.OnRunLine}
  TIFPSOnLineEvent = procedure(Sender: TIFPSExec);
  {See TIFPSExec.AddSpecialProcImport}
  TIFPSOnSpecialProcImport = function (Sender: TIFPSExec; p: PIFProcRec; Tag: Pointer): Boolean;
  {See TIFPSExec.OnException}
  TIFPSOnException = procedure (Sender: TIFPSExec; ExError: TIFError; const ExParam: string; ExObject: TObject; ProcNo, Position: Cardinal);
  {TIFPSExec is the core of the script engine executer}
  TIFPSExec = class(TObject)
  Private
    FId: Pointer;
    FJumpFlag: Boolean;
    FCallCleanup: Boolean;
    FOnException: TIFPSOnException;
    function ReadData(var Data; Len: Cardinal): Boolean;
    function ReadLong(var b: Cardinal): Boolean;
    function DoCalc(var1, Var2: PIfVariant; CalcType: Cardinal): Boolean;
    function DoBooleanCalc(var1, Var2: PIfVariant; Into: PIfVariant; Cmd: Cardinal): Boolean;
    function SetVariantValue(dest, Src: PIfVariant): Boolean;
    function ReadVariable(var NeedToFree: LongBool; UsePointer: LongBool): PIfVariant;
    function DoBooleanNot(Vd: PIfVariant): Boolean;
    function DoMinus(Vd: PIfVariant): Boolean;
    function DoIntegerNot(Vd: PIfVariant): Boolean;
    function BuildArray(Dest, Src: PIFVariant): boolean;
    procedure RegisterStandardProcs;
  Protected
    {MM is the memory manager used internally. It's needed to create and destroy variants}
{$IFNDEF IFPS3_NOSMARTMM}MM: Pointer;
{$ENDIF}
    {Resource Types}
    FResourceTypes: TIfList;
    {Support functions}
    FRPSupFuncs: TIfList;
    {The exception stack}
    FExceptionStack: TIFList;
    {The list of resources}
    FResources: TIFList;
    {The list of exported variables}
    FExportedVars: TIfList;
    {FTypes contains all types used by the script}
    FTypes: TIfList; 
    {FProcs contains all script procedures}
    FProcs: TIfList; 
    {FGlobalVars contains the global variables of the current script}
    FGlobalVars: TIfList; 
    {The current stack}
    FStack: TIfList; 
    {The main proc no or -1 (no main proc)}
    FMainProc: Cardinal;
    {The current status of the script engine}
    FStatus: TIFStatus;
    {The current proc}
    FCurrProc: PIFProcRec;
    {The currproc^.data contents}
    FData: PByteArray;
    {Length of FData}
    FDataLength: Cardinal;
    {The current position in the current proc}
    FCurrentPosition: Cardinal;
    {Current stack base}
    FCurrStackBase: Cardinal;
    {FOnRunLine event}
    FOnRunLine: TIFPSOnLineEvent;
    {List of SpecialProcs; See TIFPSExec.AddSpecialProc}
    FSpecialProcList: TIfList;
    {List of all registered external functions}
    FRegProcs: TIfList;
    {The exception object from delphi}
    ExObject: TObject;
    {The proc where the last error occured}
    ExProc: Cardinal;
    {The position of the last error}
    ExPos: Cardinal;
    {The error code}
    ExEx: TIFError;
    {The optional parameter for the error}
    ExParam: string;
    {Call a method}
    function InnerfuseCall(_Self, Address: Pointer; CallingConv: TIFPSCallingConvention; Params: TIfList; res: PIfVariant): Boolean;
    {RunLine function}
    procedure RunLine; virtual;
    {ImportProc is called when the script needs to import an external function}
    function ImportProc(const Name: ShortString; var proc: TIFProcRec): Boolean; Virtual;
    {ExceptionProc is called when an error occurs}
    procedure ExceptionProc(proc, Position: Cardinal; Ex: TIFError; const s: string; NewObject: TObject); Virtual;
  Public
    procedure RegisterResourceType(const Name: string; FreeProc: TVariantResourceFreeProc);
    procedure RegisterRProcSupFuncs(P: PResourcePtrSupportFuncs);
    {Call CMD_Err to cause an error and stop the script}
    procedure CMD_Err(EC: TIFError);
    {Call CMD_Err2 to cause an error and stop the script}
    procedure CMD_Err2(EC: TIFError; const Param: string);
    {Call CMD_Err3 to cause an error and stop the script}
    procedure CMD_Err3(EC: TIFError; const Param: string; ExObject: TObject);
    {Optional tag of the script engine}
    property Id: Pointer read FID write FID;
    {The MemoryManager used when calling CreateVariant/DestroyVariant}
{$IFNDEF IFPS3_NOSMARTMM}property MemoryManager: Pointer Read MM;{$ENDIF}
    {This function will return about information}
    class function About: string;
    {Use RunProc to call a script function. The Params will not be freed after the call}
    function RunProc(Params: TIfList; ProcNo: Cardinal): Boolean;
    {Search for a type (l is the starting position)}
    function FindType(StartAt: Cardinal; BaseType: TIFPSBaseType; var l: Cardinal): PIFTypeRec;
    {Search for a type}
    function FindType2(BaseType: TIFPSBaseType): PIFTypeRec;
    {Return type no L}
    function GetTypeNo(l: Cardinal): PIFTypeRec;
    {Create an integer variant}
    function CreateIntegerVariant(FType: PIFTypeRec; Value: Longint): PIfVariant;
    {create a string variant}
    function CreateStringVariant(FType: PIFTypeRec; const Value: string): PIfVariant;
    {Create a float variant}
    function CreateFloatVariant(FType: PIFTypeRec; Value: Extended): PIfVariant;
    {Create class variant}
    function CreateObjectVariant(FType: PIFTypeRec; Value: TObject): PIfVariant;


    {Get Type that has been compiled with a name}
    function GetType(const Name: string): Cardinal;
    {Get function that has been compiled with a name}
    function GetProc(const Name: string): Cardinal;
    {Get variable that has been compiled with a name}
    function GetVar(const Name: string): Cardinal;
    {Get variable compiled with a name as a variant}
    function GetVar2(const Name: string): PIFVariant;
    {Get variable no (C)}
    function GetVarNo(C: Cardinal): PIFVariant;
    {Get Proc no (C)}
    function GetProcNo(C: Cardinal): PIFProcRec;

    {Create an instance of the executer}
    constructor Create;
	{Destroy this instance of the executer}
    destructor Destroy; Override;

	{Run the current script}
    function RunScript: Boolean;

	{Load data into the script engine}
    function LoadData(const s: string): Boolean; virtual;
	{Clear the currently loaded script}
    procedure Clear; Virtual;
	{Reset all variables in the script to zero}
    procedure Cleanup; Virtual;
    {Stop the script engine}
    procedure Stop; Virtual;
	{Pause the script engine}
    procedure Pause; Virtual;
    {Set CallCleanup to false when you don't want the script engine to cleanup all variables after RunScript}
    property CallCleanup: Boolean read FCallCleanup write FCallCleanup;
    {Status contains the current status of the scriptengine}
    property Status: TIFStatus Read FStatus;
	{The OnRunLine event is called after each executed script line}
    property OnRunLine: TIFPSOnLineEvent Read FOnRunLine Write FOnRunLine;
    {Clear the list of special proc imports}
    procedure ClearspecialProcImports;
    {Add a special proc import; this is used for the dll and class library}
    procedure AddSpecialProcImport(const FName: string; P: TIFPSOnSpecialProcImport; Tag: Pointer);
    {Register a function by name}
    function RegisterFunctionName(const Name: string; ProcPtr: TIFProc;
      Ext1, Ext2: Pointer): PProcRec;
    procedure RegisterDelphiFunction(ProcPtr: Pointer; const Name: string; CC: TIFPSCallingConvention);
   { Register a delphi function
    ProcPtr is a pointer to the proc to be called;
    Name is the name of that proc (uppercased).
    CC is the calling convention.}
    procedure RegisterDelphiMethod(Slf, ProcPtr: Pointer; const Name: string; CC: TIFPSCallingConvention);
   { Register a delphi function
    Slf is the self pointer, don't use nil, it won't work
    ProcPtr is a pointer to the proc to be called;
    Name is the name of that proc (uppercased).
    CC is the calling convention.}

	{Clear the function list}
    procedure ClearFunctionList;
    {Contains the last error proc}
    property ExceptionProcNo: Cardinal Read ExProc;
	{Contains the last error position}
    property ExceptionPos: Cardinal Read ExPos;
	{Contains the last error code}
    property ExceptionCode: TIFError Read ExEx;
	{Contains the last error string}
    property ExceptionString: string read ExParam;
  {Contains the exception object}
    property ExceptionObject: TObject read ExObject write ExObject;
    {Add a resource}
    procedure AddResource(Proc, P: Pointer);
	{Check if P is a valid resource for Proc}
    function IsValidResource(Proc, P: Pointer): Boolean;
	{Delete a resource}
    procedure DeleteResource(P: Pointer);
	{Find a resource}
    function FindProcResource(Proc: Pointer): Pointer;
	{Find a resource}
    function FindProcResource2(Proc: Pointer; var StartAt: Longint): Pointer;
    {Raises the current Exception object, or if that doesn't exist, an EIFPS3Exception. If there
    is no current exception in ifps3 at all, it does nothing}
    procedure RaiseCurrentException;
    {OnException is called when an exception occurs}
    property OnException: TIFPSOnException read FOnException write FOnException;
  end;
{Decrease the variant's refcount and free it if it's 0}
procedure DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM: Pointer; {$ENDIF}p: PIfVariant);
{Create a variant}
function CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MM: Pointer; {$ENDIF}n: PIFTypeRec): PIfVariant;
{Convert an error to a string}
function TIFErrorToString(x: TIFError; const Param: string): string;
{Get the value of a variant (as Cardinal/Longword)}
function GetUInt(Src: PIfVariant; var s: Boolean): Cardinal;
{Get the value of a variant (as Longint)}
function GetInt(Src: PIfVariant; var s: Boolean): Longint;
{Get the value of a variant (as Extended)}
function GetReal(Src: PIfVariant; var s: Boolean): Extended;
{Get the value of a variant (as String)}
function GetString(Src: PIfVariant; var s: Boolean): string;
{Set the value of an Int64 variant in a list}
{$IFNDEF IFPS3_NOINT64}
procedure LSetInt64(List: TIfList; Pos: Cardinal; Val: Int64);
{$ENDIF}
{Set the value of an Integer variant in a list}
procedure LSetInt(List: TIfList; Pos: Cardinal; Val: Longint);
{Set the value of an unsigned integer variant in a list}
procedure LSetUInt(List: TIfList; Pos: Cardinal; Val: Cardinal);
{Get the value of an Int64 variant in a list}
{$IFNDEF IFPS3_NOINT64}
function LGetInt64(List: TIfList; Pos: Cardinal): Int64;
{$ENDIF}
{Get the value of an Integer variant in a list}
function LGetInt(List: TIfList; Pos: Cardinal): Longint;
{Get the value of an unsigned integer variant in a list}
function LGetUInt(List: TIfList; Pos: Cardinal): Cardinal;
{Set the value of a string variant in a list}
procedure LSetStr(List: TIfList; Pos: Cardinal; const s: string);
{Get the value of a string variant in a list}
function LGetStr(List: TIfList; Pos: Cardinal): string;
{Set the value of a real variant in a list}
procedure LSetReal(List: TIfList; Pos: Cardinal; const Val: Extended);
{Get the value of a real variant in a list}
function LGetReal(List: TIfList; Pos: Cardinal): Extended;
{Get the length of a variant array}
function GetIFPSArrayLength(SE: TIFPSExec; p: PIfVariant): Cardinal;
{Set the length of a variant array}
function SetIFPSArrayLength(SE: TIFPSExec; p: PIfVariant; NewLength: Cardinal): Boolean;

{Convert a variant to a string}
function IFPSVariantToString(p: PIfVariant; const ClassProperties: string): string;
{Free a list of variants and also the list}
procedure FreePIFVariantList({$IFNDEF IFPS3_NOSMARTMM}MM: Pointer; {$ENDIF}List: TIfList);

function VGetAsString(P: PIFVariant): string;
{Returns the value of p if it's a string}
function VGetString(P: PIFVariant): string;
{Returns the value of p if it's a float}
function VGetFloat(P: PIFVariant): Extended;
{Returns the value of p if it's a integer}
function VGetInt(P: PIFVariant): Longint;
{$IFNDEF IFPS3_NOINT64}
{Returns the value of p if it's a int64}
function VGetInt64(P: PIFVariant): Int64;
{$ENDIF}

{Sets the value of p if it's a string}
procedure VSetString(P: PIFVariant; const d: string);
{Sets the value of p if it's a float}
procedure VSetFloat(P: PIFVariant; const d: Extended);
{Sets the value of p if it's a int}
procedure VSetInt(P: PIFVariant; const d: Longint);
{$IFNDEF IFPS3_NOINT64}
{Sets the value of p if it's a int64}
procedure VSetInt64(P: PIFVariant; const d: Int64);
{$ENDIF}

function RP(P: PIFVariant): PIFVariant;
// Makes sure that P is not a pointer.

const
  ENoError = ERNoError;

procedure ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}MM: Pointer; {$ENDIF}p: PIFVariant; n: PIFTypeRec);

{$IFDEF IFPS3_HAVEVARIANT}
function PIFVariantToVariant(Sender: TIFPSExec; Src: PIFVariant; var Dest: Variant): Boolean;
function VariantToPIFVariant(Sender: TIFPSExec; const Src: Variant; Dest: PIFVariant): Boolean;
{$ENDIF}


type
  EIFPS3Exception = class(Exception)
  private
    FProcPos: Cardinal;
    FProcNo: Cardinal;
    FExec: TIFPSExec;
  public
    constructor Create(const Error: string; Exec: TIFPSExec; Procno, ProcPos: Cardinal);
    property ProcNo: Cardinal read FProcNo;
    property ProcPos: Cardinal read FProcPos;
    property Exec: TIFPSExec read FExec;
  end;
  {TIFPSRuntimeClass is one class at runtime}
  TIFPSRuntimeClass = class
  protected
    FClassName: string;
    FClassNameHash: Longint;

    FClassItems: TIFList;
    FClass: TClass;

    FEndOfVmt: Longint;
  public
    {Register a constructor}
    procedure RegisterConstructor(ProcPtr: Pointer; const Name: string);
	{Register a virtual constructor}
    procedure RegisterVirtualConstructor(ProcPtr: Pointer; const Name: string);
	{Register a method}
    procedure RegisterMethod(ProcPtr: Pointer; const Name: string);
	{Register a virtual method}
    procedure RegisterVirtualMethod(ProcPtr: Pointer; const Name: string);
	{Register an abstract virtual method}
    procedure RegisterVirtualAbstractMethod(ClassDef: TClass; ProcPtr: Pointer; const Name: string);
    {Register a property helper}
    procedure RegisterPropertyHelper(ReadFunc, WriteFunc: Pointer; const Name: string);
    {Register a property helper that is an event}
    procedure RegisterEventPropertyHelper(ReadFunc, WriteFunc: Pointer; const Name: string);
    {create}
    constructor Create(aClass: TClass; const AName: string);
	{destroy}
    destructor Destroy; override;
  end;
  {TIFPSRuntimeClassImporter is the runtime class importer}
  TIFPSRuntimeClassImporter = class
  private
    FClasses: TIFList;
  public
    {create}
    constructor Create;
    constructor CreateAndRegister(Exec: TIFPSexec; AutoFree: Boolean);
	{destroy}
    destructor Destroy; override;
    {Add a class}
    function Add(aClass: TClass): TIFPSRuntimeClass;
    function Add2(aClass: TClass; const Name: string): TIFPSRuntimeClass;
    {Clear}
    procedure Clear;
    {Search for a class}
    function FindClass(const Name: string): TIFPSRuntimeClass;
  end;


{Register the classes at runtime}
procedure RegisterClassLibraryRuntime(SE: TIFPSExec; Importer: TIFPSRuntimeClassImporter);
{Set a runtime variant}
procedure SetVariantToClass(V: PIFVariant; Cl: TObject);
{Internal function: Script Event Handler<br>
Supported Parameter Types:<br>
  u8,s8,u16,s16,u32,s32,s64,single,double,extended,class,variant,string,char<br>
Supported Result Types:<br>
  u8,s8,u16,s16,u32,s32,string,variant
}
procedure MyAllMethodsHandler;
{Internal Function: Returns the Data pointer of a TMethod for a ProcNo}
function GetMethodInfoRec(SE: TIFPSExec; ProcNo: Cardinal): Pointer;
{Make a method pointer of a script engine + function number, not that
this doesn't work unless the proc was exported with ExportMode etExportDecl}
function MkMethod(FSE: TIFPSExec; No: Cardinal): TMethod;

type
  {Alias to @link(ifps3utl.TIFPSCallingConvention)}
  TIFPSCallingConvention = ifps3utl.TIFPSCallingConvention;
const
  {Alias to @link(ifps3utl.cdRegister)}
  cdRegister = ifps3utl.cdRegister;
  {Alias to @link(ifps3utl.cdPascal)}
  cdPascal = ifps3utl.cdPascal;
  {Alias to @link(ifps3utl.cdCdecl)}
  cdCdecl = ifps3utl.cdCdecl;
  {Alias to @link(ifps3utl.cdStdCall)}
  cdStdCall = ifps3utl.cdStdCall;
  {Invalid results}
  InvalidVal = Cardinal(-1);

{Internal Function: Class Resource Free function for all class instance pointers}
function ClassResourceFree(FMode: TVRFMode; P, IntoP: PIFVariant): Boolean;


implementation
uses
  TypInfo;


type
  PRaiseFrame = ^TRaiseFrame;
  TRaiseFrame = record
    NextRaise: PRaiseFrame;
    ExceptAddr: Pointer;
    ExceptObject: TObject;
    ExceptionRecord: Pointer;
  end;

procedure Set_Union(Dest, Src: PByteArray; ByteSize: Integer);
var
  i: Longint;
begin
  for i := ByteSize -1 downto 0 do
    Dest^[i] := Dest^[i] or Src^[i];
end;

procedure Set_Diff(Dest, Src: PByteArray; ByteSize: Integer);
var
  i: Longint;
begin
  for i := ByteSize -1 downto 0 do
    Dest^[i] := Dest^[i] and not Src^[i];
end;

procedure Set_Intersect(Dest, Src: PByteArray; ByteSize: Integer);
var
  i: Longint;
begin
  for i := ByteSize -1 downto 0 do
    Dest^[i] := Dest^[i] and Src^[i];
end;

procedure Set_Subset(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
var
  i: Integer;
begin
  for i := ByteSize -1 downto 0 do
  begin
    if not (Src^[i] and Dest^[i] = Dest^[i]) then
    begin
      Val := False;
      exit;
    end;
  end;
  Val := True;
end;

procedure Set_Equal(Dest, Src: PByteArray; ByteSize: Integer; var Val: Boolean);
var
  i: Longint;
begin
  for i := ByteSize -1 downto 0 do
  begin
    if Dest^[i] <> Src^[i] then
    begin
      Val := False;
      exit;
    end;
  end;
  val := True;
end;

procedure Set_membership(Item: Longint; Src: PByteArray; var Val: Boolean);
begin
  Val := (Src^[Item shr 3] and (1 shl (Item and 7))) <> 0;
end;

function RP(P: PIFVariant): PIFVariant;
begin
  if (p <> nil) and (p^.FType^.BaseType = btPointer) then
    Result:= p^.tPointer
  else
    Result := p;
end;

procedure RCIFreeProc(Sender: TIFPSExec; P: TIFPSRuntimeClassImporter);
begin
  p.Free;
end;

function Trim(const s: string): string;
begin
  Result := s;
  while (Length(result) > 0) and (Result[1] = #32) do Delete(Result, 1, 1);
  while (Length(result) > 0) and (Result[Length(Result)] = #32) do Delete(Result, Length(Result), 1);
end;
function FloatToStr(E: Extended): string;
var
  s: string;
begin
  Str(e:0:12, s);
  result := s;
end;
//-------------------------------------------------------------------

function Padl(s: string; i: longInt): string;
begin
  result := StringOfChar(' ', i - length(s)) + s;
end;
//-------------------------------------------------------------------

function Padz(s: string; i: longInt): string;
begin
  result := StringOfChar('0', i - length(s)) + s;
end;
//-------------------------------------------------------------------

function Padr(s: string; i: longInt): string;
begin
  result := s + StringOfChar(' ', i - Length(s));
end;
//-------------------------------------------------------------------

function VarProc(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
var
  PStart: Cardinal;
  Pp: PIFVariant;
begin
  if p^.Ext1 = Pointer(0) then
  begin
    PStart := Stack.Count -2;
    pp := rp(Stack[PStart]);
    if (pp = nil) or (pp^.FType^.BaseType <> btVariant) then begin
      Result := False;
      Exit;
    end;
    Inc(PStart);
    if pp^.tvariant^.FType = nil then LSetInt(Stack, PStart, 0) else
    case pp^.TVariant^.FType^.BaseType of
      btU8: LSetInt(Stack, PStart, 8);
      btS8: LSetInt(Stack, PStart, 7);
      btU16: LSetInt(Stack, PStart, 6);
      btS16: LSetInt(Stack, PStart, 5);
      btU32: LSetInt(Stack, PStart, 4);
      btS32: LSetInt(Stack, PStart, 3);
      btSingle: LSetInt(Stack, PStart, 9);
      btDouble: LSetInt(Stack, PStart, 10);
      btExtended: LSetInt(Stack, PStart, 11);
      btPChar, btString: LSetInt(Stack, PStart, 1);
      btRecord: LSetInt(Stack, PStart, 14);
      btArray: LSetInt(Stack, PStart, 13);
      btResourcePointer: LSetInt(Stack, PStart, 12);
      btChar: LSetInt(Stack, PStart, 15);
      {$IFNDEF IFPS3_NOWIDESTRING}
      btWideString: LSetInt(Stack, PStart, 16);
      btWideChar: LSetInt(Stack, PStart, 17);
      {$ENDIF}
      {$IFNDEF IFPS3_NOINT64}
      btS64: LSetInt(Stack, PStart, 2);
      {$ENDIF}
    else
      LSetInt(Stack, PStart, 0);
    end;
    Result := True;
  end else if p^.Ext1 = Pointer(1) then
  begin
    Pp := rp(Stack[Stack.Count-1]);
    if (pp = nil) or (pp^.FType^.BaseType <> btVariant) then
    begin
      Result := False;
      exit;
    end;
    ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}caller.MemoryManager, {$ENDIF} pp^.tVariant, nil);
    Result := True;
  end else begin
    Result := False;
  end;
end;


function DefProc(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
var
  PStart: Cardinal;
  temp: PIfVariant;
  I: Longint;
  b: Boolean;
  E: Extended;
  Tmp: TObject;
begin
  case Longint(p^.Ext1) of
    0: // inttostr
      begin
        PStart := Stack.Count - 2;
        LSetStr(Stack, PStart + 1, IntToStr(LGetInt(Stack, PStart)));
        Result := True;
      end;
    1: // strtoint
      begin
        PStart := Stack.Count - 2;
        LSetInt(Stack, PStart+1, StrToInt(LGetStr(Stack, PStart)));
        Result := True;
      end;
    2: // strtointdef
      begin
        PStart := Stack.Count - 3;
        LSetInt(Stack, PStart+2, StrToIntDef(LGetStr(Stack, PStart + 1), LGetInt(Stack, PStart)));
        Result := True;
      end;
    3: // pos
      begin
        PStart := Stack.Count - 3;
        LSetInt(Stack, PStart+2,Pos(LGetStr(Stack, PStart+1), LGetStr(Stack, PStart)));
        Result := True;
      end;
    4: // copy
      begin
        PStart := Stack.Count - 4;
        LSetStr(Stack, PStart + 3,Copy(LGetStr(Stack, PStart+2), LGetInt(Stack, PStart + 1), LGetInt(Stack, PStart)));
        Result := True;
      end;
    5: //delete
      begin
        PStart := Stack.Count - 3;
        temp := rp(Stack[PStart + 2]);
        if (temp = nil) or (temp^.FType^.BaseType <> btString) then begin
          Result := False;
          exit;
        end;
        Delete(string(temp^.tstring), LGetInt(Stack, PStart + 1), LGetInt(Stack, PStart));
        Result := True;
      end;
    6: // insert
      begin
        PStart := Stack.Count - 3;
        temp := rp(Stack[PStart + 1]);
        if (temp = nil) or (temp^.FType^.BaseType <> btString) then begin
          Result := False;
          exit;
        end;
        Insert(LGetStr(Stack, PStart + 2), string(temp^.tstring), LGetInt(Stack, PStart + 0));
        Result := True;
      end;
    7: // StrGet
      begin
        PStart := Stack.Count - 3;
        temp := rp(Stack[PStart + 1]);
        if (temp = nil) or (temp^.FType^.BaseType <> btString) then begin
          Result := False;
          exit;
        end;
        I := LGetInt(Stack, PStart);
        if (i<1) or (i>length(string(temp^.tstring))) then
        begin
          Caller.CMD_Err2(erCustomError, 'Out Of String Range');
          Result := False;
          exit;
        end;
        LSetInt(Stack, PStart +2, Ord(string(temp^.tstring)[i]));
        Result := True;
      end;
    8: // StrSet
      begin
        PStart := Stack.Count - 3;
        temp := rp(Stack[PStart]);
        if (temp = nil) or (temp^.FType^.BaseType <> btString) then begin
          Result := False;
          Caller.CMD_Err2(erCustomError, 'Invalid Type');
          exit;
        end;
        I := LGetInt(Stack, PStart + 1);
        if (i<1) or (i>length(string(temp^.tstring))) then
        begin
          Caller.CMD_Err2(erCustomError, 'Out Of String Range');
          Result := True;
          exit;
        end;
        string(temp^.tstring)[i] := chr(LGetInt(Stack, PStart + 2));
        Result := True;
      end;
    10: // Uppercase
      begin
        PStart := STack.Count -2;
        LSetStr(Stack, PStart + 1, FastUppercase(LGetStr(Stack, PStart)));
        Result := True;
      end;
    11: // LowerCase
      begin
        PStart := STack.Count -2;
        LSetStr(Stack, PStart + 1, FastLowercase(LGetStr(Stack, PStart)));
        Result := True;
      end;
    12: // Trim
      begin
        PStart := STack.Count -2;
        LSetStr(Stack, PStart + 1, Trim(LGetStr(Stack, PStart)));
        Result := True;
      end;
    13: // Length
      begin
        PStart := Stack.Count - 2;
        LSetInt(Stack, PStart + 1, Length(LGetStr(Stack, PStart)));
        Result := True;
      end;
    14: // SetLength
      begin
        PStart := Stack.Count - 2;
        temp := rp(Stack[PStart+1]);
        if (temp = nil) or (temp^.FType^.BaseType <> btString) then begin
          Result := False;
          exit;
        end;
        SetLength(string(temp^.tstring), LGetInt(Stack, PStart));
        Result := True;
      end;
    15: // Sin
      begin
        PStart := Stack.Count - 2;
        try
          LSetReal(Stack, PStart + 1, Sin(LGetReal(Stack, PStart)));
        except
          Caller.CMD_Err2(erCustomError, 'Floating Point Exception');
        end;
        Result := True;
      end;
    16: // Cos
      begin
        PStart := Stack.Count - 2;
        try
          LSetReal(Stack, PStart + 1, Cos(LGetReal(Stack, PStart)));
        except
          Caller.CMD_Err2(erCustomError, 'Floating Point Exception');
        end;
        Result := True;
      end;
    17: // Sqrt
      begin
        PStart := Stack.Count - 2;
        try
          LSetReal(Stack, PStart + 1, Sqrt(LGetReal(Stack, PStart)));
        except
          Caller.CMD_Err2(erCustomError, 'Floating Point Exception');
        end;
        Result := True;
      end;
    18: // Round
      begin
        PStart := Stack.Count - 2;
        try
          LSetInt(Stack, PStart + 1, Round(LGetReal(Stack, PStart)));
        except
          Caller.CMD_Err2(erCustomError, 'Floating Point Exception');
        end;
        Result := True;
      end;
    19: // Trunc
      begin
        PStart := Stack.Count - 2;
        try
          LSetInt(Stack, PStart + 1, Trunc(LGetReal(Stack, PStart)));
        except
          Caller.CMD_Err2(erCustomError, 'Floating Point Exception');
        end;
        Result := True;
      end;
    20: // Int
      begin
        PStart := Stack.Count - 2;
        try
          LSetReal(Stack, PStart + 1, Int(LGetReal(Stack, PStart)));
        except
          Caller.CMD_Err2(erCustomError, 'Floating Point Exception');
        end;
        Result := True;
      end;
    21: // Pi
      begin
        PStart := Stack.Count - 1;
        try
          LSetReal(Stack, PStart, PI);
        except
          Caller.CMD_Err2(erCustomError, 'Floating Point Exception');
        end;
        Result := True;
      end;
    22: // Abs
      begin
        PStart := Stack.Count - 2;
        try
          LSetReal(Stack, PStart + 1, Abs(LGetReal(Stack, PStart)));
        except
          Caller.CMD_Err2(erCustomError, 'Floating Point Exception');
        end;
        Result := True;
      end;
    23: // StrToFloat
      begin
        PStart := Stack.Count - 2;
        try
          Val(LGetStr(Stack, PStart), E, I);
          LSetReal(Stack, PStart + 1, E);
        except
          Caller.CMD_Err2(erCustomError, 'Floating Point Exception');
        end;
        Result := True;
      end;
    24: // FloatToStr
      begin
        PStart := Stack.Count - 2;
        try
          LSetStr(Stack, PStart + 1, FloatToStr(LGetReal(Stack, PStart)));
        except
          Caller.CMD_Err2(erCustomError, 'Floating Point Exception');
        end;
        Result := True;
      end;
    25: //  PadL
      begin
        PStart := Stack.Count - 3;
        LSetStr(Stack, PStart + 2, Padl(LGetStr(Stack, PStart + 1), LGetUInt(Stack, PStart)));
        Result := True;
      end;
    26: // PadR
      begin
        PStart := Stack.Count - 3;
        LSetStr(Stack, PStart + 2, Padr(LGetStr(Stack, PStart + 1), LGetUInt(Stack, PStart)));
        Result := True;
      end;
    27: // PadZ
      begin
        PStart := Stack.Count - 3;
        LSetStr(Stack, PStart + 2, Padz(LGetStr(Stack, PStart + 1), LGetUInt(Stack, PStart)));
        Result := True;
      end;
    28: // Replicate/StrOfChar
      begin
        PSTart := Stack.Count - 3;
        LSetStr(Stack, PStart + 2, StringOfChar(Char(LGetInt(Stack, PStart + 1)), LGetInt(Stack, PStart)));
        Result := True;
      end;
    29: // Assigned
      begin
        temp := rp(Stack[Stack.Count -2]);
        if Temp = nil then
        begin
          Result := False;
          exit;
        end;

        case temp^.FType^.BaseType of
          btU8, btS8: b := Temp^.tu8 <> 0;
          btU16, btS16: b := Temp^.tu16 <> 0;
          btU32, btS32: b := Temp^.tu32 <> 0;
          btString, btPChar: b := Temp^.tstring <> nil;
          btArray: b := Temp^.tarray <> nil;
          btPointer: b := Temp^.tpointer <> nil;
          btResourcePointer: b := (temp^.tResourceP1 <> nil) or (temp^.tResourceP2 <> nil);
        else
          Result := False;
          Exit;
        end;
        if b then
          LSetInt(Stack, Stack.Count -1, 1)
        else
          LSetInt(Stack, Stack.Count -1, 0);
        Result := True;
      end;
    30: begin {RaiseLastException}
        Tmp := Caller.ExObject;
        Caller.ExObject := nil;
        Caller.ExceptionProc(Caller.ExProc, Caller.ExPos, Caller.ExEx, Caller.ExParam, tmp);
        Result := True;
    end;
    31: begin {RaiseExeption}
        Caller.CMD_Err2(TIFError(LGetInt(Stack, Stack.Count -1)), LGetStr(Stack, Stack.Count -2));
        Result := True;
    end;
    32: begin {ExceptionType}
        LSetInt(Stack, Stack.Count -1, Ord(Caller.ExEx));
        Result := True;
    end;
    33: begin {ExceptionParam}
        LSetstr(Stack, Stack.Count -1, Caller.ExParam);
        Result := True;
    end;
    34: begin {ExceptionProc}
        LSetInt(Stack, Stack.Count -1, Caller.ExProc);
        Result := True;
    end;
    35: begin {ExceptionPos}
        LSetInt(Stack, Stack.Count -1, Caller.ExPos);
        Result := True;
    end;
    36:
        begin {ExceptionToString}
          LSetStr(Stack, Stack.Count -1, TIFErrorToString(TIFError(LGetInt(Stack, Stack.Count -2)), LGetStr(Stack, Stack.Count -3)));
          Result := True;
        end;
    37: // AnsiUppercase
      begin
        PStart := STack.Count -2;
        LSetStr(Stack, PStart + 1, AnsiUppercase(LGetStr(Stack, PStart)));
        Result := True;
      end;
    38: // AnsiLowerCase
      begin
        PStart := STack.Count -2;
        LSetStr(Stack, PStart + 1, AnsiLowercase(LGetStr(Stack, PStart)));
        Result := True;
      end;
{$IFNDEF IFPS3_NOINT64}
    39: // StrToInt64
      begin
        PStart := STack.Count -2;
        LSetInt64(Stack, PStart + 1, StrToInt64(LGetStr(Stack, PStart)));
        Result := True;
      end;
    40: // Int64ToStr
      begin
        PStart := STack.Count -2;
        LSetStr(Stack, PStart + 1, SysUtils.IntToStr(LGetInt64(Stack, PStart)));
        Result := True;
      end;
{$ENDIF}
    else
      Result := False;
  end;
end;

function GetArrayLength(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
var
  PStart: Cardinal;
begin
  PStart := Stack.Count - 2;
  LSetInt(Stack, PStart + 1, GetIFPSArrayLength(Caller, Stack[PStart]));
  Result := True;
end;

function min(const x,y: integer): integer;
begin
  if x < y then result := x else result := y;
end;

function SetArrayLength(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
var
  PStart: Cardinal;
begin
  PStart := Stack.Count - 2;
  Result := SetIFPSArrayLength(Caller, Stack[PStart + 1], LGetInt(Stack, PStart));
end;
{
Function StrGet(S : String; I : Integer) : Char;
procedure StrSet(c : Char; I : Integer; var s : String);
Function Uppercase(s : string) : string;
Function Lowercase(s : string) : string;
Function Trim(s : string) : string;
Function Length(s : String) : Longint;
procedure SetLength(var S: String; L: Longint);
Function Sin(e : Extended) : Extended;
Function Cos(e : Extended) : Extended;
Function Sqrt(e : Extended) : Extended;
Function Round(e : Extended) : Longint;
Function Trunc(e : Extended) : Longint;
Function Int(e : Extended) : Longint;
Function Pi : Extended;
Function Abs(e : Extended) : Extended;
Function Sqrt(e : Extended) : Extended;
function StrToFloat(s: string): Extended;
Function FloatToStr(e : Extended) : String;
Function Padl(s : string;I : longInt) : string;
Function Padr(s : string;I : longInt) : string;
Function Padz(s : string;I : longInt) : string;
Function Replicate(c : char;I : longInt) : string;
Function StringOfChar(c : char;I : longInt) : string;
}

function VGetAsString(P: PIFVariant): string;
begin
  p := RP(p);
  if p = nil then begin Result := ''; exit; end;
  case p^.FType^.BaseType of
    btString: Result := TbtString(p^.tstring);
    btChar: Result := p.tchar;
    {$IFNDEF IFPS3_NOWIDESTRING}
    btWideString: Result := tbtWideString(p^.twidestring);
    btWideChar: Result := tbtWideChar(p^.twidechar);
    {$ENDIF}
    btSingle: Str(p^.tsingle, Result);
    btDouble: Str(p^.tdouble, Result);
    btExtended: Str(p^.textended, Result);
    btu8: Result := IntToStr(p^.tu8);
    bts8: Result := IntToStr(p^.ts8);
    btu16: Result := IntToStr(p^.tu16);
    bts16: Result := IntToStr(p^.ts16);
    btu32, btProcPtr: Result := IntToStr(p^.tu32);
    bts32: Result := IntToStr(p^.ts32);
    {$IFNDEF IFPS3_NOINT64}
    bts64: Result := IntToStr(p^.ts64);
    {$ENDIF}
    btResourcePointer: Result := '(Resource Pointer)';
    else Result := '';
  end;
end;

function VGetString(P: PIFVariant): string;
begin
  p := RP(p);
  if p = nil then begin Result := ''; exit; end;
  case p^.FType^.BaseType of
    btString: Result := TbtString(p^.tstring);
    btChar: Result := p.tchar;
    {$IFNDEF IFPS3_NOWIDESTRING}
    btWideString: Result := tbtWideString(p^.twidestring);
    btWideChar: Result := tbtWideChar(p^.twidechar);
    {$ENDIF}
    else Result := '';
  end;
end;

function VGetFloat(P: PIFVariant): Extended;
begin
  p := RP(p);
  if p = nil then begin Result := 0; exit; end;
  case p^.FType^.BaseType of
    btSingle: Result := p^.tsingle;
    btDouble: Result := p^.tdouble;
    btExtended: Result := p^.textended;
    else Result := 0;
  end;
end;
function VGetInt(P: PIFVariant): Longint;
begin
  p := RP(p);
  if p = nil then begin Result := 0; exit; end;
  case p^.FType^.BaseType of
    btu8: Result := p^.tu8;
    bts8: Result := p^.ts8;
    btu16: Result := p^.tu16;
    bts16: Result := p^.ts16;
    btu32, btProcPtr: Result := p^.tu32;
    bts32: Result := p^.ts32;
    {$IFNDEF IFPS3_NOINT64}
    bts64: Result := p^.ts64;
    {$ENDIF}
    else Result := 0;
  end;
end;
{$IFNDEF IFPS3_NOINT64}

function VGetInt64(P: PIFVariant): Int64;
begin
  p := RP(p);
  if p = nil then begin Result := 0; exit; end;
  case p^.FType^.BaseType of
    btu8: Result := p^.tu8;
    bts8: Result := p^.ts8;
    btu16: Result := p^.tu16;
    bts16: Result := p^.ts16;
    btu32, btProcPtr: Result := p^.tu32;
    bts32: Result := p^.ts32;
    btS64: Result := p^.ts64;
    else Result := 0;
  end;
end;
{$ENDIF}
procedure VSetString(P: PIFVariant; const d: string);
begin
  p := RP(p);
  if p = nil then begin exit; end;
  case p^.FType^.BaseType of
    btString: TbtString(p^.tstring) := d;
    {$IFNDEF IFPS3_NOWIDESTRING}
    btWideString: tbtWideString(p^.twidestring) := d;
    {$ENDIF}
  end;
end;
procedure VSetFloat(P: PIFVariant; const d: Extended);
begin
  p := RP(p);
  if p = nil then begin exit; end;
  case p^.FType^.BaseType of
    btSingle: p^.tsingle := d;
    btDouble: p^.tdouble := d;
    btExtended: p^.textended := d;
  end;
end;
procedure VSetInt(P: PIFVariant; const d: Longint);
begin
  p := RP(p);
  if p = nil then begin exit; end;
  case p^.FType^.BaseType of
    btu8: p^.tu8 := d;
    bts8: p^.ts8 := d;
    btu16: p^.tu16 := d;
    bts16: p^.ts16 := d;
    btu32, btProcPtr: p^.tu32 := d;
    bts32: p^.ts32 := d;
    btChar: p^.tchar:= char(d);
  end;
end;
{$IFNDEF IFPS3_NOINT64}
procedure VSetInt64(P: PIFVariant; const d: Int64);
begin
  p := RP(p);
  if p = nil then begin exit; end;
  case p^.FType^.BaseType of
    btu8: p^.tu8 := d;
    bts8: p^.ts8 := d;
    btu16: p^.tu16 := d;
    bts16: p^.ts16 := d;
    btu32, btProcPtr: p^.tu32 := d;
    bts32: p^.ts32 := d;
    btS64: p^.ts64 := d;
    btChar: p^.tchar := char(d);
  end;
end;
{$ENDIF}

{$IFNDEF IFPS3_NOWIDESTRING}
function MakeWString(const s: widestring): string;
var
  i: Longint;
  e: string;
  b: boolean;
begin
  Result := s;
  i := 1;
  b := false;
  while i <= length(result) do
  begin
    if Result[i] = '''' then
    begin
      if not b then
      begin
        b := true;
        Insert('''', Result, i);
        inc(i);
      end;
      Insert('''', Result, i);
      inc(i, 2);
    end else if (Result[i] < #32) or (Result[i] > #255) then
    begin
      e := '#'+inttostr(ord(Result[i]));
      Delete(Result, i, 1);
      if b then
      begin
        b := false;
        Insert('''', Result, i);
        inc(i);
      end;
      Insert(e, Result, i);
      inc(i, length(e));
    end else begin
      if not b then
      begin
        b := true;
        Insert('''', Result, i);
        inc(i, 2);
      end else
        inc(i);
    end;
  end;
  if b then
  begin
    Result := Result + '''';
  end;
  if Result = '' then
    Result := '''''';
end;
{$ENDIF}
function MakeString(const s: string): string;
var
  i: Longint;
  e: string;
  b: boolean;
begin
  Result := s;
  i := 1;
  b := false;
  while i <= length(result) do
  begin
    if Result[i] = '''' then
    begin
      if not b then
      begin
        b := true;
        Insert('''', Result, i);
        inc(i);
      end;
      Insert('''', Result, i);
      inc(i, 2);
    end else if (Result[i] < #32) then
    begin
      e := '#'+inttostr(ord(Result[i]));
      Delete(Result, i, 1);
      if b then
      begin
        b := false;
        Insert('''', Result, i);
        inc(i);
      end;
      Insert(e, Result, i);
      inc(i, length(e));
    end else begin
      if not b then
      begin
        b := true;
        Insert('''', Result, i);
        inc(i, 2);
      end else
        inc(i);
    end;
  end;
  if b then
  begin
    Result := Result + '''';
  end;
  if Result = '' then
    Result := '''''';
end;

function ClassResourceFree(FMode: TVRFMode; P, IntoP: PIFVariant): Boolean;
begin
  case FMode of
    vrfFree:
      begin
        if @p.FType.ResFree <> @ClassResourceFree then
        begin
          Result := False;
          exit;
        end;
        p.tResourceP1 := nil;
      end;
    vrfDuplicate:
      begin
        if (@IntoP.FType.ResFree <> @p.FType.ResFree) or (@IntoP.FType.ResFree <> @ClassResourceFree) then
        begin
          Result := False;
          exit;
        end;
        IntoP.tResourceP1 := p.tResourceP1;
      end;
    else
    begin
      Result := False;
      exit;
    end;
  end;
  Result := True;
end;

function PropertyToString(Instance: TObject; PName: string): string;
var
  s: string;
  i: Longint;
  PP: PPropInfo;
begin
  if PName = '' then
  begin
    Result := Instance.ClassName;
    exit;
  end;
  while Length(PName) > 0 do
  begin
    i := pos('.', pname);
    if i = 0 then
    begin
      s := Trim(PNAme);
      pname := '';
    end else begin
      s := trim(Copy(PName, 1, i-1));
      Delete(PName, 1, i);
    end;
    pp := GetPropInfo(PTypeInfo(Instance.ClassInfo), s);
    if pp = nil then begin Result := 'Unknown Identifier'; exit; end;

    case pp^.PropType^.Kind of
      tkInteger: begin Result := IntToStr(GetOrdProp(Instance, pp)); exit; end;
      tkChar: begin Result := '#'+IntToStr(GetOrdProp(Instance, pp)); exit; end;
      tkEnumeration: begin Result := GetEnumName(pp^.PropType{$IFDEF IFPS3_D3PLUS}^{$ENDIF}, GetOrdProp(Instance, pp)); exit; end;
      tkFloat: begin Result := FloatToStr(GetFloatProp(Instance, PP)); exit; end;
      tkString, tkLString: begin Result := ''''+GetStrProp(Instance, PP)+''''; exit; end;
      tkSet: begin Result := '[Set]'; exit; end;
      tkClass: begin Instance := TObject(GetOrdProp(Instance, pp)); end;
      tkMethod: begin Result := '[Method]'; exit; end;
      tkVariant: begin Result := '[Variant]'; exit; end;
      else begin Result := '[Unknown]'; exit; end;
    end;
    if Instance = nil then begin result := 'nil'; exit; end;
  end;
  Result := Instance.ClassName;
end;

function ClassVariantInfo(pvar: PIFVariant; const PropertyName: string): string;
begin
  if pvar^.FType^.BaseType = btResourcePointer then
  begin
    if @pvar^.FType.ResFree = @ClassResourceFree then
    begin
      if (pvar^.tResourceP1 = nil) then
        Result := 'nil'
      else 
        Result := PropertyToString(TObject(pvar^.tResourceP1), PropertyName);
    end else
      Result := 'Interface'; 
  end else Result := 'Invalid Type';
end;

function IFPSVariantToString(p: PIfVariant; const ClassProperties: string): string;
var
  I: Longint;
begin
  while p^.FType^.BaseType = btPointer do
  begin
    if p^.tPointer <> nil then p := p^.tPointer else break;
  end;
  if p^.FType^.BaseType = btVariant then P := p^.tvariant;
  case p^.FType^.BaseType of
    btProcptr: begin str(p^.tu32, Result); Result := 'Proc: '+result; end;
    btU8: str(p^.tu8, Result);
    btS8: str(p^.ts8, Result);
    btU16: str(p^.tu16, Result);
    btS16: str(p^.ts16, Result);
    btU32: str(p^.tu32, Result);
    btS32: str(p^.ts32, Result);
    btSingle: str(p^.tsingle, Result);
    btDouble: str(p^.tdouble, Result);
    btExtended: str(p^.textended, Result);
    btString, btPChar: Result := makestring(string(p^.tString));
    btchar: Result := MakeString(p^.tchar);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btwidechar: Result := MakeWString(p^.tchar);
    btWideString: Result := MakeWString(tbtwidestring(p^.tstring));
    {$ENDIF}
    {$IFNDEF IFPS3_NOINT64}btS64: str(p^.ts64, Result);{$ENDIF}
    btStaticArray, btRecord, btArray:
      begin
        Result := '[';
        if p^.tArray <>nil then
        begin
          for i := 0 to pbtRecord(p^.tarray)^.FieldCount -1 do
          begin
            if i <> 0 then
              Result := Result + ', ';
            Result := Result + IFPSVariantToString(pbtRecord(p^.tarray)^.Fields[i], '');
          end;
        end;
        Result := Result + ']';
      end;
    btPointer: Result := 'Nil';
    btResourcePointer:
      begin
        Result := ClassVariantInfo(p, ClassProperties)
      end;
  else
    Result := '[Invalid]';
  end;
end;


function GetIFPSArrayLength(SE: TIFPSExec; p: PIfVariant): Cardinal;
begin
  p := rp(p);
  if p^.FType^.BaseType = btVariant then
  begin
    p := p^.tvariant;
    if p^.ftype = nil then
    begin
      result := 0; exit;
    end;
  end;
  if (p^.FType^.BaseType <> btArray) and (p^.FType^.BaseType <> btStaticArray) then
  begin
    Result := 0;
    exit;
  end;
  if p^.tArray = nil then
    Result := 0
  else
    Result := pbtrecord(p^.tArray)^.FieldCount;
end;

function SetIFPSArrayLength(SE: TIFPSExec; p: PIfVariant; NewLength: Cardinal): Boolean;
var
  I, oldl: Integer;
  r: pbtrecord;
begin
  p := rp(p);
  if p^.FType^.BaseType = btVariant then
  begin
    p := p^.tvariant;
    if p^.ftype = nil then
    begin
      result := False; exit;
    end;
  end;
  if p^.FType^.BaseType <> btArray then begin Result := False; exit;end;
  if p^.tArray = nil then begin
    I := NewLength;
    if I > 0 then begin
      try
        GetMem(r, 4 + I * 4);
      except
        Result := False;
        exit;
      end;
      r^.FieldCount := I;
      p^.tArray := r;
      Dec(I);
      while I >= 0 do begin
        r^.Fields[I] := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}SE.MemoryManager, {$ENDIF}SE.GetTypeNo(Cardinal(p^.FType^.Ext)));
        if r^.Fields[I] = nil then begin
          while I < Longint(NewLength) do begin
            DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}SE.MemoryManager, {$ENDIF}r.Fields[I]);
            Inc(I);
          end;
          Result := False;
          exit;
        end;
        Dec(I);
      end;
    end;
  end else begin
    r := p^.tArray;
    oldl := NewLength;
    for I := oldl to r^.FieldCount - 1 do begin
      DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}SE.MemoryManager, {$ENDIF}r^.Fields[I]);
    end;
    if oldl = 0 then begin
      FreeMem(r, 4 + 4 * r^.FieldCount);
      p^.tArray := nil;
    end else begin
      I := oldl;
      oldl := r^.FieldCount;
      try
        ReallocMem(r, 4 + 4 * I);
      except
        for I := 0 to Min(NewLength, oldl) - 1 do begin
          DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}SE.MemoryManager, {$ENDIF}r^.Fields[I]);
        end;
        FreeMem(r, 4 + 4 * NewLength);
        p^.tArray := nil;
        Result := False;
        exit;
      end;
      p^.tArray := r;
      r^.FieldCount := I;
      for I := r^.FieldCount - 1 downto oldl do begin
        r^.Fields[I] := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}SE.MemoryManager, {$ENDIF}SE.GetTypeNo(Cardinal(p^.FType^.Ext)));
        if r^.Fields[I] = nil then begin
          oldl := I;
          while oldl < Longint(NewLength) do begin
            DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}SE.MemoryManager, {$ENDIF}r.Fields[oldl]);
            Inc(oldl);
          end;
          FreeMem(r, 4 + 4 * r^.FieldCount);
          p^.TArray := nil;
          Result := False;
          exit;
        end;
      end;
    end;
  end;
  Result := True;
end;

function SafeStr(const s: string): string;
var
 i : Longint;
begin
  Result := s;
  for i := 1 to length(s) do
  begin
    if s[i] in [#0..#31] then
    begin
      Result := Copy(s, 1, i-1);
      exit;
    end;
  end;

end;

function TIFErrorToString(x: TIFError; const Param: string): string;
begin
  case x of
    ErNoError: Result := 'No Error';
    erCannotImport: Result := 'Cannot Import '+Safestr(Param);
    erInvalidType: Result := 'Invalid Type';
    ErInternalError: Result := 'Internal error';
    erInvalidHeader: Result := 'Invalid Header';
    erInvalidOpcode: Result := 'Invalid Opcode';
    erInvalidOpcodeParameter: Result := 'Invalid Opcode Parameter';
    erNoMainProc: Result := 'no Main Proc';
    erOutOfGlobalVarsRange: Result := 'Out of Global Vars range';
    erOutOfProcRange: Result := 'Out of Proc Range';
    ErOutOfRange: Result := 'Out Of Range';
    erOutOfStackRange: Result := 'Out Of Stack Range';
    ErTypeMismatch: Result := 'Type Mismatch';
    erUnexpectedEof: Result := 'Unexpected End Of File';
    erVersionError: Result := 'Version error';
    ErDivideByZero: Result := 'divide by Zero';
    erMathError: Result := 'Math error';
    erCouldNotCallProc: Result := 'Could not call proc';
    erOutofRecordRange: Result := 'Out of Record Fields Range';
    erNullPointerException: Result := 'Null Pointer Exception';
    erNullVariantError: Result := 'Null variant error';
    erOutOfMemory: Result := 'Out Of Memory';
    erException: Result := 'Exception: '+ Param;
    erCustomError: Result := Param;
      else
    Result := 'Unknown error';
  end;
  //
end;

{$IFNDEF IFPS3_NOSMARTMM}
const
  Count = 50;

type
  TFreeIFVariant = packed record
    NextFreeItem: Longint;
    DummyData: array[0..SizeOf(TIfVariant) - SizeOf(Longint) - 1 +
    SizeOf(Pointer)] of Byte;
  end;
  PPageData = ^TPageData;
  TMyIFVariant = packed record
    Page: PPageData;
    p: TIfVariant;
  end;
  TPageData = packed record
    ItemCount, FirstFreeItem: Longint;
    PrevPage, NextPage,
      PrevFreeItemsPage, NextFreeItemsPage: PPageData;
    case Byte of
      0: (BLOCK: array[0..Count - 1] of TMyIFVariant);
      1: (FREELIST: array[0..Count - 1] of TFreeIFVariant);
  end;

type
  TIFVariantMemoryManager = class
  Private
    FFirstFreeItemsPage, FFirstPage: PPageData;
    procedure CleanItem(Page: PPageData);
    function AllocItem: Boolean;
  Public
    constructor Create;
    destructor Destroy; Override;
    procedure Clear;

    function Alloc: PIfVariant;
    procedure DisposeItem(p: PIfVariant);
  end;
type
  TPointingInteger = Longint; // same size as Pointer


function TIFVariantMemoryManager.Alloc: PIfVariant;
var
  CB: PPageData;
  I: Integer;
begin
  if FFirstFreeItemsPage = nil then begin
    if not AllocItem then begin
      Result := nil;
      exit;
    end;
  end;
  CB := FFirstFreeItemsPage;
  Inc(CB^.ItemCount);
  I := CB^.FirstFreeItem;
  CB^.FirstFreeItem := CB^.FREELIST[I].NextFreeItem;
  Result := @CB^.BLOCK[I].p;
  CB^.BLOCK[I].Page := CB;
  if CB^.FirstFreeItem = -1 then begin // remove from freeitemspage list
    if CB^.PrevFreeItemsPage <> nil then
      CB^.PrevFreeItemsPage^.NextFreeItemsPage := CB^.NextFreeItemsPage;
    if CB^.NextFreeItemsPage <> nil then
      CB^.NextFreeItemsPage^.PrevFreeItemsPage := CB^.PrevFreeItemsPage;
    if FFirstFreeItemsPage = CB then
      FFirstFreeItemsPage := CB^.NextFreeItemsPage;
  end;
end;

function TIFVariantMemoryManager.AllocItem: Boolean;
var
  NewItem: PPageData;
  I: Longint;

begin
  try
    New(NewItem);
  except
    Result := False;
    exit;
  end;

  NewItem^.ItemCount := 0;
  NewItem^.FirstFreeItem := Count - 1;
  NewItem^.PrevPage := nil;
  NewItem^.NextPage := FFirstPage;
  NewItem^.PrevFreeItemsPage := nil;
  NewItem^.NextFreeItemsPage := FFirstFreeItemsPage;

  for I := Count - 1 downto 0 do begin
    NewItem^.FREELIST[I].NextFreeItem := I - 1;
  end;

  if FFirstPage <> nil then
    FFirstPage^.PrevPage := NewItem;
  if FFirstFreeItemsPage <> nil then
    FFirstFreeItemsPage^.PrevPage := NewItem;

  FFirstPage := NewItem;
  FFirstFreeItemsPage := NewItem;
  Result := True;
end;

procedure TIFVariantMemoryManager.CleanItem(Page: PPageData);
begin
  if Page^.PrevPage <> nil then
    Page^.PrevPage^.NextPage := Page^.NextPage;
  if Page^.NextPage <> nil then
    Page^.NextPage^.PrevPage := Page^.PrevPage;

  if Page^.PrevFreeItemsPage <> nil then
    Page^.PrevFreeItemsPage^.NextFreeItemsPage := Page^.NextFreeItemsPage;
  if Page^.NextFreeItemsPage <> nil then
    Page^.NextFreeItemsPage^.PrevFreeItemsPage := Page^.PrevFreeItemsPage;
  if FFirstPage = Page then
    FFirstPage := Page^.NextPage;
  if FFirstFreeItemsPage = Page then
    FFirstFreeItemsPage := Page^.NextFreeItemsPage;
  Dispose(Page);
end;

procedure TIFVariantMemoryManager.Clear;
var
  CB, NB: PPageData;
begin
  CB := FFirstPage;
  while CB <> nil do begin
    NB := CB^.NextPage;
    Dispose(CB);
    CB := NB;
  end;
  FFirstPage := nil;
  FFirstFreeItemsPage := nil;
end;

constructor TIFVariantMemoryManager.Create;
begin
  inherited Create;
  FFirstFreeItemsPage := nil;
  FFirstPage := nil;
end;

destructor TIFVariantMemoryManager.Destroy;
begin
  Clear;
  inherited Destroy;
end;


procedure TIFVariantMemoryManager.DisposeItem(p: PIfVariant);
var
  Page: PPageData;
  I: Longint;
begin
  Page := PPageData(Pointer(TPointingInteger(p) - SizeOf(Pointer))^);
  I := (TPointingInteger(p) - TPointingInteger(@Page^.BLOCK) - SizeOf(Pointer)) div SizeOf(TMyIFVariant);
  Dec(Page^.ItemCount);
  Page^.FREELIST[I].NextFreeItem := Page^.FirstFreeItem;
  Page^.FirstFreeItem := I;
  if Page^.ItemCount = 0 then begin
    CleanItem(Page);
  end
  else if Page^.ItemCount = Count - 1 then begin // insert into list
    if FFirstFreeItemsPage <> nil then
      FFirstFreeItemsPage^.PrevFreeItemsPage := Page;
    Page^.PrevFreeItemsPage := nil;
    Page^.NextFreeItemsPage := FFirstFreeItemsPage;
    FFirstFreeItemsPage := Page;
  end;
end;

{$ENDIF}

function ResourcePtrToStr(PSelf: PResourcePtrSupportFuncs; Sender: TIFPSExec; P: PIFVariant): string;
begin
  SetLength(Result, 4);
  Pointer((@Result[1])^) := P^.tResourceP1;
end;

function VarResourcePtrToStr(PSelf: PResourcePtrSupportFuncs; Sender: TIFPSExec; P: PIFVariant): string;
begin
  SetLength(Result, 4);
  Pointer((@Result[1])^) := @P^.tResourceP1;
end;

procedure ResultToResourcePtr(PSelf: PResourcePtrSupportFuncs; Sender: TIFPSExec; Data: Longint; P: PIFVariant);
begin
  if Data = 0 then
  begin
    p^.tResourceP1 := nil;
  end else
  begin
    p^.tResourceP1 := Pointer(Data);
  end;
end;


function ProcPtrToStr(PSelf: PResourcePtrSupportFuncs; Sender: TIFPSExec; P: PIFVariant): string;
begin
  Setlength(Result, 8);
  TMethod((@Result[1])^) := MKMethod(Sender, P^.tu32);
end;

function ProcSupports(PSet: PResourcePtrSupportFuncs; P: PIFVariant): Boolean;
begin
  Result := ((p.FType.BaseType = btResourcePointer) and (@p.FType.ResFree = @classresourcefree)) or (p.FType.BaseType = btProcPtr);
end;

const
  ResourcePtrSupport: TResourcePtrSupportFuncs = (
    ptr: nil;
    PtrToStr: ResourcePtrToStr;
    VarPtrToStr: VarResourcePtrToStr;
    ResultMethod: rmRegister;
    ResToPtr: ResultToResourcePtr;
    ProcPtrToStr: ProcPtrToStr;
    PtrSupports: ProcSupports);


const
  ReturnAddressType: TIFTypeRec = (BaseType: btReturnAddress; Ext: nil);

type
  PResType = ^TResType;
  TResType = record
    Name: string;
    Nhash: Integer;
    Proc: TVariantResourceFreeProc;
  end;

  PIFPSExceptionHandler =^TIFPSExceptionHandler;
  TIFPSExceptionHandler = packed record
    CurrProc: PIFProcRec;
    BasePtr, StackSize: Cardinal;
    FinallyOffset, ExceptOffset, Finally2Offset, EndOfBlock: Cardinal;
  end;
  TIFPSHeader = packed record
    HDR: Cardinal;
    IFPSBuildNo: Cardinal;
    TypeCount: Cardinal;
    ProcCount: Cardinal;
    VarCount: Cardinal;
    MainProcNo: Cardinal;
    ImportTableSize: Cardinal;
  end;

  TIFPSExportItem = packed record
    ProcNo: Cardinal;
    NameLength: Cardinal;
    DeclLength: Cardinal;
  end;

  TIFPSType = packed record
    BaseType: TIFPSBaseType;
  end;
  TIFPSProc = packed record
    Flags: Byte;
  end;

  TIFPSVar = packed record
    TypeNo: Cardinal;
    Flags: Byte;
  end;
  PSpecialProc = ^TSpecialProc;
  TSpecialProc = record
    P: TIFPSOnSpecialProcImport;
    namehash: Longint;
    Name: string;
    tag: pointer;
  end;

procedure DisposeType(p: PIFTypeRec);
var
  x: PIFRecordType;
  xp: PIFStaticArrayInfo;
  xpr: PIFSetTypeInfo;
begin
  if p^.BaseType = btSet then
  begin
    xpr := p^.Ext;
    Dispose(xpr);
  end else if p^.BaseType = btStaticArray then
  begin
    xp := p^.Ext;
    Dispose(xp);
  end else
  if p^.BaseType = btRecord then
  begin
    x := p^.Ext;
    x^.Data := '';
    Dispose(x);
  end;
  Dispose(p);
end;

procedure DisposeProc(SE: TIFPSExec; p: PIFProcRec);
begin
  if not p^.ExternalProc then
    FreeMem(p^.Data, p^.Length);

  Dispose(p);
end;

function InitStaticArray({$IFNDEF IFPS3_NOSMARTMM}MM: Pointer; {$ENDIF}FType: PIFStaticArrayInfo; var Rec: pbtrecord): Boolean;
var
  I, J: Longint;
begin
  I := FType^.Size;
  try
    GetMem(Rec, 4 + 4 * I);
  except
    Result := False;
    exit;
  end;
  Rec.FieldCount := I;
  for I := 0 to Rec.FieldCount - 1 do
  begin
    Rec.Fields[I] := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF} FType^.aType);
    if Rec.Fields[I] = nil then
    begin
      for J := I - 1 downto 0 do
      begin
        DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Rec.Fields[J]);
        FreeMem(Rec, 4 * Rec.FieldCount + 4);
        Result := False;
        exit;
      end;
    end;
  end;
  Result := True;
end;

function Initrecord({$IFNDEF IFPS3_NOSMARTMM}MM: Pointer; {$ENDIF}FType:
  PIFRecordType; var Rec: pbtrecord): Boolean;
var
  I, J: Longint;
begin
  I := (Length(FType^.Data) shr 2);
  try
    GetMem(Rec, 4 + 4 * I);
  except
    Result := False;
    exit;
  end;
  Rec.FieldCount := I;
  for I := 0 to Rec.FieldCount - 1 do begin
    Rec.Fields[I] := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MM,
{$ENDIF}PIFTypeRec((@FType^.Data[I shl 2 + 1])^));
    if Rec.Fields[I] = nil then begin
      for J := I - 1 downto 0 do begin
        DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Rec.Fields[J]);
        FreeMem(Rec, 4 * 4 * (Length(FType^.Data) shr 2));
        Result := False;
        exit;
      end;
    end;
  end;
  Result := True;
end;

procedure FreeRecord({$IFNDEF IFPS3_NOSMARTMM}MM: Pointer; {$ENDIF}Rec: pbtrecord);
var
  I: Longint;
begin
  if Rec <> nil then begin
    for I := Rec.FieldCount - 1 downto 0 do
      DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Rec.Fields[I]);
    FreeMem(Rec, Rec.FieldCount * 4 + 4);
  end;
end;

procedure DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM: Pointer; {$ENDIF}p: PIfVariant);
begin
  if p <> nil then
  if p^.RefCount = 0 then begin
    if p^.FType <> nil then
    begin
      if (p^.FType^.BaseType = btPointer) and (p^.tPointer <> nil) then
      begin
        DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}mm, {$ENDIF} p^.tPointer);
      end else
      if (p^.FType^.BaseType = btRecord) or (p^.FType^.BaseType = btArray) or (p^.FType^.BaseType = btStaticArray) then
        FreeRecord({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}p^.trecord)
      else if (p^.FType^.BaseType = btString) or (p^.FType^.BaseType = btPchar) or (p^.FType^.BaseType = btset) then
        Finalize(TbtString((@p^.tstring)^))
      {$IFNDEF IFPS3_NOWIDESTRING}
      else if p^.FType^.BaseType = btWideString then
        Finalize(TbtwideString((@p^.twidestring)^))
      {$ENDIF}
      else if p^.FType^.BaseType = btResourcePointer then
      begin
        if (@p^.FType^.ResFree <> nil) then
        begin
          p^.FType^.ResFree(vrfFree, p, nil);
        end;
      end else if p^.FType^.BaseType = btvariant then
         DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}p^.tvariant);
    end;
    {$IFNDEF IFPS3_NOSMARTMM}
    TIFVariantMemoryManager(MM).DisposeItem(p);
    {$ELSE}
    Dispose(p);
    {$ENDIF}
  end
  else
    Dec(p^.RefCount);
end;

procedure ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}MM: Pointer; {$ENDIF}p: PIFVariant; n: PIFTypeRec);
begin
  if p^.FType <> nil then
  begin
    if (p^.FType^.BaseType = btRecord) or (p^.FType^.BaseType = btArray)  or (p^.FType^.BaseType = btStaticArray) then
      FreeRecord({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}p^.trecord)
    else if (p^.FType^.BaseType = btString) or (p^.FType^.BaseType = btPchar) or (p^.Ftype^.BaseType = btSet) then
      Finalize(TbtString((@p^.tstring)^))
    {$IFNDEF IFPS3_NOWIDESTRING}
    else if p^.FType^.BaseType = btWideString then
      Finalize(TbtwideString((@p^.twidestring)^))
    {$ENDIF}
    else if p^.FType^.BaseType = btResourcePointer then
    begin
      if (@p^.FType^.ResFree <> nil) then
      begin
        p^.FType^.ResFree(vrfFree, p, nil);
      end;
    end else if p^.FType^.BaseType = btvariant then
      DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}p^.tvariant);
  end;
  p^.FType := n;
  if n <> nil then
  begin
    if n^.BaseType = btSet then
    begin
      p^.RefCount := 0;
      p^.tstring := nil;
      setLength(tbtstring(p^.tstring), PIFSetTypeInfo(n^.Ext)^.aByteSize);
      FillChar(tbtstring(p^.tstring)[1], Length(tbtstring(p^.tstring)), 0); 
    end else
    if n^.BaseType = btVariant then
    begin
      {$IFDEF IFPS3_NOSMARTMM}
      try
        New(p^.tvariant);
      except
        p^.tvariant := nil;
        exit;
      end;
      {$ELSE}
      p^.TVariant := TIFVariantMemoryManager(MM).Alloc;
      {$ENDIF}
       p^.tVariant^.FType := nil;
       p^.tvariant^.refcount := 0;
    end else if (n^.BaseType = btStaticArray) then
    begin
      p^.RefCount := 0;
      if not InitStaticArray({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF} n^.Ext, pbtrecord(p^.trecord)) then
      begin
        p^.trecord := nil;
        disposevariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}p);
      end;
    end else if (n^.BaseType = btRecord) then begin
      p^.RefCount := 0;
      if not Initrecord({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}n^.Ext, pbtrecord(p^.trecord)) then begin
        p^.trecord := nil;
        DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}p);
      end;
    end
    else begin
      FillChar(p^.RefCount, SizeOf(TIfVariant) - SizeOf(Pointer), 0);
    end;
  end;
end;

function CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MM: Pointer; {$ENDIF}n: PIFTypeRec): PIfVariant;
var
  p: PIfVariant;
begin
  if n = nil then begin
    Result := nil;
    exit;
  end;
{$IFNDEF IFPS3_NOSMARTMM}
  p := TIFVariantMemoryManager(MM).Alloc;
  if p = nil then begin
    Result := nil;
    exit;
  end;
{$ELSE}
  try
    New(p);
  except
    Result := nil;
    exit;
  end;
{$ENDIF}

  p^.FType := n;
  if n^.BaseType = btSet then
  begin
    p^.RefCount := 0;
    p^.tstring := nil;
    setLength(tbtstring(p^.tstring), PIFSetTypeInfo(n^.Ext)^.aByteSize);
      FillChar(tbtstring(p^.tstring)[1], Length(tbtstring(p^.tstring)), 0); 
  end else
  if n^.BaseType = btVariant then
  begin
    {$IFDEF IFPS3_NOSMARTMM}
    try
      New(p^.tvariant);
    except
      p^.tvariant := nil;
      Result := nil;
      exit;
    end;
    {$ELSE}
    p^.TVariant := TIFVariantMemoryManager(MM).Alloc;
    {$ENDIF}
     p^.tVariant^.FType := nil;
     p^.tvariant^.RefCount := 0;
  end else if (n^.BaseType = btStaticArray) then
  begin
    p^.RefCount := 0;
    if not InitStaticArray({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF} n^.Ext, pbtrecord(p^.trecord)) then
    begin
      p^.trecord := nil;
      disposevariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}p);
    end;
  end else if (n^.BaseType = btRecord) then begin
    p^.RefCount := 0;
    if not Initrecord({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}n^.Ext, pbtrecord(p^.trecord)) then begin
      p^.trecord := nil;
      DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}p);
    end;
  end
  else begin
    FillChar(p^.RefCount, SizeOf(TIfVariant) - SizeOf(Pointer), 0);
  end;
  CreateVariant := p;
end;
procedure LSetReal(List: TIfList; Pos: Cardinal; const Val: Extended);
var
  p: PIfVariant;
begin
  p := List[Pos];
  if (p <> nil) and (p^.FType^.BaseType = btPointer) then p := p^.tPointer;
  if p = nil then exit;
  case p^.FType^.BaseType of
    btSingle: p^.tsingle := Val;
    btDouble: p^.tdouble := Val;
    btExtended: p^.textended := Val;
  end;
end;

function LGetReal(List: TIfList; Pos: Cardinal): Extended;
var
  p: PIfVariant;
begin
  p := List[Pos];
  if (p <> nil) and (p^.FType^.BaseType = btPointer) then p := p^.tPointer;
  if p = nil then begin result := 0; exit; end;
  case p^.FType^.BaseType of
    btSingle: Result := p^.tsingle;
    btDouble: Result := p^.tdouble;
    btExtended: Result := p^.textended;
  else
    Result := 0;
  end;
end;

function LGetStr(List: TIfList; Pos: Cardinal): string;
var
  p: PIfVariant;
begin
  p := List[Pos];
  if (p <> nil) and (p^.FType^.BaseType = btPointer) then p := p^.tPointer;
  if p = nil then begin result := ''; exit; end;
  case p^.FType^.BaseType of
    btString: Result := TbtString(p^.tstring);
    btChar: Result := p.tchar;
    {$IFNDEF IFPS3_NOWIDESTRING}
    btWideString: Result := tbtWideString(p^.twidestring);
    btWideChar: Result := tbtWideChar(p^.twidechar);
    {$ENDIF}
  end;
end;

procedure LSetStr(List: TIfList; Pos: Cardinal; const s: string);
var
  p: PIfVariant;
begin
  p := List[Pos];
  if (p <> nil) and (p^.FType^.BaseType = btPointer) then p := p^.tPointer;
  if p = nil then exit;
  case p^.FType^.BaseType of
    btstring: TbtString(p^.tstring) := s;
    {$IFNDEF IFPS3_NOWIDESTRING}
    btWideString: tbtwidestring(p^.twidestring) := s;
    {$ENDIF}
  end;
end;

function LGetUInt(List: TIfList; Pos: Cardinal): Cardinal;
var
  p: PIfVariant;
begin
  p := List[Pos];
  if (p <> nil) and (p^.FType^.BaseType = btPointer) then p := p^.tPointer;
  if p = nil then begin result := 0; exit; end;
  case p^.FType^.BaseType of
    btU8: Result := p^.tu8;
    btS8: Result := p^.tS8;
    btU16: Result := p^.tu16;
    btS16: Result := p^.ts16;
    btU32, btProcPtr: Result := p^.tu32;
    btS32: Result := p^.ts32;
    {$IFNDEF IFPS3_NOINT64}btS64: Result := p^.ts64;{$ENDIF}
    btChar: Result := ord(p^.tchar);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btwideChar: Result := ord(p^.twidechar);
    btwidestring: begin
      if Length(tbtwidestring(p^.twidestring)) =1 then
      begin
        Result := ord(tbtwidestring(p^.twidestring)[1]);
      end else Result := 0;
    end;
    {$ENDIF}
    btString: begin
      if Length(tbtstring(p^.tstring)) =1 then
      begin
        Result := ord(tbtstring(p^.tstring)[1]);
      end else Result := 0;
    end;
  else
    Result := 0;
  end;
end;

function LGetInt(List: TIfList; Pos: Cardinal): Longint;
var
  p: PIfVariant;
begin
  p := List[Pos];
  if (p <> nil) and (p^.FType^.BaseType = btPointer) then p := p^.tPointer;
  if p = nil then begin result := 0; exit; end;
  case p^.FType^.BaseType of
    btU8: Result := p^.tu8;
    btS8: Result := p^.tS8;
    btU16: Result := p^.tu16;
    btS16: Result := p^.ts16;
    btU32, btProcPtr: Result := p^.tu32;
    btS32: Result := p^.ts32;
    {$IFNDEF IFPS3_NOINT64}btS64: Result := p^.ts64;{$ENDIF}
    btChar: Result := ord(p^.tchar);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btwideChar: Result := ord(p^.twidechar); 
    btwidestring: begin
      if Length(tbtwidestring(p^.twidestring)) =1 then
      begin
        Result := ord(tbtwidestring(p^.twidestring)[1]);
      end else Result := 0;
    end;
    {$ENDIF}
    btString: begin
      if Length(tbtstring(p^.tstring)) =1 then
      begin
        Result := ord(tbtstring(p^.tstring)[1]);
      end else Result := 0;
    end;
  else
    Result := 0;
  end;
end;

procedure LSetUInt(List: TIfList; Pos: Cardinal; Val: Cardinal);
var
  Src: PIfVariant;
begin
  Src := List[Pos];
  if (Src <> nil) and (Src^.FType^.BaseType = btPointer) then Src := SRc^.tPointer;
  if Src = nil then exit;
  case Src^.FType^.BaseType of
    btU8: Src^.tu8 := Val;
    btS8: Src^.tS8 := Val;
    btU16: Src^.tu16 := Val;
    btS16: Src^.ts16 := Val;
    btU32, btProcPtr: Src^.tu32 := Val;
    btS32: Src^.ts32 := Val;
    {$IFNDEF IFPS3_NOINT64}btS64: src^.ts64 := Val;{$ENDIF}
    btString: tbtstring(src^.tstring) := chr(Val);
    btChar: src^.tchar := chr(val);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btwideChar: src^.tchar := chr(val);
    btwidestring: tbtwidestring(src.twidestring) := widechar(val);
    {$ENDIF}
  end;
end;
{$IFNDEF IFPS3_NOINT64}
procedure LSetInt64(List: TIfList; Pos: Cardinal; Val: Int64);
var
  Src: PIfVariant;
begin
  Src := List[Pos];
  if (Src <> nil) and (Src^.FType^.BaseType = btPointer) then Src := SRc^.tPointer;
  if Src = nil then exit;
  case Src^.FType^.BaseType of
    btU8: Src^.tu8 := Val;
    btS8: Src^.tS8 := Val;
    btU16: Src^.tu16 := Val;
    btS16: Src^.ts16 := Val;
    btU32, btProcPtr: Src^.tu32 := Val;
    btS32: Src^.ts32 := Val;
    btS64: src^.ts64 := Val;
    btString: tbtstring(src^.tstring) := chr(Val);
    btChar: src^.tchar := chr(val);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btwideChar: src^.tchar := chr(val);
    btwidestring: tbtwidestrinG(src.twidestring) := widechar(val);
    {$ENDIF}
  end;
end;
function LGetInt64(List: TIfList; Pos: Cardinal): Int64;
var
  p: PIfVariant;
begin
  p := List[Pos];
  if (p <> nil) and (p^.FType^.BaseType = btPointer) then p := p^.tPointer;
  if p = nil then begin result := 0; exit; end;
  case p^.FType^.BaseType of
    btU8: Result := p^.tu8;
    btS8: Result := p^.tS8;
    btU16: Result := p^.tu16;
    btS16: Result := p^.ts16;
    btU32, btProcPtr: Result := p^.tu32;
    btS32: Result := p^.ts32;
    btS64: Result := p^.ts64;
    btChar: Result := ord(p^.tchar);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btwideChar: Result := ord(p^.twidechar);
    btwidestring: begin
      if Length(tbtwidestring(p^.twidestring)) =1 then
      begin
        Result := ord(tbtwidestring(p^.twidestring)[1]);
      end else Result := 0;
    end;
    {$ENDIF}
    btString: begin
      if Length(tbtstring(p^.tstring)) =1 then
      begin
        Result := ord(tbtstring(p^.tstring)[1]);
      end else Result := 0;
    end;
  else
    Result := 0;
  end;
end;
{$ENDIF}

procedure LSetInt(List: TIfList; Pos: Cardinal; Val: Longint);
var
  Src: PIfVariant;
begin
  Src := List[Pos];
  if (Src <> nil) and (Src^.FType^.BaseType = btPointer) then Src := SRc^.tPointer;
  if Src = nil then exit;
  case Src^.FType^.BaseType of
    btU8: Src^.tu8 := Val;
    btS8: Src^.tS8 := Val;
    btU16: Src^.tu16 := Val;
    btS16: Src^.ts16 := Val;
    btU32, btProcPtr: Src^.tu32 := Val;
    btS32: Src^.ts32 := Val;
    {$IFNDEF IFPS3_NOINT64}btS64: src^.ts64 := Val;{$ENDIF}
    btString: tbtstring(src^.tstring) := chr(Val);
    btChar: src^.tchar := chr(val);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btwideChar: src^.tchar := chr(val);
    btwidestring: tbtwidestrinG(src.twidestring) := widechar(val);
    {$ENDIF}
  end;
end;
{$IFNDEF IFPS3_NOINT64}
function GetInt64(Src: PIfVariant; var s: Boolean): Int64;
begin
  if Src = nil then
  begin
    s := false;
    result := 0;
    exit;
  end;
  if Src^.FType^.BaseType = btPointer then
  begin
    Src := src^.tPointer;
    if Src = nil then
    begin
      s := false;
      result := 0;
      exit;
    end;
  end;
  case Src^.FType^.BaseType of
    btVariant:
      begin
        if src^.TVariant^.FType <> nil then
          Result := GetInt64(Src^.TVariant, s)
        else
         Result := 0;
      end;
    btU8: Result := Src^.tu8;
    btS8: Result := Src^.tS8;
    btU16: Result := Src^.tu16;
    btS16: Result := Src^.ts16;
    btU32, btProcPtr: Result := Src^.tu32;
    btS32: Result := Src^.ts32;
    btS64: Result := src^.ts64;
    btChar: Result := ord(src^.tchar);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btwideChar: Result := ord(src^.twidechar);
    btwidestring: begin
      if Length(tbtwidestring(src^.twidestring)) =1 then
      begin
        Result := ord(tbtwidestring(src^.twidestring)[1]);
      end else begin Result := 0; s := false; end;
    end;
    {$ENDIF}
    btString: begin
      if Length(tbtstring(src^.tstring)) =1 then
      begin
        Result := ord(tbtstring(src^.tstring)[1]);
      end else begin Result := 0; s := False; end;
    end;
  else begin
      s := False;
      Result := 0;
    end;
  end;
end;
{$ENDIF}

function GetUInt(Src: PIfVariant; var s: Boolean): Cardinal;
begin
  if Src = nil then
  begin
    s := false;
    result := 0;
    exit;
  end;
  if Src^.FType^.BaseType = btPointer then
  begin
    Src := src^.tPointer;
    if Src = nil then
    begin
      s := false;
      result := 0;
      exit;
    end;
  end;
  case Src^.FType^.BaseType of
    btVariant:
      begin
        if src^.TVariant^.FType <> nil then
          Result := GetUINT(Src^.TVariant, s)
        else
         Result := 0;
      end;
    btU8: Result := Src^.tu8;
    btS8: Result := Src^.tS8;
    btU16: Result := Src^.tu16;
    btS16: Result := Src^.ts16;
    btU32, btProcPtr: Result := Src^.tu32;
    btS32: Result := Src^.ts32;
    {$IFNDEF IFPS3_NOINT64}btS64: Result := src^.ts64;{$ENDIF}
    btChar: Result := ord(src^.tchar);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btwideChar: Result := ord(src^.twidechar);
    btwidestring: begin
      if Length(tbtwidestring(src^.twidestring)) =1 then
      begin
        Result := ord(tbtwidestring(src^.twidestring)[1]);
      end else begin Result := 0; s:= false; end;
    end;
    {$ENDIF}
    btString: begin
      if Length(tbtstring(src^.tstring)) =1 then
      begin
        Result := ord(tbtstring(src^.tstring)[1]);
      end else begin Result := 0; s := False; end;
    end;
  else begin
      s := False;
      Result := 0;
    end;
  end;
end;

function GetInt(Src: PIfVariant; var s: Boolean): Longint;
begin
  if Src = nil then
  begin
    s := false;
    result := 0;
    exit;
  end;
  if Src^.FType^.BaseType = btPointer then
  begin
    Src := src^.tPointer;
    if Src = nil then
    begin
      s := false;
      result := 0;
      exit;
    end;
  end;
  case Src^.FType^.BaseType of
    btVariant:
      begin
        if src^.TVariant^.FType <> nil then
          Result := GetInt(Src^.TVariant, s)
        else
         Result := 0;
      end;
    btU8: Result := Src^.tu8;
    btS8: Result := Src^.tS8;
    btU16: Result := Src^.tu16;
    btS16: Result := Src^.ts16;
    btU32, btProcPtr: Result := Src^.tu32;
    btS32: Result := Src^.ts32;
    {$IFNDEF IFPS3_NOINT64}btS64: Result := src^.ts64;{$ENDIF}
    btChar: Result := ord(src^.tchar);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btwideChar: Result := ord(src^.twidechar);
    btwidestring: begin
      if Length(tbtwidestring(src^.twidestring)) =1 then
      begin
        Result := ord(tbtwidestring(src^.twidestring)[1]);
      end else begin Result := 0; s := false; end;
    end;
    {$ENDIF}
    btString: begin
      if Length(tbtstring(src^.tstring)) =1 then
      begin
        Result := ord(tbtstring(src^.tstring)[1]);
      end else begin Result := 0; s := False; end;
    end;
  else begin
      s := False;
      Result := 0;
    end;
  end;
end;

function GetReal(Src: PIfVariant; var s: Boolean): Extended;
begin
  if Src = nil then
  begin
    s := false;
    result := 0;
    exit;
  end;
  if Src^.FType^.BaseType = btPointer then
  begin
    Src := src^.tPointer;
    if Src = nil then
    begin
      s := false;
      result := 0;
      exit;
    end;
  end;
  case Src^.FType^.BaseType of
    btVariant:
      begin
        if src^.TVariant^.FType <> nil then
          Result := GetReal(Src^.TVariant, s)
        else
         Result := 0;
      end;
    btU8: Result := Src^.tu8;
    btS8: Result := Src^.tS8;
    btU16: Result := Src^.tu16;
    btS16: Result := Src^.ts16;
    btU32, btProcPtr: Result := Src^.tu32;
    btS32: Result := Src^.ts32;
    {$IFNDEF IFPS3_NOINT64}
    bts64: Result := src^.ts64;
    {$ENDIF}
    btSingle: Result := Src^.tsingle;
    btDouble: Result := Src^.tdouble;
    btExtended: Result := Src^.textended;
  else begin
      s := False;
      Result := 0;
    end;
  end;
end;

function GetString(Src: PIfVariant; var s: Boolean): string;
begin
  if Src = nil then
  begin
    s := false;
    result := '';
    exit;
  end;
  if Src^.FType^.BaseType = btPointer then
  begin
    Src := src^.tPointer;
    if Src = nil then
    begin
      s := false;
      result := '';
      exit;
    end;
  end;
  case Src^.FType^.BaseType of
    btVariant:
      begin
        if src^.TVariant^.FType <> nil then
          Result := GetString(Src^.TVariant, s)
        else
         Result := '';
      end;
    btchar: Result := src^.tchar;
    btPChar, btString: Result := TbtString((@Src^.tstring)^);
    {$IFNDEF IFPS3_NOWIDESTRING}
    btwidechar: Result := src^.twidechar;
    btwideString: Result := TbtwideString((@Src^.twidestring)^);
    {$ENDIF}
  else begin
      s := False;
      Result := '';
    end;
  end;
end;
{$IFNDEF IFPS3_NOWIDESTRING}
function GetWideString(Src: PIfVariant; var s: Boolean): widestring;
begin
  if Src = nil then
  begin
    s := false;
    result := '';
    exit;
  end;
  if Src^.FType^.BaseType = btPointer then
  begin
    Src := src^.tPointer;
    if Src = nil then
    begin
      s := false;
      result := '';
      exit;
    end;
  end;
  case Src^.FType^.BaseType of
    btVariant:
      begin
        if src^.TVariant^.FType <> nil then
          Result := GetString(Src^.TVariant, s)
        else
         Result := '';
      end;
    btchar: Result := Src^.tchar;
    btPChar, btString: Result := TbtString((@Src^.tstring)^);
    btwidechar: Result := src^.twidechar;
    btwideString: Result := TbtwideString((@Src^.twidestring)^);
  else begin
      s := False;
      Result := '';
    end;
  end;
end;
{$ENDIF}
function LookupProc(List: TIfList; const Name: ShortString): PProcRec;
var
  h, l: Longint;
  p: PProcRec;
begin
  h := MakeHash(Name);
  for l := List.Count - 1 downto 0 do
  begin
    p := List.Data^[l];
    if (p^.Hash = h) and (p^.Name = Name) then
    begin
      Result := List[l];
      exit;
    end;
  end;
  Result := nil;
end;

{ TIFPSExec }           

procedure TIFPSExec.ClearFunctionList;
var
  x: PProcRec;
  x2: PResType;
  l: Longint;
begin
  for l := FResourceTypes.Count -1 downto 0 do
  begin
    x2 := FResourceTypes.Data^[l];
    Dispose(x2);
  end;
  FResourceTypes.Clear;

  FRPSupFuncs.Clear;
  for l := 0 to FRegProcs.Count - 1 do
  begin
    x := FRegProcs.Data^[l];
    if @x^.FreeProc <> nil then x^.FreeProc(Self, x);
    Dispose(x);
  end;
  FRegProcs.Clear;
  RegisterStandardProcs;
  RegisterResourceType('Class', ClassResourceFree);
  RegisterRProcSupFuncs(@ResourcePtrSupport);
end;

class function TIFPSExec.About: string;
begin
  Result := 'Innerfuse Pascal Script III ' + IFPSCurrentversion + '. Copyright (c) 2001-2003 by Carlo Kok';
end;

procedure TIFPSExec.Cleanup;
var
  I: Longint;
  p: PIfVariant;
begin
  if FStatus <> isLoaded then
    exit;
  for I := Longint(FGlobalVars.Count) - 1 downto 0 do begin
    p := FGlobalVars.Data^[I];
    FGlobalVars[I] := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}p^.FType);
    DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}p);
  end;
end;
type
  PIFPSExportedVar = ^TIFPSExportedVar;
  TIFPSExportedVar = record
    FName: string;
    FNameHash: Longint;
    FVarNo: Cardinal;
  end;

procedure TIFPSExec.Clear;
var
  I: Longint;
  temp: PIFPSResource;
  Proc: TIFPSResourceFreeProc;
  pp: PIFPSExceptionHandler;
begin
  for i := Longint(FExceptionStack.Count) -1 downto 0 do
  begin
    pp := FExceptionStack.Data^[i];
    Dispose(pp);
  end;
  for i := Longint(FResources.Count) -1 downto 0 do
  begin
    Temp := FResources.Data^[i];
    Proc := Temp^.Proc;
    Proc(Self, Temp^.P);
    Dispose(Temp);
  end;
  for i := Longint(FExportedVars.Count) -1 downto 0 do
  begin
    Dispose(PIFPSExportedVar(FExportedVars.Data^[I]));
  end;
  for I := Longint(FStack.Count) - 1 downto 0 do begin
    DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}FStack.Data^[I]);
  end;
  for I := Longint(FProcs.Count) - 1downto 0  do begin
    DisposeProc(Self, FProcs.Data^[I]);
  end;
  for I := Longint(FGlobalVars.Count) - 1downto 0  do begin
    DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}FGlobalVars.Data^[I]);
  end;
  for I := Longint(FTypes.Count) - 1downto 0  do begin
    DisposeType(FTypes.Data^[I]);
  end;
  FStack.Clear;
  FProcs.Clear;
  FGlobalVars.Clear;
  FTypes.Clear;
  FStatus := isNotLoaded;
  FResources.Clear;
  FExportedVars.Clear;
  FExceptionStack.Clear;
end;

constructor TIFPSExec.Create;
begin
  inherited Create;
{$IFNDEF IFPS3_NOSMARTMM}MM := TIFVariantMemoryManager.Create;
{$ENDIF}
  FExceptionStack := TIfList.Create;
  FCallCleanup := False;
  FResources := TIfList.Create;
  FTypes := TIfList.Create;
  FProcs := TIfList.Create;
  FGlobalVars := TIfList.Create;
  FStack := TIfList.Create;
  FMainProc := 0;
  FStatus := isNotLoaded;
  FRegProcs := TIfList.Create;
  FExportedVars := TIfList.create;
  FSpecialProcList := TIfList.Create;
  FRPSupFuncs := TIfList.Create;
  FResourceTypes := TIfList.Create;
  RegisterStandardProcs;
  RegisterResourceType('Class', ClassResourceFree);
  RegisterRProcSupFuncs(@ResourcePtrSupport);
end;

destructor TIFPSExec.Destroy;
var
  I: Longint;
  x: PProcRec;
  x2: PResType;
  P: PSpecialProc;
begin
  if ExObject <> nil then ExObject.Free;
  Clear;
  FRPSupFuncs.Free;
  for I := FSpecialProcList.Count -1 downto 0 do
  begin
    P := FSpecialProcList.Data^[I];
    Dispose(p);
  end;
  FStack.Free;
  FResources.Free;
  FExportedVars.Free;
  FGlobalVars.Free;
  FProcs.Free;
  FTypes.Free;
  FSpecialProcList.Free;
  for i := FRegProcs.Count - 1 downto 0 do
  begin
    x := FRegProcs.Data^[i];
    if @x^.FreeProc <> nil then x^.FreeProc(Self, x);
    Dispose(x);
  end;
  FRegProcs.Free;
  for i := FResourceTypes.Count -1 downto 0 do
  begin
    x2 := FResourceTypes.Data^[i];
    Dispose(x2);
  end;
  FResourceTypes.Free;
  FExceptionStack.Free;
{$IFNDEF IFPS3_NOSMARTMM}TIFVariantMemoryManager(MM).Free;
{$ENDIF}
  inherited Destroy;
end;

procedure TIFPSExec.ExceptionProc(proc, Position: Cardinal; Ex: TIFError; const s: string; NewObject: TObject);
var
  d, l: Longint;
  pp: PIFPSExceptionHandler;
begin
  ExProc := proc;
  ExPos := Position;
  ExEx := Ex;
  ExParam := s;
  if ExObject <> nil then
    ExObject.Free;
  ExObject := NewObject;
  if Ex = eNoError then Exit;
  for d := FExceptionStack.Count -1 downto 0 do
  begin
    pp := FExceptionStack[d];
    if FStack.Count > pp^.StackSize then
    begin
      for l := Longint(FStack.count) -1 downto Longint(pp^.StackSize) do
      begin
        DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}mm, {$ENDIF}FStack.Data^[l]);
        FStack.Delete(l);
      end;
    end;
    FCurrProc := pp^.CurrProc;
    FData := FCurrProc^.Data;
    FDataLength := FCurrProc^.Length;

    FCurrStackBase := pp^.BasePtr;
    if pp^.FinallyOffset <> InvalidVal then
    begin
      FCurrentPosition := pp^.FinallyOffset;
      pp^.FinallyOffset := InvalidVal;
      Exit;
    end else if pp^.ExceptOffset <> InvalidVal then
    begin
      FCurrentPosition := pp^.ExceptOffset;
      pp^.ExceptOffset := InvalidVal;
      Exit;
    end else if pp^.Finally2Offset <> InvalidVal then
    begin
      FCurrentPosition := pp^.Finally2Offset;
      pp^.Finally2Offset := InvalidVal;
      Exit;
    end;
    Dispose(pp);
    FExceptionStack.Delete(FExceptionStack.Count -1);
  end;
  FStatus := isPaused;
end;

function TIFPSExec.ImportProc(const Name: ShortString; var proc: TIFProcRec): Boolean;
var
  u: PProcRec;
  fname: string;
  I, fnh: Longint;
  P: PSpecialProc;

begin
  if name = '' then
  begin
    fname := proc.ExportDecl;
    fname := copy(fname, 1, pos(':', fname)-1);
    fnh := MakeHash(fname);
    for I := FSpecialProcList.Count -1 downto 0 do
    begin
      p := FSpecialProcList[I];
      IF (p^.name = '') or ((p^.namehash = fnh) and (p^.name = fname)) then
      begin
        if p^.P(Self, @Proc, p^.tag) then
        begin
          Result := True;
          exit;
        end;
      end;
    end;
    Result := FAlse;
    exit;
  end;
  u := LookupProc(FRegProcs, Name);
  if u = nil then begin
    Result := False;
    exit;
  end;
  proc.ProcPtr := u^.ProcPtr;
  proc.Ext1 := u^.Ext1;
  proc.Ext2 := u^.Ext2;
  Result := True;
end;

function TIFPSExec.RegisterFunctionName(const Name: string; ProcPtr: TIFProc; Ext1, Ext2: Pointer): PProcRec;
var
  p: PProcRec;
  s: string;
begin
  s := FastUppercase(Name);
  if LookupProc(FRegProcs, s) <> nil then
  begin
    Result :=  nil;
    exit;
  end;
  New(p);
  p^.Name := s;
  p^.Hash := MakeHash(s);
  p^.ProcPtr := ProcPtr;
  p^.FreeProc := nil;
  p^.Ext1 := Ext1;
  p^.Ext2 := Ext2;
  FRegProcs.Add(p);
  Result := P;
end;

function TIFPSExec.LoadData(const s: string): Boolean;
var
  HDR: TIFPSHeader;
  Pos: Cardinal;

  function read(var Data; Len: Cardinal): Boolean;
  begin
    if Longint(Pos + Len) <= Length(s) then begin
      Move(s[Pos + 1], Data, Len);
      Pos := Pos + Len;
      read := True;
    end
    else
      read := False;
  end;
{$WARNINGS OFF}

  function LoadTypes: Boolean;
  var
    currf: TIFPSType;
    Curr: PIFTypeRec;
    currr: PIFRecordType;
    currx: PIFStaticArrayInfo;
    currs: PIFSetTypeInfo;
    fe: Boolean;
    l2, l, hash: Longint;
    d: Cardinal;
    restype: string;

    function resolve(var s: string): Boolean;
    var
      l: Longint;
      p: PIFTypeRec;
    begin
      l := 1;
      while l < Length(s) do begin
        p := FTypes[Cardinal(s[l])];
        if p = nil then begin
          Result := False;
          exit;
        end;
        PIFTypeRec((@s[l])^) := p;
        l := l + 4;
      end;
      Result := True;
    end;
  begin
    LoadTypes := True;
    for l := 0 to HDR.TypeCount - 1 do begin
      if not read(currf, SizeOf(currf)) then begin
        cmd_err(erUnexpectedEof);
        LoadTypes := False;
        exit;
      end;
      if (currf.BaseType and 128) <> 0 then begin
        fe := True;
        currf.BaseType := currf.BaseType - 128;
      end else
        fe := False;
      try
        New(Curr);
      except
        CMD_Err(erOutOfMemory);
        LoadTypes := False;
        exit;
      end;
      case currf.BaseType of
        {$IFNDEF IFPS3_NOINT64}bts64, {$ENDIF}
        btU8, btS8, btU16, btS16, btU32, btS32, btProcPtr,btSingle, btDouble, btExtended, btString, btPointer, btPChar, btVariant, btChar{$IFNDEF IFPS3_NOWIDESTRING}, btWideString, btWideChar{$ENDIF}: begin
            Curr^.BaseType := currf.BaseType;
            Curr^.Ext := nil;
            FTypes.Add(Curr);
          end;
        btResourcePointer:
          begin
            if (not Read(d, 4)) or (d > 255) then
            begin
              cmd_err(erUnexpectedEof);
              LoadTypes := False;
              exit;
            end;
            setlength(restype, d);
            if not Read(restype[1], d) then
            begin
              cmd_err(erUnexpectedEof);
              LoadTypes := False;
              exit;
            end;
            hash := MakeHash(restype);
            curr^.ResFree := nil;
            for l2 := FResourceTypes.Count -1 downto 0 do
            begin
              if (PResType(FResourceTypes[l2])^.Nhash = hash) and (PResType(FResourceTypes[l2]).Name = restype) then
              begin
                curr^.ResFree := PResType(FResourceTypes[l2])^.Proc;
                break;
              end;
            end;
            if @curr^.ResFree = nil then
            begin
              cmd_err2(erCannotImport, resType);
              LoadTypes := False;
              exit;
            end;
            Curr^.BaseType := currf.BaseType;
            FTypes.Add(Curr);
          end;
        btSet:
          begin
            if not Read(d, 4) then
            begin
              cmd_err(erUnexpectedEof);
              LoadTypes := False;
              exit;
            end;
            if (d > 256) then
            begin
              cmd_err(erTypeMismatch);
              LoadTypes := False;
              exit;
            end;
            new(currs);
            currs^.aBitSize := d;
            currs^.aByteSize := currs^.aBitSize shr 3;
            if (currs^.aBitSize and 7) <> 0 then inc(currs^.abytesize);
            Curr^.BaseType := currf.BaseType;
            Curr^.Ext := currs;
            FTypes.Add(Curr);
          end;
        btStaticArray:
          begin
            if not Read(d, 4) then
            begin
              cmd_err(erUnexpectedEof);
              LoadTypes := False;
              exit;
            end;
            if (d >= FTypes.Count) then begin
              cmd_err(erTypeMismatch);
              LoadTypes := False;
              exit;
            end;
            new(currx);
            currx.aType := FTypes[d];
            if not Read(d, 4) then
            begin
              dispose(currx);
              cmd_err(erUnexpectedEof);
              LoadTypes := False;
              exit;
            end;
            if d > (MaxInt div 4) then
            begin
              dispose(currx);
              cmd_err(erUnexpectedEof);
              LoadTypes := False;
              exit;
            end;
            currx.Size := d;
            Curr^.BaseType := currf.BaseType;
            Curr^.Ext := currx;
            FTypes.Add(Curr);
          end;
        btArray: begin
            if not read(d, 4) then begin // Read type
              cmd_err(erUnexpectedEof);
              LoadTypes := False;
              exit;
            end;
            if (d >= FTypes.Count) then begin
              cmd_err(erTypeMismatch);
              LoadTypes := False;
              exit;
            end;
            Curr^.BaseType := currf.BaseType;
            Curr^.Ext := Pointer(d);
            FTypes.Add(Curr);
          end;
        btRecord: begin
            if not read(d, 4) or (d = 0) then begin
              cmd_err(erUnexpectedEof);
              LoadTypes := false;
              exit;
            end;
            try
              New(currr);
            except
              cmd_err(erOutOfMemory);
              LoadTypes := False;
              exit;
            end;
            SetLength(currr^.Data, d * 4);
            if not read(currr^.Data[1], d * 4) then begin
              currr^.Data := '';
              Dispose(currr);
              cmd_err(erUnexpectedEof);
              LoadTypes := False;
              exit;
            end;
            if not resolve(currr^.Data) then begin
              currr^.Data := '';
              Dispose(currr);
              cmd_err(erInvalidType);
              LoadTypes := False;
              exit;
            end;
            Curr^.BaseType := currf.BaseType;
            Curr^.Ext := currr;
            FTypes.Add(Curr);
          end;
      else begin
          LoadTypes := False;
          CMD_Err(erInvalidType);
          Dispose(Curr);
          exit;
        end;
      end;
      if fe then begin
        if not read(d, 4) then begin
          cmd_err(erUnexpectedEof);
          LoadTypes := False;
          exit;
        end;
        if d > IFPSAddrNegativeStackStart then begin
          cmd_err(erInvalidType);
          LoadTypes := False;
          exit;
        end;
        SetLength(Curr^.ExportName, d);
        if not read(Curr^.ExportName[1], d) then begin
          cmd_err(erUnexpectedEof);
          LoadTypes := False;
          exit;
        end;
        Curr^.ExportNameHash := MakeHash(Curr^.ExportName);
      end;
    end;
  end;

  function LoadProcs: Boolean;
  var
    Rec: TIFPSProc;
    n: string;
    b: Byte;
    l, L2, L3: Longint;
    Curr: PIFProcRec;
  begin
    LoadProcs := True;
    for l := 0 to HDR.ProcCount - 1 do begin
      if not read(Rec, SizeOf(Rec)) then begin
        cmd_err(erUnexpectedEof);
        LoadProcs := False;
        exit;
      end;
      try
        New(Curr);
      except
        cmd_err(erOutOfMemory);
        LoadProcs := False;
        exit;
      end;
      Curr^.ExternalProc := (Rec.Flags and 1) <> 0;
      if Curr^.ExternalProc then begin
        if not read(b, 1) then begin
          Dispose(Curr);
          cmd_err(erUnexpectedEof);
          LoadProcs := False;
          exit;
        end;
        SetLength(n, b);
        if not read(n[1], b) then begin
          Dispose(Curr);
          cmd_err(erUnexpectedEof);
          LoadProcs := False;
          exit;
        end;
        Curr^.Name := n;
        if (Rec.Flags and 3 = 3) then
        begin
          if (not Read(L2, 4)) or (L2 > Length(s) - Pos) then
          begin
            Dispose(Curr);
            cmd_err(erUnexpectedEof);
            LoadProcs := False;
            exit;
          end;
          SetLength(n, L2);
          Read(n[1], L2); // no check is needed
          Curr^.ExportDecl := n;
        end;
        if not ImportProc(Curr^.Name, Curr^) then begin
          if Curr^.Name <> '' then
            CMD_Err2(erCannotImport, Curr^.Name)
          else if Curr^.ExportDecl <> '' then
            CMD_Err2(erCannotImport, curr^.ExportDecl)
          else
            CMD_Err2(erCannotImport, curr^.ExportName);
          Dispose(Curr);
          LoadProcs := False;
          exit;
        end;
      end
      else begin
        if not read(L2, 4) then begin
          Dispose(Curr);
          cmd_err(erUnexpectedEof);
          LoadProcs := False;
          exit;
        end;
        if not read(L3, 4) then begin
          Dispose(Curr);
          cmd_err(erUnexpectedEof);
          LoadProcs := False;
          exit;
        end;
        if (L2 < 0) or (L2 >= Length(s)) or (L2 + L3 > Length(s)) or (L3 = 0) then begin
          Dispose(Curr);
          cmd_err(erUnexpectedEof);
          LoadProcs := False;
          exit;
        end;
        GetMem(Curr^.Data, L3);
        Move(s[L2 + 1], Curr^.Data^, L3);
        Curr^.Length := L3;
        if (Rec.Flags and 2) <> 0 then begin // exported
          if not read(L3, 4) then begin
            Dispose(Curr);
            cmd_err(erUnexpectedEof);
            LoadProcs := False;
            exit;
          end;
          if L3 > IFPSAddrNegativeStackStart then begin
            Dispose(Curr);
            cmd_err(erUnexpectedEof);
            LoadProcs := False;
            exit;
          end;
          SetLength(Curr^.ExportName, L3);
          if not read(Curr^.ExportName[1], L3) then begin
            Dispose(Curr);
            cmd_err(erUnexpectedEof);
            LoadProcs := False;
            exit;
          end;
          if not read(L3, 4) then begin
            Dispose(Curr);
            cmd_err(erUnexpectedEof);
            LoadProcs := False;
            exit;
          end;
          if L3 > IFPSAddrNegativeStackStart then begin
            Dispose(Curr);
            cmd_err(erUnexpectedEof);
            LoadProcs := False;
            exit;
          end;
          SetLength(Curr^.ExportDecl, L3);
          if not read(Curr^.ExportDecl[1], L3) then begin
            Dispose(Curr);
            cmd_err(erUnexpectedEof);
            LoadProcs := False;
            exit;
          end;
          Curr^.ExportNameHash := MakeHash(Curr^.ExportName);
        end;
      end;
      FProcs.Add(Curr);
    end;
  end;
{$WARNINGS ON}

  function LoadVars: Boolean;
  var
    l, n: Longint;
    e: PIFPSExportedVar;
    Rec: TIFPSVar;
    Curr: PIfVariant;
  begin
    LoadVars := True;
    for l := 0 to HDR.VarCount - 1 do begin
      if not read(Rec, SizeOf(Rec)) then begin
        cmd_err(erUnexpectedEof);
        LoadVars := False;
        exit;
      end;
      if Rec.TypeNo >= HDR.TypeCount then begin
        cmd_err(erInvalidType);
        LoadVars := False;
        exit;
      end;
      Curr := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MM,
{$ENDIF}FTypes.Data^[Rec.TypeNo]);
      if Curr = nil then begin
        cmd_err(erInvalidType);
        LoadVars := False;
        exit;
      end;
      if (Rec.Flags and 1) <> 0then
      begin
        if not read(n, 4) then begin
          cmd_err(erUnexpectedEof);
          LoadVars := False;
          exit;
        end;
        new(e);
        try
          SetLength(e^.FName, n);
          if not Read(e^.FName[1], n) then
          begin
            dispose(e);
            cmd_err(erUnexpectedEof);
            LoadVars := False;
            exit;
          end;
          e^.FNameHash := MakeHash(e^.FName);
          e^.FVarNo := FGlobalVars.Count;
          FExportedVars.Add(E);
        except
          dispose(e);
          cmd_err(erInvalidType);
          LoadVars := False;
          exit;
        end;
      end;
      FGlobalVars.Add(Curr);
    end;
  end;

begin
  Clear;
  Pos := 0;
  LoadData := False;
  if not read(HDR, SizeOf(HDR)) then
  begin
    CMD_Err(erInvalidHeader);
    exit;
  end;
  if HDR.HDR <> IFPSValidHeader then
  begin
    CMD_Err(erInvalidHeader);
    exit;
  end;
  if (HDR.IFPSBuildNo > IFPSCurrentBuildNo) or (HDR.IFPSBuildNo < IFPSLowBuildSupport) then begin
    CMD_Err(erInvalidHeader);
    exit;
  end;
  if not LoadTypes then
  begin
    Clear;
    exit;
  end;
  if not LoadProcs then
  begin
    Clear;
    exit;
  end;
  if not LoadVars then
  begin
    Clear;
    exit;
  end;
  if (HDR.MainProcNo >= FProcs.Count) and (HDR.MainProcNo <> InvalidVal)then begin
    CMD_Err(erNoMainProc);
    Clear;
    exit;
  end;
  // Load Import Table
  FMainProc := HDR.MainProcNo;
  FStatus := isLoaded;
  Result := True;
end;

procedure TIFPSExec.Pause;
begin
  if FStatus = isRunning then
    FStatus := isPaused;
end;

function TIFPSExec.ReadData(var Data; Len: Cardinal): Boolean;
begin
  if FCurrentPosition + Len <= FDataLength then begin
    Move(FData^[FCurrentPosition], Data, Len);
    FCurrentPosition := FCurrentPosition + Len;
    Result := True;
  end
  else
    Result := False;
end;

procedure TIFPSExec.CMD_Err(EC: TIFError); // Error
begin
  CMD_Err3(ec, '', nil);
end;

function TIFPSExec.BuildArray(Dest, Src: PIFVariant): boolean;
var
  i, j: Longint;
  t: pbtrecord;
begin
  if (Src^.FType^.BaseType = btVariant) and (Src^.TVariant^.FType <> nil) and (Src^.TVariant^.FType^.BaseType = btArray) then
    Src := Src^.TVariant;
  if (Src^.FType^.BaseType <> btArray) and (Src^.FType^.BaseType <> btRecord) then
  begin
    Result := False;
    exit;
  end;
  if Dest^.TArray <> nil then
  begin
    for i := 0 to pbtrecord(Dest^.Tarray)^.FieldCount -1 do
    begin
      DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM ,{$ENDIF}pbtrecord(Dest^.Tarray)^.fields[i]);
    end;
    FreeMem(pbtrecord(Dest^.Tarray), pbtrecord(Dest^.Tarray)^.FieldCount * 4 + 4);
  end;
  if src^.TArray = nil then
  begin
    Dest^.TArray := nil;
    Result := true;
    exit;
  end;
  try
    getmem(t, pbtRecord(src^.Tarray)^.FieldCount * 4 +4);
    t.FieldCount := pbtRecord(src^.Tarray)^.FieldCount;
  except
    Dest^.TArray := nil;
    Result := False;
    exit;
  end;
  for i := pbtRecord(src^.Tarray)^.FieldCount -1 downto 0 do
  begin
    t^.Fields[i] := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}mm, {$ENDIF} pbtRecord(src^.Tarray)^.Fields[i]^.FType);
    if t^.Fields[i] = nil then
    begin
      Freemem(t, t^.FieldCount * 4 + 4);
      for j := 0 to i -1 do
      begin
        DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}mm, {$ENDIF} t^.Fields[j]);
      end;
      Dest^.TArray := nil;
      Result := False;
      exit;
    end;
    if not SetVariantValue(t^.Fields[i], pbtRecord(src^.Tarray)^.Fields[i]) then
    begin
      for j := pbtRecord(src^.Tarray)^.FieldCount -1 downto i do
      begin
        DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}mm, {$ENDIF} t^.Fields[j]);
      end;
      Freemem(t, t^.FieldCount * 4 + 4);
      Dest^.TArray := nil;
      Result := False;
      exit;
    end;
  end;
  dest^.TArray := t;

  Result := True;
end;

function TIFPSExec.SetVariantValue(dest, Src: PIfVariant): Boolean;
begin
  Result := True;
  case dest^.FType^.BaseType of
    btSet:
      begin
        if Dest^.FType = src^.FType then
          Move(src^.tset^, dest^.tset^, PIFSetTypeInfo(Dest^.FType.Ext).aByteSize)
        else
          Result := False;
      end;
    btU8: dest^.tu8 := GetUInt(Src, Result);
    btS8: dest^.tS8 := GetInt(Src, Result);
    btU16: dest^.tu16 := GetUInt(Src, Result);
    btS16: dest^.ts16 := GetInt(Src, Result);
    btU32, btProcPtr: dest^.tu32 := GetUInt(Src, Result);
    btS32: dest^.ts32 := GetInt(Src, Result);
    {$IFNDEF IFPS3_NOINT64}
    btS64: dest^.ts64 := GetInt64(Src, Result);
    {$ENDIF}
    btSingle: dest^.tsingle := GetReal(Src, Result);
    btDouble: dest^.tdouble := GetReal(Src, Result);
    btExtended: dest^.textended := GetReal(Src, Result);
    btPChar,btString: TbtString((@dest^.tstring)^) := GetString(Src, Result);
    btChar: dest^.tchar := chr(GetUInt(Src, Result));
    {$IFNDEF IFPS3_NOWIDESTRING}
    btWideChar: dest^.twidechar := widechar(GetUInt(Src, Result));
    btWideString: tbtWideString(dest^.twidestring) := GetWideString(Src, Result);
    {$ENDIF}
    btStaticArray, btArray, btRecord: Result := BuildArray(Dest, Src);
    btVariant:
    begin
      if Src^.FType^.BaseType = btVariant then
        ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}mm, {$ENDIF}Dest^.tVariant, src^.TVariant^.FType)
      else
        ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}mm, {$ENDIF}Dest^.tVariant, src^.FType);
      if Dest^.tvariant = nil then
      begin
        Result := False;
      end else begin
        if Dest^.TVariant^.FType <> nil then
        begin
          if Src^.FType^.BaseType = btVariant then
            Result := SetVariantValue(Dest^.TVariant, Src^.tvariant)
          else
            Result := SetVariantValue(Dest^.TVariant, Src);
        end;
      end;
    end;
    btResourcePointer:
    begin
      if src^.Ftype^.BaseType = btvariant then
      begin
        Src := src^.tvariant;
        if src^.FType = nil then
        begin
          Result := False;
          exit;
        end;
      end;
      if (Src^.FType^.BaseType <> btResourcePointer) or (Dest^.FType^.BaseType <> btResourcePointer) then
      begin
        Result := False;
        exit;
      end;
      if @Dest^.FType^.ResFree <> nil then
      begin
        Dest^.FType^.ResFree(vrfFree, dest, nil);
      end;
      if @Src^.FType^.ResFree <> nil then
      begin
        Result := Src^.FType^.ResFree(vrfDuplicate, Src, Dest);
      end else begin
        Dest^.TResourceP1 := nil;
        Dest^.TResourceP2 := nil;
      end;
    end;
  else begin
      Result := False;
    end;
  end;
  if Result = False then
    CMD_Err(ErTypeMismatch);
end;

function TIFPSExec.DoBooleanCalc(var1, Var2: PIfVariant; Into: PIfVariant; Cmd:
  Cardinal): Boolean;
var
  b: Boolean;
  P: PIFTypeRec;

  procedure SetBoolean(b: Boolean; var Ok: Boolean);
  begin
    Ok := True;
    case Into^.FType^.BaseType of
      btU8: Into^.tu8 := Cardinal(b);
      btS8: Into^.tS8 := Longint(b);
      btU16: Into^.tu16 := Cardinal(b);
      btS16: Into^.ts16 := Longint(b);
      btU32: Into^.tu32 := Cardinal(b);
      btS32: Into^.ts32 := Longint(b);
    else begin
        CMD_Err(ErTypeMismatch);
        Ok := False;
      end;
    end;
  end;
begin
  if Into^.FType^.BaseType = btVariant then
  begin
    p := FindType2(btU8);
    if p = nil then
    begin
      Result := False;
      exit;
    end;
  end;
  Result := True;
  if (var1^.FType = nil) and (var1^.FType = nil) then {variants}
  begin
    case Cmd of
      0,1,2,3: Result := False; 
      4: SetBoolean(False, Result); { <> }
      5: SetBoolean(True, Result); { = }
    else begin
        Result := False;
        CMD_Err(erInvalidOpcodeParameter);
        exit;
      end;
    end;
    if not Result then begin
      CMD_Err(erTypeMismatch);
      exit;
    end;
  end else
  if (var1^.FType = nil) xor (var2^.FType = nil) then {variants}
  begin
    case Cmd of
      0,1,2,3: Result := False; 
      4: SetBoolean(True, Result); { <> }
      5: SetBoolean(False, Result); { = }
    else begin
        Result := False;
        CMD_Err(erInvalidOpcodeParameter);
        exit;
      end;
    end;
    if not Result then begin
      CMD_Err(erTypeMismatch);
      exit;
    end;
  end else
  case Cmd of
    0: begin { >= }
        case var1^.FType^.BaseType of
          btU8:
          if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
            b := char(var1^.tu8) >= GetString(Var2, Result)
          else
            b := var1^.tu8 >= GetUInt(Var2, Result);
          btS8: b := var1^.tS8 >= GetInt(Var2, Result);
          btU16: b := var1^.tu16 >= GetUInt(Var2, Result);
          btS16: b := var1^.ts16 >= GetInt(Var2, Result);
          btU32, btProcPtr: b := var1^.tu32 >= GetUInt(Var2, Result);
          btS32: b := var1^.ts32 >= GetInt(Var2, Result);
          btSingle: b := var1^.tsingle >= GetReal(Var2, Result);
          btDouble: b := var1^.tdouble >= GetReal(Var2, Result);
          btExtended: b := var1^.textended >= GetReal(Var2, Result);
          {$IFNDEF IFPS3_NOINT64}                  
          btS64: b := var1^.ts64 >= GetInt64(Var2, Result);
          {$ENDIF}
          btPChar,btString: b := tbtstring(var1^.tstring) >= GetString(Var2, Result);
          btChar: b := Var1^.tchar >= GetString(Var2, Result);
          {$IFNDEF IFPS3_NOWIDESTRING}
          btWideChar: b := Var1^.twidechar >= GetWideString(Var2, Result);
          btWideString: b := tbtwidestring(Var1^.twidestring) >= GetWideString(Var2, Result);
          {$ENDIF}
          btSet:
            begin
              if var1.FType = var2.FType then
              begin
                Set_Subset(var2^.tset, var1^.tset, PIFSetTypeInfo(var1.FType.ext).aByteSize, b);
              end else result := False;
            end;
        else begin
            CMD_Err(ErTypeMismatch);
            exit;
          end;
        end;
        if not Result then begin
          CMD_Err(ErTypeMismatch);
          exit;
        end;
        SetBoolean(b, Result);
      end;
    1: begin { <= }
        case var1^.FType^.BaseType of
          btU8:
          if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
            b := char(var1^.tu8) <= GetString(Var2, Result)
          else
            b := var1^.tu8 <= GetUInt(Var2, Result);
          btS8: b := var1^.tS8 <= GetInt(Var2, Result);
          btU16: b := var1^.tu16 <= GetUInt(Var2, Result);
          btS16: b := var1^.ts16 <= GetInt(Var2, Result);
          btU32, btProcPtr: b := var1^.tu32 <= GetUInt(Var2, Result);
          btS32: b := var1^.ts32 <= GetInt(Var2, Result);
          btSingle: b := var1^.tsingle <= GetReal(Var2, Result);
          btDouble: b := var1^.tdouble <= GetReal(Var2, Result);
          btExtended: b := var1^.textended <= GetReal(Var2, Result);
          {$IFNDEF IFPS3_NOINT64}
          btS64: b := var1^.ts64 <= GetInt64(Var2, Result);
          {$ENDIF}
          btPChar,btString: b := tbtstring(var1^.tstring) <= GetString(Var2, Result);
          btChar: b := Var1^.tchar <= GetString(Var2, Result);
          {$IFNDEF IFPS3_NOWIDESTRING}
          btWideChar: b := Var1^.twidechar <= GetWideString(Var2, Result);
          btWideString: b := tbtwidestring(Var1^.twidestring) <= GetWideString(Var2, Result);
          {$ENDIF}
          btSet:
            begin
              if var1.FType = var2.FType then
              begin
                Set_Subset(var1^.tset, var2^.tset, PIFSetTypeInfo(var1.FType.ext).aByteSize, b);
              end else result := False;
            end;
        else begin
            CMD_Err(ErTypeMismatch);
            exit;
          end;
        end;
        if not Result then begin
          CMD_Err(erTypeMismatch);
          exit;
        end;
        SetBoolean(b, Result);
      end;
    2: begin { > }
        case var1^.FType^.BaseType of
          btU8:
          if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
            b := char(var1^.tu8) > GetString(Var2, Result)
          else
            b := var1^.tu8 > GetUInt(Var2, Result);
          btS8: b := var1^.tS8 > GetInt(Var2, Result);
          btU16: b := var1^.tu16 > GetUInt(Var2, Result);
          btS16: b := var1^.ts16 > GetInt(Var2, Result);
          btU32, btProcPtr: b := var1^.tu32 > GetUInt(Var2, Result);
          btS32: b := var1^.ts32 > GetInt(Var2, Result);
          btSingle: b := var1^.tsingle > GetReal(Var2, Result);
          btDouble: b := var1^.tdouble > GetReal(Var2, Result);
          btExtended: b := var1^.textended > GetReal(Var2, Result);
          {$IFNDEF IFPS3_NOINT64}
          btS64: b := var1^.ts64 > GetInt64(Var2, Result);
          {$ENDIF}
          btPChar,btString: b := tbtstring(var1^.tstring) > GetString(Var2, Result);
          btChar: b := Var1^.tchar > GetString(Var2, Result);
          {$IFNDEF IFPS3_NOWIDESTRING}
          btWideChar: b := Var1^.twidechar > GetWideString(Var2, Result);
          btWideString: b := tbtwidestring(Var1^.twidestring) > GetWideString(Var2, Result);
          {$ENDIF}
        else begin
            CMD_Err(erTypeMismatch);
            exit;
          end;
        end;
        if not Result then begin
          CMD_Err(erTypeMismatch);
          exit;
        end;
        SetBoolean(b, Result);
      end;
    3: begin { < }
        case var1^.FType^.BaseType of
          btU8:
          if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
            b := char(var1^.tu8) < GetString(Var2, Result)
          else
            b := var1^.tu8 < GetUInt(Var2, Result);
          btS8: b := var1^.tS8 < GetInt(Var2, Result);
          btU16: b := var1^.tu16 < GetUInt(Var2, Result);
          btS16: b := var1^.ts16 < GetInt(Var2, Result);
          btU32, btProcPtr: b := var1^.tu32 < GetUInt(Var2, Result);
          btS32: b := var1^.ts32 < GetInt(Var2, Result);
          btSingle: b := var1^.tsingle < GetReal(Var2, Result);
          btDouble: b := var1^.tdouble < GetReal(Var2, Result);
          btExtended: b := var1^.textended < GetReal(Var2, Result);
          {$IFNDEF IFPS3_NOINT64}
          btS64: b := var1^.ts64 < GetInt64(Var2, Result);
          {$ENDIF}
          btPChar,btString: b := tbtstring(var1^.tstring) < GetString(Var2, Result);
          btChar: b := Var1^.tchar < GetString(Var2, Result);
          {$IFNDEF IFPS3_NOWIDESTRING}
          btWideChar: b := Var1^.twidechar < GetWideString(Var2, Result);
          btWideString: b := tbtwidestring(Var1^.twidestring) < GetWideString(Var2, Result);
          {$ENDIF}
        else begin
            CMD_Err(erTypeMismatch);
            exit;
          end;
        end;
        if not Result then begin
          CMD_Err(erTypeMismatch);
          exit;
        end;
        SetBoolean(b, Result);
      end;
    4: begin { <> }
        case var1^.FType^.BaseType of
          btU8:
          if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
            b := char(var1^.tu8) <> GetString(Var2, Result)
          else
            b := var1^.tu8 <> GetUInt(Var2, Result);
          btS8: b := var1^.tS8 <> GetInt(Var2, Result);
          btU16: b := var1^.tu16 <> GetUInt(Var2, Result);
          btS16: b := var1^.ts16 <> GetInt(Var2, Result);
          btU32, btProcPtr: b := var1^.tu32 <> GetUInt(Var2, Result);
          btS32: b := var1^.ts32 <> GetInt(Var2, Result);
          btSingle: b := var1^.tsingle <> GetReal(Var2, Result);
          btDouble: b := var1^.tdouble <> GetReal(Var2, Result);
          btExtended: b := var1^.textended <> GetReal(Var2, Result);
          btPChar,btString: b := TbtString(var1^.tstring) <> GetString(Var2, Result);
          {$IFNDEF IFPS3_NOINT64}
          btS64: b := var1^.ts64 <> GetInt64(Var2, Result);
          {$ENDIF}
          btChar: b := Var1^.tchar <> GetString(Var2, Result);
          {$IFNDEF IFPS3_NOWIDESTRING}
          btWideChar: b := Var1^.twidechar <> GetWideString(Var2, Result);
          btWideString: b := tbtwidestring(Var1^.twidestring) <> GetWideString(Var2, Result);
          {$ENDIF}
          btSet:
            begin
              if var1.FType = var2.FType then
              begin
                Set_Equal(var1^.tset, var2^.tset, PIFSetTypeInfo(var1.FType.ext).aByteSize, b);
                b := not b;
              end else result := False;
            end;
        else begin
            CMD_Err(erTypeMismatch);
            exit;
          end;
        end;
        if not Result then begin
          CMD_Err(erTypeMismatch);
          exit;
        end;
        SetBoolean(b, Result);
      end;
    5: begin { = }
        case var1^.FType^.BaseType of
          btU8:
          if (var2^.FType^.BaseType = btString) or (Var2^.Ftype^.BaseType = btPChar) then
            b := char(var1^.tu8) = GetString(Var2, Result)
          else
            b := var1^.tu8 = GetUInt(Var2, Result);
          btS8: b := var1^.tS8 = GetInt(Var2, Result);
          btU16: b := var1^.tu16 = GetUInt(Var2, Result);
          btS16: b := var1^.ts16 = GetInt(Var2, Result);
          btU32, btProcPtr: b := var1^.tu32 = GetUInt(Var2, Result);
          btS32: b := var1^.ts32 = GetInt(Var2, Result);
          btSingle: b := var1^.tsingle = GetReal(Var2, Result);
          btDouble: b := var1^.tdouble = GetReal(Var2, Result);
          btExtended: b := var1^.textended = GetReal(Var2, Result);
          btPchar, btString: b := TbtString(var1^.tstring) = GetString(Var2, Result);
          {$IFNDEF IFPS3_NOINT64}
          btS64: b := var1^.ts64 = GetInt64(Var2, Result);
          {$ENDIF}
          btChar: b := Var1^.tchar = GetString(Var2, Result);
          {$IFNDEF IFPS3_NOWIDESTRING}
          btWideChar: b := Var1^.twidechar = GetWideString(Var2, Result);
          btWideString: b := tbtwidestring(Var1^.twidestring) = GetWideString(Var2, Result);
          {$ENDIF}
          btSet:
            begin
              if var1.FType = var2.FType then
              begin
                Set_Equal(var1^.tset, var2^.tset, PIFSetTypeInfo(var1.FType.ext).aByteSize, b);
              end else result := False;
            end;
        else begin
            CMD_Err(erTypeMismatch);
            exit;
          end;
        end;
        if not Result then begin
          CMD_Err(erTypeMismatch);
          exit;
        end;
        SetBoolean(b, Result);
      end;
    6: begin { in }
        if var2^.FType^.BaseType = btSet then
        begin
          Cmd := GetUInt(var1, Result);
          if not Result then
          begin
            CMD_Err(erTypeMismatch);
            exit;
          end;
          if Cmd >= Cardinal(PIFSetTypeInfo(var2.FType.ext).aBitSize) then
          begin
            cmd_Err(erOutofRecordRange);
            Result := False;
            Exit;
          end;
          Set_membership(Cmd, var2.tset, b);
          SetBoolean(b, Result);
        end else
        begin
          CMD_Err(erTypeMismatch);
          exit;
        end;
      end;
  else begin
      Result := False;
      CMD_Err(erInvalidOpcodeParameter);
      exit;
    end;
  end;
end;

function TIFPSExec.DoCalc(var1, Var2: PIfVariant; CalcType: Cardinal): Boolean;
    { var1=dest, var2=src }
var
  Tmp: TObject;
begin
  try
    Result := True;
    case CalcType of
      0: begin { + }
          case var1^.FType^.BaseType of
            btU8: var1^.tu8 := var1^.tu8 + GetUInt(Var2, Result);
            btS8: var1^.tS8 := var1^.tS8 + GetInt(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 + GetUInt(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 + GetInt(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 + GetUInt(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 + GetInt(Var2, Result);
           {$IFNDEF IFPS3_NOINT64}
            btS64:  var1^.ts64 := var1^.ts64 + GetInt64(var2, Result);
           {$ENDIF}
            btSingle: var1^.tsingle := var1^.tsingle + GetReal(Var2, Result);
            btDouble: var1^.tdouble := var1^.tdouble + GetReal(Var2, Result);
            btExtended: var1^.textended := var1^.textended + GetReal(Var2,
                Result);
            btPchar, btString: TbtString((@var1^.tstring)^) :=
              TbtString((@var1^.tstring)^) + GetString(Var2, Result);
            btChar: Var1^.tchar := char(ord(Var1^.tchar) +  GetUInt(Var2, Result));
            {$IFNDEF IFPS3_NOWIDESTRING}
            btWideChar: var1^.twidechar := widechar(ord(var1^.twidechar) + GetUInt(Var2, Result));
            btWideString: tbtwidestring(var1^.twidestring) := tbtwidestring(var1^.twidestring) + GetWideString(Var2, Result);
            {$ENDIF}
            btSet:
              begin
                if var1.FType = var2.FType then
                begin
                  Set_Union(var1^.tset, var2^.tset, PIFSetTypeInfo(var1.FType.ext).aByteSize);
                end else result := False;
              end;

          else begin
              CMD_Err(erTypeMismatch);
              exit;
            end;
          end;
          if not Result then begin
            CMD_Err(erTypeMismatch);
            exit;
          end;
        end;
      1: begin { - }
          case var1^.FType^.BaseType of
            btU8: var1^.tu8 := var1^.tu8 - GetUInt(Var2, Result);
            btS8: var1^.tS8 := var1^.tS8 - GetInt(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 - GetUInt(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 - GetInt(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 - GetUInt(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 - GetInt(Var2, Result);
           {$IFNDEF IFPS3_NOINT64}
            btS64: var1^.ts64 := var1^.ts64 - GetInt64(var2, Result);
           {$ENDIF}
            btSingle: var1^.tsingle := var1^.tsingle - GetReal(Var2, Result);
            btDouble: var1^.tdouble := var1^.tdouble - GetReal(Var2, Result);
            btExtended: var1^.textended := var1^.textended - GetReal(Var2,
                Result);
            btChar: Var1^.tchar := char(ord(Var1^.tchar) - GetUInt(Var2, Result));
            {$IFNDEF IFPS3_NOWIDESTRING}
            btWideChar: Var1^.twidechar := widechar(ord(Var1^.twidechar) - GetUInt(Var2, Result));
            {$ENDIF}
            btSet:
              begin
                if var1.FType = var2.FType then
                begin
                  Set_Diff(var1^.tset, var2^.tset, PIFSetTypeInfo(var1.FType.ext).aByteSize);
                end else result := False;
              end;
          else begin
              CMD_Err(erTypeMismatch);
              exit;
            end;
          end;
          if not Result then begin
            CMD_Err(erTypeMismatch);
            exit;
          end;
        end;
      2: begin { * }
          case var1^.FType^.BaseType of
            btU8: var1^.tu8 := var1^.tu8 * GetUInt(Var2, Result);
            btS8: var1^.tS8 := var1^.tS8 * GetInt(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 * GetUInt(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 * GetInt(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 * GetUInt(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 * GetInt(Var2, Result);
           {$IFNDEF IFPS3_NOINT64}
            btS64: var1^.ts64 := var1^.ts64 * GetInt64(var2, Result);
           {$ENDIF}
            btSingle: var1^.tsingle := var1^.tsingle * GetReal(Var2, Result);
            btDouble: var1^.tdouble := var1^.tdouble * GetReal(Var2, Result);
            btExtended: var1^.textended := var1^.textended * GetReal(Var2,
                Result);
            btSet:
              begin
                if var1.FType = var2.FType then
                begin
                  Set_Intersect(var1^.tset, var2^.tset, PIFSetTypeInfo(var1.FType.ext).aByteSize);
                end else result := False;
              end;
          else begin
              CMD_Err(erTypeMismatch);
              exit;
            end;
          end;
          if not Result then begin
            CMD_Err(erTypeMismatch);
            exit;
          end;
        end;
      3: begin { / }
          case var1^.FType^.BaseType of
            btU8: var1^.tu8 := var1^.tu8 div GetUInt(Var2, Result);
            btS8: var1^.tS8 := var1^.tS8 div GetInt(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 div GetUInt(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 div GetInt(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 div GetUInt(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 div GetInt(Var2, Result);
           {$IFNDEF IFPS3_NOINT64}
            btS64: var1^.ts64 := var1^.ts64 div GetInt64(var2, Result);
           {$ENDIF}
            btSingle: var1^.tsingle := var1^.tsingle / GetReal(Var2, Result);
            btDouble: var1^.tdouble := var1^.tdouble / GetReal(Var2, Result);
            btExtended: var1^.textended := var1^.textended / GetReal(Var2, Result);
          else begin
              CMD_Err(erTypeMismatch);
              exit;
            end;
          end;
          if not Result then begin
            CMD_Err(erTypeMismatch);
            exit;
          end;
        end;
      4: begin { MOD }
          case var1^.FType^.BaseType of
            btU8: var1^.tu8 := var1^.tu8 mod GetUInt(Var2, Result);
            btS8: var1^.tS8 := var1^.tS8 mod GetInt(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 mod GetUInt(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 mod GetInt(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 mod GetUInt(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 mod GetInt(Var2, Result);
           {$IFNDEF IFPS3_NOINT64}
            btS64: var1^.ts64 := var1^.ts64 mod GetInt64(var2, Result);
           {$ENDIF}
          else begin
              CMD_Err(erTypeMismatch);
              exit;
            end;
          end;
          if not Result then begin
            CMD_Err(erTypeMismatch);
            exit;
          end;
        end;
      5: begin { SHL }
          case var1^.FType^.BaseType of
            btU8: var1^.tu8 := var1^.tu8 shl GetUInt(Var2, Result);
            btS8: var1^.tS8 := var1^.tS8 shl GetInt(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 shl GetUInt(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 shl GetInt(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 shl GetUInt(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 shl GetInt(Var2, Result);
           {$IFNDEF IFPS3_NOINT64}
            btS64: var1^.ts64 := var1^.ts64 shl GetInt64(var2, Result);
           {$ENDIF}
          else begin
              CMD_Err(erTypeMismatch);
              exit;
            end;
          end;
          if not Result then begin
            CMD_Err(erTypeMismatch);
            exit;
          end;
        end;
      6: begin { SHR }
          case var1^.FType^.BaseType of
            btU8: var1^.tu8 := var1^.tu8 shr GetUInt(Var2, Result);
            btS8: var1^.tS8 := var1^.tS8 shr GetInt(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 shr GetUInt(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 shr GetInt(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 shr GetUInt(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 shr GetInt(Var2, Result);
           {$IFNDEF IFPS3_NOINT64}
            btS64: var1^.ts64 := var1^.ts64 shr GetInt64(var2, Result);
           {$ENDIF}
          else begin
              CMD_Err(erTypeMismatch);
              exit;
            end;
          end;
          if not Result then begin
            CMD_Err(erTypeMismatch);
            exit;
          end;
        end;
      7: begin { AND }
          case var1^.FType^.BaseType of
            btU8: var1^.tu8 := var1^.tu8 and GetUInt(Var2, Result);
            btS8: var1^.tS8 := var1^.tS8 and GetInt(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 and GetUInt(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 and GetInt(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 and GetUInt(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 and GetInt(Var2, Result);
           {$IFNDEF IFPS3_NOINT64}
            btS64: var1^.ts64 := var1^.ts64 and GetInt64(var2, Result);
           {$ENDIF}
          else begin
              CMD_Err(erTypeMismatch);
              exit;
            end;
          end;
          if not Result then begin
            CMD_Err(erTypeMismatch);
            exit;
          end;
        end;
      8: begin { OR }
          case var1^.FType^.BaseType of
            btU8: var1^.tu8 := var1^.tu8 or GetUInt(Var2, Result);
            btS8: var1^.tS8 := var1^.tS8 or GetInt(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 or GetUInt(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 or GetInt(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 or GetUInt(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 or GetInt(Var2, Result);
           {$IFNDEF IFPS3_NOINT64}
            btS64: var1^.ts64 := var1^.ts64 or GetInt64(var2, Result);
           {$ENDIF}
          else begin
              CMD_Err(erTypeMismatch);
              exit;
            end;
          end;
          if not Result then begin
            CMD_Err(erTypeMismatch);
            exit;
          end;
        end;
      9: begin { XOR }
          case var1^.FType^.BaseType of
            btU8: var1^.tu8 := var1^.tu8 xor GetUInt(Var2, Result);
            btS8: var1^.tS8 := var1^.tS8 xor GetInt(Var2, Result);
            btU16: var1^.tu16 := var1^.tu16 xor GetUInt(Var2, Result);
            btS16: var1^.ts16 := var1^.ts16 xor GetInt(Var2, Result);
            btU32: var1^.tu32 := var1^.tu32 xor GetUInt(Var2, Result);
            btS32: var1^.ts32 := var1^.ts32 xor GetInt(Var2, Result);
           {$IFNDEF IFPS3_NOINT64}
            btS64: var1^.ts64 := var1^.ts64 xor GetInt64(var2, Result);
           {$ENDIF}
          else begin
              CMD_Err(erTypeMismatch);
              exit;
            end;
          end;
          if not Result then begin
            CMD_Err(erTypeMismatch);
            exit;
          end;
        end;
    else begin
        Result := False;
        CMD_Err(erInvalidOpcodeParameter);
        exit;
      end;
    end;
  except
    {$IFDEF IFPS3_D6PLUS}
    Tmp := AcquireExceptionObject;
    {$ELSE}
    if RaiseList <> nil then
    begin
      Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
      PRaiseFrame(RaiseList)^.ExceptObject := nil;
    end else
      Tmp := nil;
    {$ENDIF}
    if Tmp <> nil then
    begin
      if Tmp is EDivByZero then
      begin
        Result := False;
        CMD_Err3(erDivideByZero, '', Tmp);
        Exit;
      end;
      if Tmp is EZeroDivide then
      begin
        Result := False;
        CMD_Err3(erDivideByZero, '', Tmp);
        Exit;
      end;
      if Tmp is EMathError then
      begin
        Result := False;
        CMD_Err3(erMathError, '', Tmp);
        Exit;
      end;
    end;
    if (tmp <> nil) and (Tmp is Exception) then
      CMD_Err3(erException, Exception(Tmp).Message, Tmp)
    else
      CMD_Err3(erException, '', Tmp);
    Result := False;
  end;
end;

function TIFPSExec.ReadVariable(var NeedToFree: LongBool; UsePointer: LongBool): PIfVariant;
var
  VarType: Cardinal;
  Param: Cardinal;
  Tmp: PIfVariant;

begin
  if FCurrentPosition >= FDataLength then
  begin
    CMD_Err(erOutOfRange); // Error
    Result := nil;
    exit;
  end;
  VarType := FData^[FCurrentPosition];
  Inc(FCurrentPosition);
  if FCurrentPosition + 3 >= FDataLength then 
  begin
    Cmd_Err(erOutOfRange);
    Result := nil;
    exit;
  end;
  Param := Cardinal((@FData^[FCurrentPosition])^);
  Inc(FCurrentPosition, 4);
  case VarType of
    0: begin
        NeedToFree := False;
        if Param < IFPSAddrNegativeStackStart then begin
          if Param >= FGlobalVars.Count then
          begin
            CMD_Err(erOutOfGlobalVarsRange);
            Result := nil;
            exit;
          end;
          Result := FGlobalVars.Data^[Param];
        end
        else begin
          Param := Cardinal(Longint(-IFPSAddrStackStart) +
            Longint(FCurrStackBase) + Longint(Param));
          if Param >= FStack.Count then
          begin
            CMD_Err(erOutOfGlobalVarsRange);
            Result := nil;
            exit;
          end else Result := FStack.Data^[Param];
        end;
        if UsePointer then
        begin
          if Result^.FType^.BaseType = btPointer then begin
            Result := Result^.tPointer;
            if Result = nil then begin
              CMD_Err(erNullPointerException);
              exit;
            end;
          end;
          if Result^.FType^.BaseType = btVariant then begin
            Result := Result^.tvariant;         
            if Result = nil then begin
              CMD_Err(erNullPointerException);
              exit;
            end;
            if Result^.FType = nil then
            begin
              Result := nil;
              CMD_Err(erNullVariantError);
              Exit;
            end;
          end;
        end;
      end;
    1: begin
        NeedToFree := True;
        if Param >= FTypes.Count then
        begin
          CMD_Err(erInvalidType);
          Result := nil;
          exit;
        end;
        Result := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}FTypes.Data^[Param]);
        case Result^.FType^.BaseType of
          btSet:
            begin
              if not ReadData(Result^.tset^, Length(tbtstring(result^.tset))) then
              begin
                CMD_Err(erOutOfRange);
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Result);
                Result := nil;
                exit;
              end;
            end;
          bts8, btchar, btU8: if not ReadData(Result^.tu8, 1) then
          begin
              CMD_Err(erOutOfRange);
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Result);
              Result := nil;
              exit;
            end;
          bts16, {$IFNDEF IFPS3_NOWIDESTRING}btwidechar,{$ENDIF} btU16: if not ReadData((@Result^.tu16)^, SizeOf(TbtU16)) then begin
              CMD_Err(ErOutOfRange);
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Result);
              Result := nil;
              exit;
            end;
          bts32, btU32, btProcPtr:
            begin
              if FCurrentPosition + 3 >= FDataLength then
              begin
                Cmd_Err(erOutOfRange);
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Result);
                Result := nil;
                exit;;
              end;
              Result^.tu32 := Cardinal((@FData^[FCurrentPosition])^);
              Inc(FCurrentPosition, 4);
            end;
          {$IFNDEF IFPS3_NOINT64}
          bts64: if not ReadData(Result^.ts64, sizeof(tbts64)) then
            begin
              CMD_Err(erOutOfRange);
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Result);
              Result := nil;
              exit;
            end;
          {$ENDIF}
          btSingle: if not ReadData((@Result^.tsingle)^, SizeOf(TbtSingle))
            then begin
              CMD_Err(erOutOfRange);
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Result);
              Result := nil;
              exit;
            end;
          btDouble: if not ReadData((@Result^.tdouble)^, SizeOf(TbtDouble))
            then begin
              CMD_Err(erOutOfRange);
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Result);
              Result := nil;
              exit;
            end;
          btExtended: if not ReadData((@Result^.textended)^,
              SizeOf(TbtExtended)) then begin
              CMD_Err(erOutOfRange);
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Result);
              Result := nil;
              exit;
            end;
          btPchar, btString:
          begin
              if FCurrentPosition + 3 >= FDataLength then
              begin
                Cmd_Err(erOutOfRange);
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Result);
                Result := nil;
                exit;
              end;
              Param := Cardinal((@FData^[FCurrentPosition])^);
              Inc(FCurrentPosition, 4);

              SetLength(TbtString((@Result^.tstring)^), Param);
              if not ReadData(TbtString((@Result^.tstring)^)[1], Param) then begin
                CMD_Err(erOutOfRange);
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Result);
                Result := nil;
                exit;
              end;
            end;
          {$IFNDEF IFPS3_NOWIDESTRING}
          btWidestring:
            begin
              if FCurrentPosition + 3 >= FDataLength then
              begin
                Cmd_Err(erOutOfRange);
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Result);
                Result := nil;
                exit;
              end;
              Param := Cardinal((@FData^[FCurrentPosition])^);
              Inc(FCurrentPosition, 4);
              SetLength(TbtwideString(Result^.twidestring), Param);
              if not ReadData(TbtwideString(Result^.twidestring)[1], Param*2) then begin
                CMD_Err(erOutOfRange);
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Result);
                Result := nil;
                exit;
              end;
            end;
          {$ENDIF}
        else begin
            CMD_Err(erInvalidType);
            DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Result);
            Result := nil;
            exit;
          end;
        end;
      end;
    2: begin
        NeedToFree := False;
        if Param < IFPSAddrNegativeStackStart then begin
          if Param >= FGlobalVars.Count then
          begin
            CMD_Err(erOutOfGlobalVarsRange);
            Result := nil;
            exit;
          end;
          Result := FGlobalVars.Data^[Param];
        end
        else begin
          Param := Cardinal(Longint(-IFPSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param));
          if Param >= FStack.Count then
          begin
            CMD_Err(erOutOfStackRange);
            Result := nil;
            exit;
          end;
          Result := FStack.Data^[Param];
        end;
        if (Result^.FType^.BaseType = btPointer) then begin
          Result := Result^.tPointer;
          if Result = nil then begin
            CMD_Err(erNullPointerException);
            exit;
          end;
        end;
        if Result^.FType^.BaseType = btVariant then begin
          Result := Result^.tvariant;
          if Result = nil then begin
            CMD_Err(erNullPointerException);
            exit;
          end;
          if Result^.FType = nil then
          begin
            Result := nil;
            CMD_Err(erNullVariantError);
            Exit;
          end;
        end;
        if (Result^.FType^.BaseType <> btRecord) and (Result^.FType^.BaseType <> btArray) and (Result^.FType^.BaseType <> btStaticArray) then begin
          CMD_Err(erInvalidType);
          Result := nil;
          exit;
        end;
        if FCurrentPosition + 3 >= FDataLength then
        begin
          CMD_Err(erOutOfRange);
          Result := nil;
          exit;
        end;
        Param := Cardinal((@FData^[FCurrentPosition])^);
        Inc(FCurrentPosition, 4);
        if (Result^.trecord = nil) or (Param >= pbtrecord(Result^.trecord)^.FieldCount) then begin
          CMD_Err(erOutofRecordRange);
          Result := nil;
          exit;
        end;
        Result := pbtrecord(Result^.trecord)^.Fields[Param];
        if UsePointer then
        begin
          if Result^.FType^.BaseType = btPointer then begin
            Result := Result^.tPointer;
            if Result = nil then begin
              CMD_Err(erNullPointerException);
              exit;
            end;
          end;
          if Result^.FType^.BaseType = btVariant then begin
            Result := Result^.tvariant;
            if Result = nil then begin
              CMD_Err(erNullPointerException);
              exit;
            end;
            if Result^.FType = nil then
            begin
              Result := nil;
              CMD_Err(erNullVariantError);
              Exit;
            end;
          end;
        end;
      end;
    3: begin
        NeedToFree := False;
        if Param < IFPSAddrNegativeStackStart then
        begin
          if Param >= FGlobalVars.Count then
          begin
            CMD_Err(erOutOfGlobalVarsRange);
            Result := nil;
            exit;
          end;
          Result := FGlobalVars.Data^[Param];
        end
        else begin
          Param := Cardinal(Longint(-IFPSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param));
          if Param >= FStack.Count then
          begin
            CMD_Err(erOutOfStackRange);
            Result := nil;
            exit;
          end;
          Result := FStack.Data^[Param];
        end;
        if (Result^.FType^.BaseType = btPointer) then begin
          Result := Result^.tPointer;
          if Result = nil then begin
            CMD_Err(erNullPointerException);
            exit;
          end;
        end;
        if Result^.FType^.BaseType = btVariant then begin
          Result := Result^.tvariant;
          if Result = nil then begin
            CMD_Err(erNullPointerException);
            exit;
          end;
          if Result^.FType = nil then
          begin
            Result := nil;
            CMD_Err(erNullVariantError);
            Exit;
          end;
        end;
        if (Result^.FType^.BaseType <> btRecord) and (Result^.FType^.BaseType <> btArray)and (Result^.FType^.BaseType <> btStaticArray)  then begin
          CMD_Err(erInvalidType);
          Result := nil;
          exit;
        end;
        if FCurrentPosition + 3 >= FDataLength then
        begin
          CMD_Err(erOutOfRange);
          Result := nil;
          exit;
        end;
        Param := Cardinal((@FData^[FCurrentPosition])^);
        Inc(FCurrentPosition, 4);
        if Param < IFPSAddrNegativeStackStart then
        begin
          if Param >= FGlobalVars.Count then
          begin
            CMD_Err(erOutOfGlobalVarsRange);
            exit;
          end;
          Tmp := FGlobalVars.Data^[Param];
        end
        else begin
          Param := Cardinal(Longint(-IFPSAddrStackStart) + Longint(FCurrStackBase) + Longint(Param));
          if Param >= FStack.Count then
          begin
            CMD_Err(erOutOfStackRange);
            exit;
          end;
          Tmp := FStack.Data^[Param];
        end;
        case Tmp^.FType^.BaseType of
          btu8: Param := Tmp^.tu8;
          bts8: Param := Tmp^.ts8;
          btu16: Param := Tmp^.tu16;
          bts16: Param := Tmp^.ts16;
          btu32, btProcPtr: Param := Tmp^.tu32;
          bts32: Param := Tmp^.ts32;
        else
          CMD_Err(ErTypeMismatch);
          exit;
        end;

        if (Result^.trecord = nil) or (Param >= pbtrecord(Result^.trecord)^.FieldCount) then begin
          CMD_Err(erOutofRecordRange);
          Result := nil;
          exit;
        end;
        Result := pbtrecord(Result^.trecord)^.Fields[Param];
        if UsePointer then
        begin
          if Result^.FType^.BaseType = btPointer then begin
            Result := Result^.tPointer;
            if Result = nil then begin
              CMD_Err(erNullPointerException);
              exit;
            end;
          end;
          if Result^.FType^.BaseType = btVariant then begin
            if Result = nil then begin
              CMD_Err(erNullPointerException);
              exit;
            end;
            if Result^.FType = nil then
            begin
              Result := nil;
              CMD_Err(erNullVariantError);
              Exit;
            end;
          end;
        end;
      end;
  else
    Result := nil;
  end;
end;

function TIFPSExec.DoMinus(Vd: PIfVariant): Boolean;
begin
  case Vd^.FType^.BaseType of
    btU8: Vd^.tu8 := -Vd^.tu8;
    btU16: Vd^.tu16 := -Vd^.tu16;
    btU32: Vd^.tu32 := -Vd^.tu32;
    btS8: Vd^.tS8 := -Vd^.tS8;
    btS16: Vd^.ts16 := -Vd^.ts16;
    btS32: Vd^.ts32 := -Vd^.ts32;
    {$IFNDEF IFPS3_NOINT64}
    bts64: vd^.ts64 := -vd^.ts64;
    {$ENDIF}
    btSingle: Vd^.tsingle := - vd^.tsingle;
    btDouble: Vd^.tdouble := -vd^.tdouble;
    btExtended: Vd^.textended := -vd^.textended;
  else
    begin
      CMD_Err(erTypeMismatch);
      Result := False;
      exit;
    end;
  end;
  Result := True;
end;

function TIFPSExec.DoBooleanNot(Vd: PIfVariant): Boolean;
begin
  case Vd^.FType^.BaseType of
    btU8: Vd^.tu8 := TbtU8(Vd^.tu8 = 0);
    btS8: Vd^.tS8 := TbtS8(Vd^.tS8 = 0);
    btU16: Vd^.tu16 := TbtU16(Vd^.tu16 = 0);
    btS16: Vd^.ts16 := TbtS16(Vd^.ts16 = 0);
    btU32: Vd^.tu32 := TbtU32(Vd^.tu32 = 0);
    btS32: Vd^.ts32 := TbtS32(Vd^.ts32 = 0);
    {$IFNDEF IFPS3_NOINT64}
    bts64: vd^.ts64 := tbts64(vd^.ts64 = 0);
    {$ENDIF}
  else
    begin
      CMD_Err(erTypeMismatch);
      Result := False;
      exit;
    end;
  end;
  Result := True;
end;

function TIFPSExec.RunScript: Boolean;
var
  CalcType: Cardinal;
  Vd, Vs, v3: PIfVariant;
  vdFree, vsFree: LongBool;
  p: Cardinal;
  P2: Longint;
  u: PIFProcRec;
  Cmd: Cardinal;
  I: Longint;
  pp: PIFPSExceptionHandler;
  FExitPoint: Cardinal;
  FOldStatus: TIFStatus;
  Tmp: TObject;
begin
  FExitPoint := InvalidVal;
  if FStatus = isLoaded then
  begin
    for i := FExceptionStack.Count -1 downto 0 do
    begin
      pp := FExceptionStack[i];
      Dispose(pp);
    end;
    FExceptionStack.Clear;
  end;
  ExceptionProc(InvalidVal, InvalidVal, erNoError, '', nil);
  RunScript := True;
  FOldStatus := FStatus;
  case FStatus of
    isLoaded: begin
        if FMainProc = InvalidVal then
        begin
          RunScript := False;
          exit;
        end;
        FStatus := isRunning;
        FCurrProc := FProcs.Data^[FMainProc];
        if FCurrProc^.ExternalProc then begin
          CMD_Err(erNoMainProc);
          FStatus := isLoaded;
          exit;
        end;
        FData := FCurrProc^.Data;
        FDataLength := FCurrProc^.Length;
        FCurrStackBase := InvalidVal;
        FCurrentPosition := 0;
      end;
    isPaused: begin
        FStatus := isRunning;
      end;
  else begin
      RunScript := False;
      exit;
    end;
  end;
  repeat
    FStatus := isRunning;
    RunLine;
    while FStatus = isRunning do begin
      if FCurrentPosition >= FDataLength then
      begin
        CMD_Err(erOutOfRange); // Error
        break;
      end;
      cmd := FData^[FCurrentPosition];
      Inc(FCurrentPosition);
      if Cmd = CM_CA then begin // Calc and assigning are needed most and have priority
        if FCurrentPosition >= FDataLength then
        begin
          CMD_Err(erOutOfRange); // Error
          break;
        end;
        calctype := FData^[FCurrentPosition];
        Inc(FCurrentPosition);
        Vd := ReadVariable(vdFree, True);
        if Vd = nil then
          break;
        if vdFree then begin
          DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vd);
          CMD_Err(erInvalidOpcodeParameter);
          break;
        end;
        Vs := ReadVariable(vsFree, True);
        if Vs = nil then
          break;
        if not DoCalc(Vd, Vs, CalcType) then Break;
        if vsFree then
          DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vs);
      end
      else if Cmd = CM_A then begin // Calc and assigning are needed most and have priority
        Vd := ReadVariable(vdFree, False);
        if Vd = nil then
          break;
        if vdFree then begin
          DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vd);
          CMD_Err(erInvalidOpcodeParameter);
          break;
        end;
        if vd^.FType^.BaseType = btPointer then
        begin
          vd := vd^.tPointer;
          if vd = nil then
          begin
            CMD_Err(erNullPointerException);
            Break;
          end;
        end;
        Vs := ReadVariable(vsFree, False);
        if Vs = nil then
          break;
        if vs^.FType^.BaseType = btPointer then begin
          v3 := vs^.tPointer;
          if v3 = nil then begin
            if vsFree then
            begin
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vs);
            end;
            CMD_Err(erNullPointerException);
            Break;
          end;
          vs := v3;
        end;
        if not SetVariantValue(Vd, Vs) then
        begin
          if vsFree then
            DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vs);
          cmd_err(erTypeMismatch);
          Break;
        end;
        if vsFree then
          DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vs);
      end
      else
        case Cmd of
          CM_P: begin
              Vs := ReadVariable(vsFree, True);
              if Vs = nil then
                break;
              if vsFree then begin
                FStack.Add(Vs);
              end
              else begin
                Vd := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vs^.FType);
                SetVariantValue(Vd, Vs);
                FStack.Add(Vd);
              end;
            end;
          CM_PV: begin
              Vs := ReadVariable(vsFree, False);
              if vs = nil then
              begin
                break;
              end;
              if vs^.FType^.BaseType = btPointer then
              begin
                vs := vs^.tPointer;
                if vs = nil then
                begin
                  CMD_Err(erNullPointerException);
                  break;
                end;
              end;

              if Vs = nil then
                break;
              if vsFree then begin
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vs);
                CMD_Err(erInvalidOpcodeParameter);
                break;
              end
              else begin
                Inc(Vs^.RefCount);
                FStack.Add(Vs);
              end;
            end;
          CM_PO: begin
              if FStack.Count = 0 then begin
                CMD_Err(erOutOfStackRange);
                break;
              end;
              p := FStack.Count -1;
              Vs := FStack.Data^[p];
              FStack.Delete(p);
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vs);
            end;
          Cm_C: begin
              if FCurrentPosition + 3 >= FDataLength then
              begin
                Cmd_Err(erOutOfRange);
                Break;
              end;
              p := Cardinal((@FData^[FCurrentPosition])^);
              Inc(FCurrentPosition, 4);
              if p >= FProcs.Count then begin
                CMD_Err(erOutOfProcRange);
                break;
              end;
              u := FProcs.Data^[p];
              if u^.ExternalProc then begin
                try
                  if not u^.ProcPtr(Self, u, FGlobalVars, FStack) then
                  begin
                    if ExEx = erNoError then
                      CMD_Err(erCouldNotCallProc);
                    Break;
                  end;
                except
                  {$IFDEF IFPS3_D6PLUS}
                  Tmp := AcquireExceptionObject;
                  {$ELSE}
                  if RaiseList <> nil then
                  begin
                    Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
                    PRaiseFrame(RaiseList)^.ExceptObject := nil;
                  end else
                    Tmp := nil;
                  {$ENDIF}
                  if (Tmp <> nil) and (Tmp is Exception) then
                    CMD_Err3(erException, Exception(Tmp).Message, Tmp) else
                    CMD_Err3(erException, '', Tmp);
                  Break;
                end;
              end
              else begin
                Vd := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MM,
{$ENDIF}@ReturnAddressType);
                Vd^.treturnaddress.ProcNo := FCurrProc;
                Vd^.treturnaddress.Position := FCurrentPosition;
                Vd^.treturnaddress.StackBase := FCurrStackBase;
                FStack.Add(Vd);

                FCurrStackBase := FStack.Count - 1;
                FCurrProc := u;
                FData := FCurrProc^.Data;
                FDataLength := FCurrProc^.Length;
                FCurrentPosition := 0;
              end;
            end;
          Cm_G: begin
              if FCurrentPosition + 3 >= FDataLength then
              begin
                Cmd_Err(erOutOfRange);
                Break;
              end;
              p := Cardinal((@FData^[FCurrentPosition])^);
              Inc(FCurrentPosition, 4);
              FCurrentPosition := FCurrentPosition + p;
            end;
          Cm_CG: begin
              if FCurrentPosition + 3 >= FDataLength then
              begin
                Cmd_Err(erOutOfRange);
                Break;
              end;
              p := Cardinal((@FData^[FCurrentPosition])^);
              Inc(FCurrentPosition, 4);
              Vs := ReadVariable(vsFree, True);
              if Vs = nil then
                break;
              if vsFree then begin
                CMD_Err(erInvalidOpcodeParameter);
                break;
              end;
              case Vs^.FType^.BaseType of
                btU8: vdFree := Vs^.tu8 <> 0;
                btS8: vdFree := Vs^.tS8 <> 0;
                btU16: vdFree := Vs^.tu16 <> 0;
                btS16: vdFree := Vs^.ts16 <> 0;
                btU32, btProcPtr: vdFree := Vs^.tu32 <> 0;
                btS32: vdFree := Vs^.ts32 <> 0;
              else begin
                  CMD_Err(erInvalidType);
                  break;
                end;
              end;
              if vdFree then
                FCurrentPosition := FCurrentPosition + p;
            end;
          Cm_CNG: begin
              if FCurrentPosition + 3 >= FDataLength then
              begin
                Cmd_Err(erOutOfRange);
                Break;
              end;
              p := Cardinal((@FData^[FCurrentPosition])^);
              Inc(FCurrentPosition, 4);
              Vs := ReadVariable(vsFree, True);
              if Vs = nil then
                break;
              if vsFree then begin
                CMD_Err(erInvalidOpcodeParameter);
                break;
              end;
              case Vs^.FType^.BaseType of
                btU8: vdFree := Vs^.tu8 = 0;
                btS8: vdFree := Vs^.tS8 = 0;
                btU16: vdFree := Vs^.tu16 = 0;
                btS16: vdFree := Vs^.ts16 = 0;
                btU32, btProcPtr: vdFree := Vs^.tu32 = 0;
                btS32: vdFree := Vs^.ts32 = 0;
              else begin
                  CMD_Err(erInvalidType);
                  break;
                end;
              end;
              if vdFree then
                FCurrentPosition := FCurrentPosition + p;
            end;
          Cm_R: begin
              FExitPoint := FCurrentPosition -1;
              P2 := 0;
              if FExceptionStack.Count > 0 then
              begin
                pp := FExceptionStack[FExceptionStack.Count -1];
                if (pp^.BasePtr = FCurrStackBase) or ((pp^.BasePtr > FCurrStackBase) and (pp^.BasePtr <> InvalidVal)) then
                begin
                  if pp^.StackSize < FStack.Count then
                  begin
                    for p := Longint(FStack.count) -1 downto Longint(pp^.StackSize) do
                    begin
                      DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}mm, {$ENDIF}FStack.Data^[p]);
                      FStack.Delete(p);
                    end;
                  end;
                  FCurrStackBase := pp^.BasePtr;
                  if pp^.FinallyOffset <> InvalidVal then
                  begin
                    FCurrentPosition := pp^.FinallyOffset;
                    pp^.FinallyOffset := InvalidVal;
                    p2 := 1;
                  end else if pp^.Finally2Offset <> InvalidVal then
                  begin
                    FCurrentPosition := pp^.Finally2Offset;
                    pp^.Finally2Offset := InvalidVal;
                    p2 := 1;
                  end;
                end;
              end;
              if p2 = 0 then
              begin
                FExitPoint := InvalidVal;
                if FCurrStackBase = InvalidVal then
                begin
                  FStatus := FOldStatus;
                  break;
                end;
                Vs := FStack.Data^[FCurrStackBase];
                for P2 := FStack.Count - 1 downto FCurrStackBase + 1 do begin
                  DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}FStack.Data^[P2]);
                  FStack.Delete(P2);
                end;
                FStack.Delete(FCurrStackBase);
                FCurrProc := Vs^.treturnaddress.ProcNo;
                FCurrentPosition := Vs^.treturnaddress.Position;
                FCurrStackBase := Vs^.treturnaddress.StackBase;
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vs);
                if FCurrProc = nil then begin
                  FStatus := FOldStatus;
                  break;
                end;
                FData := FCurrProc^.Data;
                FDataLength := FCurrProc^.Length;
              end;
            end;
          Cm_ST: begin
              if FCurrentPosition + 3 >= FDataLength then
              begin
                Cmd_Err(erOutOfRange);
                Break;
              end;
              p := Cardinal((@FData^[FCurrentPosition])^);
              Inc(FCurrentPosition, 4);
              if FCurrentPosition + 3 >= FDataLength then
              begin
                Cmd_Err(erOutOfRange);
                Break;
              end;
              p2 := Cardinal((@FData^[FCurrentPosition])^);
              Inc(FCurrentPosition, 4);
              Cardinal(P2) := FCurrStackBase + Cardinal(P2);
              if p >= FTypes.Count then begin
                CMD_Err(erInvalidType);
                break;
              end;
              if Cardinal(P2) >= FStack.Count then begin
                CMD_Err(erOutOfStackRange);
                break;
              end;
              Vs := FStack.Data^[Cardinal(P2)];
              if Vs^.FType = @ReturnAddressType then begin
                CMD_Err(erInvalidType);
                break;
              end;
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vs);
              Vs := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MM,
{$ENDIF}FTypes.Data^[p]);
              FStack.Data^[Cardinal(P2)] := Vs;
            end;
          Cm_Pt: begin
              if FCurrentPosition + 3 >= FDataLength then
              begin
                Cmd_Err(erOutOfRange);
                Break;
              end;
              p := Cardinal((@FData^[FCurrentPosition])^);
              Inc(FCurrentPosition, 4);
              if p > FTypes.Count then
              begin
                CMD_Err(erInvalidType);
                break;
              end;
              Vs := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}FTypes.Data^[p]);
              FStack.Add(Vs);
            end;
          CM_CO: begin
              if FCurrentPosition >= FDataLength then
              begin
                CMD_Err(erOutOfRange); // Error
                break;
              end;
              calctype := FData^[FCurrentPosition];
              Inc(FCurrentPosition);
              v3 := ReadVariable(vsFree, False);
              if v3 = nil then
                break;
              if vsFree then begin
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}v3);
                CMD_Err(erInvalidOpcodeParameter);
                break;
              end;
              if v3^.FType^.BaseType = btPointer then
              begin
                v3 := v3^.tPointer;
                if v3 = nil then begin
                  CMD_Err(erNullPointerException);
                  break;
                end;
              end;
              Vs := ReadVariable(vsFree, False);
              if Vs = nil then
                break;
              if vs^.FType^.BaseType = btPointer then begin
                vs := vs^.tPointer;
                if vs = nil then begin
                  CMD_Err(erNullPointerException);
                  break;
                end;
              end;
              if vs^.FType^.BaseType = btVariant then begin
                vs := vs^.tvariant;
              end;
              Vd := ReadVariable(vdFree, False);
              if vd = nil then
              begin
                if vsFree then
                  DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vs);
                break;
              end;
              if vd^.FType^.BaseType = btPointer then begin
                vd := vd^.tPointer;
                if vd = nil then begin
                  CMD_Err(erNullPointerException);
                  break;
                end;
              end;
              if vd^.FType^.BaseType = btVariant then begin
                vd := vd^.tvariant;
              end;
              if Vd = nil then begin
                if vsFree then
                  DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vs);
                break;
              end;
              DoBooleanCalc(Vs, Vd, v3, CalcType);
              if vsFree then
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vs);
              if vdFree then
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vd);
            end;
          Cm_cv: begin
              Vd := ReadVariable(vdFree, True);
              if Vd = nil then
                break;
              if (Vd^.FType^.BaseType <> btU32) and (Vd^.FType^.BaseType <>
                btS32) and (vd^.FType^.BaseType <> btProcPtr) then begin
                if vdFree then
                  DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vd);
                CMD_Err(ErTypeMismatch);
                break;
              end;
              p := Vd^.tu32;
              if vdFree then
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vd);
              if (p >= FProcs.Count) or (p = FMainProc) then begin
                CMD_Err(erOutOfProcRange);
                break;
              end;
              u := FProcs.Data^[p];
              if u^.ExternalProc then begin
                if not u^.ProcPtr(Self, u, FGlobalVars, FStack) then
                  CMD_Err(erCouldNotCallProc);
              end
              else begin
                Vs := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MM,
{$ENDIF}@ReturnAddressType);
                Vs^.treturnaddress.ProcNo := FCurrProc;
                Vs^.treturnaddress.Position := FCurrentPosition;
                Vs^.treturnaddress.StackBase := FCurrStackBase;
                FStack.Add(Vs);
                FCurrStackBase := FStack.Count - 1;
                FCurrProc := u;
                FData := FCurrProc^.Data;
                FDataLength := FCurrProc^.Length;
                FCurrentPosition := 0;
              end;
            end;
          cm_sp: begin
              Vd := ReadVariable(vdFree, False);
              if Vd = nil then
              begin
                cmd_err(erInvalidOpcodeParameter);
                break;
              end;
              if vdFree then begin
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vd);
                CMD_Err(erInvalidOpcodeParameter);
                break;
              end;
              if Vd^.FType^.BaseType <> btPointer then begin
                CMD_Err(erInvalidOpcodeParameter);
                break;
              end;
              Vs := ReadVariable(vsFree, False);
              if Vs = nil then begin
                break;
              end else if vsFree then begin
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vs);
                CMD_Err(erInvalidOpcodeParameter);
                break;
              end else begin
                if (Vd^.tPointer <> nil) then
                begin
                  DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vd^.tPointer);
                  vd^.tPointer := nil;
                end;
                if vs^.FType^.BaseType = btPointer then
                begin
                  vs := vs^.tPointer;
                end;
                Inc(Vs^.RefCount);
                Vd^.tPointer := Vs;
              end;
            end;
          cm_bn: begin
              Vd := ReadVariable(vdFree, True);
              if Vd = nil then
                break;
              if vdFree then begin
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vd);
                CMD_Err(erInvalidOpcodeParameter);
                break;
              end;
              if not DoBooleanNot(Vd) then
                break;
            end;
          cm_in: begin
              Vd := ReadVariable(vdFree, True);
              if Vd = nil then
                break;
              if vdFree then begin
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vd);
                CMD_Err(erInvalidOpcodeParameter);
                break;
              end;
              if not DoIntegerNot(Vd) then
                Break;
            end;
          cm_vm: begin
              Vd := ReadVariable(vdFree, True);
              if Vd = nil then
                break;
              if vdFree then begin
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vd);
                CMD_Err(erInvalidOpcodeParameter);
                break;
              end;
              if not doMinus(Vd) then
                Break;
            end;
          cm_sf:
            begin
              vd := ReadVariable(vdFree, True);
              if vd = nil then
                break;
              if vdFree then
              begin
                DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}vd);
                CMD_Err(erInvalidOpcodeParameter);
                break;
              end;
              if FCurrentPosition >= FDataLength then
              begin
                CMD_Err(erOutOfRange); // Error
                break;
              end;
              p := FData^[FCurrentPosition];
              Inc(FCurrentPosition);
              case Vd^.FType^.BaseType of
                btU8: vdFree := Vd^.tu8 <> 0;
                btS8: vdFree := Vd^.tS8 <> 0;
                btU16: vdFree := Vd^.tu16 <> 0;
                 btS16: vdFree := Vd^.ts16 <> 0;
                btU32, btProcPtr: vdFree := Vd^.tu32 <> 0;
                btS32: vdFree := Vd^.ts32 <> 0;
              else begin
                  CMD_Err(erInvalidType);
                  break;
                end;
              end;
              if p <> 0 then
                FJumpFlag := not vdFree
              else
               FJumpFlag := vdFree;
            end;
          cm_fg:
            begin
              if FCurrentPosition + 3 >= FDataLength then
              begin
                Cmd_Err(erOutOfRange);
                Break;
              end;
              p := Cardinal((@FData^[FCurrentPosition])^);
              Inc(FCurrentPosition, 4);
              if FJumpFlag then
                FCurrentPosition := FCurrentPosition + p;
            end;
          cm_puexh:
            begin
              New(pp);
              pp^.CurrProc := FCurrProc;
              pp^.BasePtr :=FCurrStackBase;
              pp^.StackSize := FStack.Count;
              if not ReadLong(pp^.FinallyOffset) then begin
                CMD_Err(erOutOfRange);
                Dispose(pp);
                Break;
              end;
              if not ReadLong(pp^.ExceptOffset) then begin
                CMD_Err(erOutOfRange);
                Dispose(pp);
                Break;
              end;
              if not ReadLong(pp^.Finally2Offset) then begin
                CMD_Err(erOutOfRange);
                Dispose(pp);
                Break;
              end;
              if not ReadLong(pp^.EndOfBlock) then begin
                CMD_Err(erOutOfRange);
                Dispose(pp);
                Break;
              end;
              if pp^.FinallyOffset <> InvalidVal then
                pp^.FinallyOffset := pp^.FinallyOffset + FCurrentPosition;
              if pp^.ExceptOffset <> InvalidVal then
                pp^.ExceptOffset := pp^.ExceptOffset + FCurrentPosition;
              if pp^.Finally2Offset <> InvalidVal then
                pp^.Finally2Offset := pp^.Finally2Offset + FCurrentPosition;
              if pp^.EndOfBlock <> InvalidVal then
                pp^.EndOfBlock := pp^.EndOfBlock + FCurrentPosition;
              if ((pp^.FinallyOffset <> InvalidVal) and (pp^.FinallyOffset >= FDataLength)) or
                ((pp^.ExceptOffset <> InvalidVal) and (pp^.ExceptOffset >= FDataLength)) or
                ((pp^.Finally2Offset <> InvalidVal) and (pp^.Finally2Offset >= FDataLength)) or
                ((pp^.EndOfBlock <> InvalidVal) and (pp^.EndOfBlock >= FDataLength)) then
                begin
                  CMD_Err(ErOutOfRange);
                  Dispose(pp);
                  Break;
                end;
                FExceptionStack.Add(pp);
            end;
          cm_poexh:
            begin
              if FCurrentPosition >= FDataLength then
              begin
                CMD_Err(erOutOfRange); // Error
                break;
              end;
              p := FData^[FCurrentPosition];
              Inc(FCurrentPosition);
              case p of
                2:
                  begin
                    ExceptionProc(InvalidVal, InvalidVal, erNoError, '', nil);
                    pp := FExceptionStack[FExceptionStack.Count -1];
                    if pp = nil then begin
                      cmd_err(ErOutOfRange);
                      Break;
                    end;
                    if pp^.Finally2Offset <> InvalidVal then
                    begin
                      FCurrentPosition := pp^.Finally2Offset;
                      pp^.Finally2Offset := InvalidVal;
                    end else begin
                      p := pp^.EndOfBlock;
                      Dispose(pp);
                      FExceptionStack.Delete(FExceptionStack.Count -1);
                      if FExitPoint <> InvalidVal then
                      begin
                        FCurrentPosition := FExitPoint;
                      end else begin
                        FCurrentPosition := p;
                      end;
                    end;
                  end;
                0:
                  begin
                    pp := FExceptionStack[FExceptionStack.Count -1];
                    if pp = nil then begin
                      cmd_err(ErOutOfRange);
                      Break;
                    end;
                    if pp^.FinallyOffset <> InvalidVal then
                    begin
                      FCurrentPosition := pp^.FinallyOffset;
                      pp^.FinallyOffset := InvalidVal;
                    end else if pp^.Finally2Offset <> InvalidVal then
                    begin
                       FCurrentPosition := pp^.Finally2Offset;
                       pp^.ExceptOffset := InvalidVal;
                    end else begin
                      p := pp^.EndOfBlock;
                      Dispose(pp);
                      FExceptionStack.Delete(FExceptionStack.Count -1);
                      if ExEx <> eNoError then
                      begin
                        Tmp := ExObject;
                        ExObject := nil;
                        ExceptionProc(ExProc, ExPos, ExEx, ExParam, Tmp);
                      end else
                      if FExitPoint <> InvalidVal then
                      begin
                        FCurrentPosition := FExitPoint;
                      end else begin
                        FCurrentPosition := p;
                      end;
                    end;
                  end;
                1:
                  begin
                    pp := FExceptionStack[FExceptionStack.Count -1];
                    if pp = nil then begin
                      cmd_err(ErOutOfRange);
                      Break;
                    end;
                    if (ExEx <> ENoError) and (pp^.ExceptOffset <> InvalidVal) then
                    begin
                      FCurrentPosition := pp^.ExceptOffset;
                      pp^.ExceptOffset := InvalidVal;
                    end else if (pp^.Finally2Offset <> InvalidVal) then
                    begin
                      FCurrentPosition := pp^.Finally2Offset;
                      pp^.Finally2Offset := InvalidVal;
                    end else begin
                      p := pp^.EndOfBlock;
                      Dispose(pp);
                      FExceptionStack.Delete(FExceptionStack.Count -1);
                      if ExEx <> eNoError then
                      begin
                        Tmp := ExObject;
                        ExObject := nil;
                        ExceptionProc(ExProc, ExPos, ExEx, ExParam, Tmp);
                      end else
                      if FExitPoint <> InvalidVal then
                      begin
                        FCurrentPosition := FExitPoint;
                      end else begin
                        FCurrentPosition := p;
                      end;
                    end;
                  end;
                3:
                  begin
                    pp := FExceptionStack[FExceptionStack.Count -1];
                    if pp = nil then begin
                      cmd_err(ErOutOfRange);
                      Break;
                    end;
                    p := pp^.EndOfBlock;
                    Dispose(pp);
                    FExceptionStack.Delete(FExceptionStack.Count -1);
                    if ExEx <> eNoError then
                    begin
                      Tmp := ExObject;
                      ExObject := nil;
                      ExceptionProc(ExProc, ExPos, ExEx, ExParam, Tmp);
                    end else
                    if FExitPoint <> InvalidVal then
                    begin
                      FCurrentPosition := FExitPoint;
                    end else begin
                      FCurrentPosition := p;
                    end;
                 end;
              end;
            end;
        else
          CMD_Err(erInvalidOpcode); // Error
        end;
        RunLine;
    end;
//    if ExEx <> erNoError then FStatus := FOldStatus;
  until (FExceptionStack.Count = 0) or (Fstatus <> IsRunning);
  if FStatus = isLoaded then begin
    for I := Longint(FStack.Count) - 1 downto 0 do
      DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}FStack.Data^[I]);
    FStack.Clear;
    if FCallCleanup then Cleanup;
  end;
  Result := ExEx = erNoError;
end;

procedure TIFPSExec.Stop;
var
  I: Longint;
begin
  if FStatus = isRunning then
    FStatus := isLoaded
  else if FStatus = isPaused then begin
    FStatus := isLoaded;
    for I := Longint(FStack.Count) - 1 downto 0 do
      DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}FStack.Data^[I]);
    FStack.Clear;
  end;
end;


function TIFPSExec.ReadLong(var b: Cardinal): Boolean;
begin
  if FCurrentPosition + 3 < FDataLength then begin
    b := Cardinal((@FData^[FCurrentPosition])^);
    Inc(FCurrentPosition, 4);
    Result := True;
  end
  else
    Result := False;
end;

function TIFPSExec.RunProc(Params: TIfList; ProcNo: Cardinal): Boolean;
var
  I, I2: Integer;
  Vd: PIfVariant;
  Cp: PIFProcRec;
  oldStatus: TIFStatus;
begin
  if FStatus <> isNotLoaded then begin
    if ProcNo >= FProcs.Count then begin
      CMD_Err(erOutOfProcRange);
      Result := False;
      exit;
    end;
    if PIFProcRec(FProcs.Data^[ProcNo])^.ExternalProc then
    begin
      CMD_Err(erOutOfProcRange);
      Result := False;
      exit;
    end;
    if Params <> nil then
    begin
      for I := 0 to Params.Count - 1 do
      begin
        vd := Params[I];
        if vd = nil then
        begin
          Result := False;
          exit;
        end;
        FStack.Add(Params[I]);
      end;
    end;
    Vd := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}@ReturnAddressType);
    Cp := FCurrProc;
    Vd^.treturnaddress.ProcNo := nil;
    Vd^.treturnaddress.Position := FCurrentPosition;
    Vd^.treturnaddress.StackBase := FCurrStackBase;
    I := FStack.Count;
    FStack.Add(Vd);
    FCurrStackBase := FStack.Count - 1;
    FCurrProc := FProcs.Data^[ProcNo];
    FData := FCurrProc^.Data;
    FDataLength := FCurrProc^.Length;
    FCurrentPosition := 0;
    oldStatus := FStatus;
    FStatus := isPaused;
    Result := RunScript;
    if FStack.Count > Cardinal(I) then
    begin
      vd := FStack.Data^[I];
      if (vd <> nil) and (vd^.FType = @ReturnAddressType) then begin
        for i2 := FStack.Count - 1 downto I + 1 do begin
          DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}FStack.Data^[i2]);
          FStack.Delete(i2);
        end;
        FStack.Delete(I);
        FCurrentPosition := Vd^.treturnaddress.Position;
        FCurrStackBase := Vd^.treturnaddress.StackBase;
        DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}Vd);
      end;
    end;
    if Params <> nil then
    begin
      for I := Params.Count - 1 downto 0 do
      begin
        FStack.Delete(FStack.Count - 1);
      end;
    end;
    FStatus := oldStatus;
    FCurrProc := Cp;
    if FCurrProc <> nil then
    begin
      FData := FCurrProc^.Data;
      FDataLength := FCurrProc^.Length;
    end;
  end else begin
    Result := False;
  end;
end;

function TIFPSExec.CreateIntegerVariant(FType: PIFTypeRec; Value: Longint): PIfVariant;
begin
  Result := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}FType);
  if Result <> nil then begin
    case FType^.BaseType of
      btU8: Result^.tu8 := Value;
      btS8: Result^.tS8 := Value;
      btU16: Result^.tu16 := Value;
      btS16: Result^.ts16 := Value;
      btU32, btProcPtr: Result^.tu32 := Value;
      btS32: Result^.ts32 := Value;
    end;
  end;
end;

function TIFPSExec.CreateStringVariant(FType: PIFTypeRec; const Value: string): PIfVariant;
begin
  Result := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}FType);
  if Result <> nil then begin
    case FType^.BaseType of
      btPChar, btString: begin
          TbtString(Result^.tstring) := Value;
        end;
    end;
  end;
end;

function TIFPSExec.CreateFloatVariant(FType: PIFTypeRec; Value: Extended): PIfVariant;
begin
  Result := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}FType);
  if Result <> nil then begin
    case FType^.BaseType of
      btSingle: Result^.tsingle := Value;
      btDouble: Result^.tdouble := Value;
      btExtended: Result^.textended := Value;
    end;
  end;
end;

function TIFPSExec.FindType2(BaseType: TIFPSBaseType): PIFTypeRec;
var
  l: Cardinal;
begin
  FindType2 := FindType(0, BaseType, l);

end;

function TIFPSExec.FindType(StartAt: Cardinal; BaseType: TIFPSBaseType; var l: Cardinal): PIFTypeRec;
var
  I: Integer;
  n: PIFTypeRec;
begin
  for I := StartAt to FTypes.Count - 1 do begin
    n := FTypes[I];
    if n^.BaseType = BaseType then begin
      l := I;
      Result := n;
      exit;
    end;
  end;
  Result := nil;
end;

function TIFPSExec.GetTypeNo(l: Cardinal): PIFTypeRec;
begin
  Result := FTypes[l];
end;

function TIFPSExec.GetProc(const Name: string): Cardinal;
var
  MM,
    I: Longint;
  n: PIFProcRec;
  s: string;
begin
  s := FastUpperCase(name);
  MM := MakeHash(s);
  for I := FProcs.Count - 1 downto 0 do begin
    n := FProcs.Data^[I];
    if (not n^.ExternalProc) and (Length(n^.ExportName) <> 0) and (n^.ExportNameHash = MM) and (n^.ExportName = s) then begin
      Result := I;
      exit;
    end;
  end;
  Result := InvalidVal;
end;

function TIFPSExec.GetType(const Name: string): Cardinal;
var
  MM,
    I: Longint;
  n: PIFTypeRec;
  s: string;
begin
  s := FastUpperCase(name);
  MM := MakeHash(s);
  for I := 0 to FTypes.Count - 1 do begin
    n := FTypes.Data^[I];
    if (Length(n^.ExportName) <> 0) and (n^.ExportNameHash = MM) and (n^.ExportName = s) then begin
      Result := I;
      exit;
    end;
  end;
  Result := InvalidVal;
end;


procedure TIFPSExec.AddResource(Proc, P: Pointer);
var
  Temp: PIFPSResource;
begin
  New(Temp);
  Temp^.Proc := Proc;
  Temp^.P := p;
  FResources.Add(temp);
end;

procedure TIFPSExec.DeleteResource(P: Pointer);
var
  i: Longint;
begin
  for i := Longint(FResources.Count) -1 downto 0 do
  begin
    if PIFPSResource(FResources[I])^.P = P then
    begin
      FResources.Delete(I);
      exit;
    end;
  end;
end;

function TIFPSExec.FindProcResource(Proc: Pointer): Pointer;
var
  I: Longint;
  temp: PIFPSResource;
begin
  for i := Longint(FResources.Count) -1 downto 0 do
  begin
    temp := FResources[I];
    if temp^.Proc = proc then
    begin
      Result := Temp^.P;
      exit;
    end;
  end;
  Result := nil;
end;

function TIFPSExec.IsValidResource(Proc, P: Pointer): Boolean;
var
  i: Longint;
  temp: PIFPSResource;
begin
  for i := 0 to Longint(FResources.Count) -1 do
  begin
    temp := FResources[i];
    if temp^.p = p then begin
      result := temp^.Proc = Proc;
      exit;
    end;
  end;
  result := false;
end;

function TIFPSExec.FindProcResource2(Proc: Pointer;
  var StartAt: Longint): Pointer;
var
  I: Longint;
  temp: PIFPSResource;
begin
  if StartAt > longint(FResources.Count) -1 then 
    StartAt := longint(FResources.Count) -1;
  for i := StartAt downto 0 do
  begin
    temp := FResources[I];
    if temp^.Proc = proc then
    begin
      Result := Temp^.P;
      StartAt := i -1;
      exit;
    end;
  end;
  StartAt := -1;
  Result := nil;
end;

procedure TIFPSExec.RunLine;
begin
  if @FOnRunLine <> nil then
    FOnRunLine(Self);
end;

procedure TIFPSExec.CMD_Err3(EC: TIFError; const Param: string; ExObject: TObject);
var
  l: Longint;
  C: Cardinal;
begin
  C := InvalidVal;
  for l := FProcs.Count - 1 downto 0 do begin
    if FProcs.Data^[l] = FCurrProc then begin
      C := l;
      break;
    end;
  end;
  if @FOnException <> nil then
    FOnException(Self, Ec, Param, ExObject, C, FCurrentPosition);
  ExceptionProc(C, FCurrentPosition, EC, Param, ExObject);
end;

procedure FreePIFVariantList({$IFNDEF IFPS3_NOSMARTMM}MM: Pointer; {$ENDIF}List: TIfList);
var
  I: Longint;
begin
  for I := List.Count -1 downto 0 do
  begin
    DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}MM, {$ENDIF}List[I]);
  end;
  List.Free;
end;
procedure TIFPSExec.AddSpecialProcImport(const FName: string;
  P: TIFPSOnSpecialProcImport; Tag: Pointer);
var
  N: PSpecialProc;
begin
  New(n);
  n^.P := P;
  N^.Name := FName;
  n^.namehash := MakeHash(N^.Name);
  n^.Tag := Tag;
  FSpecialProcList.Add(n);
end;

function TIFPSExec.GetVar(const Name: string): Cardinal;
var
  l: Longint;
  h: longint;
  s: string;
  p: PIFPSExportedVar;
begin
  s := FastUpperCase(name);
  h := MakeHash(s);
  for l := FExportedVars.Count - 1 downto 0 do
  begin
    p := FexportedVars.Data^[L];
    if (p^.FNameHash = h) and(p^.FName=s) then
    begin
      Result := L;
      exit;
    end;
  end;
  Result := InvalidVal;
end;

function TIFPSExec.GetVarNo(C: Cardinal): PIFVariant;
begin
  Result := FGlobalVars[c];
end;

function TIFPSExec.GetVar2(const Name: string): PIFVariant;
begin
  Result := GetVarNo(GetVar(Name));
end;

function TIFPSExec.GetProcNo(C: Cardinal): PIFProcRec;
begin
  Result := FProcs[c];
end;

function TIFPSExec.DoIntegerNot(Vd: PIfVariant): Boolean;
begin
  case Vd^.FType^.BaseType of
    btU8: Vd^.tu8 := not Vd^.tu8;
    btS8: Vd^.tS8 := not Vd^.tS8;
    btU16: Vd^.tu16 := not Vd^.tu16;
    btS16: Vd^.ts16 := not Vd^.ts16;
    btU32: Vd^.tu32 := not Vd^.tu32;
    btS32: Vd^.ts32 := not Vd^.ts32;
    {$IFNDEF IFPS3_NOINT64} btS64: vd^.ts64 := not vd^.ts64; {$ENDIF}
  else
    begin
      CMD_Err(erTypeMismatch);
      Result := False;
      exit;
    end;
  end;
  Result := True;
end;
procedure TIFPSExec.RegisterStandardProcs;
begin
  RegisterFunctionName('INTTOSTR', DefProc, Pointer(0), nil);
  RegisterFunctionName('STRTOINT', DefProc, Pointer(1), nil);
  RegisterFunctionName('STRTOINTDEF', DefProc, Pointer(2), nil);
  RegisterFunctionName('POS', DefProc, Pointer(3), nil);
  RegisterFunctionName('COPY', DefProc, Pointer(4), nil);
  RegisterFunctionName('DELETE', DefProc, Pointer(5), nil);
  RegisterFunctionName('INSERT', DefProc, Pointer(6), nil);

  RegisterFunctionName('STRGET', DefProc, Pointer(7), nil);
  RegisterFunctionName('STRSET', DefProc, Pointer(8), nil);
  RegisterFunctionName('UPPERCASE', DefProc, Pointer(10), nil);
  RegisterFunctionName('LOWERCASE', DefProc, Pointer(11), nil);
  RegisterFunctionName('TRIM', DefProc, Pointer(12), nil);
  RegisterFunctionName('LENGTH', DefProc, Pointer(13), nil);
  RegisterFunctionName('SETLENGTH', DefProc, Pointer(14), nil);
  RegisterFunctionName('SIN', DefProc, Pointer(15), nil);
  RegisterFunctionName('COS', DefProc, Pointer(16), nil);
  RegisterFunctionName('SQRT', DefProc, Pointer(17), nil);
  RegisterFunctionName('ROUND', DefProc, Pointer(18), nil);
  RegisterFunctionName('TRUNC', DefProc, Pointer(19), nil);
  RegisterFunctionName('INT', DefProc, Pointer(20), nil);
  RegisterFunctionName('PI', DefProc, Pointer(21), nil);
  RegisterFunctionName('ABS', DefProc, Pointer(22), nil);
  RegisterFunctionName('STRTOFLOAT', DefProc, Pointer(23), nil);
  RegisterFunctionName('FLOATTOSTR', DefProc, Pointer(24), nil);
  RegisterFunctionName('PADL', DefProc, Pointer(25), nil);
  RegisterFunctionName('PADR', DefProc, Pointer(26), nil);
  RegisterFunctionName('PADZ', DefProc, Pointer(27), nil);
  RegisterFunctionName('REPLICATE', DefProc, Pointer(28), nil);
  RegisterFunctionName('STRINGOFCHAR', DefProc, Pointer(28), nil);
  RegisterFunctionName('!ASSIGNED', DefProc, Pointer(29), nil);
  RegisterFunctionName('VARGETTYPE', VarProc, Pointer(0), nil);
  RegisterFunctionName('NULL', VarProc, Pointer(1), nil);

  RegisterFunctionName('GETARRAYLENGTH', GetArrayLength, nil, nil);
  RegisterFunctionName('SETARRAYLENGTH', SetArrayLength, nil, nil);

  RegisterFunctionName('RAISELASTEXCEPTION', DefPRoc, Pointer(30), nil);
  RegisterFunctionName('RAISEEXCEPTION', DefPRoc, Pointer(31), nil);
  RegisterFunctionName('EXCEPTIONTYPE', DefPRoc, Pointer(32), nil);
  RegisterFunctionName('EXCEPTIONPARAM', DefPRoc, Pointer(33), nil);
  RegisterFunctionName('EXCEPTIONPROC', DefPRoc, Pointer(34), nil);
  RegisterFunctionName('EXCEPTIONPOS', DefPRoc, Pointer(35), nil);
  RegisterFunctionName('EXCEPTIONTOSTRING', DefProc, Pointer(36), nil);
  RegisterFunctionName('ANSIUPPERCASE', DefProc, Pointer(37), nil);
  RegisterFunctionName('ANSILOWERCASE', DefProc, Pointer(38), nil);

  {$IFNDEF IFPS3_NOINT64}
  RegisterFunctionName('STRTOINT64', DefProc, Pointer(39), nil);
  RegisterFunctionName('INT64TOSTR', DefProc, Pointer(40), nil);
  {$ENDIF}

end;

{$IFDEF IFPS3_HAVEVARIANT}
var
  VNull: Variant;

const
  VariantType: TIFTypeRec = (BaseType: btVariant;ext:nil);
  VariantArrayType: TIFTypeRec = (basetype: btArray;ext:@VariantType);
{$ENDIF}

function RealFloatCall_Register(p: Pointer;
  _EAX, _EDX, _ECX: Cardinal;
  StackData: Pointer;
  StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes)
  ): Extended; Stdcall; // make sure all things are on stack
var
  E: Extended;
begin
  asm
    mov ecx, stackdatalen
    jecxz @@2
    mov eax, stackdata
    @@1:
    mov edx, [eax]
    push edx
    sub eax, 4
    dec ecx
    or ecx, ecx
    jnz @@1
    @@2:
    mov eax,_EAX
    mov edx,_EDX
    mov ecx,_ECX
    call p
    fstp tbyte ptr [e]
  end;
  Result := E;
end;

function RealFloatCall_Other(p: Pointer;
  StackData: Pointer;
  StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes)
  ): Extended; Stdcall; // make sure all things are on stack
var
  E: Extended;
begin
  asm
    mov ecx, stackdatalen
    jecxz @@2
    mov eax, stackdata
    @@1:
    mov edx, [eax]
    push edx
    sub eax, 4
    dec ecx
    or ecx, ecx
    jnz @@1
    @@2:
    call p
    fstp tbyte ptr [e]
  end;
  Result := E;
end;

function RealFloatCall_CDecl(p: Pointer;
  StackData: Pointer;
  StackDataLen: Longint // stack length are in 4 bytes. (so 1 = 4 bytes)
  ): Extended; Stdcall; // make sure all things are on stack
var
  E: Extended;
begin
  asm
    mov ecx, stackdatalen
    jecxz @@2
    mov eax, stackdata
    @@1:
    mov edx, [eax]
    push edx
    sub eax, 4
    dec ecx
    or ecx, ecx
    jnz @@1
    @@2:
    call p
    fstp tbyte ptr [e]
    @@5:
    mov ecx, stackdatalen
    jecxz @@2
    @@6:
    pop edx
    dec ecx
    or ecx, ecx
    jnz @@6
  end;
  Result := E;
end;

function RealCall_Register(p: Pointer;
  _EAX, _EDX, _ECX: Cardinal;
  StackData: Pointer;
  StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes)
  ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack
var
  r: Longint;
begin
  asm
    mov ecx, stackdatalen
    jecxz @@2
    mov eax, stackdata
    @@1:
    mov edx, [eax]
    push edx
    sub eax, 4
    dec ecx
    or ecx, ecx
    jnz @@1
    @@2:
    mov eax,_EAX
    mov edx,_EDX
    mov ecx,_ECX
    call p
    mov ecx, resultlength
    cmp ecx, 0
    je @@5
    cmp ecx, 1
    je @@3
    cmp ecx, 2
    je @@4
    mov r, eax
    jmp @@5
    @@3:
    xor ecx, ecx
    mov cl, al
    mov r, ecx
    jmp @@5
    @@4:
    xor ecx, ecx
    mov cx, ax
    mov r, ecx
    @@5:
    mov ecx, resedx
    jecxz @@6
    mov [ecx], edx
    @@6:
  end;
  Result := r;
end;

function RealCall_Other(p: Pointer;
  StackData: Pointer;
  StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes)
  ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack
var
  r: Longint;
begin
  asm
    mov ecx, stackdatalen
    jecxz @@2
    mov eax, stackdata
    @@1:
    mov edx, [eax]
    push edx
    sub eax, 4
    dec ecx
    or ecx, ecx
    jnz @@1
    @@2:
    call p
    mov ecx, resultlength
    cmp ecx, 0
    je @@5
    cmp ecx, 1
    je @@3
    cmp ecx, 2
    je @@4
    mov r, eax
    jmp @@5
    @@3:
    xor ecx, ecx
    mov cl, al
    mov r, ecx
    jmp @@5
    @@4:
    xor ecx, ecx
    mov cx, ax
    mov r, ecx
    @@5:
    mov ecx, resedx
    jecxz @@6
    mov [ecx], edx
    @@6:
  end;
  Result := r;
end;

function RealCall_CDecl(p: Pointer;
  StackData: Pointer;
  StackDataLen: Longint; // stack length are in 4 bytes. (so 1 = 4 bytes)
  ResultLength: Longint; ResEDX: Pointer): Longint; Stdcall; // make sure all things are on stack
var
  r: Longint;
begin
  asm
    mov ecx, stackdatalen
    jecxz @@2
    mov eax, stackdata
    @@1:
    mov edx, [eax]
    push edx
    sub eax, 4
    dec ecx
    or ecx, ecx
    jnz @@1
    @@2:
    call p
    mov ecx, resultlength
    cmp ecx, 0
    je @@5
    cmp ecx, 1
    je @@3
    cmp ecx, 2
    je @@4
    mov r, eax
    jmp @@5
    @@3:
    xor ecx, ecx
    mov cl, al
    mov r, ecx
    jmp @@5
    @@4:
    xor ecx, ecx
    mov cx, ax
    mov r, ecx
    @@5:
    mov ecx, stackdatalen
    jecxz @@2
    @@6:
    pop eax
    dec ecx
    or ecx, ecx
    jnz @@6
    mov ecx, resedx
    jecxz @@7
    mov [ecx], edx
    @@7:
  end;
  Result := r;
end;
{$IFDEF IFPS3_HAVEVARIANT}
function PIFVariantToVariant(Sender: TIFPSExec; Src: PIFVariant; var Dest: Variant): Boolean;
  function CreateArrayVariant: Boolean;
  var
    v: Variant;
    i: Integer;
  begin
    Dest := VarArrayCreate([0, GetIFPSArrayLength(Sender, Src)-1], varVariant);
    for i := GetIFPSArrayLength(Sender, Src) -1 downto 0 do
    begin
      if (not PIFVariantToVariant(Sender, Src^.tArray.Fields[i], v)) or (VarIsArray(v)) then
      begin
        Result := False;
        exit;
      end;
      Dest[i] := v;
    end;
    Result := True;
  end;
begin
  if Src^.FType.BaseType = btVariant then Src := Src^.tvariant;
  if Src^.Ftype = nil then
  begin
    Dest := null;
    Result := True;
    exit;
  end;
  case Src^.FType^.BaseType of
    btArray, btStaticArray:
      begin
        if not CreateArrayVariant then
        begin
          Result := False;
          exit;
        end;
      end;
    btU8: Dest := Src^.tu8;
    btS8: Dest := Src^.ts8;
    btU16: Dest := Src^.tu16;
    btS16: Dest := Src^.ts16;
    btU32: Dest := Longint(Src^.tu32);
    btS32: Dest := Src^.ts32;
    btSingle: Dest := Src^.tsingle;
    btDouble:
      begin
        if Src^.FType^.ExportName = 'TDATETIME' then
          Dest := TDateTime(Src^.tdouble)
        else
          Dest := Src^.tdouble;
      end;
    btExtended: Dest := Src^.textended;
    btPChar, btString: Dest := tbtString(Src^.tstring);
  {$IFNDEF IFPS3_NOINT64}
  {$IFDEF IFPS3_D6PLUS} btS64: Dest := Src^.ts64; {$ELSE} bts64: begin Result := False; exit; end; {$ENDIF}
  {$ENDIF}
    btChar: Dest := src^.tChar;
  {$IFNDEF IFPS3_NOWIDESTRING}
    btWideString: Dest := tbtWideString(src^.twidestring);
    btWideChar: Dest := src^.twidechar;
  {$ENDIF}
  else
    begin
      Result := False;
      exit;
    end;
  end;
  Result := True;
end;

function VariantToPIFVariant(Sender: TIFPSExec; const Src: Variant; Dest: PIFVariant): Boolean;
var
  I: Longint;
  L: Cardinal;
  PT: PIFTypeRec;
begin
  if Dest^.FType.BaseType <> btVariant then begin Result := False; exit; end;
  if VarIsArray(Src) then
  begin
    if VarArrayDimCount(Src) > 1 then
    begin
      Result := False;
      exit;
    end;
    l := 0;
    repeat
      pt := Sender.FindType(l, btArray, l);
      if PIFTypeRec(Sender.GetTypeNo(Cardinal(pt^.Ext)))^.BaseType = btVariant then break;
    until pt = nil;
    if pt = nil then pt := @VariantArrayType;
    ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}Sender.MemoryManager, {$ENDIF}Dest^.tvariant, pt);
    SetIFPSArrayLength(Sender, Dest^.tvariant, VarArrayHighBound(Src, 1) - VarArrayLowBound(Src, 1)+1);
    for i := VarArrayLowBound(Src, 1) to VarArrayHighBound(Src, 1) do
    begin
      if not VariantToPIFVariant(Sender, Src[i], Dest^.tVariant^.tArray^.Fields[i - VarArrayLowBound(Src, 1)]) then
      begin
        Result := False;
        Exit;
      end;
    end;
  end else
  begin
    case VarType(Src) of
    varEmpty:
      begin
        ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}Sender.MemoryManager, {$ENDIF} Dest^.tvariant, nil);
      end;
    varSmallint:
      begin
        ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}Sender.MemoryManager, {$ENDIF} Dest^.tvariant, Sender.FindType2(btS16));
        Dest^.tvariant.ts16 := Src;
      end;
    varInteger:
      begin
        ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}Sender.MemoryManager, {$ENDIF} Dest^.tvariant, Sender.FindType2(btS32));
        Dest^.tvariant.ts32 := Src;
      end;
    varSingle:
      begin
        ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}Sender.MemoryManager, {$ENDIF} Dest^.tvariant, Sender.FindType2(btSingle));
        Dest^.tvariant.tsingle := Src;
      end;
    varDate:
      begin
        pt := Sender.GetTypeNo(Sender.GetType('TDATETIME'));
        if pt = nil then PT := Sender.FindType2(btDouble);
        ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}Sender.MemoryManager, {$ENDIF} Dest^.tvariant, PT);
        Dest^.tvariant.tDouble := Src;
      end;
    varCurrency, varDouble:
      begin
        ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}Sender.MemoryManager, {$ENDIF} Dest^.tvariant, Sender.FindType2(btDouble));
        Dest^.tvariant.tDouble := Src;
      end;
    {$IFNDEF IFPS3_NOWIDESTRING}
    varOleStr:
      begin
        ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}Sender.MemoryManager, {$ENDIF} Dest^.tvariant, Sender.FindType2(btWideString));
        tbtWideString(Dest^.tvariant.twidestring) := Src;
      end;
    {$ENDIF}
    varBoolean:
      begin
        ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}Sender.MemoryManager, {$ENDIF} Dest^.tvariant, Sender.FindType2(btu8));
        Boolean(Dest^.tvariant.tu8) := Src;
      end;
    {$IFDEF IFPS3_D6PLUS} varShortInt:
      begin
        ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}Sender.MemoryManager, {$ENDIF} Dest^.tvariant, Sender.FindType2(btS8));
        Dest^.tvariant.ts8 := Src;
      end;
    varByte:
      begin
        ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}Sender.MemoryManager, {$ENDIF} Dest^.tvariant, Sender.FindType2(btu8));
        Dest^.tvariant.tu8 := Src;
      end;
    varWord:
      begin
        ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}Sender.MemoryManager, {$ENDIF} Dest^.tvariant, Sender.FindType2(btS16));
        Dest^.tvariant.tu16 := Src;
      end;
    varLongWord:
      begin
        ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}Sender.MemoryManager, {$ENDIF} Dest^.tvariant, Sender.FindType2(btu32));
        Dest^.tvariant.tu32 := Src;
      end;
    {$IFNDEF IFPS3_NOINT64}
    varInt64:
      begin
        ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}Sender.MemoryManager, {$ENDIF} Dest^.tvariant, Sender.FindType2(btS64));
        Dest^.tvariant.ts64 := Src;
      end;
    {$ENDIF}{$ENDIF}
    varStrArg, varString:
      begin
        ChangeVariantType({$IFNDEF IFPS3_NOSMARTMM}Sender.MemoryManager, {$ENDIF} Dest^.tvariant, Sender.FindType2(btstring));
        tbtstring(Dest^.tvariant.tstring) := Src;
      end;
    else
      begin
        Result := False;
        exit;
      end;
    end;
  end;
  Result := True;
end;
{$ENDIF}
type
  POpenArray = ^TOpenArray;
  TOpenArray = record
    AType: Byte; {0}
    OrgVar: PIFVariant;
    ElementSize,
    ItemCount: Longint;
    Data: string;
    VarParam: Boolean;
  end;
{$IFDEF IFPS3_HAVEVARIANT}
  PVariant = ^TVariant;
  TVariant = record
    AType: Byte; {1}
    OrgVar: PIFVariant;
    P: Variant;
    VarParam: Boolean;
  end;
{$ENDIF}
  PRecord = ^TRecord;
  TRecord = record
    AType: Byte; {2}
    OrgVar: PIFVariant;
    Data: string;
    VarParam: Boolean;
  end;

{$IFDEF IFPS3_DYNARRAY}
  PDynArray = ^TDynArray;
  TDynArray = record
    AType: Byte; {3}
    OrgVar: PIfVariant;
    VarParam: Boolean;
    Data: Pointer;
  end;
{$ENDIF}
{$IFDEF IFPS3_HAVEVARIANT}
function CreateDelphiVariant(VarParam: Boolean; Sender: TIFPSExec; Val: PIFVariant): PVariant;
begin
  New(Result);
  Result.AType := 1;
  Result.OrgVar := Val;
  Result.VarParam := VarParam;
  if not PIFVariantToVariant(Sender, Val, Result^.P) then
  begin
    Dispose(Result);
    Result := nil;
    exit;
  end;
end;

procedure DestroyDelphiVariant(Sender: TIFPSExec; V: PVariant);
begin
  if V.VarParam then
  begin
    VariantToPIFVariant(Sender, V^.P, V^.OrgVar);
  end;
  Dispose(V);
end;
{$ENDIF}

function CreateOpenArray(VarParam: Boolean; Sender: TIFPSExec; Val: PIFVariant): POpenArray;
var
  p: Pointer;
  i: Longint;
{$IFDEF IFPS3_HAVEVARIANT}
  j: Longint;
  fv: PIFVariant;
  temps: string;
{$ENDIF}
begin
  if (Val.FType^.BaseType <> btArray) and (val.FType^.BaseType <> btStaticArray) then
  begin
    Result := nil;
    exit;
  end;
  New(Result);
  Result.AType := 0;
  Result.OrgVar := Val;
  Result.VarParam := VarParam;
  Result^.ItemCount := GetIFPSArrayLength(Sender, Val);
  case Sender.GetTypeNo(Longint(Val^.FType^.Ext))^.BaseType of
    btResourcePointer:
      begin
        if @Sender.GetTypeNo(Longint(Val^.FType^.Ext))^.ResFree = @ClassResourceFree then
        begin
          Result^.ElementSize := SizeOf(TObject);
        end else
        begin
          Dispose(Result);
          Result := nil;
          exit;
        end;
      end;
    {$IFDEF IFPS3_HAVEVARIANT}
    btVariant:
      begin
        if Val^.FType.ExportName = '!OPENARRAYOFVARIANT' then
          Result^.ElementSize := SizeOf(Variant)
        else
          Result^.ElementSize := SizeOf(TVarRec);
      end;
    {$ENDIF}
    btU8, bts8: Result^.ElementSize := 1;
    btu16, bts16: Result^.ElementSize := 2;
    btu32, bts32: Result^.ElementSize := 4;
    btsingle: Result^.ElementSize := 4;
    btdouble: Result^.ElementSize := 8;
    btextended: Result^.ElementSize := SizeOf(Extended);
    btstring, btpchar: Result^.ElementSize := 4;
    btchar: Result^.ElementSize := 1;
    {$IFNDEF IFPS3_NOINT64}
    btS64: Result^.ElementSize := 8;
    {$ENDIF}
    {$IFNDEF IFPS3_NOWIDESTRING}
    btWidestring: Result^.ElementSize := 4;
    btwidechar: Result^.ElementSize := 2;
    {$ENDIF}
  else
    begin
      Dispose(Result);
      Result := nil;
      exit;
    end;
  end;
  SetLength(Result^.Data, Result^.ItemCount * Result^.ElementSize);
  P := @Result^.Data[1];
  FillChar(p^, Result^.ItemCount * Result^.ElementSize, 0);
  case Sender.GetTypeNo(Longint(Val^.FType^.Ext))^.BaseType of
    btPChar, btChar, {$IFNDEF IFPS3_NOWIDESTRING}btWideChar, {$ENDIF}btU8, btS8, btU16, btS16, btu32, bts32, btSingle, btDouble, btExtended:
    begin
      for i := 0 to Result^.ItemCount -1 do
      begin
        Move(Val^.tArray.Fields[i].tu8, p^, Result^.elementsize);
        p := PChar(p) + Result^.ElementSize;
      end;
    end;
    {$IFNDEF IFPS3_NOWIDESTRING}
    btWideString:
    begin
      for i := 0 to Result^.ItemCount -1 do
      begin
        tbtwidestring(p^) := tbtwidestring(Val^.tArray.Fields[i].twidestring);
        p := PChar(p) + Result^.ElementSize;
      end;
    end;
    {$ENDIF}
    btString:
    begin
      for i := 0 to Result^.ItemCount -1 do
      begin
        string(p^) := string(Val^.tArray.Fields[i].tstring);
        p := PChar(p) + Result^.ElementSize;
      end;
    end;
    btResourcePointer:
    begin
      for i := 0 to Result^.ItemCount -1 do
      begin
        TObject(p^) := val^.Tarray.Fields[i].tresourcep1;
        p := PChar(p) + Result^.ElementSize;
      end;
    end;

    {$IFDEF IFPS3_HAVEVARIANT}
    btVariant:
    begin
      if Val^.FType.ExportName = '!OPENARRAYOFVARIANT' then
      begin
        for i := 0 to Result^.ItemCount -1 do
        begin
          Initialize(variant(p^));
          PIFVariantToVariant(Sender, val^.Tarray.Fields[i], Variant(p^));
          p := PChar(p) + Result^.ElementSize;
        end;
      end
      else
      begin
        for i := 0 to Result^.ItemCount -1 do
        begin
          fv := val^.tArray.Fields[i];
          if fv^.tvariant^.FType = nil then
          begin
            tvarrec(p^).VType := vtVariant;
            tvarrec(p^).VVariant := @VNull;
          end else begin
            case fv^.tvariant^.ftype^.BaseType of
              btchar: begin
                  tvarrec(p^).VType := vtChar;
                  tvarrec(p^).VChar := fv^.tvariant^.tchar;
                end;
              btSingle:
                begin
                  tvarrec(p^).VType := vtExtended;
                  New(tvarrec(p^).VExtended);
                  tvarrec(p^).VExtended^ := fv^.tvariant^.tsingle;
                end;
              btExtended:
                begin
                  tvarrec(p^).VType := vtExtended;
                  New(tvarrec(p^).VExtended);
                  tvarrec(p^).VExtended^ := fv^.tvariant^.textended;
                end;
              btDouble:
                begin
                  tvarrec(p^).VType := vtExtended;
                  New(tvarrec(p^).VExtended);
                  tvarrec(p^).VExtended^ := fv^.tvariant^.tdouble;
                end;
              {$IFNDEF IFPS3_NOWIDESTRING}
              btwidechar: begin
                  tvarrec(p^).VType := vtWideChar;
                  tvarrec(p^).VWideChar := fv^.tvariant^.twidechar;
                end;
              btwideString: begin
                tvarrec(p^).VType := vtWideString;
                widestring(TVarRec(p^).VWideString) := widestring(fv^.tvariant^.twidestring);
              end;
              {$ENDIF}
              btU8: begin
                  tvarrec(p^).VType := vtInteger;
                  tvarrec(p^).VInteger := fv^.tvariant^.tu8;
                end;
              btS8: begin
                  tvarrec(p^).VType := vtInteger;
                  tvarrec(p^).VInteger := fv^.tvariant^.ts8;
                end;
              btU16: begin
                  tvarrec(p^).VType := vtInteger;
                  tvarrec(p^).VInteger := fv^.tvariant^.tu16;
                end;
              btS16: begin
                  tvarrec(p^).VType := vtInteger;
                  tvarrec(p^).VInteger := fv^.tvariant^.ts16;
                end;
              btU32: begin
                  tvarrec(p^).VType := vtInteger;
                  tvarrec(p^).VInteger := Longint(fv^.tvariant^.tu32);
                end;
              btS32: begin
                  tvarrec(p^).VType := vtInteger;
                  tvarrec(p^).VInteger := fv^.tvariant^.ts32;
                end;
              {$IFNDEF IFPS3_NOINT64}
              btS64: begin
                  tvarrec(p^).VType := vtInt64;
                  New(tvarrec(p^).VInt64);
                  tvarrec(p^).VInt64^ := fv^.tvariant^.ts64;
                end;
              {$ENDIF}
              btString: begin
                tvarrec(p^).VType := vtAnsiString;
                string(TVarRec(p^).VAnsiString) := string(fv^.tvariant^.tstring);
              end;
              btPChar: begin
                tvarrec(p^).VType := vtPchar;
                TVarRec(p^).VPChar := pointer(fv^.tvariant^.tstring);
              end;
              btResourcePointer:
              begin
                temps := '';
                for j := 0 to Sender.FRPSupFuncs.Count -1 do
                begin
                  if PResourcePtrSupportFuncs(Sender.FRPSupFuncs[j]).PtrSupports(Sender.FRPSupFuncs[j], fv^.tvariant) then
                  begin
                    temps := PResourcePtrSupportFuncs(Sender.FRPSupFuncs[j]).PtrToStr(Sender.FRPSupFuncs[j], Sender, fv^.tvariant);
                    break;
                  end;
                end;
                if length(temps) = 4 then
                begin
                  tvarrec(p^).VType := vtObject;
                  TVarRec(p^).VObject := Pointer((@temps[1])^);
                end;
              end;
            end;
          end;
          p := PChar(p) + Result^.ElementSize;
        end;
      end;
    end;
    {$ENDIF}
  end;
end;

procedure DestroyOpenArray(Sender: TIFPSExec; V: POpenArray);
var
  p: Pointer;
  fv: PIFVariant;
  i,j: Longint;
begin
  p := @v^.Data[1];
  case Sender.GetTypeNo(Longint(V^.OrgVar^.FType^.Ext))^.BaseType of
    btPChar, btU8, btS8, btU16, btS16, btu32, bts32, btSingle, btDouble, btExtended, btChar{$IFNDEF IFPS3_NOWIDESTRING}, btWidechar{$ENDIF}:
    begin
      if v^.VarParam then
      begin
        for i := 0 to v^.ItemCount -1 do
        begin
          Move(p^, v^.orgvar^.tArray.Fields[i].tu8, v^.ElementSize);
          p := pchar(p) + v^.ElementSize;
        end;
      end;
    end;
    {$IFNDEF IFPS3_NOWIDESTRING}
    btWideString:
    begin
      for i := 0 to v^.ItemCount -1 do
      begin
        if v^.varparam then
          widestring(v^.OrgVar^.tArray.Fields[i].twidestring) := widestring(p^);
        Finalize(widestring(p^));
        p := pchar(p) + v^.ElementSize;
      end;
    end;
    {$ENDIF}
    btString:
    begin
      for i := 0 to v^.ItemCount -1 do
      begin
        if v^.varparam then
          string(v^.OrgVar^.tArray.Fields[i].tstring) := string(p^);
        Finalize(string(p^));
        p := pchar(p) + v^.ElementSize;
      end;
    end;
    btVariant:
    begin
    {$IFDEF IFPS3_HAVEVARIANT}
      if v^.OrgVar^.FType.ExportName = '!OPENARRAYOFVARIANT' then
      begin
        for i := 0 to v^.ItemCount -1 do
        begin
          if v^.varparam then
            VariantToPIFVariant(Sender, variant(p^), v^.OrgVar^.tArray.Fields[i]);
          Finalize(variant(p^));
          p := pchar(p) + v^.ElementSize;
        end;
      end
      else
      {$ENDIF}
      begin
        for i := 0 to v^.ItemCount -1 do
        begin
          fv := v^.OrgVar^.tArray.Fields[i];
          if fv^.tvariant^.FType = nil then
          begin
            tvarrec(p^).VType := vtInteger;
          end else begin
            case fv^.tvariant^.ftype^.BaseType of
              btU8: begin
                  if v^.varParam then
                    fv^.tvariant^.tu8 := tvarrec(p^).VInteger;
                end;
              btS8: begin
                  if v^.varParam then
                  fv^.tvariant^.ts8 := tvarrec(p^).VInteger;
                end;
              btU16: begin
                  if v^.varParam then
                  fv^.tvariant^.tu16 := tvarrec(p^).VInteger;
                end;
              btS16: begin
                  if v^.varParam then
                  fv^.tvariant^.ts16 := tvarrec(p^).VInteger;
                end;
              btU32: begin
                  if v^.varParam then
                  fv^.tvariant^.tu32 := tvarrec(p^).VInteger;
                end;
              btS32: begin
                  if v^.varParam then
                  fv^.tvariant^.ts32 := tvarrec(p^).VInteger;
                end;
              btChar: begin
                  if v^.VarParam then
                  fv^.tvariant^.tchar := tvarrec(p^).VChar;
                end;
              btSingle: begin
                if v^.VarParam then
                fv^.tvariant^.tsingle := tvarrec(p^).vextended^;
                dispose(tvarrec(p^).vextended);
              end;
              btDouble: begin
                if v^.VarParam then
                fv^.tvariant^.tdouble := tvarrec(p^).vextended^;
                dispose(tvarrec(p^).vextended);
              end;
              btExtended: begin
                if v^.VarParam then
                fv^.tvariant^.textended := tvarrec(p^).vextended^;
                dispose(tvarrec(p^).vextended);
              end;
              {$IFNDEF IFPS3_NOINT64}
              btS64: begin
                  if v^.VarParam then
                    fv^.tvariant^.ts64 := tvarrec(p^).VInt64^;
                  dispose(tvarrec(p^).VInt64);
                end;
              {$ENDIF}
              {$IFNDEF IFPS3_NOWIDESTRING}
              btWideChar: begin
                  if v^.varParam then
                  fv^.tvariant^.twidechar := tvarrec(p^).VWideChar;
                end;
              btWideString:
                begin
                if v^.VarParam then
                  widestring(fv^.tvariant^.twidestring) := widestring(TVarRec(p^).VWideString);
                finalize(widestring(TVarRec(p^).VWideString));
                end;
              {$ENDIF}
              btString: begin
                if v^.VarParam then
                  string(fv^.tvariant^.tstring) := string(TVarRec(p^).VAnsiString);
                finalize(string(TVarRec(p^).VAnsiString));
              end;
              btResourcePointer:
              begin
                if v^.varparam then
                begin
                  for j := 0 to Sender.FRPSupFuncs.Count -1 do
                  begin
                    if PResourcePtrSupportFuncs(Sender.FRPSupFuncs[j]).PtrSupports(Sender.FRPSupFuncs[j], fv) then
                    begin
                      PResourcePtrSupportFuncs(Sender.FRPSupFuncs[j]).ResToPtr(Sender.FRPSupFuncs[j], Sender, Longint(TVarRec(p^).VObject), fv);
                    end;
                  end;
                end;
              end;
            end;
          end;
          p := pchar(p) + v^.ElementSize;
        end;
      end;
    end;
  end;
  Dispose(V);
end;

procedure CreateRecordData(Rec: PIFVariant; var Data: string; SE: TIFPSExec);
var
  I: Longint;
  s: string;
begin
  while Rec^.FType^.BaseType = btPointer do
  begin
    Rec := Rec^.tPointer;
    if Rec = nil then begin Data := Data + #0#0#0#0; Exit; end;
  end;
  case Rec^.FType^.BaseType of
  btchar, btS8, btU8: Data := Data + Chr(Rec^.tu8);
  {$IFNDEF IFPS3_NOWIDESTRING}btWideChar, {$ENDIF}btU16, btS16: begin Data := Data + #0#0; Word((@Data[Length(Data)-1])^) := Rec^.tu16; end;
  btS32, btU32: begin Data := Data + #0#0#0#0; Cardinal((@Data[Length(Data)-3])^) := Rec^.tu32; end;
  btSingle: begin Data := Data + #0#0#0#0; Single((@Data[Length(Data)-3])^) := Rec^.tsingle; end;
  btDouble: begin Data := Data + #0#0#0#0#0#0#0#0; Double((@Data[Length(Data)-7])^) := Rec^.tdouble; end;
  btExtended: begin Data := Data + #0#0#0#0#0#0#0#0#0#0; Extended((@Data[Length(Data)-9])^) := Rec^.tExtended; end;
  btString, btPChar: begin Data := Data + #0#0#0#0; tbtString((@Data[Length(Data)-3])^) := tbtString(Rec^.tString); end;
  {$IFNDEF IFPS3_NOWIDESTRING}
  btWideString: begin Data := Data + #0#0#0#0; tbtWideString((@Data[Length(Data)-3])^) := tbtWideString(Rec^.twidestring); end;
  {$ENDIF}
  btRecord, btArray, btStaticArray:
    begin
      if Rec^.trecord <> nil then
      begin
        for i := 0 to Rec^.trecord^.FieldCount -1 do
        begin
          CreateRecordData(Rec^.trecord^.Fields[I], Data, Se);
        end;
      end;
    end;
  btResourcePointer:
    begin
      for i := 0 to SE.FRPSupFuncs.Count -1 do
      begin
        if PResourcePtrSupportFuncs(SE.FRPSupFuncs[i]).PtrSupports(SE.FRPSupFuncs[i], Rec) then
        begin
          s := PResourcePtrSupportFuncs(SE.FRPSupFuncs[i]).PtrToStr(se.FRPSupFuncs[i], Se, Rec);
          break;
        end;
      end;
      Data := Data + s;
    end;
{$IFNDEF IFPS3_NOINT64}btS64: begin Data := Data + #0#0#0#0#0#0#0#0; int64((@Data[Length(Data)-7])^) := Rec^.ts64; end;{$ENDIF}
  end;
end;

function CreateRecord(VarParam: Boolean; Sender: TIFPSExec; Val: PIFVariant): PRecord;
begin
  New(Result);
  Result^.AType := 2;
  Result^.orgvar := Val;
  Result^.varparam:= VarParam;
  CreateRecordData(Val, Result^.Data, Sender);
end;

procedure DestroyRecord_(CopyBack: Boolean; Rec: PIFVariant; var Position: Longint; const Data: string; SE: TIFPSExec);
var
  I, j: Longint;
  P: Pointer;

  procedure GetP(var D; Len: Longint; CBO: Boolean);
  begin
    if Position + Len -1 <= Length(Data) then
    begin
      if CopyBack or CBO then Move(Data[Position], D, Len);
      Position := Position + Len;
    end else Position := Length(Data) + 1;
  end;


begin
  while Rec^.FType^.BaseType = btPointer do
  begin
    Rec := Rec^.tPointer;
    if Rec = nil then begin Inc(position, 4); Exit; end;
  end;
  case Rec^.FType^.BaseType of
  btS8, btU8: GetP(Rec^.tu8, 1, False);
  btU16, btS16: GetP(Rec^.tu16, 2, False);
  btS32, btU32: GetP(Rec^.tu32, 4, False);
  btSingle: GetP(Rec^.tsingle, 4, False);
  btDouble: GetP(Rec^.tdouble, 8, False);
  btExtended: GetP(Rec^.TExtended, 10, False);
  btString, btPChar:
    begin
      GetP(P, 4, True);
      if CopyBack then
      tbtString(Rec^.tString) := string(p);
      Finalize(tbtString(p));
    end;
  {$IFNDEF IFPS3_NOWIDESTRING}
  btWideString: begin GetP(P, 4, False); tbtWideString(Rec^.tWideString) := WideString(p); Finalize(tbtwideString(Rec^.twideString)); end;
  {$ENDIF}
  btRecord, btArray, btStaticArray:
    begin
      if Rec^.trecord <> nil then
      begin
        for i := 0 to Rec^.trecord^.FieldCount -1 do
        begin
          DestroyRecord_(CopyBack, Rec^.trecord^.Fields[I], Position, Data, Se);
        end;
      end;
    end;
  btResourcePointer:
    begin
      GetP(I, 4, False);
      for j := 0 to SE.FRPSupFuncs.Count -1 do
      begin
        if PResourcePtrSupportFuncs(SE.FRPSupFuncs[j]).PtrSupports(SE.FRPSupFuncs[j], Rec) then
        begin
          PResourcePtrSupportFuncs(SE.FRPSupFuncs[j]).ResToPtr(SE.FRPSupFuncs[j], SE, I, Rec);
        end;
      end;
    end;
{$IFNDEF IFPS3_NOINT64}btS64: begin GetP(Rec^.ts64, 8, False); end;{$ENDIF}
  end;
end;


procedure DestroyRecord(Sender: TIFPSExec; V: PRecord);
var
  Pos: Longint;
begin
  Pos := 1;
  DestroyRecord_(V^.varparam, V^.orgvar, Pos, V^.Data, Sender);
  Dispose(v);
end;

{$IFDEF IFPS3_DYNARRAY}
type
  TArrU8 = array of byte;
  TArrS8 = array of ShortInt;
  TArrU16 = array of SmallInt;
  TArrS16 = array of Word;
  TArrU32 = array of Cardinal;
  TArrS32 = array of Longint;
  TArrSingle = array of Single;
  TArrDouble = array of Double;
  TArrExtended = array of Extended;
  TArrString = array of String;
{$IFDEF IFPS3_HAVEVARIANT}
  TArrVariant = array of Variant;
{$ENDIF}
{$IFNDEF IFPS3_NOINT64}
    TArrS64 = array of Int64;
{$ENDIF}
  TArrChar = array of Char;
{$IFNDEF IFPS3_NOWIDESTRING}
  TArrWideString = array of WideString;
  TArrWideChar = array of WideChar;
{$ENDIF}


function CreateDynamicArray(VarParam: Boolean; Sender: TIFPSExec; Val: PIFVariant): PDynArray;
var
  I, Len: Longint;
begin
  New(Result);
  Result^.AType := 3;
  Result^.OrgVar := Val;
  Result^.VarParam := VarParam;
  Result^.Data := nil;
  Len := GetIFPSArrayLength(Sender, Val);
  case Sender.GetTypeNo(Longint(Val^.FType^.Ext))^.BaseType of
    btU8:
      begin
        SetLength(TArrU8(Result^.Data), Len);
        for i := Length(TArrU8(Result^.Data)) -1 downto 0 do
          TArrU8(Result^.Data)[i] := Val.tarray.fields[i].tu8;
      end;
    btS8:
      begin
        SetLength(TArrS8(Result^.Data), Len);
        for i := Length(TArrS8(Result^.Data)) -1 downto 0 do
          TArrS8(Result^.Data)[i] := Val.tarray.fields[i].tS8;
      end;
    btU16:
      begin
        SetLength(TArrU16(Result^.Data), Len);
        for i := Length(TArrU16(Result^.Data)) -1 downto 0 do
          TArrU16(Result^.Data)[i] := Val.tarray.fields[i].tu16;
      end;
    btS16:
      begin
        SetLength(TArrs16(Result^.Data), Len);
        for i := Length(TArrs16(Result^.Data)) -1 downto 0 do
          TArrS16(Result^.Data)[i] := Val.tarray.fields[i].ts16;
      end;
    btU32:
      begin
        SetLength(TArrU32(Result^.Data), Len);
        for i := Length(TArrU32(Result^.Data)) -1 downto 0 do
          TArrU32(Result^.Data)[i] := Val.tarray.fields[i].tu32;
      end;
    bts32:
      begin
        SetLength(TArrS32(Result^.Data), Len);
        for i := Length(TArrS32(Result^.Data)) -1 downto 0 do
          TArrS32(Result^.Data)[i] := Val.tarray.fields[i].ts8;
      end;
    btSingle:
      begin
        SetLength(TArrU8(Result^.Data), Len);
        for i := Length(TArrU8(Result^.Data)) -1 downto 0 do
          TArrU8(Result^.Data)[i] := Val.tarray.fields[i].tu8;
      end;
    btDouble:
      begin
        SetLength(TArrDouble(Result^.Data), Len);
        for i := Length(TArrDouble(Result^.Data)) -1 downto 0 do
          TArrDouble(Result^.Data)[i] := Val.tarray.fields[i].tdouble;
      end;
    btExtended:
      begin
        SetLength(TArrExtended(Result^.Data), Len);
        for i := Length(TArrExtended(Result^.Data)) -1 downto 0 do
          TArrExtended(Result^.Data)[i] := Val.tarray.fields[i].tExtended;
      end;
    btString:
      begin
        SetLength(TArrString(Result^.Data), Len);
        for i := Length(TArrString(Result^.Data)) -1 downto 0 do
          TArrString(Result^.Data)[i] := tbtstring(Val.tarray.fields[i].tstring);
      end;
  {$IFDEF IFPS3_HAVEVARIANT}
    btVariant:
      begin
        SetLength(TArrVariant(Result^.Data), Len);
        for i := Length(TArrVariant(Result^.Data)) -1 downto 0 do
        begin
          if not PIFVariantToVariant(Sender, Val.tarray.fields[i], TArrVariant(Result^.Data)[i]) then
          begin
            SetLength(TArrVariant(Result^.Data), 0);
            Dispose(result);
            exit;
          end;
        end;
      end;
  {$ENDIF}
  {$IFNDEF IFPS3_NOINT64}
    btS64:
      begin
        SetLength(TArrS64(Result^.Data), Len);
        for i := Length(TArrS64(Result^.Data)) -1 downto 0 do
          TArrS64(Result^.Data)[i] := Val.tarray.fields[i].ts64;
      end;
  {$ENDIF}
    btChar:
      begin
        SetLength(TArrchar(Result^.Data), Len);
        for i := Length(TArrchar(Result^.Data)) -1 downto 0 do
          TArrchar(Result^.Data)[i] := Val.tarray.fields[i].tchar;
      end;
  {$IFNDEF IFPS3_NOWIDESTRING}
    btWideString:
      begin
        SetLength(TArrwidestring(Result^.Data), Len);
        for i := Length(TArrwidestring(Result^.Data)) -1 downto 0 do
          TArrwidestring(Result^.Data)[i] := tbtwidestring(Val.tarray.fields[i].twidestring);
      end;
    btWideChar:
      begin
        SetLength(TArrWidechar(Result^.Data), Len);
        for i := Length(TArrWidechar(Result^.Data)) -1 downto 0 do
          TArrWidechar(Result^.Data)[i] := Val.tarray.fields[i].twidechar;
      end;
  {$ENDIF}
    else begin
      Dispose(Result);
      Result := nil;
      exit;
    end;
  end;
end;

procedure DestroyDynamicArray(Sender: TIFPSExec; V: PDynArray);
var
  C, I: Longint;
begin
  case Sender.GetTypeNo(Longint(V^.OrgVar^.FType^.Ext))^.BaseType of
    btU8:
      begin
        if v.VarParam then
        begin
          c := Length(TArrU8(V^.Data));
          SetIFPSArrayLength(Sender, v.OrgVar, c);
          for i := c -1 downto 0 do
            V.OrgVar.tarray.fields[i].tu8 := TArrU8(v^.Data)[i];
        end;
        SetLength(TArrU8(V^.Data), 0);
      end;
    btS8:
      begin
        if v.VarParam then
        begin
          c := Length(TArrs8(V^.Data));
          SetIFPSArrayLength(Sender, v.OrgVar, c);
          for i := c -1 downto 0 do
            V.OrgVar.tarray.fields[i].ts8 := TArrs8(v^.Data)[i];
        end;
        SetLength(TArrs8(V^.Data), 0);
      end;
    btU16:
      begin
        if v.VarParam then
        begin
          c := Length(TArrU16(V^.Data));
          SetIFPSArrayLength(Sender, v.OrgVar, c);
          for i := c -1 downto 0 do
            V.OrgVar.tarray.fields[i].tu16 := TArrU16(v^.Data)[i];
        end;
        SetLength(TArrU16(V^.Data), 0);
      end;
    btS16:
      begin
        if v.VarParam then
        begin
          c := Length(TArrs16(V^.Data));
          SetIFPSArrayLength(Sender, v.OrgVar, c);
          for i := c -1 downto 0 do
            V.OrgVar.tarray.fields[i].ts16 := TArrs16(v^.Data)[i];
        end;
        SetLength(TArrs16(V^.Data), 0);
      end;
    btU32:
      begin
        if v.VarParam then
        begin
          c := Length(TArrU32(V^.Data));
          SetIFPSArrayLength(Sender, v.OrgVar, c);
          for i := c -1 downto 0 do
            V.OrgVar.tarray.fields[i].tu32 := TArrU32(v^.Data)[i];
        end;
        SetLength(TArrU32(V^.Data), 0);
      end;
    bts32:
      begin
        if v.VarParam then
        begin
          c := Length(TArrs32(V^.Data));
          SetIFPSArrayLength(Sender, v.OrgVar, c);
          for i := c -1 downto 0 do
            V.OrgVar.tarray.fields[i].ts32 := TArrs32(v^.Data)[i];
        end;
        SetLength(TArrs32(V^.Data), 0);
      end;
    btSingle:
      begin
        if v.VarParam then
        begin
          c := Length(TArrsingle(V^.Data));
          SetIFPSArrayLength(Sender, v.OrgVar, c);
          for i := c -1 downto 0 do
            V.OrgVar.tarray.fields[i].tsingle := TArrsingle(v^.Data)[i];
        end;
        SetLength(TArrsingle(v^.Data), 0);
      end;
    btDouble:
      begin
        if v.VarParam then
        begin
          c := Length(TArrDouble(V^.Data));
          SetIFPSArrayLength(Sender, v.OrgVar, c);
          for i := c -1 downto 0 do
            V.OrgVar.tarray.fields[i].tdouble := TArrDouble(v^.Data)[i];
        end;
        SetLength(TArrDouble(V^.Data), 0);
      end;
    btExtended:
      begin
        if v.VarParam then
        begin
          c := Length(TArrextended(V^.Data));
          SetIFPSArrayLength(Sender, v.OrgVar, c);
          for i := c -1 downto 0 do
            V.OrgVar.tarray.fields[i].tExtended := TArrextended(v^.Data)[i];
        end;
        SetLength(TArrextended(V^.Data), 0);
      end;
    btString:
      begin
        if v.VarParam then
        begin
          c := Length(TArrString(V^.Data));
          SetIFPSArrayLength(Sender, v.OrgVar, c);
          for i := c -1 downto 0 do
            tbtstring(V.OrgVar.tarray.fields[i].tstring) := TArrString(v^.Data)[i];
        end;
        SetLength(TArrString(V^.Data), 0);
      end;
  {$IFDEF IFPS3_HAVEVARIANT}
    btVariant:
      begin
        if v.VarParam then
        begin
          c := Length(TArrVariant(V^.Data));
          SetIFPSArrayLength(Sender, v.OrgVar, c);
          for i := c -1 downto 0 do
            VariantToPIFVariant(Sender,TArrVariant(v^.Data)[i], V.OrgVar.tarray.fields[i]);
        end;
        SetLength(TArrVariant(V^.Data), 0);
      end;
  {$ENDIF}
  {$IFNDEF IFPS3_NOINT64}
    btS64:
      begin
        if v.VarParam then
        begin
          c := Length(TArrs64(V^.Data));
          SetIFPSArrayLength(Sender, v.OrgVar, c);
          for i := c -1 downto 0 do
            V.OrgVar.tarray.fields[i].ts64 := TArrs64(v^.Data)[i];
        end;
        SetLength(TArrU8(V^.Data), 0);
      end;
  {$ENDIF}
    btChar:
      begin
        if v.VarParam then
        begin
          c := Length(TArrChar(V^.Data));
          SetIFPSArrayLength(Sender, v.OrgVar, c);
          for i := c -1 downto 0 do
            V.OrgVar.tarray.fields[i].tchar := TArrChar(v^.Data)[i];
        end;
        SetLength(TArrchar(V^.Data), 0);
      end;
  {$IFNDEF IFPS3_NOWIDESTRING}
    btWideString:
      begin
        if v.VarParam then
        begin
          c := Length(TArrWideString(V^.Data));
          SetIFPSArrayLength(Sender, v.OrgVar, c);
          for i := c -1 downto 0 do
            tbtwidestring(V.OrgVar.tarray.fields[i].twidestring) := TArrWideString(v^.Data)[i];
        end;
        SetLength(TArrWideString(V^.Data), 0);
      end;
    btWideChar:
      begin
        if v.VarParam then
        begin
          c := Length(TArrWideChar(V^.Data));
          SetIFPSArrayLength(Sender, v.OrgVar, c);
          for i := c -1 downto 0 do
            V.OrgVar.tarray.fields[i].twidechar := TArrWideChar(v^.Data)[i];
        end;
        SetLength(TArrU8(V^.Data), 0);
      end;
  {$ENDIF}
  end;
  Dispose(V);
end;
{$ENDIF}

function TIFPSExec.InnerfuseCall(_Self, Address: Pointer; CallingConv: TIFPSCallingConvention; Params: TIfList; res: PIfVariant): Boolean;
var
  Stack: ansistring;
  I, j: Longint;
  RegUsage: Byte;
  CallData: TIfList;
  pp: ^Byte;

  EAX, EDX, ECX: Longint;

  function GetPtr(fVar: PIfVariant): Boolean;
  var
    varPtr: Pointer;
    UseReg: Boolean;
    tempstr: string;
    p: Pointer;
    j: Longint;
  begin
    Result := False;
    if FVar = nil then exit;
    if fVar^.RefCount >= IFPSAddrStackStart then begin
      fvar^.RefCount := FVar^.RefCount and not IFPSAddrStackStart;
      case fVar^.FType^.BaseType of
        btArray:
          begin
            if Copy(fvar^.Ftype^.ExportName, 1, 10) = '!OPENARRAY' then
            begin
              p := CreateOpenArray(True, Self, FVar);
              if p = nil then exit;
              CallData.Add(p);
              case RegUsage of
                0: begin EAX := Longint(@POpenArray(p)^.Data[1]); Inc(RegUsage); end;
                1: begin EDX := Longint(@POpenArray(p)^.Data[1]); Inc(RegUsage); end;
                2: begin ECX := Longint(@POpenArray(p)^.Data[1]); Inc(RegUsage); end;
                else begin
                  Stack := #0#0#0#0 + Stack;
                  Pointer((@Stack[1])^) := @POpenArray(p)^.Data[1];
                end;
              end;
              case RegUsage of
                0: begin EAX := Longint(POpenArray(p)^.ItemCount - 1); Inc(RegUsage); end;
                1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
                2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
                else begin
                  Stack := #0#0#0#0 + Stack;
                  Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1;
                end;
              end;
              Result := True;
              Exit;
            end else begin
            {$IFDEF IFPS3_DYNARRAY}
              p := CreateDynamicArray(True, Self, FVar);
              if p = nil then exit;
              varPtr := @(PDynArray(p)^.Data);
              CallData.Add(p);
            {$ELSE}
              Exit;
            {$ENDIF}
            end;
          end;
        {$IFDEF IFPS3_HAVEVARIANT}
        btVariant:
          begin
            p := CreateDelphiVariant(True, Self, FVar);
            VarPtr := @(PVariant(p)^.P);
            CallData.Add(p);
          end;
        {$ENDIF}
        btSet:
          begin
            varPtr := fVar.tset;
          end;
        btStaticArray, btRecord:
          begin
            p := CreateRecord(True, SElf, FVar);
            VarPtr := @(PRecord(P).Data[1]);
            CallData.Add(p);
          end;
        btResourcePointer:
          begin
            tempstr := '';
            for j := 0 to FRPSupFuncs.Count -1 do
            begin
              if PResourcePtrSupportFuncs(FRPSupFuncs[j]).PtrSupports(FRPSupFuncs[j], fVar) then
              begin
                tempstr := PResourcePtrSupportFuncs(FRPSupFuncs[j]).VarPtrToStr(FRPSupFuncs[j], Self, fVar);
                break;
              end;
            end;
            if length(tempstr) <> 4 then exit;
            VarPtr := Pointer((@tempstr[1])^);
          end;
        btString: VarPtr := @tbtString(fvar^.tstring);
        {$IFNDEF IFPS3_NOWIDESTRING}
        btWideString: varPtr := @fVar^.twidestring;
          {$ENDIF}

        {$IFNDEF IFPS3_NOWIDESTRING} btWideChar, {$ENDIF} btU8, btS8, btU16, btS16, btU32, btS32, btSingle, btDouble,
        btExtended{$IFNDEF IFPS3_NOINT64}, bts64{$ENDIF}: VarPtr := @(fVar^.tu8);
      else begin
          exit; //invalid type
        end;
      end; {case}
      case RegUsage of
        0: begin EAX := Longint(VarPtr); Inc(RegUsage); end;
        1: begin EDX := Longint(VarPtr); Inc(RegUsage); end;
        2: begin ECX := Longint(VarPtr); Inc(RegUsage); end;
        else begin
          Stack := #0#0#0#0 + Stack;
          Pointer((@Stack[1])^) := VarPtr;
        end;
      end;
    end else begin
      UseReg := True;
      case fVar^.FType^.BaseType of
        btSet:
          begin
            tempstr := #0#0#0#0;
            case PIFSetTypeInfo(fvar.FType.Ext)^.aByteSize of
              1: Byte((@tempstr[1])^) := byte(fvar.tset^);
              2: word((@tempstr[1])^) := word(fvar.tset^);
              3, 4: cardinal((@tempstr[1])^) := cardinal(fvar.tset^);
              else
                pointer((@tempstr[1])^) := fvar^.tset;
            end;
          end;
        btArray:
          begin
            if Copy(fvar^.Ftype^.ExportName, 1, 10) = '!OPENARRAY' then
            begin
              p := CreateOpenArray(False, SElf, FVar);
              if p =nil then exit;
              CallData.Add(p);
              case RegUsage of
                0: begin EAX := Longint(@POpenArray(p)^.Data[1]); Inc(RegUsage); end;
                1: begin EDX := Longint(@POpenArray(p)^.Data[1]); Inc(RegUsage); end;
                2: begin ECX := Longint(@POpenArray(p)^.Data[1]); Inc(RegUsage); end;
                else begin
                  Stack := #0#0#0#0 + Stack;
                  Pointer((@Stack[1])^) := @POpenArray(p)^.Data[1];
                end;
              end;
              case RegUsage of
                0: begin EAX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
                1: begin EDX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
                2: begin ECX := Longint(POpenArray(p)^.ItemCount -1); Inc(RegUsage); end;
                else begin
                  Stack := #0#0#0#0 + Stack;
                  Longint((@Stack[1])^) := POpenArray(p)^.ItemCount -1;
                end;
              end;
              Result := True;
              exit;
            end else begin
            {$IFDEF IFPS3_DYNARRAY}
              p := CreateDynamicArray(True, Self, FVar);
              if p = nil then exit;
              CallData.Add(p);
              TempStr := #0#0#0#0;
              Pointer((@TempStr[1])^) := PDynArray(P)^.Data;
            {$ELSE}
              Exit;
            {$ENDIF}
            end;
          end;
        {$IFDEF IFPS3_HAVEVARIANT}
        btVariant:
          begin
            p := CreateDelphiVariant(False, Self, FVar);
            if p = nil then exit;
            TempStr := #0#0#0#0;
            Pointer((@TempStr[1])^) := @(PVariant(p).P);
            CallData.Add(p);
          end;
        {$ENDIF}
        btStaticArray, btRecord:
          begin
            p := CreateRecord(False, SElf, Fvar);
            CallData.Add(p);
            TempStr := #0#0#0#0;
            Pointer((@TempStr[1])^) := @(PRecord(p).Data[1]);
          end;
        btDouble: {8 bytes} begin
            TempStr := #0#0#0#0#0#0#0#0;
            UseReg := False;
            double((@TempStr[1])^) := fVar^.tdouble;
          end;

        btSingle: {4 bytes} begin
            TempStr := #0#0#0#0;
            UseReg := False;
            Single((@TempStr[1])^) := fVar^.tsingle;
          end;

        btExtended: {10 bytes} begin
            UseReg := False;
            TempStr:= #0#0#0#0#0#0#0#0#0#0#0#0;
            Extended((@TempStr[1])^) := fVar^.textended;
          end;
        btChar,
        btU8,
        btS8: begin
            TempStr := char(fVar^.tu8) + #0#0#0;
          end;
        {$IFNDEF IFPS3_NOWIDESTRING}btWideChar, {$ENDIF}
        btu16, btS16: begin
            TempStr := #0#0#0#0;
            Word((@TempStr[1])^) := fVar^.tu16;
          end;
        btu32, bts32: begin
            TempStr := #0#0#0#0;
            Longint((@TempStr[1])^) := fVar^.tu32;
          end;
        btPChar, btString: begin
            TempStr := #0#0#0#0;
            Pointer((@TempStr[1])^) := fVar^.tstring;
          end;
          {$IFNDEF IFPS3_NOWIDESTRING}
        btWideString: begin
            TempStr := #0#0#0#0;
            Pointer((@TempStr[1])^) := Pointer(fVar^.twidestring);
          end;
          {$ENDIF}

        btProcPtr:
          begin
            tempstr := '';
            for j := 0 to FRPSupFuncs.Count -1 do
            begin
              if PResourcePtrSupportFuncs(FRPSupFuncs[j]).PtrSupports(FRPSupFuncs[j], fVar) then
              begin
                tempstr := PResourcePtrSupportFuncs(FRPSupFuncs[j]).ProcPtrToStr(FRPSupFuncs[j], Self, fVar);
                break;
              end;
            end;
            if Length(TempStr) > 4 then
              UseReg := False
            else
              SetLength(TempStr, 4);
          end;

        btResourcePointer:
          begin
            tempstr := '';
            for j := 0 to FRPSupFuncs.Count -1 do
            begin
              if PResourcePtrSupportFuncs(FRPSupFuncs[j]).PtrSupports(FRPSupFuncs[j], fVar) then
              begin
                tempstr := PResourcePtrSupportFuncs(FRPSupFuncs[j]).PtrToStr(FRPSupFuncs[j], Self, fVar);
                break;
              end;
            end;
            if Length(TempStr) > 4 then
              UseReg := False
            else
              SetLength(TempStr, 4);
          end;
        {$IFNDEF IFPS3_NOINT64}bts64: begin
            TempStr:= #0#0#0#0#0#0#0#0;
            Int64((@TempStr[1])^) := fvar^.ts64;
            UseReg := False;
        end;{$ENDIF}
      end; {case}
      if UseReg then
      begin
        case RegUsage of
          0: begin EAX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
          1: begin EDX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
          2: begin ECX := Longint((@Tempstr[1])^); Inc(RegUsage); end;
          else Stack := TempStr + Stack;
        end;
      end else begin
        Stack := TempStr + Stack;
      end;
    end;
    Result := True;
  end;
begin
  InnerfuseCall := False;
  if Address = nil then
    exit; // need address
  Stack := '';
  CallData := TIfList.Create;
  res := rp(res);
  if res <> nil then
    res^.RefCount := res^.RefCount or IFPSAddrStackStart;
  try
    case CallingConv of
      cdRegister: begin
          EAX := 0;
          EDX := 0;
          ECX := 0;
          RegUsage := 0;
          if assigned(_Self) then begin
            RegUsage := 1;
            EAX := Longint(_Self);
          end;
          for I := 0 to Params.Count - 1 do
          begin
            if not GetPtr(rp(Params[I])) then Exit;
          end;
          if assigned(res) then begin
            case res^.FType^.BaseType of
              btResourcePointer:
                begin
                  for j := 0 to FRPSupFuncs.Count -1 do
                  begin
                    if PResourcePtrSupportFuncs(FRPSupFuncs[j]).PtrSupports(FRPSupFuncs[j], res) then
                    begin
                      if PResourcePtrSupportFuncs(FRPSupFuncs[j])^.ResultMethod = rmParam then GetPtr(res);
                      break;
                    end;
                  end;
                end;
              {$IFNDEF IFPS3_NOWIDESTRING}btWideString, {$ENDIF}btArray, btrecord, btstring{$IFDEF IFPS3_HAVEVARIANT}, btVariant{$ENDIF}: GetPtr(res);
            end;
            case res^.FType^.BaseType of
              btSingle:      res^.tsingle := RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
              btDouble:      res^.tdouble:= RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
              btExtended:    res^.textended:= RealFloatCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4);
              btchar,btU8, btS8:    res^.tu8 := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
              {$IFNDEF IFPS3_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16:  res^.tu16:= RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
              btu32, bts32:  res^.tu32:= RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
              btPChar:       TBTSTRING(res^.tstring) := Pchar(RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
              {$IFNDEF IFPS3_NOINT64}bts64:
                begin
                  EAX := RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
                  res^.ts64 := (EDX shl 32) or EAX;
                end;
              {$ENDIF}
              {$IFDEF IFPS3_HAVEVARIANT}btVariant, {$ENDIF}
              {$IFNDEF IFPS3_NOWIDESTRING}btWidestring: RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); {$ENDIF}
              btArray, btrecord, btstring:      RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
              btResourcePointer:
                begin
                  for j := 0 to FRPSupFuncs.Count -1 do
                  begin
                    if PResourcePtrSupportFuncs(FRPSupFuncs[j]).PtrSupports(FRPSupFuncs[j], res) then
                    begin
                      if PResourcePtrSupportFuncs(FRPSupFuncs[j])^.ResultMethod = rmParam then
                        RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil)
                      else
                        PResourcePtrSupportFuncs(FRPSupFuncs[j])^.ResToPtr(PResourcePtrSupportFuncs(FRPSupFuncs[j]), SElf, RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil), res);
                      break;
                    end;
                  end;
                end;
            else
              exit;
            end;
          end else
            RealCall_Register(Address, EAX, EDX, ECX, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
          Result := True;
        end;
      cdPascal: begin
          RegUsage := 3;
          for I :=  0 to Params.Count - 1 do begin
            if not GetPtr(Params[i]) then Exit;
          end;
          if assigned(res) then begin
            case res^.FType^.BaseType of
              btResourcePointer:
                begin
                  for j := 0 to FRPSupFuncs.Count -1 do
                  begin
                    if PResourcePtrSupportFuncs(FRPSupFuncs[j]).PtrSupports(FRPSupFuncs[j], res) then
                    begin
                      if PResourcePtrSupportFuncs(FRPSupFuncs[j])^.ResultMethod = rmParam then GetPtr(res);
                      break;
                    end;
                  end;
                end;
              {$IFNDEF IFPS3_NOWIDESTRING}btWideString, {$ENDIF}btArray, btrecord, btstring{$IFDEF IFPS3_HAVEVARIANT}, btVariant{$ENDIF}: GetPtr(res);
            end;
          end;
          if assigned(_Self) then begin
            Stack := #0#0#0#0 +Stack;
            Pointer((@Stack[1])^) := _Self;
          end;
          if assigned(res) then begin
            case res^.FType^.BaseType of
              btSingle:      res^.tsingle := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
              btDouble:      res^.tdouble:= RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
              btExtended:    res^.textended:= RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
              btChar, btU8, btS8:    res^.tu8 := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
              {$IFNDEF IFPS3_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16:  res^.tu16:= RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
              btu32, bts32:  res^.tu32:= RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
              btPChar:       TBTSTRING(res^.tstring) := Pchar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
              {$IFNDEF IFPS3_NOINT64}bts64:
                begin
                  EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
                  res^.ts64 := (EDX shl 32) or EAX;
                end;
              {$ENDIF}
              {$IFDEF IFPS3_HAVEVARIANT}btVariant, {$ENDIF}
              btrecord, btstring:      RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
              btResourcePointer:
                begin
                  for j := 0 to FRPSupFuncs.Count -1 do
                  begin
                    if PResourcePtrSupportFuncs(FRPSupFuncs[j]).PtrSupports(FRPSupFuncs[j], res) then
                    begin
                      if PResourcePtrSupportFuncs(FRPSupFuncs[j])^.ResultMethod = rmParam then
                        RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil)
                      else
                        PResourcePtrSupportFuncs(FRPSupFuncs[j])^.ResToPtr(PResourcePtrSupportFuncs(FRPSupFuncs[j]), SElf, RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil), res);
                      break;
                    end;
                  end;
                end;
            else
              exit;
            end;
          end else
            RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
          Result := True;
        end;

      CdCdecl: begin
          RegUsage := 3;
          if assigned(_Self) then begin
            Stack := #0#0#0#0;
            Pointer((@Stack[1])^) := _Self;
          end;
          for I := Params.Count - 1 downto 0 do begin
            if not GetPtr(Params[I]) then Exit;
          end;
          if assigned(res) then begin
            case res^.FType^.BaseType of
              btSingle:      res^.tsingle := RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
              btDouble:      res^.tdouble:= RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
              btExtended:    res^.textended:= RealFloatCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
              btCHar, btU8, btS8:    res^.tu8 := RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
              {$IFNDEF IFPS3_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16:  res^.tu16:= RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
              btu32, bts32:  res^.tu32:= RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
              btPChar:       TBTSTRING(res^.tstring) := Pchar(RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
              {$IFNDEF IFPS3_NOINT64}bts64:
                begin
                  EAX := RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
                  res^.ts64 := (EDX shl 32) or EAX;
                end;
              {$ENDIF}
              {$IFDEF IFPS3_HAVEVARIANT}btVariant, {$ENDIF}{$IFNDEF IFPS3_NOWIDESTRING}btWideString, {$ENDIF}
              btArray, btrecord, btstring:      begin GetPtr(res); RealCall_Cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end;
              btResourcePointer:
                begin
                  for j := 0 to FRPSupFuncs.Count -1 do
                  begin
                    if PResourcePtrSupportFuncs(FRPSupFuncs[j]).PtrSupports(FRPSupFuncs[j], res) then
                    begin
                      if PResourcePtrSupportFuncs(FRPSupFuncs[j])^.ResultMethod = rmParam then
                      begin
                        GetPtr(res);
                        RealCall_cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
                      end else
                        PResourcePtrSupportFuncs(FRPSupFuncs[j])^.ResToPtr(PResourcePtrSupportFuncs(FRPSupFuncs[j]), SElf, RealCall_cdecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil), res);
                      break;
                    end;
                  end;
                end;
            else
              exit;
            end;
          end else begin
            RealCall_CDecl(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
          end;
          Result := True;
        end;
      CdStdCall: begin
          RegUsage := 3;
          if assigned(_Self) then begin
            Stack := #0#0#0#0;
            Pointer((@Stack[1])^) := _Self;
          end;
          for I := Params.Count - 1 downto 0 do begin
            if not GetPtr(Params[I]) then exit;
          end;
          if assigned(res) then begin
            case res^.FType^.BaseType of
              btSingle:      res^.tsingle := RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
              btDouble:      res^.tdouble:= RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
              btExtended:    res^.textended:= RealFloatCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4);
              btChar, btU8, btS8:    res^.tu8 := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 1, nil);
              {$IFNDEF IFPS3_NOWIDESTRING}btWideChar, {$ENDIF}btu16, bts16:  res^.tu16:= RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 2, nil);
              btu32, bts32:  res^.tu32:= RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil);
              btPChar:       TBTSTRING(res^.tstring) := Pchar(RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil));
              {$IFNDEF IFPS3_NOINT64}bts64:
                begin
                  EAX := RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, @EDX);
                  res^.ts64 := (EDX shl 32) or EAX;
                end;
              {$ENDIF}
              {$IFDEF IFPS3_HAVEVARIANT}btVariant, {$ENDIF}{$IFNDEF IFPS3_NOWIDESTRING}btWideString, {$ENDIF}
              btArray, btrecord, btstring:      begin GetPtr(res); RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil); end;
              btResourcePointer:
                begin
                  for j := 0 to FRPSupFuncs.Count -1 do
                  begin
                    if PResourcePtrSupportFuncs(FRPSupFuncs[j]).PtrSupports(FRPSupFuncs[j], res) then
                    begin
                      if PResourcePtrSupportFuncs(FRPSupFuncs[j])^.ResultMethod = rmParam then
                      begin
                        GetPtr(res);
                        RealCall_other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
                      end else
                        PResourcePtrSupportFuncs(FRPSupFuncs[j])^.ResToPtr(PResourcePtrSupportFuncs(FRPSupFuncs[j]), SElf, RealCall_other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 4, nil), res);
                      break;
                    end;
                  end;
                end;
            else
              exit;
            end;
          end else begin
            RealCall_Other(Address, @Stack[Length(Stack)-3], Length(Stack) div 4, 0, nil);
          end;
          Result := True;
        end;
    end;
  finally
    if res <> nil then
      res^.RefCount := res^.RefCount and not IFPSAddrStackStart;
    for i := CallData.Count -1 downto 0 do
    begin
      pp := CallData[i];
      case pp^ of
        0: DestroyOpenArray(Self, Pointer(pp));
        {$IFDEF IFPS3_HAVEVARIANT}1: DestroyDelphiVariant(Self, Pointer(pp)); {$ENDIF}
        2: DestroyRecord(Self, Pointer(pp));
        {$IFDEF IFPS3_DYNARRAY}3: DestroyDynamicArray(Self, Pointer(pp));{$ENDIF}
      end;
    end;
    CallData.Free;
  end;
end;

type
  PScriptMethodInfo = ^TScriptMethodInfo;
  TScriptMethodInfo = record
    Se: TIFPSExec;
    ProcNo: Cardinal;
  end;


function MkMethod(FSE: TIFPSExec; No: Cardinal): TMethod;
begin
  if no = 0 then
  begin
    Result.Code := nil;
    Result.Data := nil;
  end else begin
    Result.Code := @MyAllMethodsHandler;
    Result.Data := GetMethodInfoRec(FSE, No);
  end;
end;


procedure PFree(Sender: TIFPSExec; P: PScriptMethodInfo);
begin
  Dispose(p);
end;

function GetMethodInfoRec(SE: TIFPSExec; ProcNo: Cardinal): Pointer;
var
  I: Longint;
  pp: PScriptMethodInfo;
begin
  I := 0;
  repeat
    pp := Se.FindProcResource2(@PFree, I);
    if (i <> -1) and (pp^.ProcNo = ProcNo) then
    begin
      Result := Pp;
      exit;
    end;
  until i = -1;
  New(pp);
  pp^.Se := TIFPSExec(Se);
  pp^.ProcNo := Procno;
  Se.AddResource(@PFree, pp);
  Result := pp;
end;





type
  TPtrArr = array[0..1000] of Pointer;
  PPtrArr = ^TPtrArr;
  TByteArr = array[0..1000] of byte;
  PByteArr = ^TByteArr;
  PPointer = ^Pointer;


function VirtualMethodPtrToPtr(Ptr, FSelf: Pointer): Pointer;
begin
  Result := PPtrArr(PPointer(FSelf)^)^[Longint(Ptr)];
end;

function VirtualClassMethodPtrToPtr(Ptr, FSelf: Pointer): Pointer;
begin
  Result := PPtrArr(FSelf)^[Longint(Ptr)];
end;


procedure CheckPackagePtr(var P: PByteArr);
begin
  if (word((@p[0])^) = $25FF) and (word((@p[6])^)=$C08B)then
  begin
    p := PPointer((@p[2])^)^;
  end;
end;

function FindVirtualMethodPtr(Ret: TIFPSRuntimeClass; FClass: TClass; Ptr: Pointer): Pointer;
// Idea of getting the number of VMT items from GExperts
var
  p: PPtrArr;
  I: Longint;
begin
  p := Pointer(FClass);
  CheckPackagePtr(PByteArr(Ptr));
  if Ret.FEndOfVMT = MaxInt then
  begin
    I := {$IFDEF VER90}-48{$ELSE}vmtSelfPtr{$ENDIF} div SizeOf(Pointer) + 1;
    while I < 0 do
    begin
      if I < 0 then
      begin
        if I <> ({$IFDEF VER90}-44{$ELSE}vmtTypeInfo{$ENDIF} div SizeOf(Pointer)) then
        begin // from GExperts code
          if (Longint(p^[I]) > Longint(p)) and ((Longint(p^[I]) - Longint(p))
            div
            4 < Ret.FEndOfVMT) then
          begin
            Ret.FEndOfVMT := (Longint(p^[I]) - Longint(p)) div SizeOf(Pointer);
          end;
        end;
      end;
      Inc(I);
    end;
    if Ret.FEndOfVMT = MaxInt then
    begin
      Ret.FEndOfVMT := 0; // cound not find EndOfVMT
      Result := nil;
      exit;
    end;
  end;
  I := 0;
  while I < Ret.FEndOfVMT do
  begin
    if p^[I] = Ptr then
    begin
      Result := Pointer(I);
      exit;
    end;
    I := I + 1;
  end;
  Result := nil;
end;


type
  PClassItem = ^TClassItem;
  TClassItem = record
    FName: string;
    FNameHash: Longint;
    b: byte;
    case byte of
    0: (Ptr: Pointer); {Method}
    1: (PointerInList: Pointer); {Virtual Method}
    3: (FReadFunc, FWriteFunc: Pointer); {Property Helper}
    4: (Ptr2: Pointer); {Constructor}
    5: (PointerInList2: Pointer); {virtual constructor}
    6: (); {Property helper, like 3}
  end;


function ClassCallProcMethod(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
var
  i: Integer;
  MyList: TIfList;
  n: PIFVariant;
  FSelf: Pointer;
  CurrStack: Cardinal;
  cc: TIFPSCallingConvention;
  s: string;
  Tmp: TObject;
begin
  s := p^.ExportDecl;
  if length(S) < 2 then
  begin
    Result := False;
    exit;
  end;
  cc := TIFPSCallingConvention(s[1]);
  delete(s, 1, 1);
  if s[1] = #0 then
    n := rp(Stack[Stack.Count -1])
  else
    n := rp(Stack[Stack.Count -2]);
  if (n = nil) or (n^.Ftype^.BaseType <> btResourcePointer) or (@n^.FType^.ResFree <> @ClassResourceFree) or (n^.tresourcep1 = nil) then
  begin
    result := false;
    exit;
  end;
  FSelf := n^.tResourceP1;
  CurrStack := Stack.Count - Cardinal(length(s)) -1;
  if s[1] = #0 then inc(CurrStack);
  MyList := tIfList.Create;
  for i := 2 to length(s) do
  begin
    MyList.Add(nil);
  end;
  for i := length(s) downto 2 do
  begin
    n :=rp(Stack[CurrStack]);
    if s[i] <> #0 then
    begin
      n^.RefCount := n^.RefCount or IFPSAddrStackStart;
    end;
    MyList[i - 2] := n;
    inc(CurrStack);
  end;
  try
    if s[1] <> #0 then
    begin
      n := rp(Stack[CurrStack + 1]);
    end else n := nil;
    if p^.Ext2 = nil then
      Result := Caller.InnerfuseCall(FSelf, p^.Ext1, cc, MyList, n)
    else
      Result := Caller.InnerfuseCall(FSelf, VirtualMethodPtrToPtr(p^.Ext1, FSelf), cc, MyList, n);
  except
    {$IFDEF IFPS3_D6PLUS}
    Tmp := AcquireExceptionObject;
    {$ELSE}
    if RaiseList <> nil then
    begin
      Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
      PRaiseFrame(RaiseList)^.ExceptObject := nil;
    end else
      Tmp := nil;
    {$ENDIF}
    if tmp = nil then
      Caller.Cmd_Err(erCouldNotCallProc)
    else if Tmp is Exception then
      Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp)
    else
      Caller.Cmd_Err3(erCustomError, 'Could not call proc', tmp);
    Result := false;
  end;
  MyList.Free;
end;

const
  IntType: TIFTypeRec = (BaseType: btU32);
  IntVal: TIFVariant = (FType: @IntType; RefCount: 1; tu32: 1);


function ClassCallProcConstructor(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
var
  i, h: Longint;
  MyList: TIfList;
  n: PIFVariant;
  FSelf: Pointer;
  CurrStack: Cardinal;
  cc: TIFPSCallingConvention;
  s: string;
  FType: PIFTypeRec;
  x: TIFPSRuntimeClass;
  Tmp: TObject;
begin

  n := rp(Stack[Stack.Count -2]);
  if (n = nil) or (n^.Ftype^.BaseType <> btU32)  then
  begin
    result := false;
    exit;
  end;
  FType := Caller.GetTypeNo(N^.tu32);
  if (FType = nil)  then
  begin
    Result := False;
    exit;
  end;
  h := MakeHash(FType^.ExportName);
  FSelf := nil;
  for i := 0 to TIFPSRuntimeClassImporter(p^.Ext2).FClasses.Count -1 do
  begin
    x:= TIFPSRuntimeClassImporter(p^.Ext2).FClasses[i];
    if (x.FClassNameHash = h) and (x.FClassName = FType^.ExportName) then
    begin
      FSelf := x.FClass;
    end;
  end;
  if FSelf = nil then begin
    Result := False;
    exit;
  end;
  s := p^.ExportDecl;
  if length(S) < 2 then
  begin
    Result := False;
    exit;
  end;
  cc := TIFPSCallingConvention(s[1]);
  delete(s, 1, 1);
  CurrStack := Stack.Count - Cardinal(length(s)) -1;
  if s[1] = #0 then inc(CurrStack);
  MyList := tIfList.Create;
  MyList.Add(@IntVal);
  for i := 2 to length(s) do
  begin
    MyList.Add(nil);
  end;
  for i := length(s) downto 2 do
  begin
    n :=rp(Stack[CurrStack]);
    if s[i] <> #0 then
    begin
      n^.RefCount := n^.RefCount or IFPSAddrStackStart;
    end;
    MyList[i - 1] := n;
    inc(CurrStack);
  end;
  try
    if s[1] <> #0 then
    begin
      n := rp(Stack[CurrStack +1]);
    end else n := nil;
    Result := Caller.InnerfuseCall(FSelf, p^.Ext1, cc, MyList, n);
  except
    {$IFDEF IFPS3_D6PLUS}
    Tmp := AcquireExceptionObject;
    {$ELSE}
    if RaiseList <> nil then
    begin
      Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
      PRaiseFrame(RaiseList)^.ExceptObject := nil;
    end else
      Tmp := nil;
    {$ENDIF}
    if tmp = nil then
      Caller.Cmd_Err(erCouldNotCallProc)
    else if Tmp is Exception then
      Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp)
    else
      Caller.Cmd_Err3(erCustomError, 'Could not call proc', tmp);
    Result := false;
  end;
  MyList.Free;
end;
function ClassCallProcVirtualConstructor(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
var
  i, h: Longint;
  MyList: TIfList;
  n: PIFVariant;
  FSelf: Pointer;
  CurrStack: Cardinal;
  cc: TIFPSCallingConvention;
  s: string;
  FType: PIFTypeRec;
  x: TIFPSRuntimeClass;
  Tmp: TObject;
begin
  n := rp(Stack[Stack.Count -2]);
  if (n = nil) or (n^.Ftype^.BaseType <> btU32)  then
  begin
    result := false;
    exit;
  end;
  FType := Caller.GetTypeNo(N^.tu32);
  if (FType = nil)  then
  begin
    Result := False;
    exit;
  end;
  h := MakeHash(FType^.ExportName);
  FSelf := nil;
  for i := 0 to TIFPSRuntimeClassImporter(p^.Ext2).FClasses.Count -1 do
  begin
    x:= TIFPSRuntimeClassImporter(p^.Ext2).FClasses[i];
    if (x.FClassNameHash = h) and (x.FClassName = FType^.ExportName) then
    begin
      FSelf := x.FClass;
      Break;
    end;
  end;
  if FSelf = nil then begin
    Result := False;
    exit;
  end;
  s := p^.ExportDecl;
  if length(S) < 2 then
  begin
    Result := False;
    exit;
  end;
  cc := TIFPSCallingConvention(s[1]);
  delete(s, 1, 1);
  CurrStack := Stack.Count - Cardinal(length(s)) -1;
  if s[1] = #0 then inc(CurrStack);
  MyList := tIfList.Create;
  MyList.Add(@IntVal);
  for i := 2 to length(s) do
  begin
    MyList.Add(nil);
  end;
  for i := length(s) downto 2 do
  begin
    n :=rp(Stack[CurrStack]);
    if s[i] <> #0 then
    begin
      n^.RefCount := n^.RefCount or IFPSAddrStackStart;
    end;
    MyList[i - 1] := n;
    inc(CurrStack);
  end;
  try
    if s[1] <> #0 then
    begin
      n := rp(Stack[CurrStack + 1]);
    end else n := nil;
    Result := Caller.InnerfuseCall(FSelf, VirtualClassMethodPtrToPtr(p^.Ext1, FSelf), cc, MyList, n);
  except
    {$IFDEF IFPS3_D6PLUS}
    Tmp := AcquireExceptionObject;
    {$ELSE}
    if RaiseList <> nil then
    begin
      Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
      PRaiseFrame(RaiseList)^.ExceptObject := nil;
    end else
      Tmp := nil;
    {$ENDIF}
    if tmp = nil then
      Caller.Cmd_Err(erCouldNotCallProc)
    else if Tmp is Exception then
      Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp)
    else
      Caller.Cmd_Err3(erCustomError, 'Could not call proc', tmp);
    Result := false;
  end;
  MyList.Free;
end;

function CastProc(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
var
  TypeNo, InVar, ResVar: PIFVariant;
  FSelf: TClass;
  FType: PIFTypeRec;
  H, I: Longint;
  x: TIFPSRuntimeClass;
begin
  TypeNo := rp(Stack[Stack.Count-3]);
  InVar := rp(Stack[Stack.Count-2]);
  ResVar := rp(Stack[Stack.Count-1]);
  if (TypeNo = nil) or (InVar = nil) or (ResVar = nil) or (InVar^.FType^.BaseType <> btResourcePointer) or (ResVar^.FType^.BaseType <> btResourcePointer) or (TypeNo^.FType^.BaseType <> btu32) then
  begin
    Result := False;
    Exit;
  end;
  if InVar^.tResourceP1 = nil then
  begin
    ResVar^.tResourceP1 := nil;
    ResVar^.FType^.ResFree:= nil;
    result := True;
    exit;
  end;
  FType := Caller.GetTypeNo(TypeNo^.tu32);
  if (FType = nil)  then
  begin
    Result := False;
    exit;
  end;
  h := MakeHash(FType^.ExportName);
  FSelf := nil;
  for i := 0 to TIFPSRuntimeClassImporter(p^.Ext2).FClasses.Count -1 do
  begin
    x:= TIFPSRuntimeClassImporter(p^.Ext2).FClasses[i];
    if (x.FClassNameHash = h) and (x.FClassName = FType^.ExportName) then
    begin
      FSelf := x.FClass;
    end;
  end;
  if FSelf = nil then begin
    Result := False;
    exit;
  end;
  ResVar^.FType^.ResFree := ClassResourceFree;
  try
    resVar^.tResourceP1 := TObject(InVar^.tResourceP1) as FSelf;
  except
    Result := False;
    exit;
  end;
  result := True;
end;

function CompareProc(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
var
  p1, p2, pres: PIFVariant;
begin
  p1 := rp(Stack[Stack.Count -3]);
  p2 := rp(Stack[Stack.Count -2]);
  pres := rp(Stack[Stack.Count -1]);
  if (p1=nil) or (p2=nil) or (pres = nil) or (p1^.FType^.BaseType <> btResourcePointer) or (p2^.FType^.BaseType <> btResourcePointer) or (pres^.FType^.BaseType <> btu8) then
  begin
    Result := False;
    exit;
  end;
  if (p1^.tResourceP1 = p2^.tResourceP1) then
    pres^.tu32 := 1
  else
    pres^.tu32 := 0;
  Result := True;
end;

function NilProc(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
var
  n: PIFVariant;
begin
  n := rp(Stack[Stack.Count-1]);
  if (n = nil) or (n^.FType^.BaseType <> btResourcePointer) or (@n^.FType^.ResFree <> @ClassResourceFree) then
  begin
    Result := False;
    Exit;
  end;
  n^.tResourceP1 := nil;
  result := True;
end;


function getMethodNo(P: TMethod): Cardinal;
begin
  if (p.Code <> @MyAllMethodsHandler) or (p.Data = nil) then
    Result := 0
  else
  begin
    Result := PScriptMethodInfo(p.Data)^.ProcNo;
  end;
end;

function ClassCallProcProperty(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
var
  n: PIFVariant;
  ltemp: Longint;
  FSelf: Pointer;
  tmp: TObject;
begin
  try
    if p^.Ext2 = Pointer(0) then
    begin
      n := rp(Stack[Stack.Count -1]);
      if (n = nil) or (n^.Ftype^.BaseType <> btResourcePointer) or (@n^.FType^.ResFree <> @ClassResourceFree) then
      begin
        result := false;
        exit;
      end;
      FSelf := n^.tResourceP1;
      n := rp(Stack[Stack.Count -2]);
      if (PPropInfo(p^.Ext1)^.PropType^.Kind = tkMethod) and ((n^.FType^.BaseType = btu32) or (n^.FType^.BaseType = btProcPtr))then
      begin
        SetMethodProp(TObject(FSelf), PPropInfo(p^.Ext1), MkMethod(Caller, n^.tu32));
      end else
      case n^.FType^.BaseType of
        btSet:
          begin
            ltemp := Longint(n^.tset^);
            SetOrdProp(TObject(FSelf), PPropInfo(p^.Ext1), ltemp);
          end;
        btChar, btU8: SetOrdProp(TObject(FSelf), PPropInfo(p^.Ext1), n^.tu8);
        btS8: SetOrdProp(TObject(FSelf), PPropInfo(p^.Ext1), n^.ts8);
        {$IFNDEF IFPS3_NOWIDESTRING}btwidechar, {$ENDIF}btU16: SetOrdProp(TObject(FSelf), PPropInfo(p^.Ext1), n^.tu16);
        btS16: SetOrdProp(TObject(FSelf), PPropInfo(p^.Ext1), n^.ts16);
        btU32: SetOrdProp(TObject(FSelf), PPropInfo(p^.Ext1), n^.tu32);
        btS32: SetOrdProp(TObject(FSelf), PPropInfo(p^.Ext1), n^.ts32);
        btSingle: SetFloatProp(TObject(FSelf), p^.Ext1, n^.tsingle);
        btDouble: SetFloatProp(TObject(FSelf), p^.Ext1, n^.tdouble);
        btExtended: SetFloatProp(TObject(FSelf), p^.Ext1, Extended(n^.textended));
        btString: SetStrProp(TObject(FSelf), p^.Ext1, string(n^.tstring));
        btPChar: SetStrProp(TObject(FSelf), p^.Ext1, string(n^.tstring));
        btResourcePointer:
        begin
          if @n^.FType.ResFree = @ClassResourceFree then
            SetOrdProp(TObject(FSelf), p^.Ext1, Longint(n^.tResourceP1))
          else begin
            Result := False;
            exit;
          end;
        end;
        else
        begin
          Result := False;
          exit;
        end;
      end;
      Result := true;
    end else begin
      n := rp(Stack[Stack.Count -2]);
      if (n = nil) or (n^.Ftype^.BaseType <> btResourcePointer) or (@n^.FType.ResFree <> @ClassResourceFree) then
      begin
        result := false;
        exit;
      end;
      FSelf := n^.tResourceP1;
      n := rp(Stack[Stack.Count -1]);
      if (PPropInfo(p^.Ext1)^.PropType^.Kind = tkMethod) and ((n^.FType^.BaseType = btu32) or (n^.FType^.BaseType = btprocptr)) then
      begin
        n^.tu32 := GetMethodNo(GetMethodProp(TObject(FSelf), PPropInfo(p^.Ext1)));
      end else
      case n^.FType^.BaseType of
        btSet:
          begin
            ltemp := GetOrdProp(TObject(FSelf), PPropInfo(p^.Ext1));
            if length(tbtstring(n^.tset)) <= 4 then
              Move(ltemp, tbtstring(n^.tset)[1], length(tbtstring(n^.tset)))
            else
              Move(ltemp, tbtstring(n^.tset)[1], 4)
          end;
        btU8: n^.tu8 := GetOrdProp(TObject(FSelf), p^.Ext1);
        btS8: n^.tS8 := GetOrdProp(TObject(FSelf), p^.Ext1);
        btU16: n^.tu16 := GetOrdProp(TObject(FSelf), p^.Ext1);
        btS16: n^.tS16 := GetOrdProp(TObject(FSelf), p^.Ext1);
        btU32: n^.tu32 := GetOrdProp(TObject(FSelf), p^.Ext1);
        btS32: n^.tS32 := GetOrdProp(TObject(FSelf), p^.Ext1);
        btSingle: n^.tsingle := GetFloatProp(TObject(FSelf), p^.Ext1);
        btDouble: n^.tdouble := GetFloatProp(TObject(FSelf), p^.Ext1);
        btExtended: n^.textended := GetFloatProp(TObject(FSelf), p^.Ext1);
        btString: string(n^.tstring) := GetStrProp(TObject(FSelf), p^.Ext1);
        btPChar: string(n^.tstring) := GetStrProp(TObject(FSelf), p^.Ext1);
        btResourcePointer:
        begin
          n^.tResourceP1 := Pointer(GetOrdProp(TObject(FSelf), p^.Ext1));
        end;
      else
        begin
          Result := False;
          exit;
        end;

      end;
      Result := True;
    end;
  except
    {$IFDEF IFPS3_D6PLUS}
    Tmp := AcquireExceptionObject;
    {$ELSE}
    if RaiseList <> nil then
    begin
      Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
      PRaiseFrame(RaiseList)^.ExceptObject := nil;
    end else
      Tmp := nil;
    {$ENDIF}
    if tmp = nil then
      Caller.Cmd_Err(erCouldNotCallProc)
    else if Tmp is Exception then
      Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp)
    else
      Caller.Cmd_Err3(erCustomError, 'Could not call proc', tmp);
    Result := False;
  end;
end;

function ClassCallProcPropertyHelper(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
var
  I, ParamCount: Longint;
  Params: TIfList;
  n: PIfVariant;
  FSelf: Pointer;
  Tmp: TObject;
begin
  if Length(P^.ExportDecl) < 4 then begin
    Result := False;
    exit;
  end;
  ParamCount := Longint((@P^.ExportDecl[1])^);
  if Longint(Stack.Count) < ParamCount +1 then begin
    Result := False;
    exit;
  end;
  Dec(ParamCount);
  if p^.Ext1 <> nil then // read
  begin
    n := rp(Stack[Longint(Stack.Count) - 2]);
    if (n = nil) or (n^.Ftype^.BaseType <> btResourcePointer) or (@n^.FType.ResFree <> @ClassResourceFree) then
    begin
      result := false;
      exit;
    end;
    FSelf := n^.tResourceP1;
    Params := TIfList.Create;
    n := rp(Stack[Longint(Stack.Count) - 1]); // Result
    n^.RefCount := n^.RefCount or IFPSAddrStackStart;
    Params.Add(n);
    for i := Stack.Count -3 downto Longint(Stack.Count) - ParamCount -2 do
    begin
      n := rp(Stack[I]);
      Params.Add(n);
    end;
    try
      Result := Caller.InnerfuseCall(FSelf, p^.Ext1, cdRegister, Params, nil);
    except
      {$IFDEF IFPS3_D6PLUS}
      Tmp := AcquireExceptionObject;
      {$ELSE}
      if RaiseList <> nil then
      begin
        Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
        PRaiseFrame(RaiseList)^.ExceptObject := nil;
      end else
        Tmp := nil;
      {$ENDIF}
      if tmp = nil then
        Caller.Cmd_Err(erCouldNotCallProc)
      else if Tmp is Exception then
        Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp)
      else
        Caller.Cmd_Err3(erCustomError, 'Could not call proc', tmp);
      Result := false;
    end;
    Params.Free;
  end else begin
    n := rp(Stack[Stack.Count -1]);
    if (n = nil) or (n^.Ftype^.BaseType <> btResourcePointer) or (@n^.FType.ResFree <> @ClassResourceFree) then
    begin
      result := false;
      exit;
    end;
    FSelf := n^.tResourceP1;
    Params := TIfList.Create;
    Params.Add(rp(Stack[Longint(Stack.Count) - ParamCount - 2]));

    for i := Stack.Count -2 downto Longint(Stack.Count) - ParamCount -1 do
    begin
      Params.Add(rp(Stack[I]));
    end;
    try
      Result := Caller.InnerfuseCall(FSelf, p^.Ext2, cdregister, Params, nil);
    except
      {$IFDEF IFPS3_D6PLUS}
      Tmp := AcquireExceptionObject;
      {$ELSE}
      if RaiseList <> nil then
      begin
        Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
        PRaiseFrame(RaiseList)^.ExceptObject := nil;
      end else
        Tmp := nil;
      {$ENDIF}
      if tmp = nil then
        Caller.Cmd_Err(erCouldNotCallProc)
      else if Tmp is Exception then
        Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp)
      else
        Caller.Cmd_Err3(erCustomError, 'Could not call proc', tmp);
      Result := false;
    end;
    Params.Free;
  end;
end;


const
  TMethodType: TIFTypeRec = (BaseType: btDouble;Ext: nil);


function ClassCallProcEventPropertyHelper(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
{Event property helper}
var
  I, ParamCount: Longint;
  Params: TIfList;
  n, n2: PIfVariant;
  FSelf: Pointer;
  Tmp: TObject;
begin
  if Length(P^.ExportDecl) < 4 then begin
    Result := False;
    exit;
  end;
  ParamCount := Longint((@P^.ExportDecl[1])^);
  if Longint(Stack.Count) < ParamCount +1 then begin
    Result := False;
    exit;
  end;
  Dec(ParamCount);
  if p^.Ext1 <> nil then // read
  begin
    n := rp(Stack[Longint(Stack.Count) - 2]);
    if (n = nil) or (n^.Ftype^.BaseType <> btResourcePointer) or (@n^.FType.ResFree <> @ClassResourceFree) then
    begin
      result := false;
      exit;
    end;
    FSelf := n^.tResourceP1;
    n := rp(Stack[Longint(Stack.Count) - 1]); // Result
    if n^.FType^.BaseType <> btU32 then
    begin
      Result := False;
      exit;
    end;
    Params := TIfList.Create;
    new(n2);
    n2^.FType := @TMethodType;
    n2^.RefCount := 1 + IFPSAddrStackStart;
    TMethod(n2^.tdouble).Code := nil;
    TMethod(n2^.tdouble).Data := nil;
    Params.Add(n2);
    for i := Stack.Count -3 downto Longint(Stack.Count) - ParamCount -2 do
    begin
      n := rp(Stack[I]);
      Params.Add(n);
    end;
    try
      Result := Caller.InnerfuseCall(FSelf, p^.Ext1, cdRegister, Params, nil);
    except
      {$IFDEF IFPS3_D6PLUS}
      Tmp := AcquireExceptionObject;
      {$ELSE}
      if RaiseList <> nil then
      begin
        Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
        PRaiseFrame(RaiseList)^.ExceptObject := nil;
      end else
        Tmp := nil;
      {$ENDIF}
      if tmp = nil then
        Caller.Cmd_Err(erCouldNotCallProc)
      else if Tmp is Exception then
        Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp)
      else
        Caller.Cmd_Err3(erCustomError, 'Could not call proc', tmp);
      Result := false;
    end;
    n^.tu32 := getMethodNo(TMethod(n2^.tdouble));
    Params.Free;
  end else begin
    n := rp(Stack[Stack.Count -1]);
    if (n = nil) or (n^.Ftype^.BaseType <> btResourcePointer) or (@n^.FType.ResFree <> @ClassResourceFree) then
    begin
      result := false;
      exit;
    end;
    FSelf := n^.tResourceP1;
    n := rp(Stack[Longint(Stack.Count) - ParamCount - 2]);
    if (n^.FType^.BaseType <> btu32) and (n^.FType^.BaseType <> btProcPtr) then
    begin
      result := false;
      exit;
    end;
    new(n2);
    n2^.FType := @TMethodType;
    n2^.RefCount := 1;
    TMethod(n2^.tdouble) := MkMethod(Caller, n^.tu32);
    Params := TIfList.Create;
    Params.Add(n2);

    for i := Stack.Count -2 downto Longint(Stack.Count) - ParamCount -1 do
    begin
      Params.Add(rp(Stack[I]));
    end;
    try
      Result := Caller.InnerfuseCall(FSelf, p^.Ext2, cdregister, Params, nil);
    except
      {$IFDEF IFPS3_D6PLUS}
      Tmp := AcquireExceptionObject;
      {$ELSE}
      if RaiseList <> nil then
      begin
        Tmp := Exception(PRaiseFrame(RaiseList)^.ExceptObject);
        PRaiseFrame(RaiseList)^.ExceptObject := nil;
      end else
        Tmp := nil;
      {$ENDIF}
      if tmp = nil then
        Caller.Cmd_Err(erCouldNotCallProc)
      else if Tmp is Exception then
        Caller.CMD_Err3(erCustomError, (tmp as Exception).Message, tmp)
      else
        Caller.Cmd_Err3(erCustomError, 'Could not call proc', tmp);
      Result := false;
    end;
    Dispose(n2);
    Params.Free;
  end;
end;


{'class:'+CLASSNAME+'|'+FUNCNAME+'|'+chr(CallingConv)+chr(hasresult)+params

For property write functions there is an '@' after the funcname.
}
function SpecImport(Sender: TIFPSExec; p: PIFProcRec; Tag: Pointer): Boolean;
var
  H, I: Longint;
  S, s2: string;
  CL: TIFPSRuntimeClass;
  Px: PClassItem;
  pp: PPropInfo;
  IsRead: Boolean;
begin
  s := p^.ExportDecl;
  delete(s, 1, 6);
  if s = '-' then {nil function}
  begin
    p^.ProcPtr := NilProc;
    Result := True;
    exit;
  end;
  if s = '+' then {cast function}
  begin
    p^.ProcPtr := CastProc;
    p^.Ext2 := Tag;
    Result := True;
    exit;
  end;
  if s = '*' then {compare function}
  begin
    p^.ProcPtr := CompareProc;
    p^.Ext2 := Tag;
    Result := True;
    exit;
  end;
  s2 := copy(S, 1, pos('|', s)-1);
  delete(s, 1, length(s2) + 1);
  H := MakeHash(s2);
  ISRead := False;
  cl := nil;
  for I := TIFPSRuntimeClassImporter(Tag).FClasses.Count -1 downto 0 do
  begin
    Cl := TIFPSRuntimeClassImporter(Tag).FClasses[I];
    if (Cl.FClassNameHash = h) and (cl.FClassName = s2) then
    begin
      IsRead := True;
      break;
    end;
  end;
  if not isRead then begin
    Result := False;
    exit;                 
  end;
  s2 := copy(S, 1, pos('|', s)-1);
  delete(s, 1, length(s2) + 1);
  if (s2 <> '') and (s2[length(s2)] = '@') then
  begin
    IsRead := False;
    Delete(S2, length(s2), 1);
  end else
    isRead := True;
  H := MakeHash(s2);
  for i := cl.FClassItems.Count -1 downto 0 do
  begin
    px := cl.FClassItems[I];
    if (px^.FNameHash = h) and (px^.FName = s2) then
    begin
      p^.ExportDecl := s;
      case px^.b of
  {0: ext1=ptr}
  {1: ext1=pointerinlist}
  {2: ext1=propertyinfo}
  {3: ext1=readfunc; ext2=writefunc}
        4:
          begin
            p^.ProcPtr := ClassCallProcConstructor;
            p^.Ext1 := px^.Ptr;
            p^.Ext2 := Tag;
          end;
        5:
          begin
            p^.ProcPtr := ClassCallProcVirtualConstructor;
            p^.Ext1 := px^.Ptr;
            p^.Ext2 := Tag;
          end;
        6:
          begin
            p^.ProcPtr := ClassCallProcEventPropertyHelper;
            if IsRead then
            begin
              p^.Ext1 := px^.FReadFunc;
              p^.Ext2 := nil;
            end else
            begin
              p^.Ext1 := nil;
              p^.Ext2 := px^.FWriteFunc;
            end;
          end;
        0:
          begin
            p^.ProcPtr := ClassCallProcMethod;
            p^.Ext1 := px^.Ptr;
            p^.Ext2 := nil;
          end;
        1:
          begin
            p^.ProcPtr := ClassCallProcMethod;
            p^.Ext1 := px^.PointerInList;
            p^.ext2 := pointer(1);
          end;
        3:
          begin
            p^.ProcPtr := ClassCallProcPropertyHelper;
            if IsRead then
            begin
              p^.Ext1 := px^.FReadFunc;
              p^.Ext2 := nil;
            end else
            begin
              p^.Ext1 := nil;
              p^.Ext2 := px^.FWriteFunc;
            end;
          end;
        else
         begin
           result := false;
           exit;
         end;
      end;
      Result := true;
      exit;
    end;
  end;
  pp := GetPropInfo(cl.FClass.ClassInfo, s2);
  if pp <> nil then
  begin
     p^.ProcPtr := ClassCallProcProperty;
     p^.Ext1 := pp;
     if IsRead then
       p^.Ext2 := Pointer(1)
     else
       p^.Ext2 := Pointer(0);
     Result := True;
  end else
    result := false;
end;

procedure RegisterClassLibraryRuntime(SE: TIFPSExec; Importer: TIFPSRuntimeClassImporter);
begin
  SE.AddSpecialProcImport('class', SpecImport, Importer);
end;

procedure TIFPSExec.RegisterRProcSupFuncs(P: PResourcePtrSupportFuncs);
begin
  FRPSupFuncs.Add(p);
end;

procedure TIFPSExec.ClearspecialProcImports;
var
  I: Longint;
  P: PSpecialProc;
begin
  for I := FSpecialProcList.Count -1 downto 0 do
  begin
    P := FSpecialProcList[I];
    Dispose(p);
  end;
  FSpecialProcList.Clear;
end;

procedure TIFPSExec.RegisterResourceType(const Name: string;
  FreeProc: TVariantResourceFreeProc);
var
  n: PResType;
begin
  New(n);
  n^.Name := Name;
  n^.Nhash := MakeHash(Name);
  N^.Proc := freeproc;
  FResourceTypes.Add(n);
end;

procedure TIFPSExec.RaiseCurrentException;
var
  ExObj: TObject;
begin
  if ExEx = erNoError then exit; // do nothing
  ExObj := Self.ExObject;
  if ExObj <> nil then
  begin
    Self.ExObject := nil;
    raise ExObj;
  end;
  raise EIFPS3Exception.Create(TIFErrorToString(ExceptionCode, ExceptionString), Self, ExProc, ExPos);
end;

procedure TIFPSExec.CMD_Err2(EC: TIFError; const Param: string);
begin
  CMD_Err3(EC, Param, Nil);
end;

function TIFPSExec.CreateObjectVariant(FType: PIFTypeRec;
  Value: TObject): PIfVariant;
begin
  Result := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}MemoryManager, {$ENDIf}FType);
  if Result <> nil then
    Result^.tResourceP1 := Value;
end;

{ TIFPSRuntimeClass }

constructor TIFPSRuntimeClass.Create(aClass: TClass; const AName: string);
begin
  inherited Create;
  FClass := AClass;
  if AName = '' then
  begin
    FClassName := FastUpperCase(aClass.ClassName);
    FClassNameHash := MakeHash(FClassName);
  end else begin
    FClassName := FastUppercase(AName);
    FClassNameHash := MakeHash(AName);
  end;
  FClassItems:= TIfList.Create;
  FEndOfVmt := MaxInt;
end;

destructor TIFPSRuntimeClass.Destroy;
var
  I: Longint;
  P: PClassItem;
begin
  for i:= FClassItems.Count -1 downto 0 do
  begin
    P := FClassItems[I];
    Dispose(p);
  end;
  FClassItems.Free;
  inherited Destroy;
end;

procedure TIFPSRuntimeClass.RegisterVirtualAbstractMethod(ClassDef: TClass;
  ProcPtr: Pointer; const Name: string);
var
  P: PClassItem;
begin
  New(P);
  p^.FName := Name;
  p^.FNameHash := MakeHash(Name);
  p^.b := 1;
  p^.PointerInList := FindVirtualMethodPtr(Self, ClassDef, ProcPtr);
  FClassItems.Add(p);
end;

procedure TIFPSRuntimeClass.RegisterConstructor(ProcPtr: Pointer;
  const Name: string);
var
  P: PClassItem;
begin
  New(P);
  p^.FName := FastUppercase(Name);
  p^.FNameHash := MakeHash(p^.FName);
  p^.b := 4;
  p^.Ptr := ProcPtr;
  FClassItems.Add(p);
end;

procedure TIFPSRuntimeClass.RegisterMethod(ProcPtr: Pointer; const Name: string);
var
  P: PClassItem;
begin
  New(P);
  p^.FName := FastUppercase(Name);
  p^.FNameHash := MakeHash(p^.FName);
  p^.b := 0;
  p^.Ptr := ProcPtr;
  FClassItems.Add(p);
end;


procedure TIFPSRuntimeClass.RegisterPropertyHelper(ReadFunc,
  WriteFunc: Pointer; const Name: string);
var
  P: PClassItem;
begin
  New(P);
  p^.FName := FastUppercase(Name);
  p^.FNameHash := MakeHash(p^.FName);
  p^.b := 3;
  p^.FReadFunc := ReadFunc;
  p^.FWriteFunc := WriteFunc;
  FClassItems.Add(p);
end;

procedure TIFPSRuntimeClass.RegisterVirtualConstructor(ProcPtr: Pointer;
  const Name: string);
var
  P: PClassItem;
begin
  New(P);
  p^.FName := FastUppercase(Name);
  p^.FNameHash := MakeHash(p^.FName);
  p^.b := 5;
  p^.PointerInList := FindVirtualMethodPtr(Self, FClass, ProcPtr);
  FClassItems.Add(p);
end;

procedure TIFPSRuntimeClass.RegisterVirtualMethod(ProcPtr: Pointer; const Name: string);
var
  P: PClassItem;
begin
  New(P);
  p^.FName := FastUppercase(Name);
  p^.FNameHash := MakeHash(p^.FName);
  p^.b := 1;
  p^.PointerInList := FindVirtualMethodPtr(Self, FClass, ProcPtr);
  FClassItems.Add(p);
end;

procedure TIFPSRuntimeClass.RegisterEventPropertyHelper(ReadFunc,
  WriteFunc: Pointer; const Name: string);
var
  P: PClassItem;
begin
  New(P);
  p^.FName := FastUppercase(Name);
  p^.FNameHash := MakeHash(p^.FName);
  p^.b := 6;
  p^.FReadFunc := ReadFunc;
  p^.FWriteFunc := WriteFunc;
  FClassItems.Add(p);
end;


{ TIFPSRuntimeClassImporter }

function TIFPSRuntimeClassImporter.Add(aClass: TClass): TIFPSRuntimeClass;
begin
  Result := FindClass(FastUppercase(aClass.ClassName));
  if Result <> nil then exit;
  Result := TIFPSRuntimeClass.Create(aClass, '');
  FClasses.Add(Result);
end;

function TIFPSRuntimeClassImporter.Add2(aClass: TClass;
  const Name: string): TIFPSRuntimeClass;
begin
  Result := FindClass(Name);
  if Result <> nil then exit;
  Result := TIFPSRuntimeClass.Create(aClass, Name);
  FClasses.Add(Result);
end;

procedure TIFPSRuntimeClassImporter.Clear;
var
  I: Longint;
begin
  for i := 0 to FClasses.Count -1 do
  begin
    TIFPSRuntimeClass(FClasses[I]).Free;
  end;
  FClasses.Clear;
end;

constructor TIFPSRuntimeClassImporter.Create;
begin
  inherited Create;
  FClasses := TIfList.Create;

end;

constructor TIFPSRuntimeClassImporter.CreateAndRegister(Exec: TIFPSexec;
  AutoFree: Boolean);
begin
  inherited Create;
  FClasses := TIfList.Create;
  RegisterClassLibraryRuntime(Exec, Self);
  if AutoFree then
    Exec.AddResource(@RCIFreeProc, Self);
end;

destructor TIFPSRuntimeClassImporter.Destroy;
begin
  Clear;
  FClasses.Free;
  inherited Destroy;
end;

procedure SetVariantToClass(V: PIFVariant; Cl: TObject);
begin
  if v <> nil then
  begin
    if (@v^.FType.ResFree <> nil) then
      v^.FType.ResFree(vrfFree, v, nil);
    v^.tResourceP1 := cl;
  end;
end;

function BGRFW(var s: string): string;
var
  l: Longint;
begin
  l := Length(s);
  while l >0 do
  begin
    if s[l] = ' ' then
    begin
      Result := copy(s, l + 1, Length(s) - l);
      Delete(s, l, Length(s) - l + 1);
      exit;
    end;
    Dec(l);
  end;
  Result := s;
  s := '';
end;



function MyAllMethodsHandler2(Self: PScriptMethodInfo; const Stack: PPointer; _EDX, _ECX: Pointer): Integer; forward;

procedure MyAllMethodsHandler;
//  On entry:
//     EAX = Self pointer
//     EDX, ECX = param1 and param2
//     STACK = param3... paramcount
asm
  push 0
  push ecx
  push edx
  mov edx, esp
  add edx, 16 // was 12
  pop ecx
  call MyAllMethodsHandler2
  pop ecx
  mov edx, [esp]
  add esp, eax
  mov [esp], edx
  mov eax, ecx
end;

function MyAllMethodsHandler2(Self: PScriptMethodInfo; const Stack: PPointer; _EDX, _ECX: Pointer): Integer;
var
  Decl: string;
  I, C, regno: Integer;
  Params: TIfList;
//  VarParams: TIfList;
  Res, Tmp: PIFVariant;
  cpt: PIFTypeRec;
  fmod: char;
  s,e: string;
  FStack: pointer;
begin
  Decl := PIFProcRec(Self^.Se.FProcs[Self^.ProcNo])^.ExportDecl;

  FStack := Stack;
  Params := TIfList.Create;
//  VarParams := TIfList.Create;
  s := decl;
  grfw(s);
  while s <> '' do
  begin
    Params.Add(nil);
    grfw(s);
  end;
  c := Params.Count;
  regno := 0;
  I := C -1 ;
  Result := 0;
  s := decl;
  grfw(s);
  while I >= 0 do
  begin
    e := grfw(s);
    fmod := e[1];
    delete(e, 1, 1);
    cpt := Self.Se.GetTypeNo(StrToInt(e));
    if fmod = '!' then
    begin
      case cpt.BaseType of
        {$IFDEF IFPS3_HAVEVARIANT}
        btVariant:
          begin
            Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
            if regno = 0 then
            begin
              VariantToPIFVariant(Self.SE, Variant(Pointer(_EDX)^), Tmp);
              Inc(regno);
            end
            else if regno = 1 then
            begin
              VariantToPIFVariant(Self.SE, Variant(Pointer(_ECX)^), Tmp);
              Inc(regno);
            end;
            Params[I] := Tmp;
          end;
        {$ENDIF}
        btResourcePointer:
          begin
            Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
            if regno = 0 then
            begin
              Inc(regno);
              Tmp^.tResourceP1:= Pointer(Pointer(_EDX)^);
              tmp^.FType.ResFree := ClassResourceFree;

            end
            else if regno = 1 then
            begin
              Inc(regno);
              Tmp^.tResourceP1:= Pointer(Pointer(_ECX)^);
              tmp^.FType.ResFree := ClassResourceFree;
            end;
//            VarParams.Add(tmp);
            Params[I] := Tmp;
          end;
        btSet:
          begin
            Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
            if regno = 0 then
            begin
              Inc(regno);
              Move(Pointer(_EDX)^, tmp^.tset^, PIFSetTypeInfo(tmp^.FType.Ext).aByteSize);
            end
            else if regno = 1 then
            begin
              Inc(regno);
              Move(Pointer(_ECX)^, tmp^.tset^, PIFSetTypeInfo(tmp^.FType.Ext).aByteSize);
            end;
            Params[I] := Tmp;
          end;
        btString, btPChar:
          begin
            Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
            if regno = 0 then
            begin
              Inc(regno);
              string(Tmp^.tString):= string(Pointer(_EDX)^);
            end
            else if regno = 1 then
            begin
              Inc(regno);
              string(Tmp^.tstring):= string(Pointer(_ECX)^);
            end;
//            VarParams.Add(tmp);
            Params[I] := Tmp;
          end;
        btDouble{$IFNDEF IFPS3_NOINT64}, btS64{$ENDIF}:
          begin
            Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
            if regno = 0 then
            begin
              Inc(regno);
              Move(Pointer(_EDX)^, tmp^.tDouble, 8);
            end
            else if regno = 1 then
            begin
              Inc(regno);
              Move(Pointer(_ECX)^, tmp^.tDouble, 8);
            end;
//            VarParams.Add(tmp);
            Params[I] := Tmp;
          end;
        btExtended:
          begin
            Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
            if regno = 0 then
            begin
              Inc(regno);
              Move(Pointer(_EDX)^, tmp^.textended, 10);
            end
            else if regno = 1 then
            begin
              Inc(regno);
              Move(Pointer(_ECX)^, tmp^.textended, 10);
            end;
//            VarParams.Add(tmp);
            Params[I] := Tmp;
          end;
        btSingle,
          btChar,
          {$IFNDEF IFPS3_NOWIDESTRING}btWidechar, {$ENDIF}
          btU8,
          btS8,
          Btu16,
          bts16,
          btu32,
          bts32:
          begin
            Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
            if regno = 0 then
            begin
              Inc(regno);
              Tmp^.ts32 := Longint(Pointer(_EDX)^);
            end
            else if regno = 1 then
            begin
              Inc(regno);
              Tmp^.ts32:= Longint(Pointer(_ECX)^);
            end;
//            VarParams.Add(tmp);
            Params[I] := Tmp;
          end;
      else
        begin
          FreePIFVariantList({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF} Params);
          exit;
//          FreePIFVariantList({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF} VarParams);
        end;
      end;
    end
    else
    begin
      case cpt.BaseType of
        {$IFDEF IFPS3_HAVEVARIANT}
        btVariant:
          begin
            Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
            if regno = 0 then
            begin
              VariantToPIFVariant(Self.SE, Variant(Pointer(_EDX)^), Tmp);
              Inc(regno);
            end
            else if regno = 1 then
            begin
              VariantToPIFVariant(Self.SE, Variant(Pointer(_ECX)^), Tmp);
              Inc(regno);
            end;
            Params[I] := Tmp;
          end;
        {$ENDIF}
        btResourcePointer:
          begin
            Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);;
            if regno = 0 then
            begin
              Inc(regno);
              Tmp^.tResourceP1 := _EDX;
            end
            else if regno = 1 then
            begin
              Inc(regno);
              Tmp^.tResourceP1 := _ECX;
            end;
            Params[I] := Tmp;
          end;

        btSet:
          begin
            Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
            if regno = 0 then
            begin
              Inc(regno);
              if PIFSetTypeInfo(tmp^.FType.Ext).aByteSize <=4 then
                Move(_EDX, tmp^.tset^, PIFSetTypeInfo(tmp^.FType.Ext).aByteSize)
              else
              Move(Pointer(_EDX)^, tmp^.tset^, PIFSetTypeInfo(tmp^.FType.Ext).aByteSize);
            end
            else if regno = 1 then
            begin
              Inc(regno);
              if PIFSetTypeInfo(tmp^.FType.Ext).aByteSize <=4 then
                Move(_ECX, tmp^.tset^, PIFSetTypeInfo(tmp^.FType.Ext).aByteSize)
              else
                Move(Pointer(_ECX)^, tmp^.tset^, PIFSetTypeInfo(tmp^.FType.Ext).aByteSize);
            end;
            Params[I] := Tmp;
          end;
        btString:
          begin
            Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
            if regno = 0 then
            begin
              Inc(regno);
              string(Tmp^.tstring) := string(_EDX);
            end
            else if regno = 1 then
            begin
              Inc(regno);
              string(Tmp^.tstring) := string(_ECX);
            end;
            Params[I] := Tmp;
          end;
          btChar,
          {$IFNDEF IFPS3_NOWIDESTRING}btWidechar, {$ENDIF}
          btU8,
          btS8,
          Btu16,
          bts16,
          btu32,
          bts32:
          begin
            Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
            if regno = 0 then
            begin
              Inc(regno);
              Tmp^.ts32 := Longint(_EDX);
            end
            else if regno = 1 then
            begin
              Inc(regno);
              Tmp^.ts32 := Longint(_ECX);
            end;
            Params[I] := Tmp;
          end;
      end;
    end;
    dec(i);
    if regno = 2 then
      break;
  end;
  s := decl;
  grfw(s);
  for I := 0 to C-1 do
  begin
    e := BGRFW(s);
    if Params[I] = nil then
    begin
      fmod := e[1];
      Delete(e, 1, 1);
      cpt := Self.Se.GetTypeNo(StrToInt(e));
      if fmod = '!' then
      begin
        case cpt.BaseType of
          {$IFDEF IFPS3_HAVEVARIANT}
          btVariant:
            begin
              Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
              VariantToPIFVariant(Self.SE, Variant(Pointer(FStack^)^), Tmp);
              FStack := Pointer(Longint(FStack) + 4);
              Inc(Result, 4);
              Params[I] := Tmp;
            end;
          {$ENDIF}
          btResourcePointer:
            begin
              Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
              Tmp^.tResourceP1 := Pointer(Pointer(FStack^)^);
              FStack := Pointer(Longint(FStack) + 4);
              Inc(Result, 4);
//              VarParams.Add(Tmp);
              Params[I] := Tmp;
            end;
          btString:
            begin
              Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
              String(Tmp^.tstring) := string(FStack^);
              FStack := Pointer(Pointer(Longint(FStack) + 4)^);
              Inc(Result, 4);
//              VarParams.Add(Tmp);
              Params[I] := Tmp;
            end;
          btSet:
            begin
              Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
              FStack := Pointer(Longint(FStack) + 4);
              Move(Pointer(FStack^)^, tmp^.tset^, PIFSetTypeInfo(tmp^.FType.Ext).aByteSize);
              Inc(Result, 4);
              Params[I] := Tmp;
            end;
          btDouble{$IFNDEF IFPS3_NOINT64}, bts64{$ENDIF}:
            begin
              Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
              Move(Pointer(FStack^)^, Tmp^.tDouble, 8);
              FStack := Pointer(Longint(FStack) + 4);
              Inc(Result, 4);
//              VarParams.Add(Tmp);
              Params[I] := Tmp;
            end;
          btExtended:
            begin
              Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
              Move(Pointer(FStack^)^, Tmp^.tExtended, 10);
              FStack := Pointer(Longint(FStack) + 4);
              Inc(Result, 4);
//              VarParams.Add(Tmp);
              Params[I] := Tmp;
            end;
          btSingle,
          btChar,
          {$IFNDEF IFPS3_NOWIDESTRING}btWidechar, {$ENDIF}
          btS8,
          btu8,
          bts16,
          btu16,
          bts32,
          btu32:
            begin
              Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
              Move(Pointer(FStack^)^, Tmp^.ts32, 4);
              FStack := Pointer(Longint(FStack) + 4);
              Inc(Result, 4);
              Params[I] := Tmp;
            end;
        else
          begin
            FreePIFVariantList({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}Params);
            exit;
          end;
        end;
      end
      else
      begin
        case cpt.BaseType of
          {$IFDEF IFPS3_HAVEVARIANT}
          btVariant:
            begin
              Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
              VariantToPIFVariant(Self.SE, Variant(Pointer(FStack^)^), Tmp);
              FStack := Pointer(Longint(FStack) + 4);
              Inc(Result, 4);
              Params[I] := Tmp;
            end;
          {$ENDIF}
          btResourcePointer:
            begin
              Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
              tmp^.tResourceP1 := Pointer(FStack^);
              FStack := Pointer(Longint(FStack) + 4);
              Inc(Result, 4);
              Params[I] := Tmp;
            end;
          btString:
            begin
              Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
              string(Tmp^.tstring):= string(FStack^);
              FStack := Pointer(Longint(FStack) + 4);
              Inc(Result, 4);
              Params[I] := Tmp;
            end;
          btSet:
            begin
              Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
              FStack := Pointer(Longint(FStack) + 4);
              if PIFSetTypeInfo(tmp^.FType.Ext).aByteSize <=4 then
                Move(FStack^, tmp^.tset^, PIFSetTypeInfo(tmp^.FType.Ext).aByteSize)
              else
                Move(Pointer(FStack^)^, tmp^.tset^, PIFSetTypeInfo(tmp^.FType.Ext).aByteSize);
              Inc(Result, 4);
              Params[I] := Tmp;
            end;
          btDouble{$IFNDEF IFPS3_NOINT64}, bts64{$ENDIF}:
            begin
              Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
              Move(FStack^, Tmp^.tDouble, 8);
              FStack := Pointer(Longint(FStack) + 8);
              Inc(Result, 8);
              Params[I] := Tmp;
            end;
          btExtended:
            begin
              Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
              Move(FStack^, Tmp^.tExtended, 10);
              FStack := Pointer(Longint(FStack) + 12);
              Inc(Result, 12);
              Params[I] := Tmp;
            end;
          btSingle,
          btChar,
          {$IFNDEF IFPS3_NOWIDESTRING}btWidechar, {$ENDIF}
          bts8,
          btu8,
          bts16,
          btu16,
          bts32,
          btu32:
            begin
              Tmp := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
              Tmp^.ts32 := Longint(FStack^);
              Params[I] := Tmp;
              FStack := Pointer(Longint(FStack) + 4);
              Inc(Result, 4);
            end;
        else
          begin
            FreePIFVariantList({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}Params);
//            VarParams.Free;
            exit;
          end;
        end;
      end;
    end;
  end;
  s := decl;
  e := grfw(s);

  if e <> '-1' then
  begin
    cpt := Self.Se.GetTypeNo(StrToInt(e));
    Res := CreateVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}cpt);
    Params.Add(Res);
  end else Res := nil;

  Self.Se.RunProc(Params, Self.ProcNo);

  if Res <> nil then
  begin
    Params.Delete(Params.Count -1);
    case res^.FType^.BaseType of
      btU8:
        begin
          tbtu8(Pointer(Longint(FStack)-12)^) := res^.tu8;
          DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF} res);
          Res := nil;
        end;
      btS8:
        begin
          tbts8(Pointer(Longint(FStack)-12)^) := res^.ts8;
          DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF} res);
          Res := nil;
        end;
      btU16:
        begin
          tbtu16(Pointer(Longint(FStack)-12)^) := res^.tu16;
          DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF} res);
          Res := nil;
        end;
      btS16:
        begin
          tbts16(Pointer(Longint(FStack)-12)^) := res^.ts16;
          DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF} res);
          Res := nil;
        end;
      btU32:
        begin
          tbtu32(Pointer(Longint(FStack)-12)^) := res^.tu32;
          DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF} res);
          Res := nil;
        end;
      btS32:
        begin
          tbts32(Pointer(Longint(FStack)-12)^) := res^.ts32;
          DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF} res);
          Res := nil;
        end;
      btString,
      btVariant:;
      else
        begin
          DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF} res);
          Dec(C);
          Params[0] := nil;
        end;
    end;
  end;

  FStack := Stack;
  regno := 0;
  I := C-1;

  while I >= 0 do
  begin
    e := grfw(s);
    fmod := e[1];
    delete(e, 1, 1);
    cpt := Self.Se.GetTypeNo(StrToInt(e));
    if fmod = '!' then
    begin
      case cpt.BaseType of
        {$IFDEF IFPS3_HAVEVARIANT}
        btVariant:
          begin
            Tmp := Params[I];
            if regno = 0 then
            begin
              Inc(regno);
              PIFVariantToVariant(Self.SE, Tmp, Variant(Pointer(_EDX)^));
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}tmp);
              Params[I] := nil;
            end
            else if regno = 1 then
            begin
              Inc(regno);
              PIFVariantToVariant(Self.SE, Tmp, Variant(Pointer(_ECX)^));
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}tmp);
              Params[I] := nil;
            end;
          end;
        {$ENDIF}
        btResourcePointer:
          begin
            tmp := Params[I];
            if regno = 0 then
            begin
              Inc(regno);
              Pointer(Pointer(_EDX)^) := Tmp^.tResourceP1;
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}tmp);
              Params[I] := nil;
            end
            else if regno = 1 then
            begin
              Inc(regno);
              Pointer(Pointer(_ECX)^) := Tmp^.tResourceP1;
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}tmp);
              Params[I] := nil;
            end;
          end;
        btString:
          begin
            tmp := Params[I];
            if regno = 0 then
            begin
              Inc(regno);
              string(Pointer(_EDX)^) := string(Tmp^.tstring);
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}tmp);
              Params[I] := nil;
            end
            else if regno = 1 then
            begin
              Inc(regno);
              string(Pointer(_ECX)^) := string(Tmp^.tstring);
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}tmp);
              Params[I] := nil;
            end;
          end;
        btDouble{$IFNDEF IFPS3_NOINT64}, bts64{$ENDIF}:
          begin
            tmp := Params[I];
            if regno = 0 then
            begin
              Inc(regno);
              Move(tmp^.tDouble, Pointer(_EDX)^, 8);
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}tmp);
              Params[I] := nil;
            end
            else if regno = 1 then
            begin
              Inc(regno);
              Move(tmp^.tDouble, Pointer(_ECX)^, 8);
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}tmp);
              Params[I] := nil;
            end;
          end;
        btExtended:
          begin
            tmp := Params[I];
            if regno = 0 then
            begin
              Inc(regno);
              Move(tmp^.tExtended, Pointer(_EDX)^, 10);
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}tmp);
              Params[I] := nil;
            end
            else if regno = 1 then
            begin
              Inc(regno);
              Move(tmp^.tExtended, Pointer(_ECX)^, 10);
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}tmp);
              Params[I] := nil;
            end;
          end;
          btSingle,
          btChar,
          {$IFNDEF IFPS3_NOWIDESTRING}btWidechar, {$ENDIF}
          bts8,
          btu8,
          bts16,
          btu16,
          bts32,
          btu32:
          begin
            tmp := Params[I];
            if regno = 0 then
            begin
              Inc(regno);
              Longint(Pointer(_EDX)^) := Tmp^.ts32;
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}tmp);
              Params[I] := nil;
            end
            else if regno = 1 then
            begin
              Inc(regno);
              Longint(Pointer(_ECX)^) := Tmp^.ts32;
              DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}tmp);
              Params[I] := nil;
            end;
          end;
      else
        begin
          FreePIFVariantList({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}Params);
//          VarParams.Free;
          exit;
        end;
      end;
    end else begin
      case cpt.BaseType of
        btResourcePointer,
        btVariant,
        btString,
          btChar,
          {$IFNDEF IFPS3_NOWIDESTRING}btWidechar, {$ENDIF}
        bts8,
        btu8,
        bts16,
        btu16,
        bts32,
        btu32:
          begin
            Inc(regno);
            DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}Params[I]);
            Params[I] := nil;
          end;
      end;
    end;
    Dec(i);
  end;
  if Res <> nil then
  begin
    case Res^.FType.BaseType of
      {$IFDEF IFPS3_HAVEVARIANT}
      btVariant:
        begin
          if regno = 0 then
          begin
            PIFVariantToVariant(Self.SE, Res, Variant(Pointer(_EDX)^));
            DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}Res);
          end
          else if regno = 1 then
          begin
            PIFVariantToVariant(Self.SE, Res, Variant(Pointer(_ECX)^));
            DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}Res);
            Params[I] := nil;
          end else
          begin
            PIFVariantToVariant(Self.SE, Res, Variant(Pointer(FStack^)^));
            FStack := Pointer(Pointer(Longint(FStack) + 4)^);
            Dispose(Res);
          end;
        end;
      {$ENDIF}
      btString:
        begin
          if regno = 0 then
          begin
            string(Pointer(_EDX)^) := string(Res^.tstring);
            DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}Res);
          end
          else if regno = 1 then
          begin
            string(Pointer(_ECX)^) := string(Res^.tstring);
            DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}Res);
            Params[I] := nil;
          end else
          begin
            string(Pointer(FStack^)^) := string(Res^.tstring);
            FStack := Pointer(Pointer(Longint(FStack) + 4)^);
            Dispose(Res);
          end;
        end;
    end;
  end;
  s := Decl;
  grfw(s);

  for I := 0 to C - 1 do
  begin
    e := BGRFW(s);
    fmod := e[1];
    delete(e, 1, 1);
    cpt := Self.Se.GetTypeNo(StrToInt(e));
    tmp := Params[i];
    if tmp <> nil then
    begin
      if (fmod = '!') then
      begin
        case cpt.BaseType of
          {$IFDEF IFPS3_HAVEVARIANT}
          btVariant:
            begin
              PIFVariantToVariant(Self.SE, Tmp, Variant(Pointer(FStack^)^));
              FStack := Pointer(Longint(FStack) + 4);
            end;
          {$ENDIF}
          btResourcePointer:
            begin
              Pointer(Pointer(FStack^)^) := tmp^.tResourceP1;
              FStack := Pointer(Longint(FStack) + 4);
            end;
          btString:
            begin
              string(Pointer(FStack^)^) := string(Tmp^.tstring);
              FStack := Pointer(Pointer(Longint(FStack) + 4)^);
            end;
          btDouble{$IFNDEF IFPS3_NOINT64}, bts64{$ENDIF}:
            begin
              Move(Tmp^.tDouble, Pointer(FStack^)^, 8);
              FStack := Pointer(Longint(FStack) + 4);
            end;
          btExtended:
            begin
              Move(Tmp^.tExtended, Pointer(FStack^)^, 10);
              FStack := Pointer(Longint(FStack) + 4);
            end;
            btSingle,
          btChar,
          {$IFNDEF IFPS3_NOWIDESTRING}btWidechar, {$ENDIF}
            bts8,
            btu8,
            bts16,
            btu16,
            bts32,
            btu32:
            begin
              Longint(Pointer(FStack^)^) := Tmp^.ts32;
              FStack := Pointer(Longint(FStack) + 4);
            end;
        else
          begin
            FreePIFVariantList({$IFNDEF IFPS3_NOSMARTMM}Self.Se.MM, {$ENDIF}Params);
            exit;
          end;
        end;

      end;
      DisposeVariant({$IFNDEF IFPS3_NOSMARTMM}Self.Se.mm, {$ENDIF}tmp);
    end;
  end;
  Params.Free;
  if Self.Se.ExEx <> erNoError then
  begin
    if Self.Se.ExObject <> nil then
      raise Self.Se.ExObject
    else
      raise EIFPS3Exception.Create(TIFErrorToString(Self.SE.ExceptionCode, Self.Se.ExceptionString), Self.Se, Self.Se.ExProc, Self.Se.ExPos);
  end;
end;

function TIFPSRuntimeClassImporter.FindClass(const Name: string): TIFPSRuntimeClass;
var
  h, i: Longint;
  p: TIFPSRuntimeClass;
begin
  h := MakeHash(Name);
  for i := FClasses.Count -1 downto 0 do
  begin
    p := FClasses[i];
    if (p.FClassNameHash = h) and (p.FClassName = Name) then
    begin
      Result := P;
      exit;
    end;
  end;
  Result := nil;
end;

function DelphiFunctionProc(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList; CC: TIFPSCallingConvention): Boolean;
var
  i: Integer;
  MyList: TIfList;
  n: PIFVariant;
  CurrStack: Cardinal;
  s: string;
begin
  s := P^.ExportDecl;
  if length(s) = 0 then begin Result := False; exit; end;
  CurrStack := Stack.Count - Cardinal(length(s));
  if s[1] = #0 then inc(CurrStack);
  MyList := tIfList.Create;

  for i := 2 to length(s) do
  begin
    MyList.Add(nil);
  end;
  for i := length(s) downto 2 do
  begin
    n :=rp(Stack[CurrStack]);
    if s[i] <> #0 then
    begin
      n^.RefCount := n^.RefCount or IFPSAddrStackStart;
    end;
    MyList[i - 2] := n;
    inc(CurrStack);
  end;
  try
    if s[1] <> #0 then
    begin
      n := rp(Stack[CurrStack]);
    end else n := nil;
    result := Caller.InnerfuseCall(p^.Ext2, p^.Ext1, cc, MyList, n);
  finally
    MyList.Free;
  end;
end;

function DelphiFunctionProc_CDECL(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
begin
  Result := DelphiFunctionProc(Caller, p, Global, Stack, cdCdecl);
end;
function DelphiFunctionProc_Register(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
begin
  Result := DelphiFunctionProc(Caller, p, Global, Stack, cdRegister);
end;
function DelphiFunctionProc_Pascal(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
begin
  Result := DelphiFunctionProc(Caller, p, Global, Stack, cdPascal);
end;
function DelphiFunctionProc_Stdcall(Caller: TIFPSExec; p: PIFProcRec; Global, Stack: TIfList): Boolean;
begin
  Result := DelphiFunctionProc(Caller, p, Global, Stack, cdStdCall);
end;

procedure TIFPSExec.RegisterDelphiFunction(ProcPtr: Pointer;
  const Name: string; CC: TIFPSCallingConvention);
begin
  RegisterDelphiMethod(nil, ProcPtr, FastUppercase(Name), CC);
end;

procedure TIFPSExec.RegisterDelphiMethod(Slf, ProcPtr: Pointer;
  const Name: string; CC: TIFPSCallingConvention);
begin
  case cc of
    cdRegister: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Register, ProcPtr, Slf);
    cdPascal: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Pascal, ProcPtr, Slf);
    cdStdCall: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_Stdcall, ProcPtr, Slf);
    cdCdecl: RegisterFunctionName(FastUppercase(Name), DelphiFunctionProc_CDECL, ProcPtr, Slf);
  end;
end;

{ EIFPS3Exception }

constructor EIFPS3Exception.Create(const Error: string; Exec: TIFPSExec;
  Procno, ProcPos: Cardinal);
begin
 inherited Create(Error);
 FExec := Exec;
 FProcNo := Procno;
 FProcPos := ProcPos;
end;

initialization
{$IFDEF IFPS3_HAVEVARIANT}
  VNull := Null;
{$ENDIF}
end.

