pascal/kolmck
1
0
Fork 0
Code Issues Releases Activity
Files
2a0bcf1de025c28648b1b56ef24d757f788c5668
kolmck/System/D5/system.pas

12007 lines
316 KiB
ObjectPascal
Raw Normal View History

read.txt git-svn-id: https://svn.code.sf.net/p/kolmck/code@17 91bb2d04-0c0c-4d2d-88a5-bbb6f4c1fa07
2009-08-19 09:26:45 +00:00
{*******************************************************} // XCL version of System
{ } // unit. Created Jun-2000
{ Borland Delphi Runtime Library } // (C) by Kladov Vladimir
{ System Unit } //
{ } // purpose: make XCL Delphi
{ Copyright (C) 1988,99 Inprise Corporation } // programs even smaller.
{ } //
{*******************************************************} // Changes are marked as {X}
unit System; { Predefined constants, types, procedures, }
{ and functions (such as True, Integer, or }
{ Writeln) do not have actual declarations.}
{ Instead they are built into the compiler }
{ and are treated as if they were declared }
{ at the beginning of the System unit. }
{$H+,I-,S-}
{ L- should never be specified.
The IDE needs to find debug hook (through the C++
compiler sometimes) for integrated debugging to
function properly.
ILINK will generate debug info for DebugHook if
the object module has not been compiled with debug info.
ILINK will not generate debug info for DebugHook if
the object module has been compiled with debug info.
Thus, the Pascal compiler must be responsible for
generating the debug information for that symbol
when a debug-enabled object file is produced.
}
interface
const
{ Variant type codes (wtypes.h) }
varEmpty = $0000; { vt_empty }
varNull = $0001; { vt_null }
varSmallint = $0002; { vt_i2 }
varInteger = $0003; { vt_i4 }
varSingle = $0004; { vt_r4 }
varDouble = $0005; { vt_r8 }
varCurrency = $0006; { vt_cy }
varDate = $0007; { vt_date }
varOleStr = $0008; { vt_bstr }
varDispatch = $0009; { vt_dispatch }
varError = $000A; { vt_error }
varBoolean = $000B; { vt_bool }
varVariant = $000C; { vt_variant }
varUnknown = $000D; { vt_unknown }
{ vt_decimal $e }
{ undefined $f }
{ vt_i1 $10 }
varByte = $0011; { vt_ui1 }
{ vt_ui2 $12 }
{ vt_ui4 $13 }
{ vt_i8 $14 }
{ if adding new items, update varLast, BaseTypeMap and OpTypeMap }
varStrArg = $0048; { vt_clsid }
varString = $0100; { Pascal string; not OLE compatible }
varAny = $0101;
varTypeMask = $0FFF;
varArray = $2000;
varByRef = $4000;
{ TVarRec.VType values }
vtInteger = 0;
vtBoolean = 1;
vtChar = 2;
vtExtended = 3;
vtString = 4;
vtPointer = 5;
vtPChar = 6;
vtObject = 7;
vtClass = 8;
vtWideChar = 9;
vtPWideChar = 10;
vtAnsiString = 11;
vtCurrency = 12;
vtVariant = 13;
vtInterface = 14;
vtWideString = 15;
vtInt64 = 16;
{ Virtual method table entries }
vmtSelfPtr = -76;
vmtIntfTable = -72;
vmtAutoTable = -68;
vmtInitTable = -64;
vmtTypeInfo = -60;
vmtFieldTable = -56;
vmtMethodTable = -52;
vmtDynamicTable = -48;
vmtClassName = -44;
vmtInstanceSize = -40;
vmtParent = -36;
vmtSafeCallException = -32;
vmtAfterConstruction = -28;
vmtBeforeDestruction = -24;
vmtDispatch = -20;
vmtDefaultHandler = -16;
vmtNewInstance = -12;
vmtFreeInstance = -8;
vmtDestroy = -4;
vmtQueryInterface = 0;
vmtAddRef = 4;
vmtRelease = 8;
vmtCreateObject = 12;
type
TObject = class;
TClass = class of TObject;
{$EXTERNALSYM HRESULT}
HRESULT = type Longint; { from WTYPES.H }
{$EXTERNALSYM IUnknown}
{$EXTERNALSYM IDispatch}
PGUID = ^TGUID;
TGUID = packed record
D1: LongWord;
D2: Word;
D3: Word;
D4: array[0..7] of Byte;
end;
PInterfaceEntry = ^TInterfaceEntry;
TInterfaceEntry = packed record
IID: TGUID;
VTable: Pointer;
IOffset: Integer;
ImplGetter: Integer;
end;
PInterfaceTable = ^TInterfaceTable;
TInterfaceTable = packed record
EntryCount: Integer;
Entries: array[0..9999] of TInterfaceEntry;
end;
TObject = class
constructor Create;
procedure Free;
class function InitInstance(Instance: Pointer): TObject;
procedure CleanupInstance;
function ClassType: TClass;
class function ClassName: ShortString;
class function ClassNameIs(const Name: string): Boolean;
class function ClassParent: TClass;
class function ClassInfo: Pointer;
class function InstanceSize: Longint;
class function InheritsFrom(AClass: TClass): Boolean;
class function MethodAddress(const Name: ShortString): Pointer;
class function MethodName(Address: Pointer): ShortString;
function FieldAddress(const Name: ShortString): Pointer;
function GetInterface(const IID: TGUID; out Obj): Boolean;
class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry;
class function GetInterfaceTable: PInterfaceTable;
function SafeCallException(ExceptObject: TObject;
ExceptAddr: Pointer): HResult; virtual;
procedure AfterConstruction; virtual;
procedure BeforeDestruction; virtual;
procedure Dispatch(var Message); virtual;
procedure DefaultHandler(var Message); virtual;
class function NewInstance: TObject; virtual;
procedure FreeInstance; virtual;
destructor Destroy; virtual;
end;
IUnknown = interface
['{00000000-0000-0000-C000-000000000046}']
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
end;
IDispatch = interface(IUnknown)
['{00020400-0000-0000-C000-000000000046}']
function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
function GetIDsOfNames(const IID: TGUID; Names: Pointer;
NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
end;
TInterfacedObject = class(TObject, IUnknown)
protected
FRefCount: Integer;
function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall;
function _AddRef: Integer; stdcall;
function _Release: Integer; stdcall;
public
procedure AfterConstruction; override;
procedure BeforeDestruction; override;
class function NewInstance: TObject; override;
property RefCount: Integer read FRefCount;
end;
TInterfacedClass = class of TInterfacedObject;
TVarArrayBound = packed record
ElementCount: Integer;
LowBound: Integer;
end;
PVarArray = ^TVarArray;
TVarArray = packed record
DimCount: Word;
Flags: Word;
ElementSize: Integer;
LockCount: Integer;
Data: Pointer;
Bounds: array[0..255] of TVarArrayBound;
end;
PVarData = ^TVarData;
TVarData = packed record
VType: Word;
Reserved1, Reserved2, Reserved3: Word;
case Integer of
varSmallint: (VSmallint: Smallint);
varInteger: (VInteger: Integer);
varSingle: (VSingle: Single);
varDouble: (VDouble: Double);
varCurrency: (VCurrency: Currency);
varDate: (VDate: Double);
varOleStr: (VOleStr: PWideChar);
varDispatch: (VDispatch: Pointer);
varError: (VError: LongWord);
varBoolean: (VBoolean: WordBool);
varUnknown: (VUnknown: Pointer);
varByte: (VByte: Byte);
varString: (VString: Pointer);
varAny: (VAny: Pointer);
varArray: (VArray: PVarArray);
varByRef: (VPointer: Pointer);
end;
PShortString = ^ShortString;
PAnsiString = ^AnsiString;
PWideString = ^WideString;
PString = PAnsiString;
PExtended = ^Extended;
PCurrency = ^Currency;
PVariant = ^Variant;
POleVariant = ^OleVariant;
PInt64 = ^Int64;
TDateTime = type Double;
PDateTime = ^TDateTime;
PVarRec = ^TVarRec;
TVarRec = record { do not pack this record; it is compiler-generated }
case Byte of
vtInteger: (VInteger: Integer; VType: Byte);
vtBoolean: (VBoolean: Boolean);
vtChar: (VChar: Char);
vtExtended: (VExtended: PExtended);
vtString: (VString: PShortString);
vtPointer: (VPointer: Pointer);
vtPChar: (VPChar: PChar);
vtObject: (VObject: TObject);
vtClass: (VClass: TClass);
vtWideChar: (VWideChar: WideChar);
vtPWideChar: (VPWideChar: PWideChar);
vtAnsiString: (VAnsiString: Pointer);
vtCurrency: (VCurrency: PCurrency);
vtVariant: (VVariant: PVariant);
vtInterface: (VInterface: Pointer);
vtWideString: (VWideString: Pointer);
vtInt64: (VInt64: PInt64);
end;
PMemoryManager = ^TMemoryManager;
TMemoryManager = record
GetMem: function(Size: Integer): Pointer;
FreeMem: function(P: Pointer): Integer;
ReallocMem: function(P: Pointer; Size: Integer): Pointer;
end;
THeapStatus = record
TotalAddrSpace: Cardinal;
TotalUncommitted: Cardinal;
TotalCommitted: Cardinal;
TotalAllocated: Cardinal;
TotalFree: Cardinal;
FreeSmall: Cardinal;
FreeBig: Cardinal;
Unused: Cardinal;
Overhead: Cardinal;
HeapErrorCode: Cardinal;
end;
PackageUnitEntry = packed record
Init, FInit : procedure;
end;
{ Compiler generated table to be processed sequentially to init & finit all package units }
{ Init: 0..Max-1; Final: Last Initialized..0 }
UnitEntryTable = array [0..9999999] of PackageUnitEntry;
PUnitEntryTable = ^UnitEntryTable;
PackageInfoTable = packed record
UnitCount : Integer; { number of entries in UnitInfo array; always > 0 }
UnitInfo : PUnitEntryTable;
end;
PackageInfo = ^PackageInfoTable;
{ Each package exports a '@GetPackageInfoTable' which can be used to retrieve }
{ the table which contains compiler generated information about the package DLL }
GetPackageInfoTable = function : PackageInfo;
const
advapi32 = 'advapi32.dll';
kernel = 'kernel32.dll';
user = 'user32.dll';
oleaut = 'oleaut32.dll';
{X+ moved here from SysInit.pas - by advise of Alexey Torgashin - to avoid
creating of separate import block from kernel32.dll : }
//////////////////////////////////////////////////////////////////////////
function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall;
external kernel name 'FreeLibrary';
function GetModuleFileName(Module: Integer; Filename: PChar; Size: Integer): Integer; stdcall;
external kernel name 'GetModuleFileNameA';
function GetModuleHandle(ModuleName: PChar): Integer; stdcall;
external kernel name 'GetModuleHandleA';
function LocalAlloc(flags, size: Integer): Pointer; stdcall;
external kernel name 'LocalAlloc';
function LocalFree(addr: Pointer): Pointer; stdcall;
external kernel name 'LocalFree';
function TlsAlloc: Integer; stdcall;
external kernel name 'TlsAlloc';
function TlsFree(TlsIndex: Integer): Boolean; stdcall;
external kernel name 'TlsFree';
function TlsGetValue(TlsIndex: Integer): Pointer; stdcall;
external kernel name 'TlsGetValue';
function TlsSetValue(TlsIndex: Integer; TlsValue: Pointer): Boolean; stdcall;
external kernel name 'TlsSetValue';
function GetCommandLine: PChar; stdcall;
external kernel name 'GetCommandLineA';
{X-}//////////////////////////////////////////////////////////////////////
{X} // following two procedures are optional and exclusive.
{X} // call it to provide error message: first - for GUI app,
{X} // second - for console app.
{X} procedure UseErrorMessageBox;
{X} procedure UseErrorMessageWrite;
{X} // call following procedure to initialize Input and Output
{X} // - for console app only:
{X} procedure UseInputOutput;
{X} // if your app uses FPU, call one of following procedures:
{X} procedure FpuInit;
{X} procedure FpuInitConsiderNECWindows;
{X} // the second additionally takes into consideration NEC
{X} // Windows keyboard (Japaneeze keyboard ???).
{X} // following variables are converted to a functions:
{X} function CmdShow : Integer;
{X} function CmdLine : PChar;
{X} procedure VarCastError;
{X} procedure VarInvalidOp;
{X} procedure DummyProc; // empty procedure
{X} procedure VariantAddRef;
{X} // procedure to refer to _VarAddRef if SysVarnt.pas is in use
{X} var VarAddRefProc : procedure = DummyProc;
{X} procedure VariantClr;
{X} // procedure to refer to _VarClr if SysVarnt.pas is in use
{X} var VarClrProc : procedure = DummyProc;
{X} procedure WStrAddRef;
{X} // procedure to refer to _WStrAddRef if SysWStr.pas is in use
{X} var WStrAddRefProc : procedure = DummyProc;
{X} procedure WStrClr;
{X} // procedure to refer to _WStrClr if SysWStr.pas is in use
{X} var WStrClrProc : procedure = DummyProc;
{X} procedure WStrArrayClr;
{X} // procedure to refer to _WStrArrayClr if SysWStr.pas is in use
{X} var WStrArrayClrProc : procedure = DummyProc;
{X} // By default, now system memory management routines are used
{X} // to allocate memory. This can be slow sometimes, so if You
{X} // want to use custom Borland Delphi memory manager, call follow:
{X} procedure UseDelphiMemoryManager;
{X} function IsDelphiMemoryManagerSet : Boolean;
{X} function MemoryManagerNotUsed : Boolean;
{X} // Standard Delphi units initialization/finalization uses
{X} // try-except and raise constructions, which leads to permanent
{X} // usage of all exception handling routines. In this XCL-aware
{X} // implementation, "light" version of initialization/finalization
{X} // is used by default. To use standard Delphi initialization and
{X} // finalization method, allowing to flow execution control even
{X} // in initalization sections, include reference to SysSfIni.pas
{X} // into uses clause *as first as possible*.
{X} procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer );
{X} procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer );
{X} var InitUnitsProc : procedure( Table : PUnitEntryTable; Idx, Count : Integer )
{X} = InitUnitsLight;
{X} procedure FInitUnitsLight;
{X} procedure FInitUnitsHard;
{X} var FInitUnitsProc : procedure = FInitUnitsLight;
{X} procedure SetExceptionHandler;
{X} procedure UnsetExceptionHandler;
{X} var UnsetExceptionHandlerProc : procedure = DummyProc;
{X} var UnloadResProc: procedure = DummyProc;
function RaiseList: Pointer; { Stack of current exception objects }
function SetRaiseList(NewPtr: Pointer): Pointer; { returns previous value }
procedure SetInOutRes(NewValue: Integer);
var
ExceptProc: Pointer; { Unhandled exception handler }
ErrorProc: Pointer; { Error handler procedure }
ExceptClsProc: Pointer; { Map an OS Exception to a Delphi class reference }
ExceptObjProc: Pointer; { Map an OS Exception to a Delphi class instance }
ExceptionClass: TClass; { Exception base class (must be Exception) }
SafeCallErrorProc: Pointer; { Safecall error handler }
AssertErrorProc: Pointer; { Assertion error handler }
AbstractErrorProc: Pointer; { Abstract method error handler }
HPrevInst: LongWord; { Handle of previous instance - HPrevInst cannot be tested for multiple instances in Win32}
MainInstance: LongWord; { Handle of the main(.EXE) HInstance }
MainThreadID: LongWord; { ThreadID of thread that module was initialized in }
IsLibrary: Boolean; { True if module is a DLL }
{X CmdShow: Integer; { CmdShow parameter for CreateWindow - converted to a function X}
{X CmdLine: PChar; { Command line pointer - converted to a function X}
InitProc: Pointer; { Last installed initialization procedure }
ExitCode: Integer; { Program result }
ExitProc: Pointer; { Last installed exit procedure }
ErrorAddr: Pointer; { Address of run-time error }
RandSeed: Longint; { Base for random number generator }
IsConsole: Boolean; { True if compiled as console app }
IsMultiThread: Boolean; { True if more than one thread }
FileMode: Byte {X} = 2; { Standard mode for opening files }
Test8086: Byte {X} = 2; { Will always be 2 (386 or later) }
Test8087: Byte {X} = 3; { Will always be 3 (387 or later) }
TestFDIV: Shortint; { -1: Flawed Pentium, 0: Not determined, 1: Ok }
Input: Text; { Standard input }
Output: Text; { Standard output }
ClearAnyProc: Pointer; { Handler clearing a varAny }
ChangeAnyProc: Pointer; { Handler to change any to variant }
RefAnyProc: Pointer; { Handler to add a reference to an varAny }
var
Default8087CW: Word = $1332;{ Default 8087 control word. FPU control
register is set to this value.
CAUTION: Setting this to an invalid value
could cause unpredictable behavior. }
HeapAllocFlags: Word = 2; { Heap allocation flags, gmem_Moveable }
DebugHook: Byte = 0; { 1 to notify debugger of non-Delphi exceptions
>1 to notify debugger of exception unwinding }
JITEnable: Byte = 0; { 1 to call UnhandledExceptionFilter if the exception
is not a Pascal exception.
>1 to call UnhandledExceptionFilter for all exceptions }
NoErrMsg: Boolean = False; { True causes the base RTL to not display the message box
when a run-time error occurs }
var
(* {X-} moved to SysVarnt.pas
Unassigned: Variant; { Unassigned standard constant }
Null: Variant; { Null standard constant }
EmptyParam: OleVariant; { "Empty parameter" standard constant which can be
passed as an optional parameter on a dual interface. }
{X+} *)
AllocMemCount: Integer; { Number of allocated memory blocks }
AllocMemSize: Integer; { Total size of allocated memory blocks }
{ Memory manager support }
procedure GetMemoryManager(var MemMgr: TMemoryManager);
procedure SetMemoryManager(const MemMgr: TMemoryManager);
{X} // following function is replaced with pointer to one
{X} // (initialized by another)
{X} //function IsMemoryManagerSet: Boolean;
var IsMemoryManagerSet : function : Boolean = MemoryManagerNotUsed;
function SysGetMem(Size: Integer): Pointer;
function SysFreeMem(P: Pointer): Integer;
function SysReallocMem(P: Pointer; Size: Integer): Pointer;
function GetHeapStatus: THeapStatus;
{ Thread support }
type
TThreadFunc = function(Parameter: Pointer): Integer;
function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord;
ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord;
var ThreadId: LongWord): Integer;
procedure EndThread(ExitCode: Integer);
{ Standard procedures and functions }
procedure _ChDir(const S: string);
procedure __Flush(var F: Text);
procedure _LGetDir(D: Byte; var S: string);
procedure _SGetDir(D: Byte; var S: ShortString);
function IOResult: Integer;
procedure _MkDir(const S: string);
procedure Move(const Source; var Dest; Count: Integer);
function ParamCount: Integer;
function ParamStr(Index: Integer): string;
procedure Randomize;
procedure _RmDir(const S: string);
function UpCase(Ch: Char): Char;
{ Control 8087 control word }
procedure Set8087CW(NewCW: Word);
{ Wide character support procedures and functions }
function WideCharToString(Source: PWideChar): string;
function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string;
procedure WideCharToStrVar(Source: PWideChar; var Dest: string);
procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer;
var Dest: string);
function StringToWideChar(const Source: string; Dest: PWideChar;
DestSize: Integer): PWideChar;
{ OLE string support procedures and functions }
function OleStrToString(Source: PWideChar): string;
procedure OleStrToStrVar(Source: PWideChar; var Dest: string);
function StringToOleStr(const Source: string): PWideChar;
{ Variant support procedures and functions }
procedure _VarClear(var V : Variant);
procedure _VarCopy(var Dest : Variant; const Source: Variant);
procedure _VarCast(var Dest : Variant; const Source: Variant; VarType: Integer);
procedure _VarCastOle(var Dest : Variant; const Source: Variant; VarType: Integer);
procedure VarCopyNoInd(var Dest: Variant; const Source: Variant);
function VarType(const V: Variant): Integer;
function VarAsType(const V: Variant; VarType: Integer): Variant;
function VarIsEmpty(const V: Variant): Boolean;
function VarIsNull(const V: Variant): Boolean;
function VarToStr(const V: Variant): string;
function VarFromDateTime(DateTime: TDateTime): Variant;
function VarToDateTime(const V: Variant): TDateTime;
{ Variant array support procedures and functions }
function VarArrayCreate(const Bounds: array of Integer;
VarType: Integer): Variant;
function VarArrayOf(const Values: array of Variant): Variant;
procedure _VarArrayRedim(var A : Variant; HighBound: Integer);
function VarArrayDimCount(const A: Variant): Integer;
function VarArrayLowBound(const A: Variant; Dim: Integer): Integer;
function VarArrayHighBound(const A: Variant; Dim: Integer): Integer;
function VarArrayLock(const A: Variant): Pointer;
procedure VarArrayUnlock(const A: Variant);
function VarArrayRef(const A: Variant): Variant;
function VarIsArray(const A: Variant): Boolean;
{ Variant IDispatch call support }
procedure _DispInvokeError;
var
VarDispProc: Pointer = @_DispInvokeError;
DispCallByIDProc: Pointer = @_DispInvokeError;
{ Package/Module registration and unregistration }
type
PLibModule = ^TLibModule;
TLibModule = record
Next: PLibModule;
Instance: LongWord;
CodeInstance: LongWord;
DataInstance: LongWord;
ResInstance: LongWord;
Reserved: Integer;
end;
TEnumModuleFunc = function (HInstance: Integer; Data: Pointer): Boolean;
{$EXTERNALSYM TEnumModuleFunc}
TEnumModuleFuncLW = function (HInstance: LongWord; Data: Pointer): Boolean;
{$EXTERNALSYM TEnumModuleFuncLW}
TModuleUnloadProc = procedure (HInstance: Integer);
{$EXTERNALSYM TModuleUnloadProc}
TModuleUnloadProcLW = procedure (HInstance: LongWord);
{$EXTERNALSYM TModuleUnloadProcLW}
PModuleUnloadRec = ^TModuleUnloadRec;
TModuleUnloadRec = record
Next: PModuleUnloadRec;
Proc: TModuleUnloadProcLW;
end;
var
LibModuleList: PLibModule = nil;
ModuleUnloadList: PModuleUnloadRec = nil;
procedure RegisterModule(LibModule: PLibModule);
{X procedure UnregisterModule(LibModule: PLibModule); -replaced with pointer to procedure }
{X} procedure UnregisterModuleLight(LibModule: PLibModule);
{X} procedure UnregisterModuleSafely(LibModule: PLibModule);
var UnregisterModule : procedure(LibModule: PLibModule) = UnregisterModuleLight;
function FindHInstance(Address: Pointer): LongWord;
function FindClassHInstance(ClassType: TClass): LongWord;
function FindResourceHInstance(Instance: LongWord): LongWord;
function LoadResourceModule(ModuleName: PChar): LongWord;
procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); overload;
procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer); overload;
procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer); overload;
procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer); overload;
procedure AddModuleUnloadProc(Proc: TModuleUnloadProc); overload;
procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc); overload;
procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW); overload;
procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW); overload;
{ ResString support function/record }
type
PResStringRec = ^TResStringRec;
TResStringRec = packed record
Module: ^Longint;
Identifier: Integer;
end;
function LoadResString(ResStringRec: PResStringRec): string;
{ Procedures and functions that need compiler magic }
procedure _COS;
procedure _EXP;
procedure _INT;
procedure _SIN;
procedure _FRAC;
procedure _ROUND;
procedure _TRUNC;
procedure _AbstractError;
procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer);
procedure _Append;
procedure _Assign(var T: Text; S: ShortString);
procedure _BlockRead;
procedure _BlockWrite;
procedure _Close;
procedure _PStrCat;
procedure _PStrNCat;
procedure _PStrCpy;
procedure _PStrNCpy;
procedure _EofFile;
procedure _EofText;
procedure _Eoln;
procedure _Erase;
procedure _FilePos;
procedure _FileSize;
procedure _FillChar;
procedure _FreeMem;
procedure _GetMem;
procedure _ReallocMem;
procedure _Halt;
procedure _Halt0;
procedure _Mark;
procedure _PStrCmp;
procedure _AStrCmp;
procedure _RandInt;
procedure _RandExt;
procedure _ReadRec;
procedure _ReadChar;
procedure _ReadLong;
procedure _ReadString;
procedure _ReadCString;
procedure _ReadLString;
procedure _ReadExt;
procedure _ReadLn;
procedure _Rename;
procedure _Release;
procedure _ResetText(var T: Text);
procedure _ResetFile;
procedure _RewritText(var T: Text);
procedure _RewritFile;
procedure _RunError;
procedure _Run0Error;
procedure _Seek;
procedure _SeekEof;
procedure _SeekEoln;
procedure _SetTextBuf;
procedure _StrLong;
procedure _Str0Long;
procedure _Truncate;
procedure _ValLong;
procedure _WriteRec;
procedure _WriteChar;
procedure _Write0Char;
procedure _WriteBool;
procedure _Write0Bool;
procedure _WriteLong;
procedure _Write0Long;
procedure _WriteString;
procedure _Write0String;
procedure _WriteCString;
procedure _Write0CString;
procedure _WriteLString;
procedure _Write0LString;
function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer;
function _Write0Variant(var T: Text; const V: Variant): Pointer;
procedure _Write2Ext;
procedure _Write1Ext;
procedure _Write0Ext;
procedure _WriteLn;
procedure __CToPasStr;
procedure __CLenToPasStr;
procedure __ArrayToPasStr;
procedure __PasToCStr;
procedure __IOTest;
procedure _Flush(var F: Text);
procedure _SetElem;
procedure _SetRange;
procedure _SetEq;
procedure _SetLe;
procedure _SetIntersect;
procedure _SetIntersect3; { BEG only }
procedure _SetUnion;
procedure _SetUnion3; { BEG only }
procedure _SetSub;
procedure _SetSub3; { BEG only }
procedure _SetExpand;
procedure _Str2Ext;
procedure _Str0Ext;
procedure _Str1Ext;
procedure _ValExt;
procedure _Pow10;
procedure _Real2Ext;
procedure _Ext2Real;
procedure _ObjSetup;
procedure _ObjCopy;
procedure _Fail;
procedure _BoundErr;
procedure _IntOver;
procedure _StartExe;
procedure _StartLib;
procedure _PackageLoad (const Table : PackageInfo);
procedure _PackageUnload(const Table : PackageInfo);
procedure _InitResStrings;
procedure _InitResStringImports;
procedure _InitImports;
procedure _InitWideStrings;
procedure _ClassCreate;
procedure _ClassDestroy;
procedure _AfterConstruction;
procedure _BeforeDestruction;
procedure _IsClass;
procedure _AsClass;
procedure _RaiseExcept;
procedure _RaiseAgain;
procedure _DoneExcept;
procedure _TryFinallyExit;
procedure _CallDynaInst;
procedure _CallDynaClass;
procedure _FindDynaInst;
procedure _FindDynaClass;
procedure _LStrClr(var S: AnsiString);
procedure _LStrArrayClr{var str: AnsiString; cnt: longint};
procedure _LStrAsg{var dest: AnsiString; source: AnsiString};
procedure _LStrLAsg{var dest: AnsiString; source: AnsiString};
procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer);
procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar);
procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar);
procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar);
procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar);
procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString);
procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer);
procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString);
procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)};
function _LStrLen{str: AnsiString}: Longint;
procedure _LStrCat{var dest: AnsiString; source: AnsiString};
procedure _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString};
procedure _LStrCatN{var dest:AnsiString; argCnt: Integer; ...};
procedure _LStrCmp{left: AnsiString; right: AnsiString};
procedure _LStrAddRef{str: AnsiString};
procedure _LStrToPChar{str: AnsiString): PChar};
procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString};
procedure _Delete{ var s : openstring; index, count : Integer };
procedure _Insert{ source : ShortString; var s : openstring; index : Integer };
procedure _Pos{ substr : ShortString; s : ShortString ) : Integer};
procedure _SetLength{var s: ShortString; newLength: Integer};
procedure _SetString{var s: ShortString: buffer: PChar; len: Integer};
procedure UniqueString(var str: string);
procedure _NewAnsiString{length: Longint}; { for debugger purposes only }
procedure _LStrCopy { const s : AnsiString; index, count : Integer) : AnsiString};
procedure _LStrDelete{ var s : AnsiString; index, count : Integer };
procedure _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer };
procedure _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer};
procedure _LStrSetLength{ var str: AnsiString; newLength: Integer};
procedure _LStrOfChar{ c: Char; count: Integer): AnsiString };
procedure _WStrClr(var S: WideString);
procedure _WStrArrayClr(var StrArray; Count: Integer);
procedure _WStrAsg(var Dest: WideString; const Source: WideString);
procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer);
procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; Length: Integer);
procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar);
procedure _WStrFromWChar(var Dest: WideString; Source: WideChar);
procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar);
procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar);
procedure _WStrFromString(var Dest: WideString; const Source: ShortString);
procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer);
procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer);
procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString);
procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer);
function _WStrToPWChar(const S: WideString): PWideChar;
function _WStrLen(const S: WideString): Integer;
procedure _WStrCat(var Dest: WideString; const Source: WideString);
procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString);
procedure _WStrCatN{var dest:WideString; argCnt: Integer; ...};
procedure _WStrCmp{left: WideString; right: WideString};
function _NewWideString(Length: Integer): PWideChar;
function _WStrCopy(const S: WideString; Index, Count: Integer): WideString;
procedure _WStrDelete(var S: WideString; Index, Count: Integer);
procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer);
procedure _WStrPos{ const substr : WideString; const s : WideString ) : Integer};
procedure _WStrSetLength(var S: WideString; NewLength: Integer);
function _WStrOfWChar(Ch: WideChar; Count: Integer): WideString;
procedure _WStrAddRef{var str: WideString};
procedure _Initialize;
procedure _InitializeArray;
procedure _InitializeRecord;
procedure _Finalize;
procedure _FinalizeArray;
procedure _FinalizeRecord;
procedure _AddRef;
procedure _AddRefArray;
procedure _AddRefRecord;
procedure _CopyArray;
procedure _CopyRecord;
procedure _CopyObject;
procedure _New;
procedure _Dispose;
procedure _DispInvoke; cdecl;
procedure _IntfDispCall; cdecl;
procedure _IntfVarCall; cdecl;
procedure _VarToInt;
procedure _VarToBool;
procedure _VarToReal;
procedure _VarToCurr;
procedure _VarToPStr(var S; const V: Variant);
procedure _VarToLStr(var S: string; const V: Variant);
procedure _VarToWStr(var S: WideString; const V: Variant);
procedure _VarToIntf(var Unknown: IUnknown; const V: Variant);
procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant);
procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);
procedure _VarFromInt;
procedure _VarFromBool;
procedure _VarFromReal;
procedure _VarFromTDateTime;
procedure _VarFromCurr;
procedure _VarFromPStr(var V: Variant; const Value: ShortString);
procedure _VarFromLStr(var V: Variant; const Value: string);
procedure _VarFromWStr(var V: Variant; const Value: WideString);
procedure _VarFromIntf(var V: Variant; const Value: IUnknown);
procedure _VarFromDisp(var V: Variant; const Value: IDispatch);
procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString);
procedure _OleVarFromLStr(var V: OleVariant; const Value: string);
procedure _OleVarFromVar(var V: OleVariant; const Value: Variant);
procedure _VarAdd;
procedure _VarSub;
procedure _VarMul;
procedure _VarDiv;
procedure _VarMod;
procedure _VarAnd;
procedure _VarOr;
procedure _VarXor;
procedure _VarShl;
procedure _VarShr;
procedure _VarRDiv;
procedure _VarCmp;
procedure _VarNeg;
procedure _VarNot;
procedure _VarCopyNoInd;
procedure _VarClr;
procedure _VarAddRef;
{ 64-bit Integer helper routines }
procedure __llmul;
procedure __lldiv;
procedure __lludiv;
procedure __llmod;
procedure __llmulo;
procedure __lldivo;
procedure __llmodo;
procedure __llumod;
procedure __llshl;
procedure __llushr;
procedure _WriteInt64;
procedure _Write0Int64;
procedure _ReadInt64;
function _StrInt64(val: Int64; width: Integer): ShortString;
function _Str0Int64(val: Int64): ShortString;
function _ValInt64(const s: AnsiString; var code: Integer): Int64;
{ Dynamic array helper functions }
procedure _DynArrayHigh;
procedure _DynArrayClear(var a: Pointer; typeInfo: Pointer);
procedure _DynArrayLength;
procedure _DynArraySetLength;
procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer);
procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer);
procedure _DynArrayAsg;
procedure _DynArrayAddRef;
procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
procedure DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);
procedure _IntfClear(var Dest: IUnknown);
procedure _IntfCopy(var Dest: IUnknown; const Source: IUnknown);
procedure _IntfCast(var Dest: IUnknown; const Source: IUnknown; const IID: TGUID);
procedure _IntfAddRef(const Dest: IUnknown);
function _VarArrayGet(var A: Variant; IndexCount: Integer;
Indices: Integer): Variant; cdecl;
procedure _VarArrayPut(var A: Variant; const Value: Variant;
IndexCount: Integer; Indices: Integer); cdecl;
procedure _HandleAnyException;
procedure _HandleOnException;
procedure _HandleFinally;
procedure _HandleAutoException;
procedure _FSafeDivide;
procedure _FSafeDivideR;
procedure _CheckAutoResult;
procedure FPower10;
procedure TextStart;
function CompToDouble(acomp: Comp): Double; cdecl;
procedure DoubleToComp(adouble: Double; var result: Comp); cdecl;
function CompToCurrency(acomp: Comp): Currency; cdecl;
procedure CurrencyToComp(acurrency: Currency; var result: Comp); cdecl;
function GetMemory(Size: Integer): Pointer; cdecl;
function FreeMemory(P: Pointer): Integer; cdecl;
function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl;
(* =================================================================== *)
implementation
uses
SysInit;
{ Internal runtime error codes }
const
reOutOfMemory = 1;
reInvalidPtr = 2;
reDivByZero = 3;
reRangeError = 4;
reIntOverflow = 5;
reInvalidOp = 6;
reZeroDivide = 7;
reOverflow = 8;
reUnderflow = 9;
reInvalidCast = 10;
reAccessViolation = 11;
reStackOverflow = 12;
reControlBreak = 13;
rePrivInstruction = 14;
reVarTypeCast = 15;
reVarInvalidOp = 16;
reVarDispatch = 17;
reVarArrayCreate = 18;
reVarNotArray = 19;
reVarArrayBounds = 20;
reAssertionFailed = 21;
reExternalException = 22; { not used here; in SysUtils }
reIntfCastError = 23;
reSafeCallError = 24;
{ this procedure should be at the very beginning of the }
{ text segment. it is only used by _RunError to find }
{ start address of the text segment so a nice error }
{ location can be shown. }
procedure TextStart;
begin
end;
{ ----------------------------------------------------- }
{ NT Calls necessary for the .asm files }
{ ----------------------------------------------------- }
type
PMemInfo = ^TMemInfo;
TMemInfo = packed record
BaseAddress: Pointer;
AllocationBase: Pointer;
AllocationProtect: Longint;
RegionSize: Longint;
State: Longint;
Protect: Longint;
Type_9 : Longint;
end;
PStartupInfo = ^TStartupInfo;
TStartupInfo = record
cb: Longint;
lpReserved: Pointer;
lpDesktop: Pointer;
lpTitle: Pointer;
dwX: Longint;
dwY: Longint;
dwXSize: Longint;
dwYSize: Longint;
dwXCountChars: Longint;
dwYCountChars: Longint;
dwFillAttribute: Longint;
dwFlags: Longint;
wShowWindow: Word;
cbReserved2: Word;
lpReserved2: ^Byte;
hStdInput: Integer;
hStdOutput: Integer;
hStdError: Integer;
end;
TWin32FindData = packed record
dwFileAttributes: Integer;
ftCreationTime: Int64;
ftLastAccessTime: Int64;
ftLastWriteTime: Int64;
nFileSizeHigh: Integer;
nFileSizeLow: Integer;
dwReserved0: Integer;
dwReserved1: Integer;
cFileName: array[0..259] of Char;
cAlternateFileName: array[0..13] of Char;
end;
procedure CloseHandle; external kernel name 'CloseHandle';
procedure CreateFileA; external kernel name 'CreateFileA';
procedure DeleteFileA; external kernel name 'DeleteFileA';
procedure GetFileType; external kernel name 'GetFileType';
procedure GetSystemTime; external kernel name 'GetSystemTime';
procedure GetFileSize; external kernel name 'GetFileSize';
procedure GetStdHandle; external kernel name 'GetStdHandle';
//procedure GetStartupInfo; external kernel name 'GetStartupInfo';
procedure MoveFileA; external kernel name 'MoveFileA';
procedure RaiseException; external kernel name 'RaiseException';
procedure ReadFile; external kernel name 'ReadFile';
procedure RtlUnwind; external kernel name 'RtlUnwind';
procedure SetEndOfFile; external kernel name 'SetEndOfFile';
procedure SetFilePointer; external kernel name 'SetFilePointer';
procedure UnhandledExceptionFilter; external kernel name 'UnhandledExceptionFilter';
procedure WriteFile; external kernel name 'WriteFile';
function CharNext(lpsz: PChar): PChar; stdcall;
external user name 'CharNextA';
function CreateThread(SecurityAttributes: Pointer; StackSize: LongWord;
ThreadFunc: TThreadFunc; Parameter: Pointer;
CreationFlags: LongWord; var ThreadId: LongWord): Integer; stdcall;
external kernel name 'CreateThread';
procedure ExitThread(ExitCode: Integer); stdcall;
external kernel name 'ExitThread';
procedure ExitProcess(ExitCode: Integer); stdcall;
external kernel name 'ExitProcess';
procedure MessageBox(Wnd: Integer; Text: PChar; Caption: PChar; Typ: Integer); stdcall;
external user name 'MessageBoxA';
function CreateDirectory(PathName: PChar; Attr: Integer): WordBool; stdcall;
external kernel name 'CreateDirectoryA';
function FindClose(FindFile: Integer): LongBool; stdcall;
external kernel name 'FindClose';
function FindFirstFile(FileName: PChar; var FindFileData: TWIN32FindData): Integer; stdcall;
external kernel name 'FindFirstFileA';
{X} //function FreeLibrary(ModuleHandle: Longint): LongBool; stdcall;
{X} // external kernel name 'FreeLibrary';
{X} //function GetCommandLine: PChar; stdcall;
{X} // external kernel name 'GetCommandLineA';
function GetCurrentDirectory(BufSize: Integer; Buffer: PChar): Integer; stdcall;
external kernel name 'GetCurrentDirectoryA';
function GetLastError: Integer; stdcall;
external kernel name 'GetLastError';
function GetLocaleInfo(Locale: Longint; LCType: Longint; lpLCData: PChar; cchData: Integer): Integer; stdcall;
external kernel name 'GetLocaleInfoA';
{X} //function GetModuleFileName(Module: Integer; Filename: PChar;
{X} // Size: Integer): Integer; stdcall;
{X} // external kernel name 'GetModuleFileNameA';
{X} //function GetModuleHandle(ModuleName: PChar): Integer; stdcall;
{X} // external kernel name 'GetModuleHandleA';
function GetProcAddress(Module: Integer; ProcName: PChar): Pointer; stdcall;
external kernel name 'GetProcAddress';
procedure GetStartupInfo(var lpStartupInfo: TStartupInfo); stdcall;
external kernel name 'GetStartupInfoA';
function GetThreadLocale: Longint; stdcall;
external kernel name 'GetThreadLocale';
function LoadLibraryEx(LibName: PChar; hFile: Longint; Flags: Longint): Longint; stdcall;
external kernel name 'LoadLibraryExA';
function LoadString(Instance: Longint; IDent: Integer; Buffer: PChar;
Size: Integer): Integer; stdcall;
external user name 'LoadStringA';
{function lstrcat(lpString1, lpString2: PChar): PChar; stdcall;
external kernel name 'lstrcatA';}
function lstrcpy(lpString1, lpString2: PChar): PChar; stdcall;
external kernel name 'lstrcpyA';
function lstrcpyn(lpString1, lpString2: PChar;
iMaxLength: Integer): PChar; stdcall;
external kernel name 'lstrcpynA';
function lstrlen(lpString: PChar): Integer; stdcall;
external kernel name 'lstrlenA';
function MultiByteToWideChar(CodePage, Flags: Integer; MBStr: PChar;
MBCount: Integer; WCStr: PWideChar; WCCount: Integer): Integer; stdcall;
external kernel name 'MultiByteToWideChar';
function RegCloseKey(hKey: Integer): Longint; stdcall;
external advapi32 name 'RegCloseKey';
function RegOpenKeyEx(hKey: LongWord; lpSubKey: PChar; ulOptions,
samDesired: LongWord; var phkResult: LongWord): Longint; stdcall;
external advapi32 name 'RegOpenKeyExA';
function RegQueryValueEx(hKey: LongWord; lpValueName: PChar;
lpReserved: Pointer; lpType: Pointer; lpData: PChar; lpcbData: Pointer): Integer; stdcall;
external advapi32 name 'RegQueryValueExA';
function RemoveDirectory(PathName: PChar): WordBool; stdcall;
external kernel name 'RemoveDirectoryA';
function SetCurrentDirectory(PathName: PChar): WordBool; stdcall;
external kernel name 'SetCurrentDirectoryA';
function WideCharToMultiByte(CodePage, Flags: Integer; WCStr: PWideChar;
WCCount: Integer; MBStr: PChar; MBCount: Integer; DefaultChar: PChar;
UsedDefaultChar: Pointer): Integer; stdcall;
external kernel name 'WideCharToMultiByte';
function VirtualQuery(lpAddress: Pointer;
var lpBuffer: TMemInfo; dwLength: Longint): Longint; stdcall;
external kernel name 'VirtualQuery';
//function SysAllocString(P: PWideChar): PWideChar; stdcall;
// external oleaut name 'SysAllocString';
function SysAllocStringLen(P: PWideChar; Len: Integer): PWideChar; stdcall;
external oleaut name 'SysAllocStringLen';
function SysReAllocStringLen(var S: WideString; P: PWideChar;
Len: Integer): LongBool; stdcall;
external oleaut name 'SysReAllocStringLen';
procedure SysFreeString(const S: WideString); stdcall;
external oleaut name 'SysFreeString';
function SysStringLen(const S: WideString): Integer; stdcall;
external oleaut name 'SysStringLen';
//procedure VariantInit(var V: Variant); stdcall;
// external oleaut name 'VariantInit';
function VariantClear(var V: Variant): Integer; stdcall;
external oleaut name 'VariantClear';
function VariantCopy(var Dest: Variant; const Source: Variant): Integer; stdcall;
external oleaut name 'VariantCopy';
function VariantCopyInd(var Dest: Variant; const Source: Variant): Integer; stdcall;
external oleaut name 'VariantCopyInd';
//function VariantChangeType(var Dest: Variant; const Source: Variant;
// Flags: Word; VarType: Word): Integer; stdcall;
// external oleaut name 'VariantChangeType';
function VariantChangeTypeEx(var Dest: Variant; const Source: Variant;
LCID: Integer; Flags: Word; VarType: Word): Integer; stdcall;
external oleaut name 'VariantChangeTypeEx';
function SafeArrayCreate(VarType, DimCount: Integer;
const Bounds): PVarArray; stdcall;
external oleaut name 'SafeArrayCreate';
function SafeArrayRedim(VarArray: PVarArray;
var NewBound: TVarArrayBound): Integer; stdcall;
external oleaut name 'SafeArrayRedim';
function SafeArrayGetLBound(VarArray: PVarArray; Dim: Integer;
var LBound: Integer): Integer; stdcall;
external oleaut name 'SafeArrayGetLBound';
function SafeArrayGetUBound(VarArray: PVarArray; Dim: Integer;
var UBound: Integer): Integer; stdcall;
external oleaut name 'SafeArrayGetUBound';
function SafeArrayAccessData(VarArray: PVarArray;
var Data: Pointer): Integer; stdcall;
external oleaut name 'SafeArrayAccessData';
function SafeArrayUnaccessData(VarArray: PVarArray): Integer; stdcall;
external oleaut name 'SafeArrayUnaccessData';
function SafeArrayGetElement(VarArray: PVarArray; Indices,
Data: Pointer): Integer; stdcall;
external oleaut name 'SafeArrayGetElement';
function SafeArrayPtrOfIndex(VarArray: PVarArray; Indices: Pointer;
var pvData: Pointer): HResult; stdcall;
external oleaut name 'SafeArrayPtrOfIndex';
function SafeArrayPutElement(VarArray: PVarArray; Indices,
Data: Pointer): Integer; stdcall;
external oleaut name 'SafeArrayPutElement';
function InterlockedIncrement(var Addend: Integer): Integer; stdcall;
external kernel name 'InterlockedIncrement';
function InterlockedDecrement(var Addend: Integer): Integer; stdcall;
external kernel name 'InterlockedDecrement';
var SaveCmdShow : Integer = -1;
function CmdShow: Integer;
var
SI: TStartupInfo;
begin
if SaveCmdShow < 0 then
begin
SaveCmdShow := 10; { SW_SHOWDEFAULT }
GetStartupInfo(SI);
if SI.dwFlags and 1 <> 0 then { STARTF_USESHOWWINDOW }
SaveCmdShow := SI.wShowWindow;
end;
Result := SaveCmdShow;
end;
{ ----------------------------------------------------- }
{ Memory manager }
{ ----------------------------------------------------- }
procedure Error(errorCode: Byte); forward;
{$I GETMEM.INC }
{X- by default, system memory allocation routines (API calls)
are used. To use Inprise's memory manager (Delphi standard)
call UseDelphiMemoryManager procedure. }
var
MemoryManager: TMemoryManager = (
GetMem: DfltGetMem;
FreeMem: DfltFreeMem;
ReallocMem: DfltReallocMem);
const
DelphiMemoryManager: TMemoryManager = (
GetMem: SysGetMem;
FreeMem: SysFreeMem;
ReallocMem: SysReallocMem);
procedure UseDelphiMemoryManager;
begin
IsMemoryManagerSet := IsDelphiMemoryManagerSet;
SetMemoryManager( DelphiMemoryManager );
end;
{X+}
procedure _GetMem;
asm
TEST EAX,EAX
JE @@1
CALL MemoryManager.GetMem
OR EAX,EAX
JE @@2
@@1: RET
@@2: MOV AL,reOutOfMemory
JMP Error
end;
procedure _FreeMem;
asm
TEST EAX,EAX
JE @@1
CALL MemoryManager.FreeMem
OR EAX,EAX
JNE @@2
@@1: RET
@@2: MOV AL,reInvalidPtr
JMP Error
end;
procedure _ReallocMem;
asm
MOV ECX,[EAX]
TEST ECX,ECX
JE @@alloc
TEST EDX,EDX
JE @@free
@@resize:
PUSH EAX
MOV EAX,ECX
CALL MemoryManager.ReallocMem
POP ECX
OR EAX,EAX
JE @@allocError
MOV [ECX],EAX
RET
@@freeError:
MOV AL,reInvalidPtr
JMP Error
@@free:
MOV [EAX],EDX
MOV EAX,ECX
CALL MemoryManager.FreeMem
OR EAX,EAX
JNE @@freeError
RET
@@allocError:
MOV AL,reOutOfMemory
JMP Error
@@alloc:
TEST EDX,EDX
JE @@exit
PUSH EAX
MOV EAX,EDX
CALL MemoryManager.GetMem
POP ECX
OR EAX,EAX
JE @@allocError
MOV [ECX],EAX
@@exit:
end;
procedure GetMemoryManager(var MemMgr: TMemoryManager);
begin
MemMgr := MemoryManager;
end;
procedure SetMemoryManager(const MemMgr: TMemoryManager);
begin
MemoryManager := MemMgr;
end;
//{X} - function is replaced with pointer to one.
// function IsMemoryManagerSet: Boolean;
function IsDelphiMemoryManagerSet;
begin
with MemoryManager do
Result := (@GetMem <> @SysGetMem) or (@FreeMem <> @SysFreeMem) or
(@ReallocMem <> @SysReallocMem);
end;
{X+ always returns False. Initial handler for IsMemoryManagerSet }
function MemoryManagerNotUsed : Boolean;
begin
Result := False;
end;
{X-}
threadvar
RaiseListPtr: pointer;
InOutRes: Integer;
function RaiseList: Pointer;
asm
CALL SysInit.@GetTLS
MOV EAX, [EAX].RaiseListPtr
end;
function SetRaiseList(NewPtr: Pointer): Pointer;
asm
MOV ECX, EAX
CALL SysInit.@GetTLS
MOV EDX, [EAX].RaiseListPtr
MOV [EAX].RaiseListPtr, ECX
MOV EAX, EDX
end;
{ ----------------------------------------------------- }
{ local functions & procedures of the system unit }
{ ----------------------------------------------------- }
procedure Error(errorCode: Byte);
asm
AND EAX,127
MOV ECX,ErrorProc
TEST ECX,ECX
JE @@term
POP EDX
CALL ECX
@@term:
DEC EAX
MOV AL,byte ptr @@errorTable[EAX]
JNS @@skip
CALL SysInit.@GetTLS
MOV EAX,[EAX].InOutRes
@@skip:
JMP _RunError
@@errorTable:
DB 203 { reOutOfMemory }
DB 204 { reInvalidPtr }
DB 200 { reDivByZero }
DB 201 { reRangeError }
{ 210 abstract error }
DB 215 { reIntOverflow }
DB 207 { reInvalidOp }
DB 200 { reZeroDivide }
DB 205 { reOverflow }
DB 206 { reUnderflow }
DB 219 { reInvalidCast }
DB 216 { Access violation }
DB 202 { Stack overflow }
DB 217 { Control-C }
DB 218 { Privileged instruction }
DB 220 { Invalid variant type cast }
DB 221 { Invalid variant operation }
DB 222 { No variant method call dispatcher }
DB 223 { Cannot create variant array }
DB 224 { Variant does not contain an array }
DB 225 { Variant array bounds error }
{ 226 thread init failure }
DB 227 { reAssertionFailed }
DB 0 { reExternalException not used here; in SysUtils }
DB 228 { reIntfCastError }
DB 229 { reSafeCallError }
end;
procedure __IOTest;
asm
PUSH EAX
PUSH EDX
PUSH ECX
CALL SysInit.@GetTLS
CMP [EAX].InOutRes,0
POP ECX
POP EDX
POP EAX
JNE @error
RET
@error:
XOR EAX,EAX
JMP Error
end;
procedure SetInOutRes;
asm
PUSH EAX
CALL SysInit.@GetTLS
POP [EAX].InOutRes
end;
procedure InOutError;
asm
CALL GetLastError
JMP SetInOutRes
end;
procedure _ChDir(const S: string);
begin
if not SetCurrentDirectory(PChar(S)) then InOutError;
end;
procedure _Copy{ s : ShortString; index, count : Integer ) : ShortString};
asm
{ ->EAX Source string }
{ EDX index }
{ ECX count }
{ [ESP+4] Pointer to result string }
PUSH ESI
PUSH EDI
MOV ESI,EAX
MOV EDI,[ESP+8+4]
XOR EAX,EAX
OR AL,[ESI]
JZ @@srcEmpty
{ limit index to satisfy 1 <= index <= Length(src) }
TEST EDX,EDX
JLE @@smallInx
CMP EDX,EAX
JG @@bigInx
@@cont1:
{ limit count to satisfy 0 <= count <= Length(src) - index + 1 }
SUB EAX,EDX { calculate Length(src) - index + 1 }
INC EAX
TEST ECX,ECX
JL @@smallCount
CMP ECX,EAX
JG @@bigCount
@@cont2:
ADD ESI,EDX
MOV [EDI],CL
INC EDI
REP MOVSB
JMP @@exit
@@smallInx:
MOV EDX,1
JMP @@cont1
@@bigInx:
{ MOV EDX,EAX
JMP @@cont1 }
@@smallCount:
XOR ECX,ECX
JMP @@cont2
@@bigCount:
MOV ECX,EAX
JMP @@cont2
@@srcEmpty:
MOV [EDI],AL
@@exit:
POP EDI
POP ESI
RET 4
end;
procedure _Delete{ var s : openstring; index, count : Integer };
asm
{ ->EAX Pointer to s }
{ EDX index }
{ ECX count }
PUSH ESI
PUSH EDI
MOV EDI,EAX
XOR EAX,EAX
MOV AL,[EDI]
{ if index not in [1 .. Length(s)] do nothing }
TEST EDX,EDX
JLE @@exit
CMP EDX,EAX
JG @@exit
{ limit count to [0 .. Length(s) - index + 1] }
TEST ECX,ECX
JLE @@exit
SUB EAX,EDX { calculate Length(s) - index + 1 }
INC EAX
CMP ECX,EAX
JLE @@1
MOV ECX,EAX
@@1:
SUB [EDI],CL { reduce Length(s) by count }
ADD EDI,EDX { point EDI to first char to be deleted }
LEA ESI,[EDI+ECX] { point ESI to first char to be preserved }
SUB EAX,ECX { #chars = Length(s) - index + 1 - count }
MOV ECX,EAX
REP MOVSB
@@exit:
POP EDI
POP ESI
end;
procedure __Flush( var f : Text );
external; { Assign }
procedure _Flush( var f : Text );
external; { Assign }
procedure _LGetDir(D: Byte; var S: string);
var
Drive: array[0..3] of Char;
DirBuf, SaveBuf: array[0..259] of Char;
begin
if D <> 0 then
begin
Drive[0] := Chr(D + Ord('A') - 1);
Drive[1] := ':';
Drive[2] := #0;
GetCurrentDirectory(SizeOf(SaveBuf), SaveBuf);
SetCurrentDirectory(Drive);
end;
GetCurrentDirectory(SizeOf(DirBuf), DirBuf);
if D <> 0 then SetCurrentDirectory(SaveBuf);
S := DirBuf;
end;
procedure _SGetDir(D: Byte; var S: ShortString);
var
L: string;
begin
GetDir(D, L);
S := L;
end;
procedure _Insert{ source : ShortString; var s : openstring; index : Integer };
asm
{ ->EAX Pointer to source string }
{ EDX Pointer to destination string }
{ ECX Length of destination string }
{ [ESP+4] Index }
PUSH EBX
PUSH ESI
PUSH EDI
PUSH ECX
MOV ECX,[ESP+16+4]
SUB ESP,512 { VAR buf: ARRAY [0..511] of Char }
MOV EBX,EDX { save pointer to s for later }
MOV ESI,EDX
XOR EDX,EDX
MOV DL,[ESI]
INC ESI
{ limit index to [1 .. Length(s)+1] }
INC EDX
TEST ECX,ECX
JLE @@smallInx
CMP ECX,EDX
JG @@bigInx
@@cont1:
DEC EDX { EDX = Length(s) }
{ EAX = Pointer to src }
{ ESI = EBX = Pointer to s }
{ ECX = Index }
{ copy index-1 chars from s to buf }
MOV EDI,ESP
DEC ECX
SUB EDX,ECX { EDX = remaining length of s }
REP MOVSB
{ copy Length(src) chars from src to buf }
XCHG EAX,ESI { save pointer into s, point ESI to src }
MOV CL,[ESI] { ECX = Length(src) (ECX was zero after rep) }
INC ESI
REP MOVSB
{ copy remaining chars of s to buf }
MOV ESI,EAX { restore pointer into s }
MOV ECX,EDX { copy remaining bytes of s }
REP MOVSB
{ calculate total chars in buf }
SUB EDI,ESP { length = bufPtr - buf }
MOV ECX,[ESP+512] { ECX = Min(length, destLength) }
{ MOV ECX,[EBP-16] }{ ECX = Min(length, destLength) }
CMP ECX,EDI
JB @@1
MOV ECX,EDI
@@1:
MOV EDI,EBX { Point EDI to s }
MOV ESI,ESP { Point ESI to buf }
MOV [EDI],CL { Store length in s }
INC EDI
REP MOVSB { Copy length chars to s }
JMP @@exit
@@smallInx:
MOV ECX,1
JMP @@cont1
@@bigInx:
MOV ECX,EDX
JMP @@cont1
@@exit:
ADD ESP,512+4
POP EDI
POP ESI
POP EBX
RET 4
end;
function IOResult: Integer;
asm
CALL SysInit.@GetTLS
XOR EDX,EDX
MOV ECX,[EAX].InOutRes
MOV [EAX].InOutRes,EDX
MOV EAX,ECX
end;
procedure _MkDir(const S: string);
begin
if not CreateDirectory(PChar(S), 0) then InOutError;
end;
procedure Move( const Source; var Dest; count : Integer );
asm
{ ->EAX Pointer to source }
{ EDX Pointer to destination }
{ ECX Count }
(*{X-} // original code.
PUSH ESI
PUSH EDI
MOV ESI,EAX
MOV EDI,EDX
MOV EAX,ECX
CMP EDI,ESI
JA @@down
JE @@exit
SAR ECX,2 { copy count DIV 4 dwords }
JS @@exit
REP MOVSD
MOV ECX,EAX
AND ECX,03H
REP MOVSB { copy count MOD 4 bytes }
JMP @@exit
@@down:
LEA ESI,[ESI+ECX-4] { point ESI to last dword of source }
LEA EDI,[EDI+ECX-4] { point EDI to last dword of dest }
SAR ECX,2 { copy count DIV 4 dwords }
JS @@exit
STD
REP MOVSD
MOV ECX,EAX
AND ECX,03H { copy count MOD 4 bytes }
ADD ESI,4-1 { point to last byte of rest }
ADD EDI,4-1
REP MOVSB
CLD
@@exit:
POP EDI
POP ESI
*){X+}
//---------------------------------------
(* {X+} // Let us write smaller:
JCXZ @@fin
PUSH ESI
PUSH EDI
MOV ESI,EAX
MOV EDI,EDX
MOV EAX,ECX
AND ECX,3 { copy count mod 4 dwords }
CMP EDI,ESI
JE @@exit
JA @@up
//down:
LEA ESI,[ESI+EAX-1] { point ESI to last byte of source }
LEA EDI,[EDI+EAX-1] { point EDI to last byte of dest }
STD
CMP EAX, 4
JL @@up
ADD ECX, 3 { move 3 bytes more to correct pos }
@@up:
REP MOVSB
SAR EAX, 2
JS @@exit
MOV ECX, EAX
REP MOVSD
@@exit:
CLD
POP EDI
POP ESI
@@fin:
*) {X-}
//---------------------------------------
{X+} // And now, let us write speedy:
CMP ECX, 4
JGE @@long
JCXZ @@fin
CMP EAX, EDX
JE @@fin
PUSH ESI
PUSH EDI
MOV ESI, EAX
MOV EDI, EDX
JA @@short_up
LEA ESI,[ESI+ECX-1] { point ESI to last byte of source }
LEA EDI,[EDI+ECX-1] { point EDI to last byte of dest }
STD
@@short_up:
REP MOVSB
JMP @@exit_up
@@long:
CMP EAX, EDX
JE @@fin
PUSH ESI
PUSH EDI
MOV ESI, EAX
MOV EDI, EDX
MOV EAX, ECX
JA @@long_up
{
SAR ECX, 2
JS @@exit
LEA ESI,[ESI+EAX-4]
LEA EDI,[EDI+EAX-4]
STD
REP MOVSD
MOV ECX, EAX
MOV EAX, 3
AND ECX, EAX
ADD ESI, EAX
ADD EDI, EAX
REP MOVSB
} // let's do it in other order - faster if data are aligned...
AND ECX, 3
LEA ESI,[ESI+EAX-1]
LEA EDI,[EDI+EAX-1]
STD
REP MOVSB
SAR EAX, 2
//JS @@exit // why to test this? but what does PC do?
MOV ECX, EAX
MOV EAX, 3
SUB ESI, EAX
SUB EDI, EAX
REP MOVSD
@@exit_up:
CLD
//JMP @@exit
DEC ECX // the same - loosing 2 tacts... but conveyer!
@@long_up:
SAR ECX, 2
JS @@exit
REP MOVSD
AND EAX, 3
MOV ECX, EAX
REP MOVSB
@@exit:
POP EDI
POP ESI
@@fin:
{X-}
end;
function GetParamStr(P: PChar; var Param: string): PChar;
var
Len: Integer;
Buffer: array[0..4095] of Char;
begin
while True do
begin
while (P[0] <> #0) and (P[0] <= ' ') do Inc(P);
if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break;
end;
Len := 0;
while (P[0] > ' ') and (Len < SizeOf(Buffer)) do
if P[0] = '"' then
begin
Inc(P);
while (P[0] <> #0) and (P[0] <> '"') do
begin
Buffer[Len] := P[0];
Inc(Len);
Inc(P);
end;
if P[0] <> #0 then Inc(P);
end else
begin
Buffer[Len] := P[0];
Inc(Len);
Inc(P);
end;
SetString(Param, Buffer, Len);
Result := P;
end;
function ParamCount: Integer;
var
P: PChar;
S: string;
begin
P := GetParamStr(GetCommandLine, S);
Result := 0;
while True do
begin
P := GetParamStr(P, S);
if S = '' then Break;
Inc(Result);
end;
end;
function ParamStr(Index: Integer): string;
var
P: PChar;
Buffer: array[0..260] of Char;
begin
if Index = 0 then
SetString(Result, Buffer, GetModuleFileName(0, Buffer, SizeOf(Buffer)))
else
begin
P := GetCommandLine;
while True do
begin
P := GetParamStr(P, Result);
if (Index = 0) or (Result = '') then Break;
Dec(Index);
end;
end;
end;
procedure _Pos{ substr : ShortString; s : ShortString ) : Integer};
asm
{ ->EAX Pointer to substr }
{ EDX Pointer to string }
{ <-EAX Position of substr in s or 0 }
PUSH EBX
PUSH ESI
PUSH EDI
MOV ESI,EAX { Point ESI to substr }
MOV EDI,EDX { Point EDI to s }
XOR ECX,ECX { ECX = Length(s) }
MOV CL,[EDI]
INC EDI { Point EDI to first char of s }
PUSH EDI { remember s position to calculate index }
XOR EDX,EDX { EDX = Length(substr) }
MOV DL,[ESI]
INC ESI { Point ESI to first char of substr }
DEC EDX { EDX = Length(substr) - 1 }
JS @@fail { < 0 ? return 0 }
MOV AL,[ESI] { AL = first char of substr }
INC ESI { Point ESI to 2'nd char of substr }
SUB ECX,EDX { #positions in s to look at }
{ = Length(s) - Length(substr) + 1 }
JLE @@fail
@@loop:
REPNE SCASB
JNE @@fail
MOV EBX,ECX { save outer loop counter }
PUSH ESI { save outer loop substr pointer }
PUSH EDI { save outer loop s pointer }
MOV ECX,EDX
REPE CMPSB
POP EDI { restore outer loop s pointer }
POP ESI { restore outer loop substr pointer }
JE @@found
MOV ECX,EBX { restore outer loop counter }
JMP @@loop
@@fail:
POP EDX { get rid of saved s pointer }
XOR EAX,EAX
JMP @@exit
@@found:
POP EDX { restore pointer to first char of s }
MOV EAX,EDI { EDI points of char after match }
SUB EAX,EDX { the difference is the correct index }
@@exit:
POP EDI
POP ESI
POP EBX
end;
procedure _SetLength{var s: ShortString; newLength: Integer};
asm
{ -> EAX pointer to string }
{ EDX new length }
MOV [EAX],DL { should also fill new space, parameter should be openstring }
end;
procedure _SetString{var s: ShortString: buffer: PChar; len: Integer};
asm
{ -> EAX pointer to string }
{ EDX pointer to buffer }
{ ECX len }
MOV [EAX],CL
TEST EDX,EDX
JE @@noMove
XCHG EAX,EDX
INC EDX
CALL Move
@@noMove:
end;
procedure Randomize;
var
systemTime :
record
wYear : Word;
wMonth : Word;
wDayOfWeek : Word;
wDay : Word;
wHour : Word;
wMinute : Word;
wSecond : Word;
wMilliSeconds: Word;
reserved : array [0..7] of char;
end;
asm
LEA EAX,systemTime
PUSH EAX
CALL GetSystemTime
MOVZX EAX,systemTime.wHour
IMUL EAX,60
ADD AX,systemTime.wMinute { sum = hours * 60 + minutes }
IMUL EAX,60
XOR EDX,EDX
MOV DX,systemTime.wSecond
ADD EAX,EDX { sum = sum * 60 + seconds }
IMUL EAX,1000
MOV DX,systemTime.wMilliSeconds
ADD EAX,EDX { sum = sum * 1000 + milliseconds }
MOV RandSeed,EAX
end;
procedure _RmDir(const S: string);
begin
if not RemoveDirectory(PChar(S)) then InOutError;
end;
function UpCase( ch : Char ) : Char;
asm
{ -> AL Character }
{ <- AL Result }
CMP AL,'a'
JB @@exit
CMP AL,'z'
JA @@exit
SUB AL,'a' - 'A'
@@exit:
end;
procedure Set8087CW(NewCW: Word);
asm
MOV Default8087CW,AX
FNCLEX // don't raise pending exceptions enabled by the new flags
FLDCW Default8087CW
end;
{ ----------------------------------------------------- }
{ functions & procedures that need compiler magic }
{ ----------------------------------------------------- }
const cwChop : Word = $1F32;
procedure _COS;
asm
FCOS
FNSTSW AX
SAHF
JP @@outOfRange
RET
@@outOfRange:
FSTP st(0) { for now, return 0. result would }
FLDZ { have little significance anyway }
end;
procedure _EXP;
asm
{ e**x = 2**(x*log2(e)) }
FLDL2E { y := x*log2e; }
FMUL
FLD ST(0) { i := round(y); }
FRNDINT
FSUB ST(1), ST { f := y - i; }
FXCH ST(1) { z := 2**f }
F2XM1
FLD1
FADD
FSCALE { result := z * 2**i }
FSTP ST(1)
end;
procedure _INT;
asm
SUB ESP,4
FSTCW [ESP]
FWAIT
FLDCW cwChop
FRNDINT
FWAIT
FLDCW [ESP]
ADD ESP,4
end;
procedure _SIN;
asm
FSIN
FNSTSW AX
SAHF
JP @@outOfRange
RET
@@outOfRange:
FSTP st(0) { for now, return 0. result would }
FLDZ { have little significance anyway }
end;
procedure _FRAC;
asm
FLD ST(0)
SUB ESP,4
FSTCW [ESP]
FWAIT
FLDCW cwChop
FRNDINT
FWAIT
FLDCW [ESP]
ADD ESP,4
FSUB
end;
procedure _ROUND;
asm
{ -> FST(0) Extended argument }
{ <- EDX:EAX Result }
SUB ESP,8
FISTP qword ptr [ESP]
FWAIT
POP EAX
POP EDX
end;
procedure _TRUNC;
asm
{ -> FST(0) Extended argument }
{ <- EDX:EAX Result }
SUB ESP,12
FSTCW [ESP]
FWAIT
FLDCW cwChop
FISTP qword ptr [ESP+4]
FWAIT
FLDCW [ESP]
POP ECX
POP EAX
POP EDX
end;
procedure _AbstractError;
asm
CMP AbstractErrorProc, 0
JE @@NoAbstErrProc
CALL AbstractErrorProc
@@NoAbstErrProc:
MOV EAX,210
JMP _RunError
end;
procedure _Append; external; { OpenText}
procedure _Assign(var t: text; s: ShortString); external; {$L Assign }
procedure _BlockRead; external; {$L BlockRea}
procedure _BlockWrite; external; {$L BlockWri}
procedure _Close; external; {$L Close }
procedure _PStrCat;
asm
{ ->EAX = Pointer to destination string }
{ EDX = Pointer to source string }
PUSH ESI
PUSH EDI
{ load dest len into EAX }
MOV EDI,EAX
XOR EAX,EAX
MOV AL,[EDI]
{ load source address in ESI, source len in ECX }
MOV ESI,EDX
XOR ECX,ECX
MOV CL,[ESI]
INC ESI
{ calculate final length in DL and store it in the destination }
MOV DL,AL
ADD DL,CL
JC @@trunc
@@cont:
MOV [EDI],DL
{ calculate final dest address }
INC EDI
ADD EDI,EAX
{ do the copy }
REP MOVSB
{ done }
POP EDI
POP ESI
RET
@@trunc:
INC DL { DL = #chars to truncate }
SUB CL,DL { CL = source len - #chars to truncate }
MOV DL,255 { DL = maximum length }
JMP @@cont
end;
procedure _PStrNCat;
asm
{ ->EAX = Pointer to destination string }
{ EDX = Pointer to source string }
{ CL = max length of result (allocated size of dest - 1) }
PUSH ESI
PUSH EDI
{ load dest len into EAX }
MOV EDI,EAX
XOR EAX,EAX
MOV AL,[EDI]
{ load source address in ESI, source len in EDX }
MOV ESI,EDX
XOR EDX,EDX
MOV DL,[ESI]
INC ESI
{ calculate final length in AL and store it in the destination }
ADD AL,DL
JC @@trunc
CMP AL,CL
JA @@trunc
@@cont:
MOV ECX,EDX
MOV DL,[EDI]
MOV [EDI],AL
{ calculate final dest address }
INC EDI
ADD EDI,EDX
{ do the copy }
REP MOVSB
@@done:
POP EDI
POP ESI
RET
@@trunc:
{ CL = maxlen }
MOV AL,CL { AL = final length = maxlen }
SUB CL,[EDI] { CL = length to copy = maxlen - destlen }
JBE @@done
MOV DL,CL
JMP @@cont
end;
procedure _PStrCpy;
asm
{ ->EAX = Pointer to dest string }
{ EDX = Pointer to source string }
XOR ECX,ECX
PUSH ESI
PUSH EDI
MOV CL,[EDX]
MOV EDI,EAX
INC ECX { we must copy len+1 bytes }
MOV ESI,EDX
MOV EAX,ECX
SHR ECX,2
AND EAX,3
REP MOVSD
MOV ECX,EAX
REP MOVSB
POP EDI
POP ESI
end;
procedure _PStrNCpy;
asm
{ ->EAX = Pointer to dest string }
{ EDX = Pointer to source string }
{ CL = Maximum length to copy (allocated size of dest - 1) }
PUSH ESI
PUSH EDI
MOV EDI,EAX
XOR EAX,EAX
MOV ESI,EDX
MOV AL,[EDX]
CMP AL,CL
JA @@trunc
INC EAX
MOV ECX,EAX
AND EAX,3
SHR ECX,2
REP MOVSD
MOV ECX,EAX
REP MOVSB
POP EDI
POP ESI
RET
@@trunc:
MOV [EDI],CL { result length is maxLen }
INC ESI { advance pointers }
INC EDI
AND ECX,0FFH { should be cheaper than MOVZX }
REP MOVSB { copy maxLen bytes }
POP EDI
POP ESI
end;
procedure _PStrCmp;
asm
{ ->EAX = Pointer to left string }
{ EDX = Pointer to right string }
PUSH EBX
PUSH ESI
PUSH EDI
MOV ESI,EAX
MOV EDI,EDX
XOR EAX,EAX
XOR EDX,EDX
MOV AL,[ESI]
MOV DL,[EDI]
INC ESI
INC EDI
SUB EAX,EDX { eax = len1 - len2 }
JA @@skip1
ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 }
@@skip1:
PUSH EDX
SHR EDX,2
JE @@cmpRest
@@longLoop:
MOV ECX,[ESI]
MOV EBX,[EDI]
CMP ECX,EBX
JNE @@misMatch
DEC EDX
JE @@cmpRestP4
MOV ECX,[ESI+4]
MOV EBX,[EDI+4]
CMP ECX,EBX
JNE @@misMatch
ADD ESI,8
ADD EDI,8
DEC EDX
JNE @@longLoop
JMP @@cmpRest
@@cmpRestP4:
ADD ESI,4
ADD EDI,4
@@cmpRest:
POP EDX
AND EDX,3
JE @@equal
MOV CL,[ESI]
CMP CL,[EDI]
JNE @@exit
DEC EDX
JE @@equal
MOV CL,[ESI+1]
CMP CL,[EDI+1]
JNE @@exit
DEC EDX
JE @@equal
MOV CL,[ESI+2]
CMP CL,[EDI+2]
JNE @@exit
@@equal:
ADD EAX,EAX
JMP @@exit
@@misMatch:
POP EDX
CMP CL,BL
JNE @@exit
CMP CH,BH
JNE @@exit
SHR ECX,16
SHR EBX,16
CMP CL,BL
JNE @@exit
CMP CH,BH
@@exit:
POP EDI
POP ESI
POP EBX
end;
procedure _AStrCmp;
asm
{ ->EAX = Pointer to left string }
{ EDX = Pointer to right string }
{ ECX = Number of chars to compare}
PUSH EBX
PUSH ESI
PUSH ECX
MOV ESI,ECX
SHR ESI,2
JE @@cmpRest
@@longLoop:
MOV ECX,[EAX]
MOV EBX,[EDX]
CMP ECX,EBX
JNE @@misMatch
DEC ESI
JE @@cmpRestP4
MOV ECX,[EAX+4]
MOV EBX,[EDX+4]
CMP ECX,EBX
JNE @@misMatch
ADD EAX,8
ADD EDX,8
DEC ESI
JNE @@longLoop
JMP @@cmpRest
@@cmpRestp4:
ADD EAX,4
ADD EDX,4
@@cmpRest:
POP ESI
AND ESI,3
JE @@exit
MOV CL,[EAX]
CMP CL,[EDX]
JNE @@exit
DEC ESI
JE @@equal
MOV CL,[EAX+1]
CMP CL,[EDX+1]
JNE @@exit
DEC ESI
JE @@equal
MOV CL,[EAX+2]
CMP CL,[EDX+2]
JNE @@exit
@@equal:
XOR EAX,EAX
JMP @@exit
@@misMatch:
POP ESI
CMP CL,BL
JNE @@exit
CMP CH,BH
JNE @@exit
SHR ECX,16
SHR EBX,16
CMP CL,BL
JNE @@exit
CMP CH,BH
@@exit:
POP ESI
POP EBX
end;
procedure _EofFile; external; {$L EofFile }
procedure _EofText; external; {$L EofText }
procedure _Eoln; external; {$L Eoln }
procedure _Erase; external; {$L Erase }
procedure _FSafeDivide; external; {$L FDIV }
procedure _FSafeDivideR; external; { FDIV }
procedure _FilePos; external; {$L FilePos }
procedure _FileSize; external; {$L FileSize}
procedure _FillChar;
asm
{ ->EAX Pointer to destination }
{ EDX count }
{ CL value }
PUSH EDI
MOV EDI,EAX { Point EDI to destination }
MOV CH,CL { Fill EAX with value repeated 4 times }
MOV EAX,ECX
SHL EAX,16
MOV AX,CX
MOV ECX,EDX
SAR ECX,2
JS @@exit
REP STOSD { Fill count DIV 4 dwords }
MOV ECX,EDX
AND ECX,3
REP STOSB { Fill count MOD 4 bytes }
@@exit:
POP EDI
end;
procedure _Mark;
begin
Error(reInvalidPtr);
end;
procedure _RandInt;
asm
{ ->EAX Range }
{ <-EAX Result }
IMUL EDX,RandSeed,08088405H
INC EDX
MOV RandSeed,EDX
MUL EDX
MOV EAX,EDX
end;
procedure _RandExt;
const two2neg32: double = ((1.0/$10000) / $10000); // 2^-32
asm
{ FUNCTION _RandExt: Extended; }
IMUL EDX,RandSeed,08088405H
INC EDX
MOV RandSeed,EDX
FLD two2neg32
PUSH 0
PUSH EDX
FILD qword ptr [ESP]
ADD ESP,8
FMULP ST(1), ST(0)
end;
procedure _ReadRec; external; {$L ReadRec }
procedure _ReadChar; external; {$L ReadChar}
procedure _ReadLong; external; {$L ReadLong}
procedure _ReadString; external; {$L ReadStri}
procedure _ReadCString; external; { ReadStri}
procedure _ReadExt; external; {$L ReadExt }
procedure _ReadLn; external; {$L ReadLn }
procedure _Rename; external; {$L Rename }
procedure _Release;
begin
Error(reInvalidPtr);
end;
procedure _ResetText(var t: text); external; {$L OpenText}
procedure _ResetFile; external; {$L OpenFile}
procedure _RewritText(var t: text); external; { OpenText}
procedure _RewritFile; external; { OpenFile}
procedure _Seek; external; {$L Seek }
procedure _SeekEof; external; {$L SeekEof }
procedure _SeekEoln; external; {$L SeekEoln}
procedure _SetTextBuf; external; {$L SetTextB}
procedure _StrLong;
asm
{ PROCEDURE _StrLong( val: Longint; width: Longint; VAR s: ShortString );
->EAX Value
EDX Width
ECX Pointer to string }
PUSH EBX { VAR i: Longint; }
PUSH ESI { VAR sign : Longint; }
PUSH EDI
PUSH EDX { store width on the stack }
SUB ESP,20 { VAR a: array [0..19] of Char; }
MOV EDI,ECX
MOV ESI,EAX { sign := val }
CDQ { val := Abs(val); canned sequence }
XOR EAX,EDX
SUB EAX,EDX
MOV ECX,10
XOR EBX,EBX { i := 0; }
@@repeat1: { repeat }
XOR EDX,EDX { a[i] := Chr( val MOD 10 + Ord('0') );}
DIV ECX { val := val DIV 10; }
ADD EDX,'0'
MOV [ESP+EBX],DL
INC EBX { i := i + 1; }
TEST EAX,EAX { until val = 0; }
JNZ @@repeat1
TEST ESI,ESI
JGE @@2
MOV byte ptr [ESP+EBX],'-'
INC EBX
@@2:
MOV [EDI],BL { s^++ := Chr(i); }
INC EDI
MOV ECX,[ESP+20] { spaceCnt := width - i; }
CMP ECX,255
JLE @@3
MOV ECX,255
@@3:
SUB ECX,EBX
JLE @@repeat2 { for k := 1 to spaceCnt do s^++ := ' '; }
ADD [EDI-1],CL
MOV AL,' '
REP STOSB
@@repeat2: { repeat }
MOV AL,[ESP+EBX-1] { s^ := a[i-1]; }
MOV [EDI],AL
INC EDI { s := s + 1 }
DEC EBX { i := i - 1; }
JNZ @@repeat2 { until i = 0; }
ADD ESP,20+4
POP EDI
POP ESI
POP EBX
end;
procedure _Str0Long;
asm
{ ->EAX Value }
{ EDX Pointer to string }
MOV ECX,EDX
XOR EDX,EDX
JMP _StrLong
end;
procedure _Truncate; external; {$L Truncate}
procedure _ValLong;
asm
{ FUNCTION _ValLong( s: AnsiString; VAR code: Integer ) : Longint; }
{ ->EAX Pointer to string }
{ EDX Pointer to code result }
{ <-EAX Result }
PUSH EBX
PUSH ESI
PUSH EDI
MOV ESI,EAX
PUSH EAX { save for the error case }
TEST EAX,EAX
JE @@empty
XOR EAX,EAX
XOR EBX,EBX
MOV EDI,07FFFFFFFH / 10 { limit }
@@blankLoop:
MOV BL,[ESI]
INC ESI
CMP BL,' '
JE @@blankLoop
@@endBlanks:
MOV CH,0
CMP BL,'-'
JE @@minus
CMP BL,'+'
JE @@plus
CMP BL,'$'
JE @@dollar
CMP BL, 'x'
JE @@dollar
CMP BL, 'X'
JE @@dollar
CMP BL, '0'
JNE @@firstDigit
MOV BL, [ESI]
INC ESI
CMP BL, 'x'
JE @@dollar
CMP BL, 'X'
JE @@dollar
TEST BL, BL
JE @@endDigits
JMP @@digLoop
@@firstDigit:
TEST BL,BL
JE @@error
@@digLoop:
SUB BL,'0'
CMP BL,9
JA @@error
CMP EAX,EDI { value > limit ? }
JA @@overFlow
LEA EAX,[EAX+EAX*4]
ADD EAX,EAX
ADD EAX,EBX { fortunately, we can't have a carry }
MOV BL,[ESI]
INC ESI
TEST BL,BL
JNE @@digLoop
@@endDigits:
DEC CH
JE @@negate
TEST EAX,EAX
JL @@overFlow
@@successExit:
POP ECX { saved copy of string pointer }
XOR ESI,ESI { signal no error to caller }
@@exit:
MOV [EDX],ESI
POP EDI
POP ESI
POP EBX
RET
@@empty:
INC ESI
JMP @@error
@@negate:
NEG EAX
JLE @@successExit
JS @@successExit { to handle 2**31 correctly, where the negate overflows }
@@error:
@@overFlow:
POP EBX
SUB ESI,EBX
JMP @@exit
@@minus:
INC CH
@@plus:
MOV BL,[ESI]
INC ESI
JMP @@firstDigit
@@dollar:
MOV EDI,0FFFFFFFH
MOV BL,[ESI]
INC ESI
TEST BL,BL
JZ @@empty
@@hDigLoop:
CMP BL,'a'
JB @@upper
SUB BL,'a' - 'A'
@@upper:
SUB BL,'0'
CMP BL,9
JBE @@digOk
SUB BL,'A' - '0'
CMP BL,5
JA @@error
ADD BL,10
@@digOk:
CMP EAX,EDI
JA @@overFlow
SHL EAX,4
ADD EAX,EBX
MOV BL,[ESI]
INC ESI
TEST BL,BL
JNE @@hDigLoop
JMP @@successExit
end;
procedure _WriteRec; external; {$L WriteRec}
procedure _WriteChar; external; { WriteStr}
procedure _Write0Char; external; { WriteStr}
procedure _WriteBool;
asm
{ PROCEDURE _WriteBool( VAR t: Text; val: Boolean; width: Longint); }
{ ->EAX Pointer to file record }
{ DL Boolean value }
{ ECX Field width }
TEST DL,DL
JE @@false
MOV EDX,offset @trueString
JMP _WriteString
@@false:
MOV EDX,offset @falseString
JMP _WriteString
@trueString: db 4,'TRUE'
@falseString: db 5,'FALSE'
end;
procedure _Write0Bool;
asm
{ PROCEDURE _Write0Bool( VAR t: Text; val: Boolean); }
{ ->EAX Pointer to file record }
{ DL Boolean value }
XOR ECX,ECX
JMP _WriteBool
end;
procedure _WriteLong;
asm
{ PROCEDURE _WriteLong( VAR t: Text; val: Longint; with: Longint); }
{ ->EAX Pointer to file record }
{ EDX Value }
{ ECX Field width }
SUB ESP,32 { VAR s: String[31]; }
PUSH EAX
PUSH ECX
MOV EAX,EDX { Str( val : 0, s ); }
XOR EDX,EDX
CMP ECX,31
JG @@1
MOV EDX,ECX
@@1:
LEA ECX,[ESP+8]
CALL _StrLong
POP ECX
POP EAX
MOV EDX,ESP { Write( t, s : width );}
CALL _WriteString
ADD ESP,32
end;
procedure _Write0Long;
asm
{ PROCEDURE _Write0Long( VAR t: Text; val: Longint); }
{ ->EAX Pointer to file record }
{ EDX Value }
XOR ECX,ECX
JMP _WriteLong
end;
procedure _WriteString; external; {$L WriteStr}
procedure _Write0String; external; { WriteStr}
procedure _WriteCString; external; { WriteStr}
procedure _Write0CString; external; { WriteStr}
procedure _WriteBytes; external; { WriteStr}
procedure _WriteSpaces; external; { WriteStr}
procedure _Write2Ext;
asm
{ PROCEDURE _Write2Ext( VAR t: Text; val: Extended; width, prec: Longint);
->EAX Pointer to file record
[ESP+4] Extended value
EDX Field width
ECX precision (<0: scientific, >= 0: fixed point) }
FLD tbyte ptr [ESP+4] { load value }
SUB ESP,256 { VAR s: String; }
PUSH EAX
PUSH EDX
{ Str( val, width, prec, s ); }
SUB ESP,12
FSTP tbyte ptr [ESP] { pass value }
MOV EAX,EDX { pass field width }
MOV EDX,ECX { pass precision }
LEA ECX,[ESP+8+12] { pass destination string }
CALL _Str2Ext
{ Write( t, s, width ); }
POP ECX { pass width }
POP EAX { pass text }
MOV EDX,ESP { pass string }
CALL _WriteString
ADD ESP,256
RET 12
end;
procedure _Write1Ext;
asm
{ PROCEDURE _Write1Ext( VAR t: Text; val: Extended; width: Longint);
-> EAX Pointer to file record
[ESP+4] Extended value
EDX Field width }
OR ECX,-1
JMP _Write2Ext
end;
procedure _Write0Ext;
asm
{ PROCEDURE _Write0Ext( VAR t: Text; val: Extended);
->EAX Pointer to file record
[ESP+4] Extended value }
MOV EDX,23 { field width }
OR ECX,-1
JMP _Write2Ext
end;
procedure _WriteLn; external; { WriteStr}
procedure __CToPasStr;
asm
{ ->EAX Pointer to destination }
{ EDX Pointer to source }
PUSH EAX { save destination }
MOV CL,255
@@loop:
MOV CH,[EDX] { ch = *src++; }
INC EDX
TEST CH,CH { if (ch == 0) break }
JE @@endLoop
INC EAX { *++dest = ch; }
MOV [EAX],CH
DEC CL
JNE @@loop
@@endLoop:
POP EDX
SUB EAX,EDX
MOV [EDX],AL
end;
procedure __CLenToPasStr;
asm
{ ->EAX Pointer to destination }
{ EDX Pointer to source }
{ ECX cnt }
PUSH EBX
PUSH EAX { save destination }
CMP ECX,255
JBE @@loop
MOV ECX,255
@@loop:
MOV BL,[EDX] { ch = *src++; }
INC EDX
TEST BL,BL { if (ch == 0) break }
JE @@endLoop
INC EAX { *++dest = ch; }
MOV [EAX],BL
DEC ECX { while (--cnt != 0) }
JNZ @@loop
@@endLoop:
POP EDX
SUB EAX,EDX
MOV [EDX],AL
POP EBX
end;
procedure __ArrayToPasStr;
asm
{ ->EAX Pointer to destination }
{ EDX Pointer to source }
{ ECX cnt }
XCHG EAX,EDX
{ limit the length to 255 }
CMP ECX,255
JBE @@skip
MOV ECX,255
@@skip:
MOV [EDX],CL
{ copy the source to destination + 1 }
INC EDX
JMP Move
end;
procedure __PasToCStr;
asm
{ ->EAX Pointer to source }
{ EDX Pointer to destination }
PUSH ESI
PUSH EDI
MOV ESI,EAX
MOV EDI,EDX
XOR ECX,ECX
MOV CL,[ESI]
INC ESI
REP MOVSB
MOV byte ptr [EDI],CL { Append terminator: CL is zero here }
POP EDI
POP ESI
end;
procedure _SetElem;
asm
{ PROCEDURE _SetElem( VAR d: SET; elem, size: Byte); }
{ EAX = dest address }
{ DL = element number }
{ CL = size of set }
PUSH EBX
PUSH EDI
MOV EDI,EAX
XOR EBX,EBX { zero extend set size into ebx }
MOV BL,CL
MOV ECX,EBX { and use it for the fill }
XOR EAX,EAX { for zero fill }
REP STOSB
SUB EDI,EBX { point edi at beginning of set again }
INC EAX { eax is still zero - make it 1 }
MOV CL,DL
ROL AL,CL { generate a mask }
SHR ECX,3 { generate the index }
CMP ECX,EBX { if index >= siz then exit }
JAE @@exit
OR [EDI+ECX],AL{ set bit }
@@exit:
POP EDI
POP EBX
end;
procedure _SetRange;
asm
{ PROCEDURE _SetRange( lo, hi, size: Byte; VAR d: SET ); }
{ ->AL low limit of range }
{ DL high limit of range }
{ ECX Pointer to set }
{ AH size of set }
PUSH EBX
PUSH ESI
PUSH EDI
XOR EBX,EBX { EBX = set size }
MOV BL,AH
MOVZX ESI,AL { ESI = low zero extended }
MOVZX EDX,DL { EDX = high zero extended }
MOV EDI,ECX
{ clear the set }
MOV ECX,EBX
XOR EAX,EAX
REP STOSB
{ prepare for setting the bits }
SUB EDI,EBX { point EDI at start of set }
SHL EBX,3 { EBX = highest bit in set + 1 }
CMP EDX,EBX
JB @@inrange
LEA EDX,[EBX-1] { ECX = highest bit in set }
@@inrange:
CMP ESI,EDX { if lo > hi then exit; }
JA @@exit
DEC EAX { loMask = 0xff << (lo & 7) }
MOV ECX,ESI
AND CL,07H
SHL AL,CL
SHR ESI,3 { loIndex = lo >> 3; }
MOV CL,DL { hiMask = 0xff >> (7 - (hi & 7)); }
NOT CL
AND CL,07
SHR AH,CL
SHR EDX,3 { hiIndex = hi >> 3; }
ADD EDI,ESI { point EDI to set[loIndex] }
MOV ECX,EDX
SUB ECX,ESI { if ((inxDiff = (hiIndex - loIndex)) == 0) }
JNE @@else
AND AL,AH { set[loIndex] = hiMask & loMask; }
MOV [EDI],AL
JMP @@exit
@@else:
STOSB { set[loIndex++] = loMask; }
DEC ECX
MOV AL,0FFH { while (loIndex < hiIndex) }
REP STOSB { set[loIndex++] = 0xff; }
MOV [EDI],AH { set[hiIndex] = hiMask; }
@@exit:
POP EDI
POP ESI
POP EBX
end;
procedure _SetEq;
asm
{ FUNCTION _SetEq( CONST l, r: Set; size: Byte): ConditionCode; }
{ EAX = left operand }
{ EDX = right operand }
{ CL = size of set }
PUSH ESI
PUSH EDI
MOV ESI,EAX
MOV EDI,EDX
AND ECX,0FFH
REP CMPSB
POP EDI
POP ESI
end;
procedure _SetLe;
asm
{ FUNCTION _SetLe( CONST l, r: Set; size: Byte): ConditionCode; }
{ EAX = left operand }
{ EDX = right operand }
{ CL = size of set (>0 && <= 32) }
@@loop:
MOV CH,[EDX]
NOT CH
AND CH,[EAX]
JNE @@exit
INC EDX
INC EAX
DEC CL
JNZ @@loop
@@exit:
end;
procedure _SetIntersect;
asm
{ PROCEDURE _SetIntersect( VAR dest: Set; CONST src: Set; size: Byte);}
{ EAX = destination operand }
{ EDX = source operand }
{ CL = size of set (0 < size <= 32) }
@@loop:
MOV CH,[EDX]
INC EDX
AND [EAX],CH
INC EAX
DEC CL
JNZ @@loop
end;
procedure _SetIntersect3;
asm
{ PROCEDURE _SetIntersect3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);}
{ EAX = destination operand }
{ EDX = source operand }
{ ECX = size of set (0 < size <= 32) }
{ [ESP+4] = 2nd source operand }
PUSH EBX
PUSH ESI
MOV ESI,[ESP+8+4]
@@loop:
MOV BL,[EDX+ECX-1]
AND BL,[ESI+ECX-1]
MOV [EAX+ECX-1],BL
DEC ECX
JNZ @@loop
POP ESI
POP EBX
end;
procedure _SetUnion;
asm
{ PROCEDURE _SetUnion( VAR dest: Set; CONST src: Set; size: Byte); }
{ EAX = destination operand }
{ EDX = source operand }
{ CL = size of set (0 < size <= 32) }
@@loop:
MOV CH,[EDX]
INC EDX
OR [EAX],CH
INC EAX
DEC CL
JNZ @@loop
end;
procedure _SetUnion3;
asm
{ PROCEDURE _SetUnion3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);}
{ EAX = destination operand }
{ EDX = source operand }
{ ECX = size of set (0 < size <= 32) }
{ [ESP+4] = 2nd source operand }
PUSH EBX
PUSH ESI
MOV ESI,[ESP+8+4]
@@loop:
MOV BL,[EDX+ECX-1]
OR BL,[ESI+ECX-1]
MOV [EAX+ECX-1],BL
DEC ECX
JNZ @@loop
POP ESI
POP EBX
end;
procedure _SetSub;
asm
{ PROCEDURE _SetSub( VAR dest: Set; CONST src: Set; size: Byte); }
{ EAX = destination operand }
{ EDX = source operand }
{ CL = size of set (0 < size <= 32) }
@@loop:
MOV CH,[EDX]
NOT CH
INC EDX
AND [EAX],CH
INC EAX
DEC CL
JNZ @@loop
end;
procedure _SetSub3;
asm
{ PROCEDURE _SetSub3( VAR dest: Set; CONST src: Set; size: Longint; src2: Set);}
{ EAX = destination operand }
{ EDX = source operand }
{ ECX = size of set (0 < size <= 32) }
{ [ESP+4] = 2nd source operand }
PUSH EBX
PUSH ESI
MOV ESI,[ESP+8+4]
@@loop:
MOV BL,[ESI+ECX-1]
NOT BL
AND BL,[EDX+ECX-1]
MOV [EAX+ECX-1],BL
DEC ECX
JNZ @@loop
POP ESI
POP EBX
end;
procedure _SetExpand;
asm
{ PROCEDURE _SetExpand( CONST src: Set; VAR dest: Set; lo, hi: Byte); }
{ ->EAX Pointer to source (packed set) }
{ EDX Pointer to destination (expanded set) }
{ CH high byte of source }
{ CL low byte of source }
{ algorithm: }
{ clear low bytes }
{ copy high-low+1 bytes }
{ clear 31-high bytes }
PUSH ESI
PUSH EDI
MOV ESI,EAX
MOV EDI,EDX
MOV EDX,ECX { save low, high in dl, dh }
XOR ECX,ECX
XOR EAX,EAX
MOV CL,DL { clear low bytes }
REP STOSB
MOV CL,DH { copy high - low bytes }
SUB CL,DL
REP MOVSB
MOV CL,32 { copy 32 - high bytes }
SUB CL,DH
REP STOSB
POP EDI
POP ESI
end;
procedure _Str2Ext; external; {$L StrExt }
procedure _Str0Ext; external; { StrExt }
procedure _Str1Ext; external; { StrExt }
procedure _ValExt; external; {$L ValExt }
procedure _Pow10; external; {$L Pow10 }
procedure FPower10; external; { Pow10 }
procedure _Real2Ext; external; {$L Real2Ext}
procedure _Ext2Real; external; {$L Ext2Real}
const
ovtInstanceSize = -8; { Offset of instance size in OBJECTs }
ovtVmtPtrOffs = -4;
procedure _ObjSetup;
asm
{ FUNCTION _ObjSetup( self: ^OBJECT; vmt: ^VMT): ^OBJECT; }
{ ->EAX Pointer to self (possibly nil) }
{ EDX Pointer to vmt (possibly nil) }
{ <-EAX Pointer to self }
{ EDX <> 0: an object was allocated }
{ Z-Flag Set: failure, Cleared: Success }
CMP EDX,1 { is vmt = 0, indicating a call }
JAE @@skip1 { from a constructor? }
RET { return immediately with Z-flag cleared }
@@skip1:
PUSH ECX
TEST EAX,EAX { is self already allocated? }
JNE @@noAlloc
MOV EAX,[EDX].ovtInstanceSize
TEST EAX,EAX
JE @@zeroSize
PUSH EDX
CALL MemoryManager.GetMem
POP EDX
TEST EAX,EAX
JZ @@fail
{ Zero fill the memory }
PUSH EDI
MOV ECX,[EDX].ovtInstanceSize
MOV EDI,EAX
PUSH EAX
XOR EAX,EAX
SHR ECX,2
REP STOSD
MOV ECX,[EDX].ovtInstanceSize
AND ECX,3
REP STOSB
POP EAX
POP EDI
MOV ECX,[EDX].ovtVmtPtrOffs
TEST ECX,ECX
JL @@skip
MOV [EAX+ECX],EDX { store vmt in object at this offset }
@@skip:
TEST EAX,EAX { clear zero flag }
POP ECX
RET
@@fail:
XOR EDX,EDX
POP ECX
RET
@@zeroSize:
XOR EDX,EDX
CMP EAX,1 { clear zero flag - we were successful (kind of) }
POP ECX
RET
@@noAlloc:
MOV ECX,[EDX].ovtVmtPtrOffs
TEST ECX,ECX
JL @@exit
MOV [EAX+ECX],EDX { store vmt in object at this offset }
@@exit:
XOR EDX,EDX { clear allocated flag }
TEST EAX,EAX { clear zero flag }
POP ECX
end;
procedure _ObjCopy;
asm
{ PROCEDURE _ObjCopy( dest, src: ^OBJECT; vmtPtrOff: Longint); }
{ ->EAX Pointer to destination }
{ EDX Pointer to source }
{ ECX Offset of vmt in those objects. }
PUSH EBX
PUSH ESI
PUSH EDI
MOV ESI,EDX
MOV EDI,EAX
LEA EAX,[EDI+ECX] { remember pointer to dest vmt pointer }
MOV EDX,[EAX] { fetch dest vmt pointer }
MOV EBX,[EDX].ovtInstanceSize
MOV ECX,EBX { copy size DIV 4 dwords }
SHR ECX,2
REP MOVSD
MOV ECX,EBX { copy size MOD 4 bytes }
AND ECX,3
REP MOVSB
MOV [EAX],EDX { restore dest vmt }
POP EDI
POP ESI
POP EBX
end;
procedure _Fail;
asm
{ FUNCTION _Fail( self: ^OBJECT; allocFlag:Longint): ^OBJECT; }
{ ->EAX Pointer to self (possibly nil) }
{ EDX <> 0: Object must be deallocated }
{ <-EAX Nil }
TEST EDX,EDX
JE @@exit { if no object was allocated, return }
CALL _FreeMem
@@exit:
XOR EAX,EAX
end;
function GetKeyboardType(nTypeFlag: Integer): Integer; stdcall;
external user name 'GetKeyboardType';
function _isNECWindows: Boolean;
var
KbSubType: Integer;
begin
Result := False;
if GetKeyboardType(0) = $7 then
begin
KbSubType := GetKeyboardType(1) and $FF00;
if (KbSubType = $0D00) or (KbSubType = $0400) then
Result := True;
end;
end;
procedure _FpuMaskInit;
const
HKEY_LOCAL_MACHINE = $80000002;
KEY_QUERY_VALUE = $00000001;
REG_DWORD = 4;
FPUMASKKEY = 'SOFTWARE\Borland\Delphi\RTL';
FPUMASKNAME = 'FPUMaskValue';
var
phkResult: LongWord;
lpData, DataSize: Longint;
begin
lpData := Default8087CW;
if RegOpenKeyEx(HKEY_LOCAL_MACHINE, FPUMASKKEY, 0, KEY_QUERY_VALUE, phkResult) = 0 then
try
DataSize := Sizeof(lpData);
RegQueryValueEx(phkResult, FPUMASKNAME, nil, nil, @lpData, @DataSize);
finally
RegCloseKey(phkResult);
end;
Default8087CW := (Default8087CW and $ffc0) or (lpData and $3f);
end;
procedure FpuInit;
//const cwDefault: Word = $1332 { $133F};
asm
FNINIT
FWAIT
FLDCW Default8087CW
end;
procedure FpuInitConsiderNECWindows;
begin
if _isNECWindows then _FpuMaskInit;
FpuInit();
end;
procedure _BoundErr;
asm
MOV AL,reRangeError
JMP Error
end;
procedure _IntOver;
asm
MOV AL,reIntOverflow
JMP Error
end;
function TObject.ClassType: TClass;
asm
mov eax,[eax]
end;
class function TObject.ClassName: ShortString;
asm
{ -> EAX VMT }
{ EDX Pointer to result string }
PUSH ESI
PUSH EDI
MOV EDI,EDX
MOV ESI,[EAX].vmtClassName
XOR ECX,ECX
MOV CL,[ESI]
INC ECX
REP MOVSB
POP EDI
POP ESI
end;
class function TObject.ClassNameIs(const Name: string): Boolean;
asm
PUSH EBX
XOR EBX,EBX
OR EDX,EDX
JE @@exit
MOV EAX,[EAX].vmtClassName
XOR ECX,ECX
MOV CL,[EAX]
CMP ECX,[EDX-4]
JNE @@exit
DEC EDX
@@loop:
MOV BH,[EAX+ECX]
XOR BH,[EDX+ECX]
AND BH,0DFH
JNE @@exit
DEC ECX
JNE @@loop
INC EBX
@@exit:
MOV AL,BL
POP EBX
end;
class function TObject.ClassParent: TClass;
asm
MOV EAX,[EAX].vmtParent
TEST EAX,EAX
JE @@exit
MOV EAX,[EAX]
@@exit:
end;
class function TObject.NewInstance: TObject;
asm
PUSH EAX
MOV EAX,[EAX].vmtInstanceSize
CALL _GetMem
MOV EDX,EAX
POP EAX
JMP TObject.InitInstance
end;
procedure TObject.FreeInstance;
asm
PUSH EBX
PUSH ESI
MOV EBX,EAX
MOV ESI,EAX
@@loop:
MOV ESI,[ESI]
MOV EDX,[ESI].vmtInitTable
MOV ESI,[ESI].vmtParent
TEST EDX,EDX
JE @@skip
CALL _FinalizeRecord
MOV EAX,EBX
@@skip:
TEST ESI,ESI
JNE @@loop
CALL _FreeMem
POP ESI
POP EBX
end;
class function TObject.InstanceSize: Longint;
asm
MOV EAX,[EAX].vmtInstanceSize
end;
constructor TObject.Create;
begin
end;
destructor TObject.Destroy;
begin
end;
procedure TObject.Free;
asm
TEST EAX,EAX
JE @@exit
MOV ECX,[EAX]
MOV DL,1
CALL dword ptr [ECX].vmtDestroy
@@exit:
end;
class function TObject.InitInstance(Instance: Pointer): TObject;
asm
PUSH EBX
PUSH ESI
PUSH EDI
MOV EBX,EAX
MOV EDI,EDX
STOSD
MOV ECX,[EBX].vmtInstanceSize
XOR EAX,EAX
PUSH ECX
SHR ECX,2
DEC ECX
REP STOSD
POP ECX
AND ECX,3
REP STOSB
MOV EAX,EDX
MOV EDX,ESP
@@0: MOV ECX,[EBX].vmtIntfTable
TEST ECX,ECX
JE @@1
PUSH ECX
@@1: MOV EBX,[EBX].vmtParent
TEST EBX,EBX
JE @@2
MOV EBX,[EBX]
JMP @@0
@@2: CMP ESP,EDX
JE @@5
@@3: POP EBX
MOV ECX,[EBX].TInterfaceTable.EntryCount
ADD EBX,4
@@4: MOV ESI,[EBX].TInterfaceEntry.VTable
TEST ESI,ESI
JE @@4a
MOV EDI,[EBX].TInterfaceEntry.IOffset
MOV [EAX+EDI],ESI
@@4a: ADD EBX,TYPE TInterfaceEntry
DEC ECX
JNE @@4
CMP ESP,EDX
JNE @@3
@@5: POP EDI
POP ESI
POP EBX
end;
procedure TObject.CleanupInstance;
asm
PUSH EBX
PUSH ESI
MOV EBX,EAX
MOV ESI,EAX
@@loop:
MOV ESI,[ESI]
MOV EDX,[ESI].vmtInitTable
MOV ESI,[ESI].vmtParent
TEST EDX,EDX
JE @@skip
CALL _FinalizeRecord
MOV EAX,EBX
@@skip:
TEST ESI,ESI
JNE @@loop
POP ESI
POP EBX
end;
function InvokeImplGetter(Self: TObject; ImplGetter: Integer): IUnknown;
asm
XCHG EDX,ECX
CMP ECX,$FF000000
JAE @@isField
CMP ECX,$FE000000
JB @@isStaticMethod
{ the GetProc is a virtual method }
MOVSX ECX,CX { sign extend slot offs }
ADD ECX,[EAX] { vmt + slotoffs }
JMP dword ptr [ECX] { call vmt[slot] }
@@isStaticMethod:
JMP ECX
@@isField:
AND ECX,$00FFFFFF
ADD ECX,EAX
MOV EAX,EDX
MOV EDX,[ECX]
JMP _IntfCopy
end;
function TObject.GetInterface(const IID: TGUID; out Obj): Boolean;
var
InterfaceEntry: PInterfaceEntry;
begin
InterfaceEntry := GetInterfaceEntry(IID);
if InterfaceEntry <> nil then
begin
if InterfaceEntry^.IOffset <> 0 then
Pointer(Obj) := Pointer(Integer(Self) + InterfaceEntry^.IOffset)
else
IUnknown(Obj) := InvokeImplGetter(Self, InterfaceEntry^.ImplGetter);
if Pointer(Obj) <> nil then
begin
if InterfaceEntry^.IOffset <> 0 then IUnknown(Obj)._AddRef;
Result := True;
end
else
Result := False;
end else
begin
Pointer(Obj) := nil;
Result := False;
end;
end;
class function TObject.GetInterfaceEntry(const IID: TGUID): PInterfaceEntry;
asm
PUSH EBX
PUSH ESI
MOV EBX,EAX
@@1: MOV EAX,[EBX].vmtIntfTable
TEST EAX,EAX
JE @@4
MOV ECX,[EAX].TInterfaceTable.EntryCount
ADD EAX,4
@@2: MOV ESI,[EDX].Integer[0]
CMP ESI,[EAX].TInterfaceEntry.IID.Integer[0]
JNE @@3
MOV ESI,[EDX].Integer[4]
CMP ESI,[EAX].TInterfaceEntry.IID.Integer[4]
JNE @@3
MOV ESI,[EDX].Integer[8]
CMP ESI,[EAX].TInterfaceEntry.IID.Integer[8]
JNE @@3
MOV ESI,[EDX].Integer[12]
CMP ESI,[EAX].TInterfaceEntry.IID.Integer[12]
JE @@5
@@3: ADD EAX,type TInterfaceEntry
DEC ECX
JNE @@2
@@4: MOV EBX,[EBX].vmtParent
TEST EBX,EBX
JE @@4a
MOV EBX,[EBX]
JMP @@1
@@4a: XOR EAX,EAX
@@5: POP ESI
POP EBX
end;
class function TObject.GetInterfaceTable: PInterfaceTable;
asm
MOV EAX,[EAX].vmtIntfTable
end;
procedure _IsClass;
asm
{ -> EAX left operand (class) }
{ EDX VMT of right operand }
{ <- AL left is derived from right }
TEST EAX,EAX
JE @@exit
@@loop:
MOV EAX,[EAX]
CMP EAX,EDX
JE @@success
MOV EAX,[EAX].vmtParent
TEST EAX,EAX
JNE @@loop
JMP @@exit
@@success:
MOV AL,1
@@exit:
end;
procedure _AsClass;
asm
{ -> EAX left operand (class) }
{ EDX VMT of right operand }
{ <- EAX if left is derived from right, else runtime error }
TEST EAX,EAX
JE @@exit
MOV ECX,EAX
@@loop:
MOV ECX,[ECX]
CMP ECX,EDX
JE @@exit
MOV ECX,[ECX].vmtParent
TEST ECX,ECX
JNE @@loop
{ do runtime error }
MOV AL,reInvalidCast
JMP Error
@@exit:
end;
procedure GetDynaMethod;
{ function GetDynaMethod(vmt: TClass; selector: Smallint) : Pointer; }
asm
{ -> EAX vmt of class }
{ BX dynamic method index }
{ <- EBX pointer to routine }
{ ZF = 0 if found }
{ trashes: EAX, ECX }
PUSH EDI
XCHG EAX,EBX
JMP @@haveVMT
@@outerLoop:
MOV EBX,[EBX]
@@haveVMT:
MOV EDI,[EBX].vmtDynamicTable
TEST EDI,EDI
JE @@parent
MOVZX ECX,word ptr [EDI]
PUSH ECX
ADD EDI,2
REPNE SCASW
JE @@found
POP ECX
@@parent:
MOV EBX,[EBX].vmtParent
TEST EBX,EBX
JNE @@outerLoop
JMP @@exit
@@found:
POP EAX
ADD EAX,EAX
SUB EAX,ECX { this will always clear the Z-flag ! }
MOV EBX,[EDI+EAX*2-4]
@@exit:
POP EDI
end;
procedure _CallDynaInst;
asm
PUSH EAX
PUSH ECX
MOV EAX,[EAX]
CALL GetDynaMethod
POP ECX
POP EAX
JE @@Abstract
JMP EBX
@@Abstract:
POP ECX
JMP _AbstractError
end;
procedure _CallDynaClass;
asm
PUSH EAX
PUSH ECX
CALL GetDynaMethod
POP ECX
POP EAX
JE @@Abstract
JMP EBX
@@Abstract:
POP ECX
JMP _AbstractError
end;
procedure _FindDynaInst;
asm
PUSH EBX
MOV EBX,EDX
MOV EAX,[EAX]
CALL GetDynaMethod
MOV EAX,EBX
POP EBX
JNE @@exit
POP ECX
JMP _AbstractError
@@exit:
end;
procedure _FindDynaClass;
asm
PUSH EBX
MOV EBX,EDX
CALL GetDynaMethod
MOV EAX,EBX
POP EBX
JNE @@exit
POP ECX
JMP _AbstractError
@@exit:
end;
class function TObject.InheritsFrom(AClass: TClass): Boolean;
asm
{ -> EAX Pointer to our class }
{ EDX Pointer to AClass }
{ <- AL Boolean result }
JMP @@haveVMT
@@loop:
MOV EAX,[EAX]
@@haveVMT:
CMP EAX,EDX
JE @@success
MOV EAX,[EAX].vmtParent
TEST EAX,EAX
JNE @@loop
JMP @@exit
@@success:
MOV AL,1
@@exit:
end;
class function TObject.ClassInfo: Pointer;
asm
MOV EAX,[EAX].vmtTypeInfo
end;
function TObject.SafeCallException(ExceptObject: TObject;
ExceptAddr: Pointer): HResult;
begin
Result := HResult($8000FFFF); { E_UNEXPECTED }
end;
procedure TObject.DefaultHandler(var Message);
begin
end;
procedure TObject.AfterConstruction;
begin
end;
procedure TObject.BeforeDestruction;
begin
end;
procedure TObject.Dispatch(var Message);
asm
PUSH EBX
MOV BX,[EDX]
OR BX,BX
JE @@default
CMP BX,0C000H
JAE @@default
PUSH EAX
MOV EAX,[EAX]
CALL GetDynaMethod
POP EAX
JE @@default
MOV ECX,EBX
POP EBX
JMP ECX
@@default:
POP EBX
MOV ECX,[EAX]
JMP dword ptr [ECX].vmtDefaultHandler
end;
class function TObject.MethodAddress(const Name: ShortString): Pointer;
asm
{ -> EAX Pointer to class }
{ EDX Pointer to name }
PUSH EBX
PUSH ESI
PUSH EDI
XOR ECX,ECX
XOR EDI,EDI
MOV BL,[EDX]
JMP @@haveVMT
@@outer: { upper 16 bits of ECX are 0 ! }
MOV EAX,[EAX]
@@haveVMT:
MOV ESI,[EAX].vmtMethodTable
TEST ESI,ESI
JE @@parent
MOV DI,[ESI] { EDI := method count }
ADD ESI,2
@@inner: { upper 16 bits of ECX are 0 ! }
MOV CL,[ESI+6] { compare length of strings }
CMP CL,BL
JE @@cmpChar
@@cont: { upper 16 bits of ECX are 0 ! }
MOV CX,[ESI] { fetch length of method desc }
ADD ESI,ECX { point ESI to next method }
DEC EDI
JNZ @@inner
@@parent:
MOV EAX,[EAX].vmtParent { fetch parent vmt }
TEST EAX,EAX
JNE @@outer
JMP @@exit { return NIL }
@@notEqual:
MOV BL,[EDX] { restore BL to length of name }
JMP @@cont
@@cmpChar: { upper 16 bits of ECX are 0 ! }
MOV CH,0 { upper 24 bits of ECX are 0 ! }
@@cmpCharLoop:
MOV BL,[ESI+ECX+6] { case insensitive string cmp }
XOR BL,[EDX+ECX+0] { last char is compared first }
AND BL,$DF
JNE @@notEqual
DEC ECX { ECX serves as counter }
JNZ @@cmpCharLoop
{ found it }
MOV EAX,[ESI+2]
@@exit:
POP EDI
POP ESI
POP EBX
end;
class function TObject.MethodName(Address: Pointer): ShortString;
asm
{ -> EAX Pointer to class }
{ EDX Address }
{ ECX Pointer to result }
PUSH EBX
PUSH ESI
PUSH EDI
MOV EDI,ECX
XOR EBX,EBX
XOR ECX,ECX
JMP @@haveVMT
@@outer:
MOV EAX,[EAX]
@@haveVMT:
MOV ESI,[EAX].vmtMethodTable { fetch pointer to method table }
TEST ESI,ESI
JE @@parent
MOV CX,[ESI]
ADD ESI,2
@@inner:
CMP EDX,[ESI+2]
JE @@found
MOV BX,[ESI]
ADD ESI,EBX
DEC ECX
JNZ @@inner
@@parent:
MOV EAX,[EAX].vmtParent
TEST EAX,EAX
JNE @@outer
MOV [EDI],AL
JMP @@exit
@@found:
ADD ESI,6
XOR ECX,ECX
MOV CL,[ESI]
INC ECX
REP MOVSB
@@exit:
POP EDI
POP ESI
POP EBX
end;
function TObject.FieldAddress(const Name: ShortString): Pointer;
asm
{ -> EAX Pointer to instance }
{ EDX Pointer to name }
PUSH EBX
PUSH ESI
PUSH EDI
XOR ECX,ECX
XOR EDI,EDI
MOV BL,[EDX]
PUSH EAX { save instance pointer }
@@outer:
MOV EAX,[EAX] { fetch class pointer }
MOV ESI,[EAX].vmtFieldTable
TEST ESI,ESI
JE @@parent
MOV DI,[ESI] { fetch count of fields }
ADD ESI,6
@@inner:
MOV CL,[ESI+6] { compare string lengths }
CMP CL,BL
JE @@cmpChar
@@cont:
LEA ESI,[ESI+ECX+7] { point ESI to next field }
DEC EDI
JNZ @@inner
@@parent:
MOV EAX,[EAX].vmtParent { fetch parent VMT }
TEST EAX,EAX
JNE @@outer
POP EDX { forget instance, return Nil }
JMP @@exit
@@notEqual:
MOV BL,[EDX] { restore BL to length of name }
MOV CL,[ESI+6] { ECX := length of field name }
JMP @@cont
@@cmpChar:
MOV BL,[ESI+ECX+6] { case insensitive string cmp }
XOR BL,[EDX+ECX+0] { starting with last char }
AND BL,$DF
JNE @@notEqual
DEC ECX { ECX serves as counter }
JNZ @@cmpChar
{ found it }
MOV EAX,[ESI] { result is field offset plus ... }
POP EDX
ADD EAX,EDX { instance pointer }
@@exit:
POP EDI
POP ESI
POP EBX
end;
const { copied from xx.h }
cContinuable = 0;
cNonContinuable = 1;
cUnwinding = 2;
cUnwindingForExit = 4;
cUnwindInProgress = cUnwinding or cUnwindingForExit;
cDelphiException = $0EEDFADE;
cDelphiReRaise = $0EEDFADF;
cDelphiExcept = $0EEDFAE0;
cDelphiFinally = $0EEDFAE1;
cDelphiTerminate = $0EEDFAE2;
cDelphiUnhandled = $0EEDFAE3;
cNonDelphiException = $0EEDFAE4;
cDelphiExitFinally = $0EEDFAE5;
cCppException = $0EEFFACE; { used by BCB }
EXCEPTION_CONTINUE_SEARCH = 0;
EXCEPTION_EXECUTE_HANDLER = 1;
EXCEPTION_CONTINUE_EXECUTION = -1;
type
JmpInstruction =
packed record
opCode: Byte;
distance: Longint;
end;
TExcDescEntry =
record
vTable: Pointer;
handler: Pointer;
end;
PExcDesc = ^TExcDesc;
TExcDesc =
packed record
jmp: JmpInstruction;
case Integer of
0: (instructions: array [0..0] of Byte);
1{...}: (cnt: Integer; excTab: array [0..0{cnt-1}] of TExcDescEntry);
end;
PExcFrame = ^TExcFrame;
TExcFrame =
record
next: PExcFrame;
desc: PExcDesc;
hEBP: Pointer;
case Integer of
0: ( );
1: ( ConstructedObject: Pointer );
2: ( SelfOfMethod: Pointer );
end;
PExceptionRecord = ^TExceptionRecord;
TExceptionRecord =
record
ExceptionCode : LongWord;
ExceptionFlags : LongWord;
OuterException : PExceptionRecord;
ExceptionAddress : Pointer;
NumberParameters : Longint;
case {IsOsException:} Boolean of
True: (ExceptionInformation : array [0..14] of Longint);
False: (ExceptAddr: Pointer; ExceptObject: Pointer);
end;
PRaiseFrame = ^TRaiseFrame;
TRaiseFrame = packed record
NextRaise: PRaiseFrame;
ExceptAddr: Pointer;
ExceptObject: TObject;
ExceptionRecord: PExceptionRecord;
end;
procedure _ClassCreate;
asm
{ -> EAX = pointer to VMT }
{ <- EAX = pointer to instance }
PUSH EDX
PUSH ECX
PUSH EBX
TEST DL,DL
JL @@noAlloc
CALL dword ptr [EAX].vmtNewInstance
@@noAlloc:
XOR EDX,EDX
LEA ECX,[ESP+16]
MOV EBX,FS:[EDX]
MOV [ECX].TExcFrame.next,EBX
MOV [ECX].TExcFrame.hEBP,EBP
MOV [ECX].TExcFrame.desc,offset @desc
MOV [ECX].TexcFrame.ConstructedObject,EAX { trick: remember copy to instance }
MOV FS:[EDX],ECX
POP EBX
POP ECX
POP EDX
RET
@desc:
JMP _HandleAnyException
{ destroy the object }
MOV EAX,[ESP+8+9*4]
MOV EAX,[EAX].TExcFrame.ConstructedObject
TEST EAX,EAX
JE @@skip
MOV ECX,[EAX]
MOV DL,$81
PUSH EAX
CALL dword ptr [ECX].vmtDestroy
POP EAX
CALL _ClassDestroy
@@skip:
{ reraise the exception }
CALL _RaiseAgain
end;
procedure _ClassDestroy;
asm
MOV EDX,[EAX]
CALL dword ptr [EDX].vmtFreeInstance
end;
procedure _AfterConstruction;
asm
{ -> EAX = pointer to instance }
PUSH EAX
MOV EDX,[EAX]
CALL dword ptr [EDX].vmtAfterConstruction
POP EAX
end;
procedure _BeforeDestruction;
asm
{ -> EAX = pointer to instance }
{ DL = dealloc flag }
TEST DL,DL
JG @@outerMost
RET
@@outerMost:
PUSH EAX
PUSH EDX
MOV EDX,[EAX]
CALL dword ptr [EDX].vmtBeforeDestruction
POP EDX
POP EAX
end;
{
The following NotifyXXXX routines are used to "raise" special exceptions
as a signaling mechanism to an interested debugger. If the debugger sets
the DebugHook flag to 1 or 2, then all exception processing is tracked by
raising these special exceptions. The debugger *MUST* respond to the
debug event with DBG_CONTINE so that normal processing will occur.
}
{ tell the debugger that the next raise is a re-raise of the current non-Delphi
exception }
procedure NotifyReRaise;
asm
CMP BYTE PTR DebugHook,1
JBE @@1
PUSH 0
PUSH 0
PUSH cContinuable
PUSH cDelphiReRaise
CALL RaiseException
@@1:
end;
{ tell the debugger about the raise of a non-Delphi exception }
procedure NotifyNonDelphiException;
asm
CMP BYTE PTR DebugHook,0
JE @@1
PUSH EAX
PUSH EAX
PUSH EDX
PUSH ESP
PUSH 2
PUSH cContinuable
PUSH cNonDelphiException
CALL RaiseException
ADD ESP,8
POP EAX
@@1:
end;
{ Tell the debugger where the handler for the current exception is located }
procedure NotifyExcept;
asm
PUSH ESP
PUSH 1
PUSH cContinuable
PUSH cDelphiExcept { our magic exception code }
CALL RaiseException
ADD ESP,4
POP EAX
end;
procedure NotifyOnExcept;
asm
CMP BYTE PTR DebugHook,1
JBE @@1
PUSH EAX
PUSH [EBX].TExcDescEntry.handler
JMP NotifyExcept
@@1:
end;
procedure NotifyAnyExcept;
asm
CMP BYTE PTR DebugHook,1
JBE @@1
PUSH EAX
PUSH EBX
JMP NotifyExcept
@@1:
end;
procedure CheckJmp;
asm
TEST ECX,ECX
JE @@3
MOV EAX,[ECX + 1]
CMP BYTE PTR [ECX],0E9H { near jmp }
JE @@1
CMP BYTE PTR [ECX],0EBH { short jmp }
JNE @@3
MOVSX EAX,AL
INC ECX
INC ECX
JMP @@2
@@1:
ADD ECX,5
@@2:
ADD ECX,EAX
@@3:
end;
{ Notify debugger of a finally during an exception unwind }
procedure NotifyExceptFinally;
asm
CMP BYTE PTR DebugHook,1
JBE @@1
PUSH EAX
PUSH EDX
PUSH ECX
CALL CheckJmp
PUSH ECX
PUSH ESP { pass pointer to arguments }
PUSH 1 { there is 1 argument }
PUSH cContinuable { continuable execution }
PUSH cDelphiFinally { our magic exception code }
CALL RaiseException
POP ECX
POP ECX
POP EDX
POP EAX
@@1:
end;
{ Tell the debugger that the current exception is handled and cleaned up.
Also indicate where execution is about to resume. }
procedure NotifyTerminate;
asm
CMP BYTE PTR DebugHook,1
JBE @@1
PUSH EDX
PUSH ESP
PUSH 1
PUSH cContinuable
PUSH cDelphiTerminate { our magic exception code }
CALL RaiseException
POP EDX
@@1:
end;
{ Tell the debugger that there was no handler found for the current execption
and we are about to go to the default handler }
procedure NotifyUnhandled;
asm
PUSH EAX
PUSH EDX
CMP BYTE PTR DebugHook,1
JBE @@1
PUSH ESP
PUSH 2
PUSH cContinuable
PUSH cDelphiUnhandled
CALL RaiseException
@@1:
POP EDX
POP EAX
end;
procedure _HandleAnyException;
asm
{ -> [ESP+ 4] excPtr: PExceptionRecord }
{ [ESP+ 8] errPtr: PExcFrame }
{ [ESP+12] ctxPtr: Pointer }
{ [ESP+16] dspPtr: Pointer }
{ <- EAX return value - always one }
MOV EAX,[ESP+4]
TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
JNE @@exit
CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException
MOV EDX,[EAX].TExceptionRecord.ExceptObject
MOV ECX,[EAX].TExceptionRecord.ExceptAddr
JE @@DelphiException
CLD
CALL FpuInit
MOV EDX,ExceptObjProc
TEST EDX,EDX
JE @@exit
CALL EDX
TEST EAX,EAX
JE @@exit
MOV EDX,[ESP+12]
MOV ECX,[ESP+4]
CMP [ECX].TExceptionRecord.ExceptionCode,cCppException
JE @@CppException
CALL NotifyNonDelphiException
CMP BYTE PTR JITEnable,0
JBE @@CppException
CMP BYTE PTR DebugHook,0
JA @@CppException { Do not JIT if debugging }
LEA ECX,[ESP+4]
PUSH EAX
PUSH ECX
CALL UnhandledExceptionFilter
CMP EAX,EXCEPTION_CONTINUE_SEARCH
POP EAX
JE @@exit
MOV EDX,EAX
MOV EAX,[ESP+4]
MOV ECX,[EAX].TExceptionRecord.ExceptionAddress
JMP @@GoUnwind
@@CppException:
MOV EDX,EAX
MOV EAX,[ESP+4]
MOV ECX,[EAX].TExceptionRecord.ExceptionAddress
@@DelphiException:
CMP BYTE PTR JITEnable,1
JBE @@GoUnwind
CMP BYTE PTR DebugHook,0 { Do not JIT if debugging }
JA @@GoUnwind
PUSH EAX
LEA EAX,[ESP+8]
PUSH EDX
PUSH ECX
PUSH EAX
CALL UnhandledExceptionFilter
CMP EAX,EXCEPTION_CONTINUE_SEARCH
POP ECX
POP EDX
POP EAX
JE @@exit
@@GoUnwind:
OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding
PUSH EBX
XOR EBX,EBX
PUSH ESI
PUSH EDI
PUSH EBP
MOV EBX,FS:[EBX]
PUSH EBX { Save pointer to topmost frame }
PUSH EAX { Save OS exception pointer }
PUSH EDX { Save exception object }
PUSH ECX { Save exception address }
MOV EDX,[ESP+8+8*4]
PUSH 0
PUSH EAX
PUSH offset @@returnAddress
PUSH EDX
CALL RtlUnwind
@@returnAddress:
MOV EDI,[ESP+8+8*4]
{ Make the RaiseList entry on the stack }
CALL SysInit.@GetTLS
PUSH [EAX].RaiseListPtr
MOV [EAX].RaiseListPtr,ESP
MOV EBP,[EDI].TExcFrame.hEBP
MOV EBX,[EDI].TExcFrame.desc
MOV [EDI].TExcFrame.desc,offset @@exceptFinally
ADD EBX,TExcDesc.instructions
CALL NotifyAnyExcept
JMP EBX
@@exceptFinally:
JMP _HandleFinally
@@destroyExcept:
{ we come here if an exception handler has thrown yet another exception }
{ we need to destroy the exception object and pop the raise list. }
CALL SysInit.@GetTLS
MOV ECX,[EAX].RaiseListPtr
MOV EDX,[ECX].TRaiseFrame.NextRaise
MOV [EAX].RaiseListPtr,EDX
MOV EAX,[ECX].TRaiseFrame.ExceptObject
JMP TObject.Free
@@exit:
MOV EAX,1
end;
procedure _HandleOnException;
asm
{ -> [ESP+ 4] excPtr: PExceptionRecord }
{ [ESP+ 8] errPtr: PExcFrame }
{ [ESP+12] ctxPtr: Pointer }
{ [ESP+16] dspPtr: Pointer }
{ <- EAX return value - always one }
MOV EAX,[ESP+4]
TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
JNE @@exit
CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException
JE @@DelphiException
CLD
CALL FpuInit
MOV EDX,ExceptClsProc
TEST EDX,EDX
JE @@exit
CALL EDX
TEST EAX,EAX
JNE @@common
JMP @@exit
@@DelphiException:
MOV EAX,[EAX].TExceptionRecord.ExceptObject
MOV EAX,[EAX] { load vtable of exception object }
@@common:
MOV EDX,[ESP+8]
PUSH EBX
PUSH ESI
PUSH EDI
PUSH EBP
MOV ECX,[EDX].TExcFrame.desc
MOV EBX,[ECX].TExcDesc.cnt
LEA ESI,[ECX].TExcDesc.excTab { point ECX to exc descriptor table }
MOV EBP,EAX { load vtable of exception object }
@@innerLoop:
MOV EAX,[ESI].TExcDescEntry.vTable
TEST EAX,EAX { catch all clause? }
JE @@doHandler { yes: go execute handler }
MOV EDI,EBP { load vtable of exception object }
JMP @@haveVMT
@@vtLoop:
MOV EDI,[EDI]
@@haveVMT:
MOV EAX,[EAX]
CMP EAX,EDI
JE @@doHandler
MOV ECX,[EAX].vmtInstanceSize
CMP ECX,[EDI].vmtInstanceSize
JNE @@parent
MOV EAX,[EAX].vmtClassName
MOV EDX,[EDI].vmtClassName
XOR ECX,ECX
MOV CL,[EAX]
CMP CL,[EDX]
JNE @@parent
INC EAX
INC EDX
CALL _AStrCmp
JE @@doHandler
@@parent:
MOV EDI,[EDI].vmtParent { load vtable of parent }
MOV EAX,[ESI].TExcDescEntry.vTable
TEST EDI,EDI
JNE @@vtLoop
ADD ESI,8
DEC EBX
JNZ @@innerLoop
POP EBP
POP EDI
POP ESI
POP EBX
JMP @@exit
@@doHandler:
MOV EAX,[ESP+4+4*4]
CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException
MOV EDX,[EAX].TExceptionRecord.ExceptObject
MOV ECX,[EAX].TExceptionRecord.ExceptAddr
JE @@haveObject
CALL ExceptObjProc
MOV EDX,[ESP+12+4*4]
CALL NotifyNonDelphiException
CMP BYTE PTR JITEnable,0
JBE @@NoJIT
CMP BYTE PTR DebugHook,0
JA @@noJIT { Do not JIT if debugging }
LEA ECX,[ESP+4]
PUSH EAX
PUSH ECX
CALL UnhandledExceptionFilter
CMP EAX,EXCEPTION_CONTINUE_SEARCH
POP EAX
JE @@exit
@@noJIT:
MOV EDX,EAX
MOV EAX,[ESP+4+4*4]
MOV ECX,[EAX].TExceptionRecord.ExceptionAddress
JMP @@GoUnwind
@@haveObject:
CMP BYTE PTR JITEnable,1
JBE @@GoUnwind
CMP BYTE PTR DebugHook,0
JA @@GoUnwind
PUSH EAX
LEA EAX,[ESP+8]
PUSH EDX
PUSH ECX
PUSH EAX
CALL UnhandledExceptionFilter
CMP EAX,EXCEPTION_CONTINUE_SEARCH
POP ECX
POP EDX
POP EAX
JE @@exit
@@GoUnwind:
XOR EBX,EBX
MOV EBX,FS:[EBX]
PUSH EBX { Save topmost frame }
PUSH EAX { Save exception record }
PUSH EDX { Save exception object }
PUSH ECX { Save exception address }
MOV EDX,[ESP+8+8*4]
OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding
PUSH ESI { Save handler entry }
PUSH 0
PUSH EAX
PUSH offset @@returnAddress
PUSH EDX
CALL RtlUnwind
@@returnAddress:
POP EBX { Restore handler entry }
MOV EDI,[ESP+8+8*4]
{ Make the RaiseList entry on the stack }
CALL SysInit.@GetTLS
PUSH [EAX].RaiseListPtr
MOV [EAX].RaiseListPtr,ESP
MOV EBP,[EDI].TExcFrame.hEBP
MOV [EDI].TExcFrame.desc,offset @@exceptFinally
MOV EAX,[ESP].TRaiseFrame.ExceptObject
CALL NotifyOnExcept
JMP [EBX].TExcDescEntry.handler
@@exceptFinally:
JMP _HandleFinally
@@destroyExcept:
{ we come here if an exception handler has thrown yet another exception }
{ we need to destroy the exception object and pop the raise list. }
CALL SysInit.@GetTLS
MOV ECX,[EAX].RaiseListPtr
MOV EDX,[ECX].TRaiseFrame.NextRaise
MOV [EAX].RaiseListPtr,EDX
MOV EAX,[ECX].TRaiseFrame.ExceptObject
JMP TObject.Free
@@exit:
MOV EAX,1
end;
procedure _HandleFinally;
asm
{ -> [ESP+ 4] excPtr: PExceptionRecord }
{ [ESP+ 8] errPtr: PExcFrame }
{ [ESP+12] ctxPtr: Pointer }
{ [ESP+16] dspPtr: Pointer }
{ <- EAX return value - always one }
MOV EAX,[ESP+4]
MOV EDX,[ESP+8]
TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
JE @@exit
MOV ECX,[EDX].TExcFrame.desc
MOV [EDX].TExcFrame.desc,offset @@exit
PUSH EBX
PUSH ESI
PUSH EDI
PUSH EBP
MOV EBP,[EDX].TExcFrame.hEBP
ADD ECX,TExcDesc.instructions
CALL NotifyExceptFinally
CALL ECX
POP EBP
POP EDI
POP ESI
POP EBX
@@exit:
MOV EAX,1
end;
procedure _HandleAutoException;
asm
{ -> [ESP+ 4] excPtr: PExceptionRecord }
{ [ESP+ 8] errPtr: PExcFrame }
{ [ESP+12] ctxPtr: Pointer }
{ [ESP+16] dspPtr: Pointer }
{ <- EAX return value - always one }
MOV EAX,[ESP+4]
TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
JNE @@exit
CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException
CLD
CALL FpuInit
JE @@DelphiException
CMP BYTE PTR JITEnable,0
JBE @@DelphiException
CMP BYTE PTR DebugHook,0
JA @@DelphiException
@@DoUnhandled:
LEA EAX,[ESP+4]
PUSH EAX
CALL UnhandledExceptionFilter
CMP EAX,EXCEPTION_CONTINUE_SEARCH
JE @@exit
MOV EAX,[ESP+4]
JMP @@GoUnwind
@@DelphiException:
CMP BYTE PTR JITEnable,1
JBE @@GoUnwind
CMP BYTE PTR DebugHook,0
JA @@GoUnwind
JMP @@DoUnhandled
@@GoUnwind:
OR [EAX].TExceptionRecord.ExceptionFlags,cUnwinding
PUSH ESI
PUSH EDI
PUSH EBP
MOV EDX,[ESP+8+3*4]
PUSH 0
PUSH EAX
PUSH offset @@returnAddress
PUSH EDX
CALL RtlUnwind
@@returnAddress:
POP EBP
POP EDI
POP ESI
MOV EAX,[ESP+4]
MOV EBX,8000FFFFH
CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException
JNE @@done
MOV EDX,[EAX].TExceptionRecord.ExceptObject
MOV ECX,[EAX].TExceptionRecord.ExceptAddr
MOV EAX,[ESP+8]
MOV EAX,[EAX].TExcFrame.SelfOfMethod
MOV EBX,[EAX]
CALL [EBX].vmtSafeCallException.Pointer
MOV EBX,EAX
MOV EAX,[ESP+4]
MOV EAX,[EAX].TExceptionRecord.ExceptObject
CALL TObject.Free
@@done:
XOR EAX,EAX
MOV ESP,[ESP+8]
POP ECX
MOV FS:[EAX],ECX
POP EDX
POP EBP
LEA EDX,[EDX].TExcDesc.instructions
POP ECX
JMP EDX
@@exit:
MOV EAX,1
end;
procedure _RaiseExcept;
asm
{ When making changes to the way Delphi Exceptions are raised, }
{ please realize that the C++ Exception handling code reraises }
{ some exceptions as Delphi Exceptions. Of course we want to }
{ keep exception raising compatible between Delphi and C++, so }
{ when you make changes here, consult with the relevant C++ }
{ exception handling engineer. The C++ code is in xx.cpp, in }
{ the RTL sources, in function tossAnException. }
{ -> EAX Pointer to exception object }
{ [ESP] Error address }
POP EDX
PUSH ESP
PUSH EBP
PUSH EDI
PUSH ESI
PUSH EBX
PUSH EAX { pass class argument }
PUSH EDX { pass address argument }
PUSH ESP { pass pointer to arguments }
PUSH 7 { there are seven arguments }
PUSH cNonContinuable { we can't continue execution }
PUSH cDelphiException { our magic exception code }
PUSH EDX { pass the user's return address }
JMP RaiseException
end;
procedure _RaiseAgain;
asm
{ -> [ESP ] return address to user program }
{ [ESP+ 4 ] raise list entry (4 dwords) }
{ [ESP+ 4+ 4*4] saved topmost frame }
{ [ESP+ 4+ 5*4] saved registers (4 dwords) }
{ [ESP+ 4+ 9*4] return address to OS }
{ -> [ESP+ 4+10*4] excPtr: PExceptionRecord }
{ [ESP+ 8+10*4] errPtr: PExcFrame }
{ Point the error handler of the exception frame to something harmless }
MOV EAX,[ESP+8+10*4]
MOV [EAX].TExcFrame.desc,offset @@exit
{ Pop the RaiseList }
CALL SysInit.@GetTLS
MOV EDX,[EAX].RaiseListPtr
MOV ECX,[EDX].TRaiseFrame.NextRaise
MOV [EAX].RaiseListPtr,ECX
{ Destroy any objects created for non-delphi exceptions }
MOV EAX,[EDX].TRaiseFrame.ExceptionRecord
AND [EAX].TExceptionRecord.ExceptionFlags,NOT cUnwinding
CMP [EAX].TExceptionRecord.ExceptionCode,cDelphiException
JE @@delphiException
MOV EAX,[EDX].TRaiseFrame.ExceptObject
CALL TObject.Free
CALL NotifyReRaise
@@delphiException:
XOR EAX,EAX
ADD ESP,5*4
MOV EDX,FS:[EAX]
POP ECX
MOV EDX,[EDX].TExcFrame.next
MOV [ECX].TExcFrame.next,EDX
POP EBP
POP EDI
POP ESI
POP EBX
@@exit:
MOV EAX,1
end;
procedure _DoneExcept;
asm
{ -> [ESP+ 4+10*4] excPtr: PExceptionRecord }
{ [ESP+ 8+10*4] errPtr: PExcFrame }
{ Pop the RaiseList }
CALL SysInit.@GetTLS
MOV EDX,[EAX].RaiseListPtr
MOV ECX,[EDX].TRaiseFrame.NextRaise
MOV [EAX].RaiseListPtr,ECX
{ Destroy exception object }
MOV EAX,[EDX].TRaiseFrame.ExceptObject
CALL TObject.Free
POP EDX
MOV ESP,[ESP+8+9*4]
XOR EAX,EAX
POP ECX
MOV FS:[EAX],ECX
POP EAX
POP EBP
CALL NotifyTerminate
JMP EDX
end;
procedure _TryFinallyExit;
asm
XOR EDX,EDX
MOV ECX,[ESP+4].TExcFrame.desc
MOV EAX,[ESP+4].TExcFrame.next
ADD ECX,TExcDesc.instructions
MOV FS:[EDX],EAX
CALL ECX
@@1: RET 12
end;
type
PInitContext = ^TInitContext;
TInitContext = record
OuterContext: PInitContext; { saved InitContext }
ExcFrame: PExcFrame; { bottom exc handler }
InitTable: PackageInfo; { unit init info }
InitCount: Integer; { how far we got }
Module: PLibModule; { ptr to module desc }
DLLSaveEBP: Pointer; { saved regs for DLLs }
DLLSaveEBX: Pointer; { saved regs for DLLs }
DLLSaveESI: Pointer; { saved regs for DLLs }
DLLSaveEDI: Pointer; { saved regs for DLLs }
DLLInitState: Byte;
ExitProcessTLS: procedure; { Shutdown for TLS }
end;
var
InitContext: TInitContext;
procedure RunErrorAt(ErrCode: Integer; ErrorAddr: Pointer);
asm
MOV [ESP],ErrorAddr
JMP _RunError
end;
procedure MapToRunError(P: PExceptionRecord); stdcall;
const
STATUS_ACCESS_VIOLATION = $C0000005;
STATUS_ARRAY_BOUNDS_EXCEEDED = $C000008C;
STATUS_FLOAT_DENORMAL_OPERAND = $C000008D;
STATUS_FLOAT_DIVIDE_BY_ZERO = $C000008E;
STATUS_FLOAT_INEXACT_RESULT = $C000008F;
STATUS_FLOAT_INVALID_OPERATION = $C0000090;
STATUS_FLOAT_OVERFLOW = $C0000091;
STATUS_FLOAT_STACK_CHECK = $C0000092;
STATUS_FLOAT_UNDERFLOW = $C0000093;
STATUS_INTEGER_DIVIDE_BY_ZERO = $C0000094;
STATUS_INTEGER_OVERFLOW = $C0000095;
STATUS_PRIVILEGED_INSTRUCTION = $C0000096;
STATUS_STACK_OVERFLOW = $C00000FD;
STATUS_CONTROL_C_EXIT = $C000013A;
var
ErrCode: Byte;
begin
case P.ExceptionCode of
STATUS_INTEGER_DIVIDE_BY_ZERO: ErrCode := 200;
STATUS_ARRAY_BOUNDS_EXCEEDED: ErrCode := 201;
STATUS_FLOAT_OVERFLOW: ErrCode := 205;
STATUS_FLOAT_INEXACT_RESULT,
STATUS_FLOAT_INVALID_OPERATION,
STATUS_FLOAT_STACK_CHECK: ErrCode := 207;
STATUS_FLOAT_DIVIDE_BY_ZERO: ErrCode := 200;
STATUS_INTEGER_OVERFLOW: ErrCode := 215;
STATUS_FLOAT_UNDERFLOW,
STATUS_FLOAT_DENORMAL_OPERAND: ErrCode := 206;
STATUS_ACCESS_VIOLATION: ErrCode := 216;
STATUS_PRIVILEGED_INSTRUCTION: ErrCode := 218;
STATUS_CONTROL_C_EXIT: ErrCode := 217;
STATUS_STACK_OVERFLOW: ErrCode := 202;
else ErrCode := 255;
end;
RunErrorAt(ErrCode, P.ExceptionAddress);
end;
procedure _ExceptionHandler;
asm
MOV EAX,[ESP+4]
TEST [EAX].TExceptionRecord.ExceptionFlags,cUnwindInProgress
JNE @@exit
CMP BYTE PTR DebugHook,0
JA @@ExecuteHandler
LEA EAX,[ESP+4]
PUSH EAX
CALL UnhandledExceptionFilter
CMP EAX,EXCEPTION_CONTINUE_SEARCH
JNE @@ExecuteHandler
JMP @@exit
// MOV EAX,1
// RET
@@ExecuteHandler:
MOV EAX,[ESP+4]
CLD
CALL FpuInit
MOV EDX,[ESP+8]
PUSH 0
PUSH EAX
PUSH offset @@returnAddress
PUSH EDX
CALL RtlUnwind
@@returnAddress:
MOV EBX,[ESP+4]
CMP [EBX].TExceptionRecord.ExceptionCode,cDelphiException
MOV EDX,[EBX].TExceptionRecord.ExceptAddr
MOV EAX,[EBX].TExceptionRecord.ExceptObject
JE @@DelphiException2
MOV EDX,ExceptObjProc
TEST EDX,EDX
JE MapToRunError
MOV EAX,EBX
CALL EDX
TEST EAX,EAX
JE MapToRunError
MOV EDX,[EBX].TExceptionRecord.ExceptionAddress
@@DelphiException2:
CALL NotifyUnhandled
MOV ECX,ExceptProc
TEST ECX,ECX
JE @@noExceptProc
CALL ECX { call ExceptProc(ExceptObject, ExceptAddr) }
@@noExceptProc:
MOV ECX,[ESP+4]
MOV EAX,217
MOV EDX,[ECX].TExceptionRecord.ExceptAddr
MOV [ESP],EDX
JMP _RunError
@@exit:
XOR EAX,EAX
end;
procedure SetExceptionHandler;
asm
XOR EDX,EDX { using [EDX] saves some space over [0] }
{X} // now we come here from another place, and EBP is used above for loop counter
{X} // let us restore it...
{X} PUSH EBP
{X} LEA EBP, [ESP + $60]
LEA EAX,[EBP-12]
MOV ECX,FS:[EDX] { ECX := head of chain }
MOV FS:[EDX],EAX { head of chain := @exRegRec }
MOV [EAX].TExcFrame.next,ECX
MOV [EAX].TExcFrame.desc,offset _ExceptionHandler
MOV [EAX].TExcFrame.hEBP,EBP
MOV InitContext.ExcFrame,EAX
{X} POP EBP
end;
procedure UnsetExceptionHandler;
asm
XOR EDX,EDX
MOV EAX,InitContext.ExcFrame
MOV ECX,FS:[EDX] { ECX := head of chain }
CMP EAX,ECX { simple case: our record is first }
JNE @@search
MOV EAX,[EAX] { head of chain := exRegRec.next }
MOV FS:[EDX],EAX
JMP @@exit
@@loop:
MOV ECX,[ECX]
@@search:
CMP ECX,-1 { at end of list? }
JE @@exit { yes - didn't find it }
CMP [ECX],EAX { is it the next one on the list? }
JNE @@loop { no - look at next one on list }
@@unlink: { yes - unlink our record }
MOV EAX,[EAX] { get next record on list }
MOV [ECX],EAX { unlink our record }
@@exit:
end;
{X+ see comments in InitUnits below }
//procedure FInitUnits; {X} - renamed to FInitUnitsHard
{X} procedure FInitUnitsHard;
var
Count: Integer;
Table: PUnitEntryTable;
P: procedure;
begin
if InitContext.InitTable = nil then
exit;
Count := InitContext.InitCount;
Table := InitContext.InitTable^.UnitInfo;
try
while Count > 0 do
begin
Dec(Count);
InitContext.InitCount := Count;
P := Table^[Count].FInit;
if Assigned(P) then
P;
end;
except
{X- rename: FInitUnits; { try to finalize the others }
FInitUnitsHard;
raise;
end;
end;
// This handler can be set in initialization section of
// unit SysSfIni.pas only.
procedure InitUnitsHard( Table : PUnitEntryTable; Idx, Count : Integer );
begin
try
InitUnitsLight( Table, Idx, Count );
except
FInitUnitsHard;
raise;
end;
end;
{X+ see comments in InitUnits below }
procedure FInitUnitsLight;
var
Count: Integer;
Table: PUnitEntryTable;
P: procedure;
begin
if InitContext.InitTable = nil then
exit;
Count := InitContext.InitCount;
Table := InitContext.InitTable^.UnitInfo;
while Count > 0 do
begin
Dec(Count);
InitContext.InitCount := Count;
P := Table^[Count].FInit;
if Assigned(P) then
P;
end;
end;
{X+ see comments in InitUnits below }
procedure InitUnitsLight( Table : PUnitEntryTable; Idx, Count : Integer );
var P : procedure;
Light : Boolean;
begin
Light := @InitUnitsProc = @InitUnitsLight;
while Idx < Count do
begin
P := Table^[ Idx ].Init;
Inc( Idx );
InitContext.InitCount := Idx;
if Assigned( P ) then
P;
if Light and (@InitUnitsProc <> @InitUnitsLight) then
begin
InitUnitsProc( Table, Idx, Count );
break;
end;
end;
end;
{X+ see comments in body of InitUnits below }
procedure InitUnits;
var
Count, I: Integer;
Table: PUnitEntryTable;
{X- P: procedure; }
begin
if InitContext.InitTable = nil then
exit;
Count := InitContext.InitTable^.UnitCount;
I := 0;
Table := InitContext.InitTable^.UnitInfo;
{X- by default, Delphi InitUnits uses try-except & raise constructions,
which leads to permanent use of all exception handler routines.
Let us make this by another way.
try
while I < Count do
begin
P := Table^[I].Init;
Inc(I);
InitContext.InitCount := I;
if Assigned(P) then
P;
end;
except
FInitUnits;
raise;
end;
X+}
InitUnitsProc( Table, I, Count );
end;
procedure _PackageLoad(const Table : PackageInfo);
var
SavedContext: TInitContext;
begin
SavedContext := InitContext;
InitContext.DLLInitState := 0;
InitContext.InitTable := Table;
InitContext.InitCount := 0;
InitContext.OuterContext := @SavedContext;
try
InitUnits;
finally
InitContext := SavedContext;
end;
end;
procedure _PackageUnload(const Table : PackageInfo);
var
SavedContext: TInitContext;
begin
SavedContext := InitContext;
InitContext.DLLInitState := 0;
InitContext.InitTable := Table;
InitContext.InitCount := Table^.UnitCount;
InitContext.OuterContext := @SavedContext;
try
FInitUnitsProc;
finally
InitContext := SavedContext;
end;
end;
procedure _StartExe;
asm
{ -> EAX InitTable }
{ EDX Module }
MOV InitContext.InitTable,EAX
XOR EAX,EAX
MOV InitContext.InitCount,EAX
MOV InitContext.Module,EDX
MOV EAX,[EDX].TLibModule.Instance
MOV MainInstance,EAX
{X CALL SetExceptionHandler - moved to SysSfIni.pas }
MOV IsLibrary,0
CALL InitUnits;
end;
procedure _StartLib;
asm
{ -> EAX InitTable }
{ EDX Module }
{ ECX InitTLS }
{ [ESP+4] DllProc }
{ [EBP+8] HInst }
{ [EBP+12] Reason }
{ Push some desperately needed registers }
PUSH ECX
PUSH ESI
PUSH EDI
{ Save the current init context into the stackframe of our caller }
MOV ESI,offset InitContext
LEA EDI,[EBP- (type TExcFrame) - (type TInitContext)]
MOV ECX,(type TInitContext)/4
REP MOVSD
{ Setup the current InitContext }
POP InitContext.DLLSaveEDI
POP InitContext.DLLSaveESI
MOV InitContext.DLLSaveEBP,EBP
MOV InitContext.DLLSaveEBX,EBX
MOV InitContext.InitTable,EAX
MOV InitContext.Module,EDX
LEA ECX,[EBP- (type TExcFrame) - (type TInitContext)]
MOV InitContext.OuterContext,ECX
XOR ECX,ECX
CMP dword ptr [EBP+12],0
JNE @@notShutDown
MOV ECX,[EAX].PackageInfoTable.UnitCount
@@notShutDown:
MOV InitContext.InitCount,ECX
CALL SetExceptionHandler {X-- could be moved to SysSfIni.pas but ...}
MOV EAX,[EBP+12]
INC EAX
MOV InitContext.DLLInitState,AL
DEC EAX
{ Init any needed TLS }
POP ECX
MOV EDX,[ECX]
MOV InitContext.ExitProcessTLS,EDX
JE @@noTLSproc
CALL dword ptr [ECX+EAX*4]
@@noTLSproc:
{ Call any DllProc }
MOV EDX,[ESP+4]
TEST EDX,EDX
JE @@noDllProc
MOV EAX,[EBP+12]
CALL EDX
@@noDllProc:
{ Set IsLibrary if there was no exe yet }
CMP MainInstance,0
JNE @@haveExe
MOV IsLibrary,1
FNSTCW Default8087CW // save host exe's FPU preferences
@@haveExe:
MOV EAX,[EBP+12]
DEC EAX
JNE _Halt0
CALL InitUnits
RET 4
end;
procedure _InitResStrings;
asm
{ -> EAX Pointer to init table }
{ record }
{ cnt: Integer; }
{ tab: array [1..cnt] record }
{ variableAddress: Pointer; }
{ resStringAddress: Pointer; }
{ end; }
{ end; }
PUSH EBX
PUSH ESI
MOV EBX,[EAX]
LEA ESI,[EAX+4]
@@loop:
MOV EAX,[ESI+4] { load resStringAddress }
MOV EDX,[ESI] { load variableAddress }
CALL LoadResString
ADD ESI,8
DEC EBX
JNZ @@loop
POP ESI
POP EBX
end;
procedure _InitResStringImports;
asm
{ -> EAX Pointer to init table }
{ record }
{ cnt: Integer; }
{ tab: array [1..cnt] record }
{ variableAddress: Pointer; }
{ resStringAddress: ^Pointer; }
{ end; }
{ end; }
PUSH EBX
PUSH ESI
MOV EBX,[EAX]
LEA ESI,[EAX+4]
@@loop:
MOV EAX,[ESI+4] { load address of import }
MOV EDX,[ESI] { load address of variable }
MOV EAX,[EAX] { load contents of import }
CALL LoadResString
ADD ESI,8
DEC EBX
JNZ @@loop
POP ESI
POP EBX
end;
procedure _InitImports;
asm
{ -> EAX Pointer to init table }
{ record }
{ cnt: Integer; }
{ tab: array [1..cnt] record }
{ variableAddress: Pointer; }
{ sourceAddress: ^Pointer; }
{ sourceOffset: Longint; }
{ end; }
{ end; }
PUSH EBX
PUSH ESI
MOV EBX,[EAX]
LEA ESI,[EAX+4]
@@loop:
MOV EAX,[ESI+4] { load address of import }
MOV EDX,[ESI] { load address of variable }
MOV ECX,[ESI+8] { load offset }
MOV EAX,[EAX] { load contents of import }
ADD EAX,ECX { calc address of variable }
MOV [EDX],EAX { store result }
ADD ESI,12
DEC EBX
JNZ @@loop
POP ESI
POP EBX
end;
procedure _InitWideStrings;
asm
{ -> EAX Pointer to init table }
{ record }
{ cnt: Integer; }
{ tab: array [1..cnt] record }
{ variableAddress: Pointer; }
{ stringAddress: ^Pointer; }
{ end; }
{ end; }
PUSH EBX
PUSH ESI
MOV EBX,[EAX]
LEA ESI,[EAX+4]
@@loop:
MOV EDX,[ESI+4] { load address of string }
MOV EAX,[ESI] { load address of variable }
CALL _WStrAsg
ADD ESI,8
DEC EBX
JNZ @@loop
POP ESI
POP EBX
end;
var
runErrMsg: array[0..29] of Char = 'Runtime error at 00000000'#0;
// columns: 0123456789012345678901234567890
errCaption: array[0..5] of Char = 'Error'#0;
procedure MakeErrorMessage;
const
dig : array [0..15] of Char = '0123456789ABCDEF';
asm
PUSH EBX
MOV EAX,ExitCode
MOV EBX,offset runErrMsg + 16
MOV ECX,10
@@digLoop:
XOR EDX,EDX
DIV ECX
ADD DL,'0'
MOV [EBX],DL
DEC EBX
TEST EAX,EAX
JNZ @@digLoop
MOV EAX,ErrorAddr
CALL FindHInstance
MOV EDX, ErrorAddr
XCHG EAX, EDX
SUB EAX, EDX { EAX <=> offset from start of code for HINSTANCE }
MOV EBX,offset runErrMsg + 28
@@hdigLoop:
MOV EDX,EAX
AND EDX,0FH
MOV DL,byte ptr dig[EDX]
MOV [EBX],DL
DEC EBX
SHR EAX,4
JNE @@hdigLoop
POP EBX
end;
procedure ExitDll;
asm
{ Restore the InitContext }
MOV EDI,offset InitContext
MOV EBX,InitContext.DLLSaveEBX
MOV EBP,InitContext.DLLSaveEBP
PUSH [EDI].TInitContext.DLLSaveESI
PUSH [EDI].TInitContext.DLLSaveEDI
MOV ESI,[EDI].TInitContext.OuterContext
MOV ECX,(type TInitContext)/4
REP MOVSD
POP EDI
POP ESI
{ Return False if ExitCode <> 0, and set ExitCode to 0 }
XOR EAX,EAX
XCHG EAX,ExitCode
NEG EAX
SBB EAX,EAX
INC EAX
LEAVE
RET 12
end;
// {X} Procedure Halt0 refers to WriteLn and MessageBox
// but actually such code can be not used really.
// So, implementation changed to avoid such references.
//
// Either call UseErrorMessageBox or UseErrorMessageWrite
// to provide error message output in GUI or console app.
// {X}+
var ErrorMessageOutProc : procedure = DummyProc;
procedure ErrorMessageBox;
begin
MakeErrorMessage;
if not NoErrMsg then
MessageBox(0, runErrMsg, errCaption, 0);
end;
procedure UseErrorMessageBox;
begin
ErrorMessageOutProc := ErrorMessageBox;
end;
procedure ErrorMessageWrite;
begin
MakeErrorMessage;
WriteLn(PChar(@runErrMsg));
end;
procedure UseErrorMessageWrite;
begin
ErrorMessageOutProc := ErrorMessageWrite;
end;
procedure DoCloseInputOutput;
begin
Close( Input );
Close( Output );
end;
var CloseInputOutput : procedure;
procedure UseInputOutput;
begin
if not assigned( CloseInputOutput ) then
begin
CloseInputOutput := DoCloseInputOutput;
_Assign( Input, '' );
_Assign( Output, '' );
end;
end;
// {X}-
procedure _Halt0;
var
P: procedure;
begin
if InitContext.DLLInitState = 0 then
while ExitProc <> nil do
begin
@P := ExitProc;
ExitProc := nil;
P;
end;
{ If there was some kind of runtime error, alert the user }
if ErrorAddr <> nil then
begin
{X+}
ErrorMessageOutProc;
{
MakeErrorMessage;
if IsConsole then
WriteLn(PChar(@runErrMsg))
else if not NoErrMsg then
MessageBox(0, runErrMsg, errCaption, 0);
} {X-}
{X- As it is said by Alexey Torgashin, it is better not to clear ErrorAddr
to make possible check ErrorAddr <> nil in finalization of rest units.
If You want, You can uncomment it again: }
//ErrorAddr := nil;
{X+}
end;
{ This loop exists because we might be nested in PackageLoad calls when }
{ Halt got called. We need to unwind these contexts. }
while True do
begin
{ If we are a library, and we are starting up fine, there are no units to finalize }
if (InitContext.DLLInitState = 2) and (ExitCode = 0) then
InitContext.InitCount := 0;
{ Undo any unit initializations accomplished so far }
FInitUnitsProc;
if (InitContext.DLLInitState <= 1) or (ExitCode <> 0) then
if InitContext.Module <> nil then
with InitContext do
begin
UnregisterModule(Module);
if Module.ResInstance <> Module.Instance then
FreeLibrary(Module.ResInstance);
end;
{X UnsetExceptionHandler; - changed to call of handler }
UnsetExceptionHandlerProc;
if InitContext.DllInitState = 1 then
InitContext.ExitProcessTLS;
if InitContext.DllInitState <> 0 then
ExitDll;
if InitContext.OuterContext = nil then
ExitProcess(ExitCode);
InitContext := InitContext.OuterContext^
end;
asm
db 'Portions Copyright (c) 1983,99 Borland',0
end;
end;
procedure _Halt;
asm
MOV ExitCode,EAX
JMP _Halt0
end;
procedure _Run0Error;
asm
XOR EAX,EAX
JMP _RunError
end;
procedure _RunError;
asm
POP ErrorAddr
JMP _Halt
end;
procedure _Assert(const Message, Filename: AnsiString; LineNumber: Integer);
asm
CMP AssertErrorProc,0
JE @@1
PUSH [ESP].Pointer
CALL AssertErrorProc
RET
@@1: MOV AL,reAssertionFailed
JMP Error
end;
type
PThreadRec = ^TThreadRec;
TThreadRec = record
Func: TThreadFunc;
Parameter: Pointer;
end;
function ThreadWrapper(Parameter: Pointer): Integer; stdcall;
asm
CALL FpuInit
XOR ECX,ECX
PUSH EBP
PUSH offset _ExceptionHandler
MOV EDX,FS:[ECX]
PUSH EDX
MOV EAX,Parameter
MOV FS:[ECX],ESP
MOV ECX,[EAX].TThreadRec.Parameter
MOV EDX,[EAX].TThreadRec.Func
PUSH ECX
PUSH EDX
CALL _FreeMem
POP EDX
POP EAX
CALL EDX
XOR EDX,EDX
POP ECX
MOV FS:[EDX],ECX
POP ECX
POP EBP
end;
function BeginThread(SecurityAttributes: Pointer; StackSize: LongWord;
ThreadFunc: TThreadFunc; Parameter: Pointer; CreationFlags: LongWord;
var ThreadId: LongWord): Integer;
var
P: PThreadRec;
begin
New(P);
P.Func := ThreadFunc;
P.Parameter := Parameter;
IsMultiThread := TRUE;
Result := CreateThread(SecurityAttributes, StackSize, @ThreadWrapper, P,
CreationFlags, ThreadID);
end;
procedure EndThread(ExitCode: Integer);
begin
ExitThread(ExitCode);
end;
type
StrRec = packed record
allocSiz: Longint;
refCnt: Longint;
length: Longint;
end;
const
skew = sizeof(StrRec);
rOff = sizeof(StrRec) - sizeof(Longint); { refCnt offset }
overHead = sizeof(StrRec) + 1;
procedure _LStrClr(var S: AnsiString);
asm
{ -> EAX pointer to str }
MOV EDX,[EAX] { fetch str }
TEST EDX,EDX { if nil, nothing to do }
JE @@done
MOV dword ptr [EAX],0 { clear str }
MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt }
DEC ECX { if < 0: literal str }
JL @@done
{X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount }
JNE @@done
PUSH EAX
LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate}
CALL _FreeMem
POP EAX
@@done:
end;
procedure _LStrArrayClr{var str: AnsiString; cnt: longint};
asm
{ -> EAX pointer to str }
{ EDX cnt }
PUSH EBX
PUSH ESI
MOV EBX,EAX
MOV ESI,EDX
@@loop:
MOV EDX,[EBX] { fetch str }
TEST EDX,EDX { if nil, nothing to do }
JE @@doneEntry
MOV dword ptr [EBX],0 { clear str }
MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt }
DEC ECX { if < 0: literal str }
JL @@doneEntry
{X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount }
JNE @@doneEntry
LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate}
CALL _FreeMem
@@doneEntry:
ADD EBX,4
DEC ESI
JNE @@loop
POP ESI
POP EBX
end;
{ 99.03.11
This function is used when assigning to global variables.
Literals are copied to prevent a situation where a dynamically
allocated DLL or package assigns a literal to a variable and then
is unloaded -- thereby causing the string memory (in the code
segment of the DLL) to be removed -- and therefore leaving the
global variable pointing to invalid memory.
}
procedure _LStrAsg{var dest: AnsiString; source: AnsiString};
asm
{ -> EAX pointer to dest str }
{ -> EDX pointer to source str }
TEST EDX,EDX { have a source? }
JE @@2 { no -> jump }
MOV ECX,[EDX-skew].StrRec.refCnt
INC ECX
JG @@1 { literal string -> jump not taken }
PUSH EAX
PUSH EDX
MOV EAX,[EDX-skew].StrRec.length
CALL _NewAnsiString
MOV EDX,EAX
POP EAX
PUSH EDX
MOV ECX,[EAX-skew].StrRec.length
CALL Move
POP EDX
POP EAX
JMP @@2
@@1:
{X LOCK} INC [EDX-skew].StrRec.refCnt
@@2: XCHG EDX,[EAX]
TEST EDX,EDX
JE @@3
MOV ECX,[EDX-skew].StrRec.refCnt
DEC ECX
JL @@3
{X LOCK} DEC [EDX-skew].StrRec.refCnt
JNE @@3
LEA EAX,[EDX-skew].StrRec.refCnt
CALL _FreeMem
@@3:
end;
procedure _LStrLAsg{var dest: AnsiString; source: AnsiString};
asm
{ -> EAX pointer to dest }
{ EDX source }
TEST EDX,EDX
JE @@sourceDone
{ bump up the ref count of the source }
MOV ECX,[EDX-skew].StrRec.refCnt
INC ECX
JLE @@sourceDone { literal assignment -> jump taken }
{X LOCK} INC [EDX-skew].StrRec.refCnt
@@sourceDone:
{ we need to release whatever the dest is pointing to }
XCHG EDX,[EAX] { fetch str }
TEST EDX,EDX { if nil, nothing to do }
JE @@done
MOV ECX,[EDX-skew].StrRec.refCnt { fetch refCnt }
DEC ECX { if < 0: literal str }
JL @@done
{X LOCK} DEC [EDX-skew].StrRec.refCnt { NONthreadsafe dec refCount }
JNE @@done
LEA EAX,[EDX-skew].StrRec.refCnt { if refCnt now zero, deallocate}
CALL _FreeMem
@@done:
end;
procedure _NewAnsiString{length: Longint};
asm
{ -> EAX length }
{ <- EAX pointer to new string }
TEST EAX,EAX
JLE @@null
PUSH EAX
ADD EAX,rOff+1
CALL _GetMem
ADD EAX,rOff
POP EDX
MOV [EAX-skew].StrRec.length,EDX
MOV [EAX-skew].StrRec.refCnt,1
MOV byte ptr [EAX+EDX],0
RET
@@null:
XOR EAX,EAX
end;
procedure _LStrFromPCharLen(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
asm
{ -> EAX pointer to dest }
{ EDX source }
{ ECX length }
PUSH EBX
PUSH ESI
PUSH EDI
MOV EBX,EAX
MOV ESI,EDX
MOV EDI,ECX
{ allocate new string }
MOV EAX,EDI
CALL _NewAnsiString
MOV ECX,EDI
MOV EDI,EAX
TEST ESI,ESI
JE @@noMove
MOV EDX,EAX
MOV EAX,ESI
CALL Move
{ assign the result to dest }
@@noMove:
MOV EAX,EBX
CALL _LStrClr
MOV [EBX],EDI
POP EDI
POP ESI
POP EBX
end;
procedure _LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer);
var
DestLen: Integer;
Buffer: array[0..2047] of Char;
begin
if Length <= 0 then
begin
_LStrClr(Dest);
Exit;
end;
if Length < SizeOf(Buffer) div 2 then
begin
DestLen := WideCharToMultiByte(0, 0, Source, Length,
Buffer, SizeOf(Buffer), nil, nil);
if DestLen > 0 then
begin
_LStrFromPCharLen(Dest, Buffer, DestLen);
Exit;
end;
end;
DestLen := WideCharToMultiByte(0, 0, Source, Length, nil, 0, nil, nil);
_LStrFromPCharLen(Dest, nil, DestLen);
WideCharToMultiByte(0, 0, Source, Length, Pointer(Dest), DestLen, nil, nil);
end;
procedure _LStrFromChar(var Dest: AnsiString; Source: AnsiChar);
asm
PUSH EDX
MOV EDX,ESP
MOV ECX,1
CALL _LStrFromPCharLen
POP EDX
end;
procedure _LStrFromWChar(var Dest: AnsiString; Source: WideChar);
asm
PUSH EDX
MOV EDX,ESP
MOV ECX,1
CALL _LStrFromPWCharLen
POP EDX
end;
procedure _LStrFromPChar(var Dest: AnsiString; Source: PAnsiChar);
asm
XOR ECX,ECX
TEST EDX,EDX
JE @@5
PUSH EDX
@@0: CMP CL,[EDX+0]
JE @@4
CMP CL,[EDX+1]
JE @@3
CMP CL,[EDX+2]
JE @@2
CMP CL,[EDX+3]
JE @@1
ADD EDX,4
JMP @@0
@@1: INC EDX
@@2: INC EDX
@@3: INC EDX
@@4: MOV ECX,EDX
POP EDX
SUB ECX,EDX
@@5: JMP _LStrFromPCharLen
end;
procedure _LStrFromPWChar(var Dest: AnsiString; Source: PWideChar);
asm
XOR ECX,ECX
TEST EDX,EDX
JE @@5
PUSH EDX
@@0: CMP CX,[EDX+0]
JE @@4
CMP CX,[EDX+2]
JE @@3
CMP CX,[EDX+4]
JE @@2
CMP CX,[EDX+6]
JE @@1
ADD EDX,8
JMP @@0
@@1: ADD EDX,2
@@2: ADD EDX,2
@@3: ADD EDX,2
@@4: MOV ECX,EDX
POP EDX
SUB ECX,EDX
SHR ECX,1
@@5: JMP _LStrFromPWCharLen
end;
procedure _LStrFromString(var Dest: AnsiString; const Source: ShortString);
asm
XOR ECX,ECX
MOV CL,[EDX]
INC EDX
JMP _LStrFromPCharLen
end;
procedure _LStrFromArray(var Dest: AnsiString; Source: PAnsiChar; Length: Integer);
asm
PUSH EDI
PUSH EAX
PUSH ECX
MOV EDI,EDX
XOR EAX,EAX
REPNE SCASB
JNE @@1
NOT ECX
@@1: POP EAX
ADD ECX,EAX
POP EAX
POP EDI
JMP _LStrFromPCharLen
end;
procedure _LStrFromWArray(var Dest: AnsiString; Source: PWideChar; Length: Integer);
asm
PUSH EDI
PUSH EAX
PUSH ECX
MOV EDI,EDX
XOR EAX,EAX
REPNE SCASW
JNE @@1
NOT ECX
@@1: POP EAX
ADD ECX,EAX
POP EAX
POP EDI
JMP _LStrFromPWCharLen
end;
procedure _LStrFromWStr(var Dest: AnsiString; const Source: WideString);
asm
{ -> EAX pointer to dest }
{ EDX pointer to WideString data }
XOR ECX,ECX
TEST EDX,EDX
JE @@1
MOV ECX,[EDX-4]
SHR ECX,1
@@1: JMP _LStrFromPWCharLen
end;
procedure _LStrToString{(var Dest: ShortString; const Source: AnsiString; MaxLen: Integer)};
asm
{ -> EAX pointer to result }
{ EDX AnsiString s }
{ ECX length of result }
PUSH EBX
TEST EDX,EDX
JE @@empty
MOV EBX,[EDX-skew].StrRec.length
TEST EBX,EBX
JE @@empty
CMP ECX,EBX
JL @@truncate
MOV ECX,EBX
@@truncate:
MOV [EAX],CL
INC EAX
XCHG EAX,EDX
CALL Move
JMP @@exit
@@empty:
MOV byte ptr [EAX],0
@@exit:
POP EBX
end;
function _LStrLen{str: AnsiString}: Longint;
asm
{ -> EAX str }
TEST EAX,EAX
JE @@done
MOV EAX,[EAX-skew].StrRec.length;
@@done:
end;
procedure _LStrCat{var dest: AnsiString; source: AnsiString};
asm
{ -> EAX pointer to dest }
{ EDX source }
TEST EDX,EDX
JE @@exit
MOV ECX,[EAX]
TEST ECX,ECX
JE _LStrAsg
PUSH EBX
PUSH ESI
PUSH EDI
MOV EBX,EAX
MOV ESI,EDX
MOV EDI,[ECX-skew].StrRec.length
MOV EDX,[ESI-skew].StrRec.length
ADD EDX,EDI
CMP ESI,ECX
JE @@appendSelf
CALL _LStrSetLength
MOV EAX,ESI
MOV ECX,[ESI-skew].StrRec.length
@@appendStr:
MOV EDX,[EBX]
ADD EDX,EDI
CALL Move
POP EDI
POP ESI
POP EBX
RET
@@appendSelf:
CALL _LStrSetLength
MOV EAX,[EBX]
MOV ECX,EDI
JMP @@appendStr
@@exit:
end;
procedure _LStrCat3{var dest:AnsiString; source1: AnsiString; source2: AnsiString};
asm
{ ->EAX = Pointer to dest }
{ EDX = source1 }
{ ECX = source2 }
TEST EDX,EDX
JE @@assignSource2
TEST ECX,ECX
JE _LStrAsg
CMP EDX,[EAX]
JE @@appendToDest
CMP ECX,[EAX]
JE @@theHardWay
PUSH EAX
PUSH ECX
CALL _LStrAsg
POP EDX
POP EAX
JMP _LStrCat
@@theHardWay:
PUSH EBX
PUSH ESI
PUSH EDI
MOV EBX,EDX
MOV ESI,ECX
PUSH EAX
MOV EAX,[EBX-skew].StrRec.length
ADD EAX,[ESI-skew].StrRec.length
CALL _NewAnsiString
MOV EDI,EAX
MOV EDX,EAX
MOV EAX,EBX
MOV ECX,[EBX-skew].StrRec.length
CALL Move
MOV EDX,EDI
MOV EAX,ESI
MOV ECX,[ESI-skew].StrRec.length
ADD EDX,[EBX-skew].StrRec.length
CALL Move
POP EAX
MOV EDX,EDI
TEST EDI,EDI
JE @@skip
DEC [EDI-skew].StrRec.refCnt // EDI = local temp str
@@skip:
CALL _LStrAsg
POP EDI
POP ESI
POP EBX
JMP @@exit
@@assignSource2:
MOV EDX,ECX
JMP _LStrAsg
@@appendToDest:
MOV EDX,ECX
JMP _LStrCat
@@exit:
end;
procedure _LStrCatN{var dest:AnsiString; argCnt: Integer; ...};
asm
{ ->EAX = Pointer to dest }
{ EDX = number of args (>= 3) }
{ [ESP+4], [ESP+8], ... crgCnt AnsiString arguments }
PUSH EBX
PUSH ESI
PUSH EDX
PUSH EAX
MOV EBX,EDX
XOR EAX,EAX
@@loop1:
MOV ECX,[ESP+EDX*4+4*4]
TEST ECX,ECX
JE @@1
ADD EAX,[ECX-skew].StrRec.length
@@1:
DEC EDX
JNE @@loop1
CALL _NewAnsiString
PUSH EAX
MOV ESI,EAX
@@loop2:
MOV EAX,[ESP+EBX*4+5*4]
MOV EDX,ESI
TEST EAX,EAX
JE @@2
MOV ECX,[EAX-skew].StrRec.length
ADD ESI,ECX
CALL Move
@@2:
DEC EBX
JNE @@loop2
POP EDX
POP EAX
TEST EDX,EDX
JE @@skip
DEC [EDX-skew].StrRec.refCnt // EDX = local temp str
@@skip:
CALL _LStrAsg
POP EDX
POP ESI
POP EBX
POP EAX
LEA ESP,[ESP+EDX*4]
JMP EAX
end;
procedure _LStrCmp{left: AnsiString; right: AnsiString};
asm
{ ->EAX = Pointer to left string }
{ EDX = Pointer to right string }
PUSH EBX
PUSH ESI
PUSH EDI
MOV ESI,EAX
MOV EDI,EDX
CMP EAX,EDX
JE @@exit
TEST ESI,ESI
JE @@str1null
TEST EDI,EDI
JE @@str2null
MOV EAX,[ESI-skew].StrRec.length
MOV EDX,[EDI-skew].StrRec.length
SUB EAX,EDX { eax = len1 - len2 }
JA @@skip1
ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 }
@@skip1:
PUSH EDX
SHR EDX,2
JE @@cmpRest
@@longLoop:
MOV ECX,[ESI]
MOV EBX,[EDI]
CMP ECX,EBX
JNE @@misMatch
DEC EDX
JE @@cmpRestP4
MOV ECX,[ESI+4]
MOV EBX,[EDI+4]
CMP ECX,EBX
JNE @@misMatch
ADD ESI,8
ADD EDI,8
DEC EDX
JNE @@longLoop
JMP @@cmpRest
@@cmpRestP4:
ADD ESI,4
ADD EDI,4
@@cmpRest:
POP EDX
AND EDX,3
JE @@equal
MOV ECX,[ESI]
MOV EBX,[EDI]
CMP CL,BL
JNE @@exit
DEC EDX
JE @@equal
CMP CH,BH
JNE @@exit
DEC EDX
JE @@equal
AND EBX,$00FF0000
AND ECX,$00FF0000
CMP ECX,EBX
JNE @@exit
@@equal:
ADD EAX,EAX
JMP @@exit
@@str1null:
MOV EDX,[EDI-skew].StrRec.length
SUB EAX,EDX
JMP @@exit
@@str2null:
MOV EAX,[ESI-skew].StrRec.length
SUB EAX,EDX
JMP @@exit
@@misMatch:
POP EDX
CMP CL,BL
JNE @@exit
CMP CH,BH
JNE @@exit
SHR ECX,16
SHR EBX,16
CMP CL,BL
JNE @@exit
CMP CH,BH
@@exit:
POP EDI
POP ESI
POP EBX
end;
procedure _LStrAddRef{str: AnsiString};
asm
{ -> EAX str }
TEST EAX,EAX
JE @@exit
MOV EDX,[EAX-skew].StrRec.refCnt
INC EDX
JLE @@exit
{X LOCK} INC [EAX-skew].StrRec.refCnt
@@exit:
end;
procedure _LStrToPChar{str: AnsiString): PChar};
asm
{ -> EAX pointer to str }
{ <- EAX pointer to PChar }
TEST EAX,EAX
JE @@handle0
RET
@@zeroByte:
DB 0
@@handle0:
MOV EAX,offset @@zeroByte
end;
procedure UniqueString(var str: string);
asm
{ -> EAX pointer to str }
{ <- EAX pointer to unique copy }
MOV EDX,[EAX]
TEST EDX,EDX
JE @@exit
MOV ECX,[EDX-skew].StrRec.refCnt
DEC ECX
JE @@exit
PUSH EBX
MOV EBX,EAX
MOV EAX,[EDX-skew].StrRec.length
CALL _NewAnsiString
MOV EDX,EAX
MOV EAX,[EBX]
MOV [EBX],EDX
MOV ECX,[EAX-skew].StrRec.refCnt
DEC ECX
JL @@skip
{X LOCK} DEC [EAX-skew].StrRec.refCnt
@@skip:
MOV ECX,[EAX-skew].StrRec.length
CALL Move
MOV EDX,[EBX]
POP EBX
@@exit:
MOV EAX,EDX
end;
procedure _LStrCopy{ const s : AnsiString; index, count : Integer) : AnsiString};
asm
{ ->EAX Source string }
{ EDX index }
{ ECX count }
{ [ESP+4] Pointer to result string }
PUSH EBX
TEST EAX,EAX
JE @@srcEmpty
MOV EBX,[EAX-skew].StrRec.length
TEST EBX,EBX
JE @@srcEmpty
{ make index 0-based and limit to 0 <= index < Length(src) }
DEC EDX
JL @@smallInx
CMP EDX,EBX
JGE @@bigInx
@@cont1:
{ limit count to satisfy 0 <= count <= Length(src) - index }
SUB EBX,EDX { calculate Length(src) - index }
TEST ECX,ECX
JL @@smallCount
CMP ECX,EBX
JG @@bigCount
@@cont2:
ADD EDX,EAX
MOV EAX,[ESP+4+4]
CALL _LStrFromPCharLen
JMP @@exit
@@smallInx:
XOR EDX,EDX
JMP @@cont1
@@bigCount:
MOV ECX,EBX
JMP @@cont2
@@bigInx:
@@smallCount:
@@srcEmpty:
MOV EAX,[ESP+4+4]
CALL _LStrClr
@@exit:
POP EBX
RET 4
end;
procedure _LStrDelete{ var s : AnsiString; index, count : Integer };
asm
{ ->EAX Pointer to s }
{ EDX index }
{ ECX count }
PUSH EBX
PUSH ESI
PUSH EDI
MOV EBX,EAX
MOV ESI,EDX
MOV EDI,ECX
CALL UniqueString
MOV EDX,[EBX]
TEST EDX,EDX { source already empty: nothing to do }
JE @@exit
MOV ECX,[EDX-skew].StrRec.length
{ make index 0-based, if not in [0 .. Length(s)-1] do nothing }
DEC ESI
JL @@exit
CMP ESI,ECX
JGE @@exit
{ limit count to [0 .. Length(s) - index] }
TEST EDI,EDI
JLE @@exit
SUB ECX,ESI { ECX = Length(s) - index }
CMP EDI,ECX
JLE @@1
MOV EDI,ECX
@@1:
{ move length - index - count characters from s+index+count to s+index }
SUB ECX,EDI { ECX = Length(s) - index - count }
ADD EDX,ESI { EDX = s+index }
LEA EAX,[EDX+EDI] { EAX = s+index+count }
CALL Move
{ set length(s) to length(s) - count }
MOV EDX,[EBX]
MOV EAX,EBX
MOV EDX,[EDX-skew].StrRec.length
SUB EDX,EDI
CALL _LStrSetLength
@@exit:
POP EDI
POP ESI
POP EBX
end;
procedure _LStrInsert{ const source : AnsiString; var s : AnsiString; index : Integer };
asm
{ -> EAX source string }
{ EDX pointer to destination string }
{ ECX index }
TEST EAX,EAX
JE @@nothingToDo
PUSH EBX
PUSH ESI
PUSH EDI
PUSH EBP
MOV EBX,EAX
MOV ESI,EDX
MOV EDI,ECX
{ make index 0-based and limit to 0 <= index <= Length(s) }
MOV EDX,[EDX]
PUSH EDX
TEST EDX,EDX
JE @@sIsNull
MOV EDX,[EDX-skew].StrRec.length
@@sIsNull:
DEC EDI
JGE @@indexNotLow
XOR EDI,EDI
@@indexNotLow:
CMP EDI,EDX
JLE @@indexNotHigh
MOV EDI,EDX
@@indexNotHigh:
MOV EBP,[EBX-skew].StrRec.length
{ set length of result to length(source) + length(s) }
MOV EAX,ESI
ADD EDX,EBP
CALL _LStrSetLength
POP EAX
CMP EAX,EBX
JNE @@notInsertSelf
MOV EBX,[ESI]
@@notInsertSelf:
{ move length(s) - length(source) - index chars from s+index to s+index+length(source) }
MOV EAX,[ESI] { EAX = s }
LEA EDX,[EDI+EBP] { EDX = index + length(source) }
MOV ECX,[EAX-skew].StrRec.length
SUB ECX,EDX { ECX = length(s) - length(source) - index }
ADD EDX,EAX { EDX = s + index + length(source) }
ADD EAX,EDI { EAX = s + index }
CALL Move
{ copy length(source) chars from source to s+index }
MOV EAX,EBX
MOV EDX,[ESI]
MOV ECX,EBP
ADD EDX,EDI
CALL Move
@@exit:
POP EBP
POP EDI
POP ESI
POP EBX
@@nothingToDo:
end;
procedure _LStrPos{ const substr : AnsiString; const s : AnsiString ) : Integer};
asm
{ ->EAX Pointer to substr }
{ EDX Pointer to string }
{ <-EAX Position of substr in s or 0 }
TEST EAX,EAX
JE @@noWork
TEST EDX,EDX
JE @@stringEmpty
PUSH EBX
PUSH ESI
PUSH EDI
MOV ESI,EAX { Point ESI to substr }
MOV EDI,EDX { Point EDI to s }
MOV ECX,[EDI-skew].StrRec.length { ECX = Length(s) }
PUSH EDI { remember s position to calculate index }
MOV EDX,[ESI-skew].StrRec.length { EDX = Length(substr) }
DEC EDX { EDX = Length(substr) - 1 }
JS @@fail { < 0 ? return 0 }
MOV AL,[ESI] { AL = first char of substr }
INC ESI { Point ESI to 2'nd char of substr }
SUB ECX,EDX { #positions in s to look at }
{ = Length(s) - Length(substr) + 1 }
JLE @@fail
@@loop:
REPNE SCASB
JNE @@fail
MOV EBX,ECX { save outer loop counter }
PUSH ESI { save outer loop substr pointer }
PUSH EDI { save outer loop s pointer }
MOV ECX,EDX
REPE CMPSB
POP EDI { restore outer loop s pointer }
POP ESI { restore outer loop substr pointer }
JE @@found
MOV ECX,EBX { restore outer loop counter }
JMP @@loop
@@fail:
POP EDX { get rid of saved s pointer }
XOR EAX,EAX
JMP @@exit
@@stringEmpty:
XOR EAX,EAX
JMP @@noWork
@@found:
POP EDX { restore pointer to first char of s }
MOV EAX,EDI { EDI points of char after match }
SUB EAX,EDX { the difference is the correct index }
@@exit:
POP EDI
POP ESI
POP EBX
@@noWork:
end;
procedure _LStrSetLength{ var str: AnsiString; newLength: Integer};
asm
{ -> EAX Pointer to str }
{ EDX new length }
PUSH EBX
PUSH ESI
PUSH EDI
MOV EBX,EAX
MOV ESI,EDX
XOR EDI,EDI
TEST EDX,EDX
JE @@setString
MOV EAX,[EBX]
TEST EAX,EAX
JE @@copyString
CMP [EAX-skew].StrRec.refCnt,1
JNE @@copyString
SUB EAX,rOff
ADD EDX,rOff+1
PUSH EAX
MOV EAX,ESP
CALL _ReallocMem
POP EAX
ADD EAX,rOff
MOV [EBX],EAX
MOV [EAX-skew].StrRec.length,ESI
MOV BYTE PTR [EAX+ESI],0
JMP @@exit
@@copyString:
MOV EAX,EDX
CALL _NewAnsiString
MOV EDI,EAX
MOV EAX,[EBX]
TEST EAX,EAX
JE @@setString
MOV EDX,EDI
MOV ECX,[EAX-skew].StrRec.length
CMP ECX,ESI
JL @@moveString
MOV ECX,ESI
@@moveString:
CALL Move
@@setString:
MOV EAX,EBX
CALL _LStrClr
MOV [EBX],EDI
@@exit:
POP EDI
POP ESI
POP EBX
end;
procedure _LStrOfChar{ c: Char; count: Integer): AnsiString };
asm
{ -> AL c }
{ EDX count }
{ ECX result }
PUSH EBX
PUSH ESI
PUSH EDI
MOV EBX,EAX
MOV ESI,EDX
MOV EDI,ECX
MOV EAX,ECX
CALL _LStrClr
TEST ESI,ESI
JLE @@exit
MOV EAX,ESI
CALL _NewAnsiString
MOV [EDI],EAX
MOV EDX,ESI
MOV CL,BL
CALL _FillChar
@@exit:
POP EDI
POP ESI
POP EBX
end;
procedure _Write0LString{ VAR t: Text; s: AnsiString };
asm
{ -> EAX Pointer to text record }
{ EDX Pointer to AnsiString }
XOR ECX,ECX
JMP _WriteLString
end;
procedure _WriteLString{ VAR t: Text; s: AnsiString; width: Longint };
asm
{ -> EAX Pointer to text record }
{ EDX Pointer to AnsiString }
{ ECX Field width }
PUSH EBX
MOV EBX,EDX
MOV EDX,ECX
XOR ECX,ECX
TEST EBX,EBX
JE @@skip
MOV ECX,[EBX-skew].StrRec.length
SUB EDX,ECX
@@skip:
PUSH ECX
CALL _WriteSpaces
POP ECX
MOV EDX,EBX
POP EBX
JMP _WriteBytes
end;
procedure _ReadLString{var t: Text; var str: AnsiString};
asm
{ -> EAX pointer to Text }
{ EDX pointer to AnsiString }
PUSH EBX
PUSH ESI
MOV EBX,EAX
MOV ESI,EDX
MOV EAX,EDX
CALL _LStrClr
SUB ESP,256
MOV EAX,EBX
MOV EDX,ESP
MOV ECX,255
CALL _ReadString
MOV EAX,ESI
MOV EDX,ESP
CALL _LStrFromString
CMP byte ptr [ESP],255
JNE @@exit
@@loop:
MOV EAX,EBX
MOV EDX,ESP
MOV ECX,255
CALL _ReadString
MOV EDX,ESP
PUSH 0
MOV EAX,ESP
CALL _LStrFromString
MOV EAX,ESI
MOV EDX,[ESP]
CALL _LStrCat
MOV EAX,ESP
CALL _LStrClr
POP EAX
CMP byte ptr [ESP],255
JE @@loop
@@exit:
ADD ESP,256
POP ESI
POP EBX
end;
procedure WStrError;
asm
MOV AL,reOutOfMemory
JMP Error
end;
procedure WStrSet(var S: WideString; P: PWideChar);
asm
MOV ECX,[EAX]
MOV [EAX],EDX
TEST ECX,ECX
JE @@1
PUSH ECX
CALL SysFreeString
@@1:
end;
procedure WStrClr;
asm
JMP _WStrClr
end;
procedure _WStrClr(var S: WideString);
asm
{ -> EAX Pointer to WideString }
MOV EDX,[EAX]
TEST EDX,EDX
JE @@1
MOV DWORD PTR [EAX],0
PUSH EAX
PUSH EDX
CALL SysFreeString
POP EAX
@@1:
end;
procedure WStrArrayClr;
asm
JMP _WStrArrayClr;
end;
procedure _WStrArrayClr(var StrArray; Count: Integer);
asm
PUSH EBX
PUSH ESI
MOV EBX,EAX
MOV ESI,EDX
@@1: MOV EAX,[EBX]
TEST EAX,EAX
JE @@2
MOV DWORD PTR [EBX],0
PUSH EAX
CALL SysFreeString
@@2: ADD EBX,4
DEC ESI
JNE @@1
POP ESI
POP EBX
end;
procedure _WStrAsg(var Dest: WideString; const Source: WideString);
asm
{ -> EAX Pointer to WideString }
{ EDX Pointer to data }
TEST EDX,EDX
JE _WStrClr
MOV ECX,[EDX-4]
SHR ECX,1
JE _WStrClr
PUSH ECX
PUSH EDX
PUSH EAX
CALL SysReAllocStringLen
TEST EAX,EAX
JE WStrError
end;
procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer);
var
DestLen: Integer;
Buffer: array[0..1023] of WideChar;
begin
if Length <= 0 then
begin
_WStrClr(Dest);
Exit;
end;
if Length < SizeOf(Buffer) div 2 then
begin
DestLen := MultiByteToWideChar(0, 0, Source, Length,
Buffer, SizeOf(Buffer) div 2);
if DestLen > 0 then
begin
_WStrFromPWCharLen(Dest, Buffer, DestLen);
Exit;
end;
end;
DestLen := MultiByteToWideChar(0, 0, Source, Length, nil, 0);
_WStrFromPWCharLen(Dest, nil, DestLen);
MultiByteToWideChar(0, 0, Source, Length, Pointer(Dest), DestLen);
end;
procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; Length: Integer);
asm
{ -> EAX Pointer to WideString (dest) }
{ EDX Pointer to characters (source) }
{ ECX number of characters (not bytes) }
TEST ECX,ECX
JE _WStrClr
PUSH EAX
PUSH ECX
PUSH EDX
CALL SysAllocStringLen
TEST EAX,EAX
JE WStrError
POP EDX
PUSH [EDX].PWideChar
MOV [EDX],EAX
CALL SysFreeString
end;
procedure _WStrFromChar(var Dest: WideString; Source: AnsiChar);
asm
PUSH EDX
MOV EDX,ESP
MOV ECX,1
CALL _WStrFromPCharLen
POP EDX
end;
procedure _WStrFromWChar(var Dest: WideString; Source: WideChar);
asm
{ -> EAX Pointer to WideString (dest) }
{ EDX character (source) }
PUSH EDX
MOV EDX,ESP
MOV ECX,1
CALL _WStrFromPWCharLen
POP EDX
end;
procedure _WStrFromPChar(var Dest: WideString; Source: PAnsiChar);
asm
{ -> EAX Pointer to WideString (dest) }
{ EDX Pointer to character (source) }
XOR ECX,ECX
TEST EDX,EDX
JE @@5
PUSH EDX
@@0: CMP CL,[EDX+0]
JE @@4
CMP CL,[EDX+1]
JE @@3
CMP CL,[EDX+2]
JE @@2
CMP CL,[EDX+3]
JE @@1
ADD EDX,4
JMP @@0
@@1: INC EDX
@@2: INC EDX
@@3: INC EDX
@@4: MOV ECX,EDX
POP EDX
SUB ECX,EDX
@@5: JMP _WStrFromPCharLen
end;
procedure _WStrFromPWChar(var Dest: WideString; Source: PWideChar);
asm
{ -> EAX Pointer to WideString (dest) }
{ EDX Pointer to character (source) }
XOR ECX,ECX
TEST EDX,EDX
JE @@5
PUSH EDX
@@0: CMP CX,[EDX+0]
JE @@4
CMP CX,[EDX+2]
JE @@3
CMP CX,[EDX+4]
JE @@2
CMP CX,[EDX+6]
JE @@1
ADD EDX,8
JMP @@0
@@1: ADD EDX,2
@@2: ADD EDX,2
@@3: ADD EDX,2
@@4: MOV ECX,EDX
POP EDX
SUB ECX,EDX
SHR ECX,1
@@5: JMP _WStrFromPWCharLen
end;
procedure _WStrFromString(var Dest: WideString; const Source: ShortString);
asm
XOR ECX,ECX
MOV CL,[EDX]
INC EDX
JMP _WStrFromPCharLen
end;
procedure _WStrFromArray(var Dest: WideString; Source: PAnsiChar; Length: Integer);
asm
PUSH EDI
PUSH EAX
PUSH ECX
MOV EDI,EDX
XOR EAX,EAX
REPNE SCASB
JNE @@1
NOT ECX
@@1: POP EAX
ADD ECX,EAX
POP EAX
POP EDI
JMP _WStrFromPCharLen
end;
procedure _WStrFromWArray(var Dest: WideString; Source: PWideChar; Length: Integer);
asm
PUSH EDI
PUSH EAX
PUSH ECX
MOV EDI,EDX
XOR EAX,EAX
REPNE SCASW
JNE @@1
NOT ECX
@@1: POP EAX
ADD ECX,EAX
POP EAX
POP EDI
JMP _WStrFromPWCharLen
end;
procedure _WStrFromLStr(var Dest: WideString; const Source: AnsiString);
asm
XOR ECX,ECX
TEST EDX,EDX
JE @@1
MOV ECX,[EDX-4]
@@1: JMP _WStrFromPCharLen
end;
procedure _WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer);
var
SourceLen, DestLen: Integer;
Buffer: array[0..511] of Char;
begin
SourceLen := Length(Source);
if SourceLen >= 255 then SourceLen := 255;
if SourceLen = 0 then DestLen := 0 else
begin
DestLen := WideCharToMultiByte(0, 0, Pointer(Source), SourceLen,
Buffer, SizeOf(Buffer), nil, nil);
if DestLen > MaxLen then DestLen := MaxLen;
end;
Dest^[0] := Chr(DestLen);
if DestLen > 0 then Move(Buffer, Dest^[1], DestLen);
end;
function _WStrToPWChar(const S: WideString): PWideChar;
asm
TEST EAX,EAX
JE @@1
RET
NOP
@@0: DW 0
@@1: MOV EAX,OFFSET @@0
end;
function _WStrLen(const S: WideString): Integer;
asm
{ -> EAX Pointer to WideString data }
TEST EAX,EAX
JE @@1
MOV EAX,[EAX-4]
SHR EAX,1
@@1:
end;
procedure _WStrCat(var Dest: WideString; const Source: WideString);
var
DestLen, SourceLen: Integer;
NewStr: PWideChar;
begin
SourceLen := Length(Source);
if SourceLen <> 0 then
begin
DestLen := Length(Dest);
NewStr := _NewWideString(DestLen + SourceLen);
if DestLen > 0 then
Move(Pointer(Dest)^, NewStr^, DestLen * 2);
Move(Pointer(Source)^, NewStr[DestLen], SourceLen * 2);
WStrSet(Dest, NewStr);
end;
end;
procedure _WStrCat3(var Dest: WideString; const Source1, Source2: WideString);
var
Source1Len, Source2Len: Integer;
NewStr: PWideChar;
begin
Source1Len := Length(Source1);
Source2Len := Length(Source2);
if (Source1Len <> 0) or (Source2Len <> 0) then
begin
NewStr := _NewWideString(Source1Len + Source2Len);
Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * 2);
Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * 2);
WStrSet(Dest, NewStr);
end;
end;
procedure _WStrCatN{var Dest: WideString; ArgCnt: Integer; ...};
asm
{ ->EAX = Pointer to dest }
{ EDX = number of args (>= 3) }
{ [ESP+4], [ESP+8], ... crgCnt WideString arguments }
PUSH EBX
PUSH ESI
PUSH EDX
PUSH EAX
MOV EBX,EDX
XOR EAX,EAX
@@loop1:
MOV ECX,[ESP+EDX*4+4*4]
TEST ECX,ECX
JE @@1
ADD EAX,[ECX-4]
@@1:
DEC EDX
JNE @@loop1
SHR EAX,1
CALL _NewWideString
PUSH EAX
MOV ESI,EAX
@@loop2:
MOV EAX,[ESP+EBX*4+5*4]
MOV EDX,ESI
TEST EAX,EAX
JE @@2
MOV ECX,[EAX-4]
ADD ESI,ECX
CALL Move
@@2:
DEC EBX
JNE @@loop2
POP EDX
POP EAX
CALL WStrSet
POP EDX
POP ESI
POP EBX
POP EAX
LEA ESP,[ESP+EDX*4]
JMP EAX
end;
procedure _WStrCmp{left: WideString; right: WideString};
asm
{ ->EAX = Pointer to left string }
{ EDX = Pointer to right string }
PUSH EBX
PUSH ESI
PUSH EDI
MOV ESI,EAX
MOV EDI,EDX
CMP EAX,EDX
JE @@exit
TEST ESI,ESI
JE @@str1null
TEST EDI,EDI
JE @@str2null
MOV EAX,[ESI-4]
MOV EDX,[EDI-4]
SUB EAX,EDX { eax = len1 - len2 }
JA @@skip1
ADD EDX,EAX { edx = len2 + (len1 - len2) = len1 }
@@skip1:
PUSH EDX
SHR EDX,2
JE @@cmpRest
@@longLoop:
MOV ECX,[ESI]
MOV EBX,[EDI]
CMP ECX,EBX
JNE @@misMatch
DEC EDX
JE @@cmpRestP4
MOV ECX,[ESI+4]
MOV EBX,[EDI+4]
CMP ECX,EBX
JNE @@misMatch
ADD ESI,8
ADD EDI,8
DEC EDX
JNE @@longLoop
JMP @@cmpRest
@@cmpRestP4:
ADD ESI,4
ADD EDI,4
@@cmpRest:
POP EDX
AND EDX,2
JE @@equal
MOV CX,[ESI]
MOV BX,[EDI]
CMP CX,BX
JNE @@exit
@@equal:
ADD EAX,EAX
JMP @@exit
@@str1null:
MOV EDX,[EDI-4]
SUB EAX,EDX
JMP @@exit
@@str2null:
MOV EAX,[ESI-4]
SUB EAX,EDX
JMP @@exit
@@misMatch:
POP EDX
CMP CX,BX
JNE @@exit
SHR ECX,16
SHR EBX,16
CMP CX,BX
@@exit:
POP EDI
POP ESI
POP EBX
end;
function _NewWideString(Length: Integer): PWideChar;
asm
TEST EAX,EAX
JE @@1
PUSH EAX
PUSH 0
CALL SysAllocStringLen
TEST EAX,EAX
JE WStrError
@@1:
end;
function _WStrCopy(const S: WideString; Index, Count: Integer): WideString;
var
L, N: Integer;
begin
L := Length(S);
if Index < 1 then Index := 0 else
begin
Dec(Index);
if Index > L then Index := L;
end;
if Count < 0 then N := 0 else
begin
N := L - Index;
if N > Count then N := Count;
end;
_WStrFromPWCharLen(Result, PWideChar(Pointer(S)) + Index, N);
end;
procedure _WStrDelete(var S: WideString; Index, Count: Integer);
var
L, N: Integer;
NewStr: PWideChar;
begin
L := Length(S);
if (L > 0) and (Index >= 1) and (Index <= L) and (Count > 0) then
begin
Dec(Index);
N := L - Index - Count;
if N < 0 then N := 0;
if (Index = 0) and (N = 0) then NewStr := nil else
begin
NewStr := _NewWideString(Index + N);
if Index > 0 then
Move(Pointer(S)^, NewStr^, Index * 2);
if N > 0 then
Move(PWideChar(Pointer(S))[L - N], NewStr[Index], N * 2);
end;
WStrSet(S, NewStr);
end;
end;
procedure _WStrInsert(const Source: WideString; var Dest: WideString; Index: Integer);
var
SourceLen, DestLen: Integer;
NewStr: PWideChar;
begin
SourceLen := Length(Source);
if SourceLen > 0 then
begin
DestLen := Length(Dest);
if Index < 1 then Index := 0 else
begin
Dec(Index);
if Index > DestLen then Index := DestLen;
end;
NewStr := _NewWideString(DestLen + SourceLen);
if Index > 0 then
Move(Pointer(Dest)^, NewStr^, Index * 2);
Move(Pointer(Source)^, NewStr[Index], SourceLen * 2);
if Index < DestLen then
Move(PWideChar(Pointer(Dest))[Index], NewStr[Index + SourceLen],
(DestLen - Index) * 2);
WStrSet(Dest, NewStr);
end;
end;
procedure _WStrPos{ const substr : WideString; const s : WideString ) : Integer};
asm
{ ->EAX Pointer to substr }
{ EDX Pointer to string }
{ <-EAX Position of substr in s or 0 }
TEST EAX,EAX
JE @@noWork
TEST EDX,EDX
JE @@stringEmpty
PUSH EBX
PUSH ESI
PUSH EDI
MOV ESI,EAX { Point ESI to substr }
MOV EDI,EDX { Point EDI to s }
MOV ECX,[EDI-4] { ECX = Length(s) }
SHR ECX,1
PUSH EDI { remember s position to calculate index }
MOV EDX,[ESI-4] { EDX = Length(substr) }
SHR EDX,1
DEC EDX { EDX = Length(substr) - 1 }
JS @@fail { < 0 ? return 0 }
MOV AX,[ESI] { AL = first char of substr }
ADD ESI,2 { Point ESI to 2'nd char of substr }
SUB ECX,EDX { #positions in s to look at }
{ = Length(s) - Length(substr) + 1 }
JLE @@fail
@@loop:
REPNE SCASW
JNE @@fail
MOV EBX,ECX { save outer loop counter }
PUSH ESI { save outer loop substr pointer }
PUSH EDI { save outer loop s pointer }
MOV ECX,EDX
REPE CMPSW
POP EDI { restore outer loop s pointer }
POP ESI { restore outer loop substr pointer }
JE @@found
MOV ECX,EBX { restore outer loop counter }
JMP @@loop
@@fail:
POP EDX { get rid of saved s pointer }
XOR EAX,EAX
JMP @@exit
@@stringEmpty:
XOR EAX,EAX
JMP @@noWork
@@found:
POP EDX { restore pointer to first char of s }
MOV EAX,EDI { EDI points of char after match }
SUB EAX,EDX { the difference is the correct index }
SHR EAX,1
@@exit:
POP EDI
POP ESI
POP EBX
@@noWork:
end;
procedure _WStrSetLength(var S: WideString; NewLength: Integer);
var
NewStr: PWideChar;
Count: Integer;
begin
NewStr := nil;
if NewLength > 0 then
begin
NewStr := _NewWideString(NewLength);
Count := Length(S);
if Count > 0 then
begin
if Count > NewLength then Count := NewLength;
Move(Pointer(S)^, NewStr^, Count * 2);
end;
end;
WStrSet(S, NewStr);
end;
function _WStrOfWChar(Ch: WideChar; Count: Integer): WideString;
var
P: PWideChar;
begin
_WStrFromPWCharLen(Result, nil, Count);
P := Pointer(Result);
while Count > 0 do
begin
Dec(Count);
P[Count] := Ch;
end;
end;
procedure WStrAddRef;
asm
JMP _WStrAddRef
end;
procedure _WStrAddRef{var str: WideString};
asm
MOV EDX,[EAX]
TEST EDX,EDX
JE @@1
PUSH EAX
MOV ECX,[EDX-4]
SHR ECX,1
PUSH ECX
PUSH EDX
CALL SysAllocStringLen
POP EDX
TEST EAX,EAX
JE WStrError
MOV [EDX],EAX
@@1:
end;
procedure _InitializeRecord{ p: Pointer; typeInfo: Pointer };
asm
{ -> EAX pointer to record to be initialized }
{ EDX pointer to type info }
XOR ECX,ECX
PUSH EBX
MOV CL,[EDX+1] { type name length }
PUSH ESI
PUSH EDI
MOV EBX,EAX
LEA ESI,[EDX+ECX+2+8] { address of destructable fields }
MOV EDI,[EDX+ECX+2+4] { number of destructable fields }
@@loop:
MOV EDX,[ESI]
MOV EAX,[ESI+4]
ADD EAX,EBX
MOV EDX,[EDX]
CALL _Initialize
ADD ESI,8
DEC EDI
JG @@loop
POP EDI
POP ESI
POP EBX
end;
const
tkLString = 10;
tkWString = 11;
tkVariant = 12;
tkArray = 13;
tkRecord = 14;
tkInterface = 15;
tkDynArray = 17;
procedure _InitializeArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
asm
{ -> EAX pointer to data to be initialized }
{ EDX pointer to type info describing data }
{ ECX number of elements of that type }
PUSH EBX
PUSH ESI
PUSH EDI
MOV EBX,EAX
MOV ESI,EDX
MOV EDI,ECX
XOR EDX,EDX
MOV AL,[ESI]
MOV DL,[ESI+1]
XOR ECX,ECX
CMP AL,tkLString
JE @@LString
CMP AL,tkWString
JE @@WString
CMP AL,tkVariant
JE @@Variant
CMP AL,tkArray
JE @@Array
CMP AL,tkRecord
JE @@Record
CMP AL,tkInterface
JE @@Interface
CMP AL,tkDynArray
JE @@DynArray
MOV AL,reInvalidPtr
POP EDI
POP ESI
POP EBX
JMP Error
@@LString:
@@WString:
@@Interface:
@@DynArray:
MOV [EBX],ECX
ADD EBX,4
DEC EDI
JG @@LString
JMP @@exit
@@Variant:
MOV [EBX ],ECX
MOV [EBX+ 4],ECX
MOV [EBX+ 8],ECX
MOV [EBX+12],ECX
ADD EBX,16
DEC EDI
JG @@Variant
JMP @@exit
@@Array:
PUSH EBP
MOV EBP,EDX
@@ArrayLoop:
MOV EDX,[ESI+EBP+2+8]
MOV EAX,EBX
ADD EBX,[ESI+EBP+2]
MOV ECX,[ESI+EBP+2+4]
MOV EDX,[EDX]
CALL _InitializeArray
DEC EDI
JG @@ArrayLoop
POP EBP
JMP @@exit
@@Record:
PUSH EBP
MOV EBP,EDX
@@RecordLoop:
MOV EAX,EBX
ADD EBX,[ESI+EBP+2]
MOV EDX,ESI
CALL _InitializeRecord
DEC EDI
JG @@RecordLoop
POP EBP
@@exit:
POP EDI
POP ESI
POP EBX
end;
procedure _Initialize{ p: Pointer; typeInfo: Pointer};
asm
MOV ECX,1
JMP _InitializeArray
end;
procedure _FinalizeRecord{ p: Pointer; typeInfo: Pointer };
asm
{ -> EAX pointer to record to be finalized }
{ EDX pointer to type info }
XOR ECX,ECX
PUSH EBX
MOV CL,[EDX+1]
PUSH ESI
PUSH EDI
MOV EBX,EAX
LEA ESI,[EDX+ECX+2+8]
MOV EDI,[EDX+ECX+2+4]
@@loop:
MOV EDX,[ESI]
MOV EAX,[ESI+4]
ADD EAX,EBX
MOV EDX,[EDX]
CALL _Finalize
ADD ESI,8
DEC EDI
JG @@loop
MOV EAX,EBX
POP EDI
POP ESI
POP EBX
end;
procedure _FinalizeArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
asm
{ -> EAX pointer to data to be finalized }
{ EDX pointer to type info describing data }
{ ECX number of elements of that type }
CMP ECX, 0 { no array -> nop }
JE @@zerolength
PUSH EAX
PUSH EBX
PUSH ESI
PUSH EDI
MOV EBX,EAX
MOV ESI,EDX
MOV EDI,ECX
XOR EDX,EDX
MOV AL,[ESI]
MOV DL,[ESI+1]
CMP AL,tkLString
JE @@LString
CMP AL,tkWString
JE @@WString
CMP AL,tkVariant
JE @@Variant
CMP AL,tkArray
JE @@Array
CMP AL,tkRecord
JE @@Record
CMP AL,tkInterface
JE @@Interface
CMP AL,tkDynArray
JE @@DynArray
POP EDI
POP ESI
POP EBX
POP EAX
MOV AL,reInvalidPtr
JMP Error
@@LString:
CMP ECX,1
MOV EAX,EBX
JG @@LStringArray
CALL _LStrClr
JMP @@exit
@@LStringArray:
MOV EDX,ECX
CALL _LStrArrayClr
JMP @@exit
@@WString:
CMP ECX,1
MOV EAX,EBX
JG @@WStringArray
//CALL _WStrClr
CALL [WStrClrProc]
JMP @@exit
@@WStringArray:
MOV EDX,ECX
//CALL _WStrArrayClr
CALL [WStrArrayClrProc]
JMP @@exit
@@Variant:
MOV EAX,EBX
ADD EBX,16
//CALL _VarClr
CALL [VarClrProc]
DEC EDI
JG @@Variant
JMP @@exit
@@Array:
PUSH EBP
MOV EBP,EDX
@@ArrayLoop:
MOV EDX,[ESI+EBP+2+8]
MOV EAX,EBX
ADD EBX,[ESI+EBP+2]
MOV ECX,[ESI+EBP+2+4]
MOV EDX,[EDX]
CALL _FinalizeArray
DEC EDI
JG @@ArrayLoop
POP EBP
JMP @@exit
@@Record:
PUSH EBP
MOV EBP,EDX
@@RecordLoop:
{ inv: EDI = number of array elements to finalize }
MOV EAX,EBX
ADD EBX,[ESI+EBP+2]
MOV EDX,ESI
CALL _FinalizeRecord
DEC EDI
JG @@RecordLoop
POP EBP
JMP @@exit
@@Interface:
MOV EAX,EBX
ADD EBX,4
CALL _IntfClear
DEC EDI
JG @@Interface
JMP @@exit
@@DynArray:
MOV EAX,EBX
MOV EDX,ESI
ADD EBX,4
CALL _DynArrayClear
DEC EDI
JG @@DynArray
@@exit:
POP EDI
POP ESI
POP EBX
POP EAX
@@zerolength:
end;
procedure _Finalize{ p: Pointer; typeInfo: Pointer};
asm
MOV ECX,1
JMP _FinalizeArray
end;
procedure _AddRefRecord{ p: Pointer; typeInfo: Pointer };
asm
{ -> EAX pointer to record to be referenced }
{ EDX pointer to type info }
XOR ECX,ECX
PUSH EBX
MOV CL,[EDX+1]
PUSH ESI
PUSH EDI
MOV EBX,EAX
LEA ESI,[EDX+ECX+2+8]
MOV EDI,[EDX+ECX+2+4]
@@loop:
MOV EDX,[ESI]
MOV EAX,[ESI+4]
ADD EAX,EBX
MOV EDX,[EDX]
CALL _AddRef
ADD ESI,8
DEC EDI
JG @@loop
POP EDI
POP ESI
POP EBX
end;
procedure DummyProc;
begin
end;
procedure _AddRefArray{ p: Pointer; typeInfo: Pointer; elemCount: Longint};
asm
{ -> EAX pointer to data to be referenced }
{ EDX pointer to type info describing data }
{ ECX number of elements of that type }
PUSH EBX
PUSH ESI
PUSH EDI
MOV EBX,EAX
MOV ESI,EDX
MOV EDI,ECX
XOR EDX,EDX
MOV AL,[ESI]
MOV DL,[ESI+1]
CMP AL,tkLString
JE @@LString
CMP AL,tkWString
JE @@WString
CMP AL,tkVariant
JE @@Variant
CMP AL,tkArray
JE @@Array
CMP AL,tkRecord
JE @@Record
CMP AL,tkInterface
JE @@Interface
CMP AL,tkDynArray
JE @@DynArray
MOV AL,reInvalidPtr
POP EDI
POP ESI
POP EBX
JMP Error
@@LString:
MOV EAX,[EBX]
ADD EBX,4
CALL _LStrAddRef
DEC EDI
JG @@LString
JMP @@exit
@@WString:
MOV EAX,EBX
ADD EBX,4
//CALL _WStrAddRef
CALL [WStrAddRefProc]
DEC EDI
JG @@WString
JMP @@exit
@@Variant:
MOV EAX,EBX
ADD EBX,16
//CALL _VarAddRef
CALL [VarAddRefProc]
DEC EDI
JG @@Variant
JMP @@exit
@@Array:
PUSH EBP
MOV EBP,EDX
@@ArrayLoop:
MOV EDX,[ESI+EBP+2+8]
MOV EAX,EBX
ADD EBX,[ESI+EBP+2]
MOV ECX,[ESI+EBP+2+4]
MOV EDX,[EDX]
CALL _AddRefArray
DEC EDI
JG @@ArrayLoop
POP EBP
JMP @@exit
@@Record:
PUSH EBP
MOV EBP,EDX
@@RecordLoop:
MOV EAX,EBX
ADD EBX,[ESI+EBP+2]
MOV EDX,ESI
CALL _AddRefRecord
DEC EDI
JG @@RecordLoop
POP EBP
JMP @@exit
@@Interface:
MOV EAX,[EBX]
ADD EBX,4
CALL _IntfAddRef
DEC EDI
JG @@Interface
JMP @@exit
@@DynArray:
MOV EAX,[EBX]
ADD EBX,4
CALL _DynArrayAddRef
DEC EDI
JG @@DynArray
@@exit:
POP EDI
POP ESI
POP EBX
end;
procedure _AddRef{ p: Pointer; typeInfo: Pointer};
asm
MOV ECX,1
JMP _AddRefArray
end;
procedure _CopyRecord{ dest, source, typeInfo: Pointer };
asm
{ -> EAX pointer to dest }
{ EDX pointer to source }
{ ECX pointer to typeInfo }
PUSH EBX
PUSH ESI
PUSH EDI
PUSH EBP
MOV EBX,EAX
MOV ESI,EDX
XOR EAX,EAX
MOV AL,[ECX+1]
LEA EDI,[ECX+EAX+2+8]
MOV EBP,[EDI-4]
XOR EAX,EAX
MOV ECX,[EDI-8]
PUSH ECX
@@loop:
MOV ECX,[EDI+4]
SUB ECX,EAX
JLE @@nomove1
MOV EDX,EAX
ADD EAX,ESI
ADD EDX,EBX
CALL Move
@@noMove1:
MOV EAX,[EDI+4]
MOV EDX,[EDI]
MOV EDX,[EDX]
MOV CL,[EDX]
CMP CL,tkLString
JE @@LString
CMP CL,tkWString
JE @@WString
CMP CL,tkVariant
JE @@Variant
CMP CL,tkArray
JE @@Array
CMP CL,tkRecord
JE @@Record
CMP CL,tkInterface
JE @@Interface
CMP CL,tkDynArray
JE @@DynArray
MOV AL,reInvalidPtr
POP EBP
POP EDI
POP ESI
POP EBX
JMP Error
@@LString:
MOV EDX,[ESI+EAX]
ADD EAX,EBX
CALL _LStrAsg
MOV EAX,4
JMP @@common
@@WString:
MOV EDX,[ESI+EAX]
ADD EAX,EBX
CALL _WStrAsg
MOV EAX,4
JMP @@common
@@Variant:
LEA EDX,[ESI+EAX]
ADD EAX,EBX
CALL _VarCopy
MOV EAX,16
JMP @@common
@@Array:
XOR ECX,ECX
MOV CL,[EDX+1]
PUSH dword ptr [EDX+ECX+2]
PUSH dword ptr [EDX+ECX+2+4]
MOV ECX,[EDX+ECX+2+8]
MOV ECX,[ECX]
LEA EDX,[ESI+EAX]
ADD EAX,EBX
CALL _CopyArray
POP EAX
JMP @@common
@@Record:
XOR ECX,ECX
MOV CL,[EDX+1]
MOV ECX,[EDX+ECX+2]
PUSH ECX
MOV ECX,EDX
LEA EDX,[ESI+EAX]
ADD EAX,EBX
CALL _CopyRecord
POP EAX
JMP @@common
@@Interface:
MOV EDX,[ESI+EAX]
ADD EAX,EBX
CALL _IntfCopy
MOV EAX,4
JMP @@common
@@DynArray:
MOV ECX,EDX
MOV EDX,[ESI+EAX]
ADD EAX,EBX
CALL _DynArrayAsg
MOV EAX,4
@@common:
ADD EAX,[EDI+4]
ADD EDI,8
DEC EBP
JNZ @@loop
POP ECX
SUB ECX,EAX
JLE @@noMove2
LEA EDX,[EBX+EAX]
ADD EAX,ESI
CALL Move
@@noMove2:
POP EBP
POP EDI
POP ESI
POP EBX
end;
procedure _CopyObject{ dest, source: Pointer; vmtPtrOffs: Longint; typeInfo: Pointer };
asm
{ -> EAX pointer to dest }
{ EDX pointer to source }
{ ECX offset of vmt in object }
{ [ESP+4] pointer to typeInfo }
ADD ECX,EAX { pointer to dest vmt }
PUSH dword ptr [ECX] { save dest vmt }
PUSH ECX
MOV ECX,[ESP+4+4+4]
CALL _CopyRecord
POP ECX
POP dword ptr [ECX] { restore dest vmt }
RET 4
end;
procedure _CopyArray{ dest, source, typeInfo: Pointer; cnt: Integer };
asm
{ -> EAX pointer to dest }
{ EDX pointer to source }
{ ECX pointer to typeInfo }
{ [ESP+4] count }
PUSH EBX
PUSH ESI
PUSH EDI
PUSH EBP
MOV EBX,EAX
MOV ESI,EDX
MOV EDI,ECX
MOV EBP,[ESP+4+4*4]
MOV CL,[EDI]
CMP CL,tkLString
JE @@LString
CMP CL,tkWString
JE @@WString
CMP CL,tkVariant
JE @@Variant
CMP CL,tkArray
JE @@Array
CMP CL,tkRecord
JE @@Record
CMP CL,tkInterface
JE @@Interface
CMP CL,tkDynArray
JE @@DynArray
MOV AL,reInvalidPtr
POP EBP
POP EDI
POP ESI
POP EBX
JMP Error
@@LString:
MOV EAX,EBX
MOV EDX,[ESI]
CALL _LStrAsg
ADD EBX,4
ADD ESI,4
DEC EBP
JNE @@LString
JMP @@exit
@@WString:
MOV EAX,EBX
MOV EDX,[ESI]
CALL _WStrAsg
ADD EBX,4
ADD ESI,4
DEC EBP
JNE @@WString
JMP @@exit
@@Variant:
MOV EAX,EBX
MOV EDX,ESI
CALL _VarCopy
ADD EBX,16
ADD ESI,16
DEC EBP
JNE @@Variant
JMP @@exit
@@Array:
XOR ECX,ECX
MOV CL,[EDI+1]
LEA EDI,[EDI+ECX+2]
@@ArrayLoop:
MOV EAX,EBX
MOV EDX,ESI
MOV ECX,[EDI+8]
PUSH dword ptr [EDI+4]
CALL _CopyArray
ADD EBX,[EDI]
ADD ESI,[EDI]
DEC EBP
JNE @@ArrayLoop
JMP @@exit
@@Record:
MOV EAX,EBX
MOV EDX,ESI
MOV ECX,EDI
CALL _CopyRecord
XOR EAX,EAX
MOV AL,[EDI+1]
ADD EBX,[EDI+EAX+2]
ADD ESI,[EDI+EAX+2]
DEC EBP
JNE @@Record
JMP @@exit
@@Interface:
MOV EAX,EBX
MOV EDX,[ESI]
CALL _IntfCopy
ADD EBX,4
ADD ESI,4
DEC EBP
JNE @@Interface
JMP @@exit
@@DynArray:
MOV EAX,EBX
MOV EDX,[ESI]
MOV ECX,EDI
CALL _DynArrayAsg
ADD EBX,4
ADD ESI,4
DEC EBP
JNE @@DynArray
@@exit:
POP EBP
POP EDI
POP ESI
POP EBX
RET 4
end;
procedure _New{ size: Longint; typeInfo: Pointer};
asm
{ -> EAX size of object to allocate }
{ EDX pointer to typeInfo }
PUSH EDX
CALL _GetMem
POP EDX
TEST EAX,EAX
JE @@exit
PUSH EAX
CALL _Initialize
POP EAX
@@exit:
end;
procedure _Dispose{ p: Pointer; typeInfo: Pointer};
asm
{ -> EAX Pointer to object to be disposed }
{ EDX Pointer to type info }
PUSH EAX
CALL _Finalize
POP EAX
CALL _FreeMem
end;
{ ----------------------------------------------------- }
{ Wide character support }
{ ----------------------------------------------------- }
function WideCharToString(Source: PWideChar): string;
begin
WideCharToStrVar(Source, Result);
end;
function WideCharLenToString(Source: PWideChar; SourceLen: Integer): string;
begin
WideCharLenToStrVar(Source, SourceLen, Result);
end;
procedure WideCharToStrVar(Source: PWideChar; var Dest: string);
var
SourceLen: Integer;
begin
SourceLen := 0;
while Source[SourceLen] <> #0 do Inc(SourceLen);
WideCharLenToStrVar(Source, SourceLen, Dest);
end;
procedure WideCharLenToStrVar(Source: PWideChar; SourceLen: Integer;
var Dest: string);
var
DestLen: Integer;
Buffer: array[0..2047] of Char;
begin
if SourceLen = 0 then
Dest := ''
else
if SourceLen < SizeOf(Buffer) div 2 then
SetString(Dest, Buffer, WideCharToMultiByte(0, 0,
Source, SourceLen, Buffer, SizeOf(Buffer), nil, nil))
else
begin
DestLen := WideCharToMultiByte(0, 0, Source, SourceLen,
nil, 0, nil, nil);
SetString(Dest, nil, DestLen);
WideCharToMultiByte(0, 0, Source, SourceLen, Pointer(Dest),
DestLen, nil, nil);
end;
end;
function StringToWideChar(const Source: string; Dest: PWideChar;
DestSize: Integer): PWideChar;
begin
Dest[MultiByteToWideChar(0, 0, PChar(Source), Length(Source),
Dest, DestSize - 1)] := #0;
Result := Dest;
end;
{ ----------------------------------------------------- }
{ OLE string support }
{ ----------------------------------------------------- }
function OleStrToString(Source: PWideChar): string;
begin
OleStrToStrVar(Source, Result);
end;
procedure OleStrToStrVar(Source: PWideChar; var Dest: string);
begin
WideCharLenToStrVar(Source, SysStringLen(WideString(Pointer(Source))), Dest);
end;
function StringToOleStr(const Source: string): PWideChar;
var
SourceLen, ResultLen: Integer;
Buffer: array[0..1023] of WideChar;
begin
SourceLen := Length(Source);
if Length(Source) < SizeOf(Buffer) div 2 then
Result := SysAllocStringLen(Buffer, MultiByteToWideChar(0, 0,
PChar(Source), SourceLen, Buffer, SizeOf(Buffer) div 2))
else
begin
ResultLen := MultiByteToWideChar(0, 0,
Pointer(Source), SourceLen, nil, 0);
Result := SysAllocStringLen(nil, ResultLen);
MultiByteToWideChar(0, 0, Pointer(Source), SourceLen,
Result, ResultLen);
end;
end;
{ ----------------------------------------------------- }
{ Variant support }
{ ----------------------------------------------------- }
type
TBaseType = (btErr, btNul, btInt, btFlt, btCur, btStr, btBol, btDat);
const
varLast = varByte;
const
BaseTypeMap: array[0..varLast] of TBaseType = (
btErr, { varEmpty }
btNul, { varNull }
btInt, { varSmallint }
btInt, { varInteger }
btFlt, { varSingle }
btFlt, { varDouble }
btCur, { varCurrency }
btDat, { varDate }
btStr, { varOleStr }
btErr, { varDispatch }
btErr, { varError }
btBol, { varBoolean }
btErr, { varVariant }
btErr, { varUnknown }
btErr, { vt_decimal }
btErr, { undefined }
btErr, { vt_i1 }
btInt); { varByte }
const
OpTypeMap: array[TBaseType, TBaseType] of TBaseType = (
(btErr, btErr, btErr, btErr, btErr, btErr, btErr, btErr),
(btErr, btNul, btNul, btNul, btNul, btNul, btNul, btNul),
(btErr, btNul, btInt, btFlt, btCur, btFlt, btInt, btDat),
(btErr, btNul, btFlt, btFlt, btCur, btFlt, btFlt, btDat),
(btErr, btNul, btCur, btCur, btCur, btCur, btCur, btDat),
(btErr, btNul, btFlt, btFlt, btCur, btStr, btBol, btDat),
(btErr, btNul, btInt, btFlt, btCur, btBol, btBol, btDat),
(btErr, btNul, btDat, btDat, btDat, btDat, btDat, btDat));
const
C10000: Single = 10000;
const
opAdd = 0;
opSub = 1;
opMul = 2;
opDvd = 3;
opDiv = 4;
opMod = 5;
opShl = 6;
opShr = 7;
opAnd = 8;
opOr = 9;
opXor = 10;
procedure _DispInvoke;
asm
{ -> [ESP+4] Pointer to result or nil }
{ [ESP+8] Pointer to variant }
{ [ESP+12] Pointer to call descriptor }
{ [ESP+16] Additional parameters, if any }
JMP VarDispProc
end;
procedure _DispInvokeError;
asm
MOV AL,reVarDispatch
JMP Error
end;
procedure VarCastError;
asm
MOV AL,reVarTypeCast
JMP Error
end;
procedure VarInvalidOp;
asm
MOV AL,reVarInvalidOp
JMP Error
end;
procedure _VarClear(var V : Variant);
asm
XOR EDX,EDX
MOV DX,[EAX].TVarData.VType
TEST EDX,varByRef
JNE @@2
CMP EDX,varOleStr
JB @@2
CMP EDX,varString
JE @@1
CMP EDX,varAny
JNE @@3
JMP [ClearAnyProc]
@@1: MOV [EAX].TVarData.VType,varEmpty
ADD EAX,OFFSET TVarData.VString
JMP _LStrClr
@@2: MOV [EAX].TVarData.VType,varEmpty
RET
@@3: PUSH EAX
CALL VariantClear
end;
procedure _VarCopy(var Dest : Variant; const Source: Variant);
asm
CMP EAX,EDX
JE @@9
CMP [EAX].TVarData.VType,varOleStr
JB @@3
PUSH EAX
PUSH EDX
CMP [EAX].TVarData.VType,varString
JE @@1
CMP [EAX].TVarData.VType,varAny
JE @@0
PUSH EAX
CALL VariantClear
JMP @@2
@@0: CALL [ClearAnyProc]
JMP @@2
@@1: ADD EAX,OFFSET TVarData.VString
CALL _LStrClr
@@2: POP EDX
POP EAX
@@3: CMP [EDX].TVarData.VType,varOleStr
JAE @@5
@@4: MOV ECX,[EDX]
MOV [EAX],ECX
MOV ECX,[EDX+8]
MOV [EAX+8],ECX
MOV ECX,[EDX+12]
MOV [EAX+12],ECX
RET
@@5: CMP [EDX].TVarData.VType,varString
JE @@6
CMP [EDX].TVarData.VType,varAny
JNE @@8
PUSH EAX
CALL @@4
POP EAX
JMP [RefAnyProc]
@@6: MOV EDX,[EDX].TVarData.VString
OR EDX,EDX
JE @@7
MOV ECX,[EDX-skew].StrRec.refCnt
INC ECX
JLE @@7
{X LOCK} INC [EDX-skew].StrRec.refCnt
@@7: MOV [EAX].TVarData.VType,varString
MOV [EAX].TVarData.VString,EDX
RET
@@8: MOV [EAX].TVarData.VType,varEmpty
PUSH EDX
PUSH EAX
CALL VariantCopyInd
OR EAX,EAX
JNE VarInvalidOp
@@9:
end;
procedure VarCopyNoInd(var Dest: Variant; const Source: Variant);
asm
CMP EAX,EDX
JE @@9
CMP [EAX].TVarData.VType,varOleStr
JB @@3
PUSH EAX
PUSH EDX
CMP [EAX].TVarData.VType,varString
JE @@1
CMP [EAX].TVarData.VType,varAny
JE @@0
PUSH EAX
CALL VariantClear
JMP @@2
@@0: CALL [ClearAnyProc]
JMP @@2
@@1: ADD EAX,OFFSET TVarData.VString
CALL _LStrClr
@@2: POP EDX
POP EAX
@@3: CMP [EDX].TVarData.VType,varOleStr
JAE @@5
@@4: MOV ECX,[EDX]
MOV [EAX],ECX
MOV ECX,[EDX+8]
MOV [EAX+8],ECX
MOV ECX,[EDX+12]
MOV [EAX+12],ECX
RET
@@5: CMP [EDX].TVarData.VType,varString
JNE @@6
CMP [EDX].TVarData.VType,varAny
JNE @@8
CALL @@4
JMP [RefAnyProc]
@@6: MOV EDX,[EDX].TVarData.VString
OR EDX,EDX
JE @@7
MOV ECX,[EDX-skew].StrRec.refCnt
INC ECX
JLE @@7
{X LOCK} INC [EDX-skew].StrRec.refCnt
@@7: MOV [EAX].TVarData.VType,varString
MOV [EAX].TVarData.VString,EDX
RET
@@8: MOV [EAX].TVarData.VType,varEmpty
PUSH EDX
PUSH EAX
CALL VariantCopy
@@9:
end;
type
TAnyProc = procedure (var V: Variant);
procedure VarChangeType(var Dest: Variant; const Source: Variant;
DestType: Word); forward;
procedure AnyChangeType(var Dest: Variant; Source: Variant; DestType: Word);
begin
TAnyProc(ChangeAnyProc)(Source);
VarChangeType(Dest, Source, DestType);
end;
procedure VarChangeType(var Dest: Variant; const Source: Variant;
DestType: Word);
type
TVarMem = array[0..3] of Integer;
function ChangeSourceAny(var Dest: Variant; const Source: Variant;
DestType: Word): Boolean;
begin
Result := False;
if TVarData(Source).VType = varAny then
begin
AnyChangeType(Dest, Source, DestType);
Result := True;
end;
end;
var
Temp: TVarData;
begin
case TVarData(Dest).VType of
varString:
begin
if not ChangeSourceAny(Dest, Source, DestType) then
begin
Temp.VType := varEmpty;
if VariantChangeTypeEx(Variant(Temp), Source, $400, 0, DestType) <> 0 then
VarCastError;
_VarClear(Dest);
TVarMem(Dest)[0] := TVarMem(Temp)[0];
TVarMem(Dest)[2] := TVarMem(Temp)[2];
TVarMem(Dest)[3] := TVarMem(Temp)[3];
end;
end;
varAny: AnyChangeType(Dest, Source, DestType);
else if not ChangeSourceAny(Dest, Source, DestType) then
if VariantChangeTypeEx(Dest, Source, $400, 0, DestType) <> 0 then
VarCastError;
end;
end;
procedure VarOleStrToString(var Dest: Variant; const Source: Variant);
var
StringPtr: Pointer;
begin
StringPtr := nil;
OleStrToStrVar(TVarData(Source).VOleStr, string(StringPtr));
_VarClear(Dest);
TVarData(Dest).VType := varString;
TVarData(Dest).VString := StringPtr;
end;
procedure VarStringToOleStr(var Dest: Variant; const Source: Variant);
var
OleStrPtr: PWideChar;
begin
OleStrPtr := StringToOleStr(string(TVarData(Source).VString));
_VarClear(Dest);
TVarData(Dest).VType := varOleStr;
TVarData(Dest).VOleStr := OleStrPtr;
end;
procedure _VarCast(var Dest : Variant; const Source: Variant; VarType: Integer);
var
SourceType, DestType: Word;
Temp: TVarData;
begin
SourceType := TVarData(Source).VType;
DestType := Word(VarType);
if SourceType = DestType then
_VarCopy(Dest, Source)
else
if SourceType = varString then
if DestType = varOleStr then
VarStringToOleStr(Variant(Dest), Source)
else
begin
Temp.VType := varEmpty;
VarStringToOleStr(Variant(Temp), Source);
try
VarChangeType(Variant(Dest), Variant(Temp), DestType);
finally
_VarClear(PVariant(@Temp)^);
end;
end
else
if (DestType = varString) and (SourceType <> varAny) then
if SourceType = varOleStr then
VarOleStrToString(Variant(Dest), Source)
else
begin
Temp.VType := varEmpty;
VarChangeType(Variant(Temp), Source, varOleStr);
try
VarOleStrToString(Variant(Dest), Variant(Temp));
finally
_VarClear(Variant(Temp));
end;
end
else
VarChangeType(Variant(Dest), Source, DestType);
end;
(* VarCast when the destination is OleVariant *)
procedure _VarCastOle(var Dest : Variant; const Source: Variant; VarType: Integer);
begin
if (VarType = varString) or (VarType = varAny) then
VarCastError
else
_VarCast(Dest, Source, VarType);
end;
procedure _VarToInt;
asm
XOR EDX,EDX
MOV DX,[EAX].TVarData.VType
CMP EDX,varInteger
JE @@0
CMP EDX,varSmallint
JE @@1
CMP EDX,varByte
JE @@2
CMP EDX,varDouble
JE @@5
CMP EDX,varSingle
JE @@4
CMP EDX,varCurrency
JE @@3
SUB ESP,16
MOV [ESP].TVarData.VType,varEmpty
MOV EDX,EAX
MOV EAX,ESP
MOV ECX,varInteger
CALL _VarCast
MOV EAX,[ESP].TVarData.VInteger
ADD ESP,16
RET
@@0: MOV EAX,[EAX].TVarData.VInteger
RET
@@1: MOVSX EAX,[EAX].TVarData.VSmallint
RET
@@2: MOVZX EAX,[EAX].TVarData.VByte
RET
@@3: FILD [EAX].TVarData.VCurrency
FDIV C10000
JMP @@6
@@4: FLD [EAX].TVarData.VSingle
JMP @@6
@@5: FLD [EAX].TVarData.VDouble
@@6: PUSH EAX
FISTP DWORD PTR [ESP]
FWAIT
POP EAX
end;
procedure _VarToBool;
asm
CMP [EAX].TVarData.VType,varBoolean
JE @@1
SUB ESP,16
MOV [ESP].TVarData.VType,varEmpty
MOV EDX,EAX
MOV EAX,ESP
MOV ECX,varBoolean
CALL _VarCast
MOV AX,[ESP].TVarData.VBoolean
ADD ESP,16
JMP @@2
@@1: MOV AX,[EAX].TVarData.VBoolean
@@2: NEG AX
SBB EAX,EAX
NEG EAX
end;
procedure _VarToReal;
asm
XOR EDX,EDX
MOV DX,[EAX].TVarData.VType
CMP EDX,varDouble
JE @@1
CMP EDX,varSingle
JE @@2
CMP EDX,varCurrency
JE @@3
CMP EDX,varInteger
JE @@4
CMP EDX,varSmallint
JE @@5
CMP EDX,varDate
JE @@1
SUB ESP,16
MOV [ESP].TVarData.VType,varEmpty
MOV EDX,EAX
MOV EAX,ESP
MOV ECX,varDouble
CALL _VarCast
FLD [ESP].TVarData.VDouble
ADD ESP,16
RET
@@1: FLD [EAX].TVarData.VDouble
RET
@@2: FLD [EAX].TVarData.VSingle
RET
@@3: FILD [EAX].TVarData.VCurrency
FDIV C10000
RET
@@4: FILD [EAX].TVarData.VInteger
RET
@@5: FILD [EAX].TVarData.VSmallint
end;
procedure _VarToCurr;
asm
XOR EDX,EDX
MOV DX,[EAX].TVarData.VType
CMP EDX,varCurrency
JE @@1
CMP EDX,varDouble
JE @@2
CMP EDX,varSingle
JE @@3
CMP EDX,varInteger
JE @@4
CMP EDX,varSmallint
JE @@5
SUB ESP,16
MOV [ESP].TVarData.VType,varEmpty
MOV EDX,EAX
MOV EAX,ESP
MOV ECX,varCurrency
CALL _VarCast
FILD [ESP].TVarData.VCurrency
ADD ESP,16
RET
@@1: FILD [EAX].TVarData.VCurrency
RET
@@2: FLD [EAX].TVarData.VDouble
JMP @@6
@@3: FLD [EAX].TVarData.VSingle
JMP @@6
@@4: FILD [EAX].TVarData.VInteger
JMP @@6
@@5: FILD [EAX].TVarData.VSmallint
@@6: FMUL C10000
end;
procedure _VarToPStr(var S; const V: Variant);
var
Temp: string;
begin
_VarToLStr(Temp, V);
ShortString(S) := Temp;
end;
procedure _VarToLStr(var S: string; const V: Variant);
asm
{ -> EAX: destination string }
{ EDX: source variant }
{ <- none }
CMP [EDX].TVarData.VType,varString
JNE @@1
MOV EDX,[EDX].TVarData.VString
JMP _LStrAsg
@@1: PUSH EBX
MOV EBX,EAX
SUB ESP,16
MOV [ESP].TVarData.VType,varEmpty
MOV EAX,ESP
MOV ECX,varString
CALL _VarCast
MOV EAX,EBX
CALL _LStrClr
MOV EAX,[ESP].TVarData.VString
MOV [EBX],EAX
ADD ESP,16
POP EBX
end;
procedure _VarToWStr(var S: WideString; const V: Variant);
asm
CMP [EDX].TVarData.VType,varOleStr
JNE @@1
MOV EDX,[EDX].TVarData.VOleStr
JMP _WStrAsg
@@1: PUSH EBX
MOV EBX,EAX
SUB ESP,16
MOV [ESP].TVarData.VType,varEmpty
MOV EAX,ESP
MOV ECX,varOleStr
CALL _VarCast
MOV EAX,EBX
MOV EDX,[ESP].TVarData.VOleStr
CALL WStrSet
ADD ESP,16
POP EBX
end;
procedure AnyToIntf(var Unknown: IUnknown; V: Variant);
begin
TAnyProc(ChangeAnyProc)(V);
if TVarData(V).VType <> varUnknown then
VarCastError;
Unknown := IUnknown(TVarData(V).VUnknown);
end;
procedure _VarToIntf(var Unknown: IUnknown; const V: Variant);
asm
CMP [EDX].TVarData.VType,varEmpty
JE _IntfClear
CMP [EDX].TVarData.VType,varUnknown
JE @@2
CMP [EDX].TVarData.VType,varDispatch
JE @@2
CMP [EDX].TVarData.VType,varUnknown+varByRef
JE @@1
CMP [EDX].TVarData.VType,varDispatch+varByRef
JE @@1
CMP [EDX].TVarData.VType,varAny
JNE VarCastError
JMP AnyToIntf
@@0: CALL _VarClear
ADD ESP,16
JMP VarCastError
@@1: MOV EDX,[EDX].TVarData.VPointer
MOV EDX,[EDX]
JMP _IntfCopy
@@2: MOV EDX,[EDX].TVarData.VUnknown
JMP _IntfCopy
end;
procedure _VarToDisp(var Dispatch: IDispatch; const V: Variant);
asm
CMP [EDX].TVarData.VType,varEmpty
JE _IntfClear
CMP [EDX].TVarData.VType,varDispatch
JE @@1
CMP [EDX].TVarData.VType,varDispatch+varByRef
JNE VarCastError
MOV EDX,[EDX].TVarData.VPointer
MOV EDX,[EDX]
JMP _IntfCopy
@@1: MOV EDX,[EDX].TVarData.VDispatch
JMP _IntfCopy
end;
procedure _VarToDynArray(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);
asm
CALL DynArrayFromVariant
OR EAX, EAX
JNZ @@1
JMP VarCastError
@@1:
end;
procedure _VarFromInt;
asm
CMP [EAX].TVarData.VType,varOleStr
JB @@1
PUSH EAX
PUSH EDX
CALL _VarClear
POP EDX
POP EAX
@@1: MOV [EAX].TVarData.VType,varInteger
MOV [EAX].TVarData.VInteger,EDX
end;
procedure _VarFromBool;
asm
CMP [EAX].TVarData.VType,varOleStr
JB @@1
PUSH EAX
PUSH EDX
CALL _VarClear
POP EDX
POP EAX
@@1: MOV [EAX].TVarData.VType,varBoolean
NEG DL
SBB EDX,EDX
MOV [EAX].TVarData.VBoolean,DX
end;
procedure _VarFromReal;
asm
CMP [EAX].TVarData.VType,varOleStr
JB @@1
PUSH EAX
CALL _VarClear
POP EAX
@@1: MOV [EAX].TVarData.VType,varDouble
FSTP [EAX].TVarData.VDouble
FWAIT
end;
procedure _VarFromTDateTime;
asm
CMP [EAX].TVarData.VType,varOleStr
JB @@1
PUSH EAX
CALL _VarClear
POP EAX
@@1: MOV [EAX].TVarData.VType,varDate
FSTP [EAX].TVarData.VDouble
FWAIT
end;
procedure _VarFromCurr;
asm
CMP [EAX].TVarData.VType,varOleStr
JB @@1
PUSH EAX
CALL _VarClear
POP EAX
@@1: MOV [EAX].TVarData.VType,varCurrency
FISTP [EAX].TVarData.VCurrency
FWAIT
end;
procedure _VarFromPStr(var V: Variant; const Value: ShortString);
begin
_VarFromLStr(V, Value);
end;
procedure _VarFromLStr(var V: Variant; const Value: string);
asm
CMP [EAX].TVarData.VType,varOleStr
JB @@1
PUSH EAX
PUSH EDX
CALL _VarClear
POP EDX
POP EAX
@@1: TEST EDX,EDX
JE @@3
MOV ECX,[EDX-skew].StrRec.refCnt
INC ECX
JLE @@2
{X LOCK} INC [EDX-skew].StrRec.refCnt
JMP @@3
@@2: PUSH EAX
PUSH EDX
MOV EAX,[EDX-skew].StrRec.length
CALL _NewAnsiString
MOV EDX,EAX
POP EAX
PUSH EDX
MOV ECX,[EDX-skew].StrRec.length
CALL Move
POP EDX
POP EAX
@@3: MOV [EAX].TVarData.VType,varString
MOV [EAX].TVarData.VString,EDX
end;
procedure _VarFromWStr(var V: Variant; const Value: WideString);
asm
PUSH EAX
CMP [EAX].TVarData.VType,varOleStr
JB @@1
PUSH EDX
CALL _VarClear
POP EDX
@@1: XOR EAX,EAX
TEST EDX,EDX
JE @@2
MOV EAX,[EDX-4]
SHR EAX,1
JE @@2
PUSH EAX
PUSH EDX
CALL SysAllocStringLen
TEST EAX,EAX
JE WStrError
@@2: POP EDX
MOV [EDX].TVarData.VType,varOleStr
MOV [EDX].TVarData.VOleStr,EAX
end;
procedure _VarFromIntf(var V: Variant; const Value: IUnknown);
asm
CMP [EAX].TVarData.VType,varOleStr
JB @@1
PUSH EAX
PUSH EDX
CALL _VarClear
POP EDX
POP EAX
@@1: MOV [EAX].TVarData.VType,varUnknown
MOV [EAX].TVarData.VUnknown,EDX
TEST EDX,EDX
JE @@2
PUSH EDX
MOV EAX,[EDX]
CALL [EAX].vmtAddRef.Pointer
@@2:
end;
procedure _VarFromDisp(var V: Variant; const Value: IDispatch);
asm
CMP [EAX].TVarData.VType,varOleStr
JB @@1
PUSH EAX
PUSH EDX
CALL _VarClear
POP EDX
POP EAX
@@1: MOV [EAX].TVarData.VType,varDispatch
MOV [EAX].TVarData.VDispatch,EDX
TEST EDX,EDX
JE @@2
PUSH EDX
MOV EAX,[EDX]
CALL [EAX].vmtAddRef.Pointer
@@2:
end;
procedure _VarFromDynArray(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
asm
PUSH EAX
CALL DynArrayToVariant
POP EAX
CMP [EAX].TVarData.VType,varEmpty
JNE @@1
JMP VarCastError
@@1:
end;
procedure _OleVarFromPStr(var V: OleVariant; const Value: ShortString);
begin
_OleVarFromLStr(V, Value);
end;
procedure _OleVarFromLStr(var V: OleVariant; const Value: string);
asm
CMP [EAX].TVarData.VType,varOleStr
JB @@1
PUSH EAX
PUSH EDX
CALL _VarClear
POP EDX
POP EAX
@@1: MOV [EAX].TVarData.VType,varOleStr
ADD EAX,TVarData.VOleStr
XOR ECX,ECX
MOV [EAX],ECX
JMP _WStrFromLStr
end;
procedure OleVarFromAny(var V: OleVariant; Value: Variant);
begin
TAnyProc(ChangeAnyProc)(Value);
V := Value;
end;
procedure _OleVarFromVar(var V: OleVariant; const Value: Variant);
asm
CMP [EDX].TVarData.VType,varAny
JE OleVarFromAny
CMP [EDX].TVarData.VType,varString
JNE _VarCopy
CMP [EAX].TVarData.VType,varOleStr
JB @@1
PUSH EAX
PUSH EDX
CALL _VarClear
POP EDX
POP EAX
@@1: MOV [EAX].TVarData.VType,varOleStr
ADD EAX,TVarData.VOleStr
ADD EDX,TVarData.VString
XOR ECX,ECX
MOV EDX,[EDX]
MOV [EAX],ECX
JMP _WStrFromLStr
@@2:
end;
procedure VarStrCat(var Dest: Variant; const Source: Variant);
begin
if TVarData(Dest).VType = varString then
Dest := string(Dest) + string(Source)
else
Dest := WideString(Dest) + WideString(Source);
end;
procedure VarOp(var Dest: Variant; const Source: Variant; OpCode: Integer); forward;
procedure AnyOp(var Dest: Variant; Source: Variant; OpCode: Integer);
begin
if TVarData(Dest).VType = varAny then TAnyProc(ChangeAnyProc)(Dest);
if TVarData(Source).VType = varAny then TAnyProc(ChangeAnyProc)(Source);
VarOp(Dest, Source, OpCode);
end;
procedure VarOp(var Dest: Variant; const Source: Variant; OpCode: Integer);
asm
PUSH EBX
PUSH ESI
PUSH EDI
MOV EDI,EAX
MOV ESI,EDX
MOV EBX,ECX
MOV EAX,[EDI].TVarData.VType.Integer
MOV EDX,[ESI].TVarData.VType.Integer
AND EAX,varTypeMask
AND EDX,varTypeMask
CMP EAX,varLast
JBE @@1
CMP EAX,varString
JNE @@4
MOV EAX,varOleStr
@@1: CMP EDX,varLast
JBE @@2
CMP EDX,varString
JNE @@3
MOV EDX,varOleStr
@@2: MOV AL,BaseTypeMap.Byte[EAX]
MOV DL,BaseTypeMap.Byte[EDX]
MOVZX ECX,OpTypeMap.Byte[EAX*8+EDX]
CALL @VarOpTable.Pointer[ECX*4]
POP EDI
POP ESI
POP EBX
RET
@@3: MOV EAX,EDX
@@4: CMP EAX,varAny
JNE @InvalidOp
POP EDI
POP ESI
POP EBX
JMP AnyOp
@VarOpTable:
DD @VarOpError
DD @VarOpNull
DD @VarOpInteger
DD @VarOpReal
DD @VarOpCurr
DD @VarOpString
DD @VarOpBoolean
DD @VarOpDate
@VarOpError:
POP EAX
@InvalidOp:
POP EDI
POP ESI
POP EBX
JMP VarInvalidOp
@VarOpNull:
MOV EAX,EDI
CALL _VarClear
MOV [EDI].TVarData.VType,varNull
RET
@VarOpInteger:
CMP BL,opDvd
JE @RealOp
@IntegerOp:
MOV EAX,ESI
CALL _VarToInt
PUSH EAX
MOV EAX,EDI
CALL _VarToInt
POP EDX
CALL @IntegerOpTable.Pointer[EBX*4]
MOV EDX,EAX
MOV EAX,EDI
JMP _VarFromInt
@IntegerOpTable:
DD @IntegerAdd
DD @IntegerSub
DD @IntegerMul
DD 0
DD @IntegerDiv
DD @IntegerMod
DD @IntegerShl
DD @IntegerShr
DD @IntegerAnd
DD @IntegerOr
DD @IntegerXor
@IntegerAdd:
ADD EAX,EDX
JO @IntToRealOp
RET
@IntegerSub:
SUB EAX,EDX
JO @IntToRealOp
RET
@IntegerMul:
IMUL EDX
JO @IntToRealOp
RET
@IntegerDiv:
MOV ECX,EDX
CDQ
IDIV ECX
RET
@IntegerMod:
MOV ECX,EDX
CDQ
IDIV ECX
MOV EAX,EDX
RET
@IntegerShl:
MOV ECX,EDX
SHL EAX,CL
RET
@IntegerShr:
MOV ECX,EDX
SHR EAX,CL
RET
@IntegerAnd:
AND EAX,EDX
RET
@IntegerOr:
OR EAX,EDX
RET
@IntegerXor:
XOR EAX,EDX
RET
@IntToRealOp:
POP EAX
JMP @RealOp
@VarOpReal:
CMP BL,opDiv
JAE @IntegerOp
@RealOp:
MOV EAX,ESI
CALL _VarToReal
SUB ESP,12
FSTP TBYTE PTR [ESP]
MOV EAX,EDI
CALL _VarToReal
FLD TBYTE PTR [ESP]
ADD ESP,12
CALL @RealOpTable.Pointer[EBX*4]
@RealResult:
MOV EAX,EDI
JMP _VarFromReal
@VarOpCurr:
CMP BL,opDiv
JAE @IntegerOp
CMP BL,opMul
JAE @CurrMulDvd
MOV EAX,ESI
CALL _VarToCurr
SUB ESP,12
FSTP TBYTE PTR [ESP]
MOV EAX,EDI
CALL _VarToCurr
FLD TBYTE PTR [ESP]
ADD ESP,12
CALL @RealOpTable.Pointer[EBX*4]
@CurrResult:
MOV EAX,EDI
JMP _VarFromCurr
@CurrMulDvd:
CMP DL,btCur
JE @CurrOpCurr
MOV EAX,ESI
CALL _VarToReal
FILD [EDI].TVarData.VCurrency
FXCH
CALL @RealOpTable.Pointer[EBX*4]
JMP @CurrResult
@CurrOpCurr:
CMP BL,opDvd
JE @CurrDvdCurr
CMP AL,btCur
JE @CurrMulCurr
MOV EAX,EDI
CALL _VarToReal
FILD [ESI].TVarData.VCurrency
FMUL
JMP @CurrResult
@CurrMulCurr:
FILD [EDI].TVarData.VCurrency
FILD [ESI].TVarData.VCurrency
FMUL
FDIV C10000
JMP @CurrResult
@CurrDvdCurr:
MOV EAX,EDI
CALL _VarToCurr
FILD [ESI].TVarData.VCurrency
FDIV
JMP @RealResult
@RealOpTable:
DD @RealAdd
DD @RealSub
DD @RealMul
DD @RealDvd
@RealAdd:
FADD
RET
@RealSub:
FSUB
RET
@RealMul:
FMUL
RET
@RealDvd:
FDIV
RET
@VarOpString:
CMP BL,opAdd
JNE @VarOpReal
MOV EAX,EDI
MOV EDX,ESI
JMP VarStrCat
@VarOpBoolean:
CMP BL,opAnd
JB @VarOpReal
MOV EAX,ESI
CALL _VarToBool
PUSH EAX
MOV EAX,EDI
CALL _VarToBool
POP EDX
CALL @IntegerOpTable.Pointer[EBX*4]
MOV EDX,EAX
MOV EAX,EDI
JMP _VarFromBool
@VarOpDate:
CMP BL,opSub
JA @VarOpReal
JB @DateOp
MOV AH,DL
CMP AX,btDat+btDat*256
JE @RealOp
@DateOp:
CALL @RealOp
MOV [EDI].TVarData.VType,varDate
RET
end;
procedure _VarAdd;
asm
MOV ECX,opAdd
JMP VarOp
end;
procedure _VarSub;
asm
MOV ECX,opSub
JMP VarOp
end;
procedure _VarMul;
asm
MOV ECX,opMul
JMP VarOp
end;
procedure _VarDiv;
asm
MOV ECX,opDiv
JMP VarOp
end;
procedure _VarMod;
asm
MOV ECX,opMod
JMP VarOp
end;
procedure _VarAnd;
asm
MOV ECX,opAnd
JMP VarOp
end;
procedure _VarOr;
asm
MOV ECX,opOr
JMP VarOp
end;
procedure _VarXor;
asm
MOV ECX,opXor
JMP VarOp
end;
procedure _VarShl;
asm
MOV ECX,opShl
JMP VarOp
end;
procedure _VarShr;
asm
MOV ECX,opShr
JMP VarOp
end;
procedure _VarRDiv;
asm
MOV ECX,opDvd
JMP VarOp
end;
function VarCompareString(const S1, S2: string): Integer;
asm
PUSH ESI
PUSH EDI
MOV ESI,EAX
MOV EDI,EDX
OR EAX,EAX
JE @@1
MOV EAX,[EAX-4]
@@1: OR EDX,EDX
JE @@2
MOV EDX,[EDX-4]
@@2: MOV ECX,EAX
CMP ECX,EDX
JBE @@3
MOV ECX,EDX
@@3: CMP ECX,ECX
REPE CMPSB
JE @@4
MOVZX EAX,BYTE PTR [ESI-1]
MOVZX EDX,BYTE PTR [EDI-1]
@@4: SUB EAX,EDX
POP EDI
POP ESI
end;
function VarCmpStr(const V1, V2: Variant): Integer;
begin
Result := VarCompareString(V1, V2);
end;
function AnyCmp(var Dest: Variant; const Source: Variant): Integer;
var
Temp: Variant;
P: ^Variant;
begin
asm
PUSH Dest
end;
P := @Source;
if TVarData(Dest).VType = varAny then TAnyProc(ChangeAnyProc)(Dest);
if TVarData(Source).VType = varAny then
begin
Temp := Source;
TAnyProc(ChangeAnyProc)(Temp);
P := @Temp;
end;
asm
MOV EDX,P
POP EAX
CALL _VarCmp
PUSHF
POP EAX
MOV Result,EAX
end;
end;
procedure _VarCmp;
asm
PUSH ESI
PUSH EDI
MOV EDI,EAX
MOV ESI,EDX
MOV EAX,[EDI].TVarData.VType.Integer
MOV EDX,[ESI].TVarData.VType.Integer
AND EAX,varTypeMask
AND EDX,varTypeMask
CMP EAX,varLast
JBE @@1
CMP EAX,varString
JNE @@4
MOV EAX,varOleStr
@@1: CMP EDX,varLast
JBE @@2
CMP EDX,varString
JNE @@3
MOV EDX,varOleStr
@@2: MOV AL,BaseTypeMap.Byte[EAX]
MOV DL,BaseTypeMap.Byte[EDX]
MOVZX ECX,OpTypeMap.Byte[EAX*8+EDX]
JMP @VarCmpTable.Pointer[ECX*4]
@@3: MOV EAX,EDX
@@4: CMP EAX,varAny
JNE @VarCmpError
POP EDI
POP ESI
CALL AnyCmp
PUSH EAX
POPF
RET
@VarCmpTable:
DD @VarCmpError
DD @VarCmpNull
DD @VarCmpInteger
DD @VarCmpReal
DD @VarCmpCurr
DD @VarCmpString
DD @VarCmpBoolean
DD @VarCmpDate
@VarCmpError:
POP EDI
POP ESI
JMP VarInvalidOp
@VarCmpNull:
CMP AL,DL
JMP @Exit
@VarCmpInteger:
MOV EAX,ESI
CALL _VarToInt
XCHG EAX,EDI
CALL _VarToInt
CMP EAX,EDI
JMP @Exit
@VarCmpReal:
@VarCmpDate:
MOV EAX,EDI
CALL _VarToReal
SUB ESP,12
FSTP TBYTE PTR [ESP]
MOV EAX,ESI
CALL _VarToReal
FLD TBYTE PTR [ESP]
ADD ESP,12
@RealCmp:
FCOMPP
FNSTSW AX
MOV AL,AH { Move CF into SF }
AND AX,4001H
ROR AL,1
OR AH,AL
SAHF
JMP @Exit
@VarCmpCurr:
MOV EAX,EDI
CALL _VarToCurr
SUB ESP,12
FSTP TBYTE PTR [ESP]
MOV EAX,ESI
CALL _VarToCurr
FLD TBYTE PTR [ESP]
ADD ESP,12
JMP @RealCmp
@VarCmpString:
MOV EAX,EDI
MOV EDX,ESI
CALL VarCmpStr
CMP EAX,0
JMP @Exit
@VarCmpBoolean:
MOV EAX,ESI
CALL _VarToBool
XCHG EAX,EDI
CALL _VarToBool
MOV EDX,EDI
CMP AL,DL
@Exit:
POP EDI
POP ESI
end;
procedure _VarNeg;
asm
MOV EDX,[EAX].TVarData.VType.Integer
AND EDX,varTypeMask
CMP EDX,varLast
JBE @@1
CMP EDX,varString
JNE @VarNegError
MOV EDX,varOleStr
@@1: MOV DL,BaseTypeMap.Byte[EDX]
JMP @VarNegTable.Pointer[EDX*4]
@@2: CMP EAX,varAny
JNE @VarNegError
PUSH EAX
CALL [ChangeAnyProc]
POP EAX
JMP _VarNeg
@VarNegTable:
DD @VarNegError
DD @VarNegNull
DD @VarNegInteger
DD @VarNegReal
DD @VarNegCurr
DD @VarNegReal
DD @VarNegInteger
DD @VarNegDate
@VarNegError:
JMP VarInvalidOp
@VarNegNull:
RET
@VarNegInteger:
PUSH EAX
CALL _VarToInt
NEG EAX
MOV EDX,EAX
POP EAX
JMP _VarFromInt
@VarNegReal:
PUSH EAX
CALL _VarToReal
FCHS
POP EAX
JMP _VarFromReal
@VarNegCurr:
FILD [EAX].TVarData.VCurrency
FCHS
FISTP [EAX].TVarData.VCurrency
FWAIT
RET
@VarNegDate:
FLD [EAX].TVarData.VDate
FCHS
FSTP [EAX].TVarData.VDate
FWAIT
end;
procedure _VarNot;
asm
MOV EDX,[EAX].TVarData.VType.Integer
AND EDX,varTypeMask
JE @@2
CMP EDX,varBoolean
JE @@3
CMP EDX,varNull
JE @@4
CMP EDX,varLast
JBE @@1
CMP EDX,varString
JE @@1
CMP EAX,varAny
JNE @@2
PUSH EAX
CALL [ChangeAnyProc]
POP EAX
JMP _VarNot
@@1: PUSH EAX
CALL _VarToInt
NOT EAX
MOV EDX,EAX
POP EAX
JMP _VarFromInt
@@2: JMP VarInvalidOp
@@3: MOV DX,[EAX].TVarData.VBoolean
NEG DX
SBB EDX,EDX
NOT EDX
MOV [EAX].TVarData.VBoolean,DX
@@4:
end;
procedure _VarCopyNoInd;
asm
JMP VarCopyNoInd
end;
procedure VariantClr;
asm
JMP _VarClr
end;
procedure _VarClr;
asm
PUSH EAX
CALL _VarClear
POP EAX
end;
procedure VariantAddRef;
asm
JMP _VarAddRef
end;
procedure _VarAddRef;
asm
CMP [EAX].TVarData.VType,varOleStr
JB @@1
PUSH [EAX].Integer[12]
PUSH [EAX].Integer[8]
PUSH [EAX].Integer[4]
PUSH [EAX].Integer[0]
MOV [EAX].TVarData.VType,varEmpty
MOV EDX,ESP
CALL _VarCopy
ADD ESP,16
@@1:
end;
function VarType(const V: Variant): Integer;
asm
MOVZX EAX,[EAX].TVarData.VType
end;
function VarAsType(const V: Variant; VarType: Integer): Variant;
begin
_VarCast(Result, V, VarType);
end;
function VarIsEmpty(const V: Variant): Boolean;
begin
with TVarData(V) do
Result := (VType = varEmpty) or ((VType = varDispatch) or
(VType = varUnknown)) and (VDispatch = nil);
end;
function VarIsNull(const V: Variant): Boolean;
begin
Result := TVarData(V).VType = varNull;
end;
function VarToStr(const V: Variant): string;
begin
if TVarData(V).VType <> varNull then Result := V else Result := '';
end;
function VarFromDateTime(DateTime: TDateTime): Variant;
begin
_VarClear(Result);
TVarData(Result).VType := varDate;
TVarData(Result).VDate := DateTime;
end;
function VarToDateTime(const V: Variant): TDateTime;
var
Temp: TVarData;
begin
Temp.VType := varEmpty;
_VarCast(Variant(Temp), V, varDate);
Result := Temp.VDate;
end;
function _WriteVariant(var T: Text; const V: Variant; Width: Integer): Pointer;
var
S: string;
begin
if TVarData(V).VType >= varSmallint then S := V;
Write(T, S: Width);
Result := @T;
end;
function _Write0Variant(var T: Text; const V: Variant): Pointer;
begin
Result := _WriteVariant(T, V, 0);
end;
{ ----------------------------------------------------- }
{ Variant array support }
{ ----------------------------------------------------- }
function VarArrayCreate(const Bounds: array of Integer;
VarType: Integer): Variant;
var
I, DimCount: Integer;
VarArrayRef: PVarArray;
VarBounds: array[0..63] of TVarArrayBound;
begin
if not Odd(High(Bounds)) or (High(Bounds) > 127) then
Error(reVarArrayCreate);
DimCount := (High(Bounds) + 1) div 2;
for I := 0 to DimCount - 1 do
with VarBounds[I] do
begin
LowBound := Bounds[I * 2];
ElementCount := Bounds[I * 2 + 1] - LowBound + 1;
end;
VarArrayRef := SafeArrayCreate(VarType, DimCount, VarBounds);
if VarArrayRef = nil then Error(reVarArrayCreate);
_VarClear(Result);
TVarData(Result).VType := VarType or varArray;
TVarData(Result).VArray := VarArrayRef;
end;
function VarArrayOf(const Values: array of Variant): Variant;
var
I: Integer;
begin
Result := VarArrayCreate([0, High(Values)], varVariant);
for I := 0 to High(Values) do Result[I] := Values[I];
end;
procedure _VarArrayRedim(var A : Variant; HighBound: Integer);
var
VarBound: TVarArrayBound;
begin
if (TVarData(A).VType and (varArray or varByRef)) <> varArray then
Error(reVarNotArray);
with TVarData(A).VArray^ do
VarBound.LowBound := Bounds[DimCount - 1].LowBound;
VarBound.ElementCount := HighBound - VarBound.LowBound + 1;
if SafeArrayRedim(TVarData(A).VArray, VarBound) <> 0 then
Error(reVarArrayCreate);
end;
function GetVarArray(const A: Variant): PVarArray;
begin
if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
if TVarData(A).VType and varByRef <> 0 then
Result := PVarArray(TVarData(A).VPointer^) else
Result := TVarData(A).VArray;
end;
function VarArrayDimCount(const A: Variant): Integer;
begin
if TVarData(A).VType and varArray <> 0 then
Result := GetVarArray(A)^.DimCount else
Result := 0;
end;
function VarArrayLowBound(const A: Variant; Dim: Integer): Integer;
begin
if SafeArrayGetLBound(GetVarArray(A), Dim, Result) <> 0 then
Error(reVarArrayBounds);
end;
function VarArrayHighBound(const A: Variant; Dim: Integer): Integer;
begin
if SafeArrayGetUBound(GetVarArray(A), Dim, Result) <> 0 then
Error(reVarArrayBounds);
end;
function VarArrayLock(const A: Variant): Pointer;
begin
if SafeArrayAccessData(GetVarArray(A), Result) <> 0 then
Error(reVarNotArray);
end;
procedure VarArrayUnlock(const A: Variant);
begin
if SafeArrayUnaccessData(GetVarArray(A)) <> 0 then
Error(reVarNotArray);
end;
function VarArrayRef(const A: Variant): Variant;
begin
if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
_VarClear(Result);
TVarData(Result).VType := TVarData(A).VType or varByRef;
if TVarData(A).VType and varByRef <> 0 then
TVarData(Result).VPointer := TVarData(A).VPointer else
TVarData(Result).VPointer := @TVarData(A).VArray;
end;
function VarIsArray(const A: Variant): Boolean;
begin
Result := TVarData(A).VType and varArray <> 0;
end;
function _VarArrayGet(var A: Variant; IndexCount: Integer;
Indices: Integer): Variant; cdecl;
var
VarArrayPtr: PVarArray;
VarType: Integer;
P: Pointer;
begin
if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
VarArrayPtr := GetVarArray(A);
if VarArrayPtr^.DimCount <> IndexCount then Error(reVarArrayBounds);
VarType := TVarData(A).VType and varTypeMask;
_VarClear(Result);
if VarType = varVariant then
begin
if SafeArrayPtrOfIndex(VarArrayPtr, @Indices, P) <> 0 then
Error(reVarArrayBounds);
Result := PVariant(P)^;
end else
begin
if SafeArrayGetElement(VarArrayPtr, @Indices,
@TVarData(Result).VPointer) <> 0 then Error(reVarArrayBounds);
TVarData(Result).VType := VarType;
end;
end;
procedure _VarArrayPut(var A: Variant; const Value: Variant;
IndexCount: Integer; Indices: Integer); cdecl;
type
TAnyPutArrayProc = procedure (var A: Variant; const Value: Variant; Index: Integer);
var
VarArrayPtr: PVarArray;
VarType: Integer;
P: Pointer;
Temp: TVarData;
begin
if TVarData(A).VType and varArray = 0 then Error(reVarNotArray);
VarArrayPtr := GetVarArray(A);
if VarArrayPtr^.DimCount <> IndexCount then Error(reVarArrayBounds);
VarType := TVarData(A).VType and varTypeMask;
if (VarType = varVariant) and (TVarData(Value).VType <> varString) then
begin
if SafeArrayPtrOfIndex(VarArrayPtr, @Indices, P) <> 0 then
Error(reVarArrayBounds);
PVariant(P)^ := Value;
end else
begin
Temp.VType := varEmpty;
try
if VarType = varVariant then
begin
VarStringToOleStr(Variant(Temp), Value);
P := @Temp;
end else
begin
_VarCast(Variant(Temp), Value, VarType);
case VarType of
varOleStr, varDispatch, varUnknown:
P := Temp.VPointer;
else
P := @Temp.VPointer;
end;
end;
if SafeArrayPutElement(VarArrayPtr, @Indices, P) <> 0 then
Error(reVarArrayBounds);
finally
_VarClear(Variant(Temp));
end;
end;
end;
function VarArrayGet(const A: Variant; const Indices: array of Integer): Variant;
asm
{ ->EAX Pointer to A }
{ EDX Pointer to Indices }
{ ECX High bound of Indices }
{ [EBP+8] Pointer to result }
PUSH EBX
MOV EBX,ECX
INC EBX
JLE @@endLoop
@@loop:
PUSH [EDX+ECX*4].Integer
DEC ECX
JNS @@loop
@@endLoop:
PUSH EBX
PUSH EAX
MOV EAX,[EBP+8]
PUSH EAX
CALL _VarArrayGet
LEA ESP,[ESP+EBX*4+3*4]
POP EBX
end;
procedure VarArrayPut(var A: Variant; const Value: Variant; const Indices: array of Integer);
asm
{ ->EAX Pointer to A }
{ EDX Pointer to Value }
{ ECX Pointer to Indices }
{ [EBP+8] High bound of Indices }
PUSH EBX
MOV EBX,[EBP+8]
TEST EBX,EBX
JS @@endLoop
@@loop:
PUSH [ECX+EBX*4].Integer
DEC EBX
JNS @@loop
@@endLoop:
MOV EBX,[EBP+8]
INC EBX
PUSH EBX
PUSH EDX
PUSH EAX
CALL _VarArrayPut
LEA ESP,[ESP+EBX*4+3*4]
POP EBX
end;
{ 64-bit Integer helper routines - recycling C++ RTL routines }
procedure __llmul; external; {$L _LL }
procedure __lldiv; external; { _LL }
procedure __llmod; external; { _LL }
procedure __llmulo; external; { _LL (overflow version) }
procedure __lldivo; external; { _LL (overflow version) }
procedure __llmodo; external; { _LL (overflow version) }
procedure __llshl; external; { _LL }
procedure __llushr; external; { _LL }
procedure __llumod; external; { _LL }
procedure __lludiv; external; { _LL }
function _StrInt64(val: Int64; width: Integer): ShortString;
var
d: array[0..31] of Char; { need 19 digits and a sign }
i, k: Integer;
sign: Boolean;
spaces: Integer;
begin
{ Produce an ASCII representation of the number in reverse order }
i := 0;
sign := val < 0;
repeat
d[i] := Chr( Abs(val mod 10) + Ord('0') );
Inc(i);
val := val div 10;
until val = 0;
if sign then
begin
d[i] := '-';
Inc(i);
end;
{ Fill the Result with the appropriate number of blanks }
if width > 255 then
width := 255;
k := 1;
spaces := width - i;
while k <= spaces do
begin
Result[k] := ' ';
Inc(k);
end;
{ Fill the Result with the number }
while i > 0 do
begin
Dec(i);
Result[k] := d[i];
Inc(k);
end;
{ Result is k-1 characters long }
SetLength(Result, k-1);
end;
function _Str0Int64(val: Int64): ShortString;
begin
Result := _StrInt64(val, 0);
end;
procedure _WriteInt64;
asm
{ PROCEDURE _WriteInt64( VAR t: Text; val: Int64; with: Longint); }
{ ->EAX Pointer to file record }
{ [ESP+4] Value }
{ EDX Field width }
SUB ESP,32 { VAR s: String[31]; }
PUSH EAX
PUSH EDX
PUSH dword ptr [ESP+8+32+8] { Str( val : 0, s ); }
PUSH dword ptr [ESP+8+32+8]
XOR EAX,EAX
LEA EDX,[ESP+8+8]
CALL _StrInt64
POP ECX
POP EAX
MOV EDX,ESP { Write( t, s : width );}
CALL _WriteString
ADD ESP,32
RET 8
end;
procedure _Write0Int64;
asm
{ PROCEDURE _Write0Long( VAR t: Text; val: Longint); }
{ ->EAX Pointer to file record }
{ EDX Value }
XOR EDX,EDX
JMP _WriteInt64
end;
procedure _ReadInt64; external; {$L ReadInt64 }
function _ValInt64(const s: AnsiString; var code: Integer): Int64;
var
i: Integer;
dig: Integer;
sign: Boolean;
empty: Boolean;
begin
i := 1;
dig := 0;
Result := 0;
if s = '' then
begin
code := i;
exit;
end;
while s[i] = ' ' do
Inc(i);
sign := False;
if s[i] = '-' then
begin
sign := True;
Inc(i);
end
else if s[i] = '+' then
Inc(i);
empty := True;
if (s[i] = '$') or (s[i] = '0') and (Upcase(s[i+1]) = 'X') then
begin
if s[i] = '0' then
Inc(i);
Inc(i);
while True do
begin
case s[i] of
'0'..'9': dig := Ord(s[i]) - Ord('0');
'A'..'F': dig := Ord(s[i]) - (Ord('A') - 10);
'a'..'f': dig := Ord(s[i]) - (Ord('a') - 10);
else
break;
end;
if (Result < 0) or (Result > $0FFFFFFFFFFFFFFF) then
break;
Result := Result shl 4 + dig;
Inc(i);
empty := False;
end;
if sign then
Result := - Result;
end
else
begin
while True do
begin
case s[i] of
'0'..'9': dig := Ord(s[i]) - Ord('0');
else
break;
end;
if (Result < 0) or (Result > $7FFFFFFFFFFFFFFF div 10) then
break;
Result := Result*10 + dig;
Inc(i);
empty := False;
end;
if sign then
Result := - Result;
if (Result <> 0) and (sign <> (Result < 0)) then
Dec(i);
end;
if (s[i] <> #0) or empty then
code := i
else
code := 0;
end;
procedure _DynArrayLength;
asm
{ FUNCTION _DynArrayLength(const a: array of ...): Longint; }
{ ->EAX Pointer to array or nil }
{ <-EAX High bound of array + 1 or 0 }
TEST EAX,EAX
JZ @@skip
MOV EAX,[EAX-4]
@@skip:
end;
procedure _DynArrayHigh;
asm
{ FUNCTION _DynArrayHigh(const a: array of ...): Longint; }
{ ->EAX Pointer to array or nil }
{ <-EAX High bound of array or -1 }
CALL _DynArrayLength
DEC EAX
end;
type
PLongint = ^Longint;
PointerArray = array [0..512*1024*1024 -2] of Pointer;
PPointerArray = ^PointerArray;
PDynArrayTypeInfo = ^TDynArrayTypeInfo;
TDynArrayTypeInfo = packed record
kind: Byte;
name: string[0];
elSize: Longint;
elType: ^PDynArrayTypeInfo;
varType: Integer;
end;
procedure CopyArray(dest, source, typeInfo: Pointer; cnt: Integer);
asm
PUSH dword ptr [EBP+8]
CALL _CopyArray
end;
procedure FinalizeArray(p, typeInfo: Pointer; cnt: Integer);
asm
JMP _FinalizeArray
end;
procedure DynArrayClear(var a: Pointer; typeInfo: Pointer);
asm
CALL _DynArrayClear
end;
procedure DynArraySetLength(var a: Pointer; typeInfo: PDynArrayTypeInfo; dimCnt: Longint; lengthVec: PLongint);
var
i: Integer;
newLength, oldLength, minLength: Longint;
elSize: Longint;
neededSize: Longint;
p, pp: Pointer;
begin
p := a;
// Fetch the new length of the array in this dimension, and the old length
newLength := PLongint(lengthVec)^;
if newLength <= 0 then
begin
if newLength < 0 then
Error(reRangeError);
DynArrayClear(a, typeInfo);
exit;
end;
oldLength := 0;
if p <> nil then
begin
Dec(PLongint(p));
oldLength := PLongint(p)^;
Dec(PLongint(p));
end;
// Calculate the needed size of the heap object
Inc(PChar(typeInfo), Length(typeInfo.name));
elSize := typeInfo.elSize;
if typeInfo.elType <> nil then
typeInfo := typeInfo.elType^
else
typeInfo := nil;
neededSize := newLength*elSize;
if neededSize div newLength <> elSize then
Error(reRangeError);
Inc(neededSize, Sizeof(Longint)*2);
// If the heap object isn't shared (ref count = 1), just resize it. Otherwise, we make a copy
if (p = nil) or (PLongint(p)^ = 1) then
begin
pp := p;
if (newLength < oldLength) and (typeInfo <> nil) then
FinalizeArray(PChar(p) + Sizeof(Longint)*2 + newLength*elSize, typeInfo, oldLength - newLength);
ReallocMem(pp, neededSize);
p := pp;
end
else
begin
Dec(PLongint(p)^);
GetMem(p, neededSize);
minLength := oldLength;
if minLength > newLength then
minLength := newLength;
if typeInfo <> nil then
begin
FillChar((PChar(p) + Sizeof(Longint)*2)^, minLength*elSize, 0);
CopyArray(PChar(p) + Sizeof(Longint)*2, a, typeInfo, minLength)
end
else
Move(PChar(a)^, (PChar(p) + Sizeof(Longint)*2)^, minLength*elSize);
end;
// The heap object will now have a ref count of 1 and the new length
PLongint(p)^ := 1;
Inc(PLongint(p));
PLongint(p)^ := newLength;
Inc(PLongint(p));
// Set the new memory to all zero bits
FillChar((PChar(p) + elSize * oldLength)^, elSize * (newLength - oldLength), 0);
// Take care of the inner dimensions, if any
if dimCnt > 1 then
begin
Inc(lengthVec);
Dec(dimCnt);
for i := 0 to newLength-1 do
DynArraySetLength(PPointerArray(p)[i], typeInfo, dimCnt, lengthVec);
end;
a := p;
end;
procedure _DynArraySetLength;
asm
{ PROCEDURE _DynArraySetLength(var a: dynarray; typeInfo: PDynArrayTypeInfo; dimCnt: Longint; lengthVec: ^Longint) }
{ ->EAX Pointer to dynamic array (= pointer to pointer to heap object) }
{ EDX Pointer to type info for the dynamic array }
{ ECX number of dimensions }
{ [ESP+4] dimensions }
PUSH ESP
ADD dword ptr [ESP],4
CALL DynArraySetLength
end;
procedure _DynArrayCopy(a: Pointer; typeInfo: Pointer; var Result: Pointer);
begin
if a <> nil then
_DynArrayCopyRange(a, typeInfo, 0, PLongint(PChar(a)-4)^, Result);
end;
procedure _DynArrayCopyRange(a: Pointer; typeInfo: Pointer; index, count : Integer; var Result: Pointer);
var
arrayLength: Integer;
elSize: Integer;
typeInf: PDynArrayTypeInfo;
p: Pointer;
begin
p := nil;
if a <> nil then
begin
typeInf := typeInfo;
// Limit index and count to values within the array
if index < 0 then
begin
Inc(count, index);
index := 0;
end;
arrayLength := PLongint(PChar(a)-4)^;
if index > arrayLength then
index := arrayLength;
if count > arrayLength - index then
count := arrayLength - index;
if count < 0 then
count := 0;
if count > 0 then
begin
// Figure out the size and type descriptor of the element type
Inc(PChar(typeInf), Length(typeInf.name));
elSize := typeInf.elSize;
if typeInf.elType <> nil then
typeInf := typeInf.elType^
else
typeInf := nil;
// Allocate the amount of memory needed
GetMem(p, count*elSize + Sizeof(Longint)*2);
// The reference count of the new array is 1, the length is count
PLongint(p)^ := 1;
Inc(PLongint(p));
PLongint(p)^ := count;
Inc(PLongint(p));
Inc(PChar(a), index*elSize);
// If the element type needs destruction, we must copy each element,
// otherwise we can just copy the bits
if count > 0 then
begin
if typeInf <> nil then
begin
FillChar(p^, count*elSize, 0);
CopyArray(p, a, typeInf, count)
end
else
Move(a^, p^, count*elSize);
end;
end;
end;
DynArrayClear(Result, typeInfo);
Result := p;
end;
procedure _DynArrayClear;
asm
{ ->EAX Pointer to dynamic array (Pointer to pointer to heap object }
{ EDX Pointer to type info }
{ Nothing to do if Pointer to heap object is nil }
MOV ECX,[EAX]
TEST ECX,ECX
JE @@exit
{ Set the variable to be finalized to nil }
MOV dword ptr [EAX],0
{ Decrement ref count. Nothing to do if not zero now. }
{X LOCK} DEC dword ptr [ECX-8]
JNE @@exit
{ Save the source - we're supposed to return it }
PUSH EAX
MOV EAX,ECX
{ Fetch the type descriptor of the elements }
XOR ECX,ECX
MOV CL,[EDX].TDynArrayTypeInfo.name;
MOV EDX,[EDX+ECX].TDynArrayTypeInfo.elType;
{ If it's non-nil, finalize the elements }
TEST EDX,EDX
JE @@noFinalize
MOV ECX,[EAX-4]
TEST ECX,ECX
JE @@noFinalize
MOV EDX,[EDX]
CALL _FinalizeArray
@@noFinalize:
{ Now deallocate the array }
SUB EAX,8
CALL _FreeMem
POP EAX
@@exit:
end;
procedure _DynArrayAsg;
asm
{ ->EAX Pointer to destination (pointer to pointer to heap object }
{ EDX source (pointer to heap object }
{ ECX Pointer to rtti describing dynamic array }
PUSH EBX
MOV EBX,[EAX]
{ Increment ref count of source if non-nil }
TEST EDX,EDX
JE @@skipInc
{X LOCK} INC dword ptr [EDX-8]
@@skipInc:
{ Dec ref count of destination - if it becomes 0, clear dest }
TEST EBX,EBX
JE @@skipClear
{X LOCK} DEC dword ptr[EBX-8]
JNZ @@skipClear
PUSH EAX
PUSH EDX
MOV EDX,ECX
INC dword ptr[EBX-8]
CALL _DynArrayClear
POP EDX
POP EAX
@@skipClear:
{ Finally store source into destination }
MOV [EAX],EDX
POP EBX
end;
procedure _DynArrayAddRef;
asm
{ ->EAX Pointer to heap object }
TEST EAX,EAX
JE @@exit
{X LOCK} INC dword ptr [EAX-8]
@@exit:
end;
function DynArrayIndex(const P: Pointer; const Indices: array of Integer; const TypInfo: Pointer): Pointer;
asm
{ ->EAX P }
{ EDX Pointer to Indices }
{ ECX High bound of Indices }
{ [EBP+8] TypInfo }
PUSH EBX
PUSH ESI
PUSH EDI
PUSH EBP
MOV ESI,EDX
MOV EDI,[EBP+8]
MOV EBP,EAX
XOR EBX,EBX { for i := 0 to High(Indices) do }
TEST ECX,ECX
JGE @@start
@@loop:
MOV EBP,[EBP]
@@start:
XOR EAX,EAX
MOV AL,[EDI].TDynArrayTypeInfo.name
ADD EDI,EAX
MOV EAX,[ESI+EBX*4] { P := P + Indices[i]*TypInfo.elSize }
MUL [EDI].TDynArrayTypeInfo.elSize
MOV EDI,[EDI].TDynArrayTypeInfo.elType
TEST EDI,EDI
JE @@skip
MOV EDI,[EDI]
@@skip:
ADD EBP,EAX
INC EBX
CMP EBX,ECX
JLE @@loop
@@loopEnd:
MOV EAX,EBP
POP EBP
POP EDI
POP ESI
POP EBX
end;
type
TBoundArray = array of Integer;
PPointer = ^Pointer;
{ Returns the DynArrayTypeInfo of the Element Type of the specified DynArrayTypeInfo }
function DynArrayElTypeInfo(typeInfo: PDynArrayTypeInfo): PDynArrayTypeInfo;
begin
Result := nil;
if typeInfo <> nil then
begin
Inc(PChar(typeInfo), Length(typeInfo.name));
if typeInfo.elType <> nil then
Result := typeInfo.elType^;
end;
end;
{ Returns # of dimemsions of the DynArray described by the specified DynArrayTypeInfo}
function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer;
begin
Result := 0;
while (typeInfo <> nil) and (typeInfo.kind = tkDynArray) do
begin
Inc(Result);
typeInfo := DynArrayElTypeInfo(typeInfo);
end;
end;
{ Returns size of the Dynamic Array}
function DynArraySize(a: Pointer): Integer;
asm
TEST EAX, EAX
JZ @@exit
MOV EAX, [EAX-4]
@@exit:
end;
// Returns whether array is rectangular
function IsDynArrayRectangular(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): Boolean;
var
Dim, I, J, Size, SubSize: Integer;
P: Pointer;
begin
// Assume we have a rectangular array
Result := True;
P := DynArray;
Dim := DynArrayDim(typeInfo);
{NOTE: Start at 1. Don't need to test the first dimension - it's rectangular by definition}
for I := 1 to dim-1 do
begin
if P <> nil then
begin
{ Get size of this dimension }
Size := DynArraySize(P);
{ Get Size of first sub. dimension }
SubSize := DynArraySize(PPointerArray(P)[0]);
{ Walk through every dimension making sure they all have the same size}
for J := 1 to Size-1 do
if DynArraySize(PPointerArray(P)[J]) <> SubSize then
begin
Result := False;
Exit;
end;
{ Point to next dimension}
P := PPointerArray(P)[0];
end;
end;
end;
// Returns Bounds of a DynamicArray in a format usable for creating a Variant.
// i.e. The format of the bounds returns contains pairs of lo and hi bounds where
// lo is always 0, and hi is the size dimension of the array-1.
function DynArrayVariantBounds(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): TBoundArray;
var
Dim, I: Integer;
P: Pointer;
begin
P := DynArray;
Dim := DynArrayDim(typeInfo);
SetLength(Result, Dim*2);
I := 0;
while I < dim*2 do
begin
Result[I] := 0; // Always use 0 as low-bound in low/high pair
Inc(I);
if P <> nil then
begin
Result[I] := DynArraySize(P)-1; // Adjust for 0-base low-bound
P := PPointerArray(p)[0]; // Assume rectangular arrays
end;
Inc(I);
end;
end;
// Returns Bounds of Dynamic array as an array of integer containing the 'high' of each dimension
function DynArrayBounds(const DynArray: Pointer; typeInfo: PDynArrayTypeInfo): TBoundArray;
var
Dim, I: Integer;
P: Pointer;
begin
P := DynArray;
Dim := DynArrayDim(typeInfo);
SetLength(Result, Dim);
for I := 0 to dim-1 do
if P <> nil then
begin
Result[I] := DynArraySize(P)-1;
P := PPointerArray(P)[0]; // Assume rectangular arrays
end;
end;
// The dynamicArrayTypeInformation contains the VariantType of the element type
// when the kind == tkDynArray. This function returns that VariantType.
function DynArrayVarType(typeInfo: PDynArrayTypeInfo): Integer;
begin
Result := varNull;
if (typeInfo <> nil) and (typeInfo.Kind = tkDynArray) then
begin
Inc(PChar(typeInfo), Length(typeInfo.name));
Result := typeInfo.varType;
end;
{ NOTE: DECL.H and SYSTEM.PAS have different values for varString }
if Result = $48 then
Result := varString;
end;
type
IntegerArray = array[0..$effffff] of Integer;
PIntegerArray = ^IntegerArray;
PSmallInt = ^SmallInt;
PInteger = ^Integer;
PSingle = ^Single;
PDouble = ^Double;
PDate = ^Double;
PDispatch = ^IDispatch;
PPDispatch = ^PDispatch;
PError = ^LongWord;
PWordBool = ^WordBool;
PUnknown = ^IUnknown;
PPUnknown = ^PUnknown;
PByte = ^Byte;
PPWideChar = ^PWideChar;
{ Decrements to next lower index - Returns True if successful }
{ Indices: Indices to be decremented }
{ Bounds : High bounds of each dimension }
function DecIndices(var Indices: TBoundArray; const Bounds: TBoundArray): Boolean;
var
I, J: Integer;
begin
{ Find out if we're done: all at zeroes }
Result := False;
for I := Low(Indices) to High(Indices) do
if Indices[I] <> 0 then
begin
Result := True;
break;
end;
if not Result then
Exit;
{ Two arrays must be of same length }
Assert(Length(Indices) = Length(Bounds));
{ Find index of item to tweak }
for I := High(Indices) downto Low(Bounds) do
begin
// If not reach zero, dec and bail out
if Indices[I] <> 0 then
begin
Dec(Indices[I]);
Exit;
end
else
begin
J := I;
while Indices[J] = 0 do
begin
// Restore high bound when we've reached zero on a particular dimension
Indices[J] := Bounds[J];
// Move to higher dimension
Dec(J);
Assert(J >= 0);
end;
Dec(Indices[J]);
Exit;
end;
end;
end;
// Copy Contents of Dynamic Array to Variant
// NOTE: The Dynamic array must be rectangular
// The Dynamic array must contain items whose type is Automation compatible
// In case of failure, the function returns with a Variant of type VT_EMPTY.
procedure DynArrayToVariant(var V: Variant; const DynArray: Pointer; TypeInfo: Pointer);
var
VarBounds, Bounds, Indices: TBoundArray;
DAVarType, VVarType, DynDim: Integer;
PDAData: Pointer;
Value: Variant;
begin
VarBounds := nil;
Bounds := nil;
{ This resets the Variant to VT_EMPTY - flag which is used to determine whether the }
{ the cast to Variant succeeded or not }
VarClear(V);
{ Get variantType code from DynArrayTypeInfo }
DAVarType := DynArrayVarType(PDynArrayTypeInfo(TypeInfo));
{ Validate the Variant Type }
if ((DAVarType > varNull) and (DAVarType <= varByte)) or (DAVarType = varString) then
begin
{NOTE: Map varString to varOleStr for SafeArrayCreate call }
if DAVarType = varString then
VVarType := varOleStr
else
VVarType := DAVarType;
{ Get dimension of Dynamic Array }
DynDim := DynarrayDim(PDynArrayTypeInfo(TypeInfo));
{ If more than one dimension, make sure we're dealing with a rectangular array }
if DynDim > 1 then
if not IsDynArrayRectangular(DynArray, PDynArrayTypeInfo(TypeInfo)) then
Exit;
{ Get Variant-style Bounds (lo/hi pair) of Dynamic Array }
VarBounds := DynArrayVariantBounds(DynArray, TypeInfo);
{ Get DynArray Bounds }
Bounds := DynArrayBounds(DynArray, TypeInfo);
Indices:= Copy(Bounds);
{ Create Variant of SAFEARRAY }
V := VarArrayCreate(VarBounds, VVarType);
Assert(VarArrayDimCount(V) = DynDim);
repeat
PDAData := DynArrayIndex(DynArray, Indices, TypeInfo);
if PDAData <> nil then
begin
case DAVarType of
varSmallInt: Value := PSmallInt(PDAData)^;
varInteger: Value := PInteger(PDAData)^;
varSingle: value := PSingle(PDAData)^;
varDouble: value := PDouble(PDAData)^;
varCurrency: Value := PCurrency(PDAData)^;
varDate: Value := PDouble(PDAData)^;
varOleStr: Value := PWideString(PDAData)^;
varDispatch: Value := PDispatch(PDAData)^;
varError: Value := PError(PDAData)^;
varBoolean: Value := PWordBool(PDAData)^;
varVariant: Value := PVariant(PDAData)^;
varUnknown: Value := PUnknown(PDAData)^;
varByte: Value := PByte(PDAData)^;
varString: Value := PString(PDAData)^;
else
VarClear(Value);
end; { case }
VarArrayPut(V, Value, Indices);
end;
until not DecIndices(Indices, Bounds);
end;
end;
// Copies data from the Variant to the DynamicArray
procedure DynArrayFromVariant(var DynArray: Pointer; const V: Variant; TypeInfo: Pointer);
var
DADimCount, VDimCount : Integer;
DAVarType, I: Integer;
lengthVec: PLongInt;
Bounds, Indices: TBoundArray;
Value: Variant;
PDAData: Pointer;
begin
{ Get Variant information }
VDimCount:= VarArrayDimCount(V);
{ Allocate vector for lengths }
GetMem(lengthVec, VDimCount * sizeof(Integer));
{ Initialize lengths - NOTE: VarArrayxxxxBound are 1-based.}
for I := 0 to VDimCount-1 do
PIntegerArray(lengthVec)[I]:= (VarArrayHighBound(V, I+1) - VarArrayLowBound(V, I+1)) + 1;
{ Set Length of DynArray }
DynArraySetLength(DynArray, PDynArrayTypeInfo(TypeInfo), VDimCount, lengthVec);
{ Get DynArray information }
DADimCount:= DynArrayDim(PDynArrayTypeInfo(TypeInfo));
DAVarType := DynArrayVarType(PDynArrayTypeInfo(TypeInfo));
Assert(VDimCount = DADimCount);
{ Get DynArray Bounds }
Bounds := DynArrayBounds(DynArray, TypeInfo);
Indices:= Copy(Bounds);
{ Copy data over}
repeat
Value := VarArrayGet(V, Indices);
PDAData := DynArrayIndex(DynArray, Indices, TypeInfo);
case DAVarType of
varSmallInt: PSmallInt(PDAData)^ := Value;
varInteger: PInteger(PDAData)^ := Value;
varSingle: PSingle(PDAData)^ := Value;
varDouble: PDouble(PDAData)^ := Value;
varCurrency: PCurrency(PDAData)^ := Value;
varDate: PDouble(PDAData)^ := Value;
varOleStr: PWideString(PDAData)^ := Value;
varDispatch: PDispatch(PDAData)^ := Value;
varError: PError(PDAData)^ := Value;
varBoolean: PWordBool(PDAData)^ := Value;
varVariant: PVariant(PDAData)^ := Value;
varUnknown: PUnknown(PDAData)^ := value;
varByte: PByte(PDAData)^ := Value;
varString: PString(PDAData)^ := Value;
end; { case }
until not DecIndices(Indices, Bounds);
{ Free vector of lengths }
FreeMem(lengthVec);
end;
{ Package/Module registration/unregistration }
const
LOCALE_SABBREVLANGNAME = $00000003; { abbreviated language name }
LOAD_LIBRARY_AS_DATAFILE = 2;
HKEY_CURRENT_USER = $80000001;
KEY_ALL_ACCESS = $000F003F;
OldLocaleOverrideKey = 'Software\Borland\Delphi\Locales'; // do not localize
NewLocaleOverrideKey = 'Software\Borland\Locales'; // do not localize
function FindHInstance(Address: Pointer): LongWord;
var
MemInfo: TMemInfo;
begin
VirtualQuery(Address, MemInfo, SizeOf(MemInfo));
if MemInfo.State = $1000{MEM_COMMIT} then
Result := Longint(MemInfo.AllocationBase)
else Result := 0;
end;
function FindClassHInstance(ClassType: TClass): LongWord;
begin
Result := FindHInstance(Pointer(ClassType));
end;
function FindResourceHInstance(Instance: LongWord): LongWord;
var
CurModule: PLibModule;
begin
CurModule := LibModuleList;
while CurModule <> nil do
begin
if (Instance = CurModule.Instance) or
(Instance = CurModule.CodeInstance) or
(Instance = CurModule.DataInstance) then
begin
Result := CurModule.ResInstance;
Exit;
end;
CurModule := CurModule.Next;
end;
Result := Instance;
end;
function LoadResourceModule(ModuleName: PChar): LongWord;
var
FileName: array[0..260] of Char;
Key: LongWord;
LocaleName, LocaleOverride: array[0..4] of Char;
Size: Integer;
P: PChar;
function FindBS(Current: PChar): PChar;
begin
Result := Current;
while (Result^ <> #0) and (Result^ <> '\') do
Result := CharNext(Result);
end;
function ToLongPath(AFileName: PChar): PChar;
var
CurrBS, NextBS: PChar;
Handle, L: Integer;
FindData: TWin32FindData;
Buffer: array[0..260] of Char;
GetLongPathName: function (ShortPathName: PChar; LongPathName: PChar;
cchBuffer: Integer): Integer stdcall;
begin
Result := AFileName;
Handle := GetModuleHandle(kernel);
if Handle <> 0 then
begin
@GetLongPathName := GetProcAddress(Handle, 'GetLongPathNameA');
if Assigned(GetLongPathName) and
(GetLongPathName(AFileName, Buffer, SizeOf(Buffer)) <> 0) then
begin
lstrcpy(AFileName, Buffer);
Exit;
end;
end;
if AFileName[0] = '\' then
begin
if AFileName[1] <> '\' then Exit;
CurrBS := FindBS(AFileName + 2); // skip server name
if CurrBS^ = #0 then Exit;
CurrBS := FindBS(CurrBS + 1); // skip share name
if CurrBS^ = #0 then Exit;
end else
CurrBS := AFileName + 2; // skip drive name
L := CurrBS - AFileName;
lstrcpyn(Buffer, AFileName, L + 1);
while CurrBS^ <> #0 do
begin
NextBS := FindBS(CurrBS + 1);
if L + (NextBS - CurrBS) + 1 > SizeOf(Buffer) then Exit;
lstrcpyn(Buffer + L, CurrBS, (NextBS - CurrBS) + 1);
Handle := FindFirstFile(Buffer, FindData);
if (Handle = -1) then Exit;
FindClose(Handle);
if L + 1 + lstrlen(FindData.cFileName) + 1 > SizeOf(Buffer) then Exit;
Buffer[L] := '\';
lstrcpy(Buffer + L + 1, FindData.cFileName);
Inc(L, lstrlen(FindData.cFileName) + 1);
CurrBS := NextBS;
end;
lstrcpy(AFileName, Buffer);
end;
begin
GetModuleFileName(0, FileName, SizeOf(FileName)); // Get host appliation name
LocaleOverride[0] := #0;
if (RegOpenKeyEx(HKEY_CURRENT_USER, NewLocaleOverrideKey, 0, KEY_ALL_ACCESS, Key) = 0) or
(RegOpenKeyEx(HKEY_CURRENT_USER, OldLocaleOverrideKey, 0, KEY_ALL_ACCESS, Key) = 0) then
try
Size := SizeOf(LocaleOverride);
if RegQueryValueEx(Key, ToLongPath(FileName), nil, nil, LocaleOverride, @Size) <> 0 then
RegQueryValueEx(Key, '', nil, nil, LocaleOverride, @Size);
finally
RegCloseKey(Key);
end;
lstrcpy(FileName, ModuleName);
GetLocaleInfo(GetThreadLocale, LOCALE_SABBREVLANGNAME, LocaleName, SizeOf(LocaleName));
Result := 0;
if (FileName[0] <> #0) and ((LocaleName[0] <> #0) or (LocaleOverride[0] <> #0)) then
begin
P := PChar(@FileName) + lstrlen(FileName);
while (P^ <> '.') and (P <> @FileName) do Dec(P);
if P <> @FileName then
begin
Inc(P);
// First look for a locale registry override
if LocaleOverride[0] <> #0 then
begin
lstrcpy(P, LocaleOverride);
Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);
end;
if (Result = 0) and (LocaleName[0] <> #0) then
begin
// Then look for a potential language/country translation
lstrcpy(P, LocaleName);
Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);
if Result = 0 then
begin
// Finally look for a language only translation
LocaleName[2] := #0;
lstrcpy(P, LocaleName);
Result := LoadLibraryEx(FileName, 0, LOAD_LIBRARY_AS_DATAFILE);
end;
end;
end;
end;
end;
procedure EnumModules(Func: TEnumModuleFunc; Data: Pointer); assembler;
begin
EnumModules(TEnumModuleFuncLW(Func), Data);
end;
procedure EnumResourceModules(Func: TEnumModuleFunc; Data: Pointer);
begin
EnumResourceModules(TEnumModuleFuncLW(Func), Data);
end;
procedure EnumModules(Func: TEnumModuleFuncLW; Data: Pointer);
var
CurModule: PLibModule;
begin
CurModule := LibModuleList;
while CurModule <> nil do
begin
if not Func(CurModule.Instance, Data) then Exit;
CurModule := CurModule.Next;
end;
end;
procedure EnumResourceModules(Func: TEnumModuleFuncLW; Data: Pointer);
var
CurModule: PLibModule;
begin
CurModule := LibModuleList;
while CurModule <> nil do
begin
if not Func(CurModule.ResInstance, Data) then Exit;
CurModule := CurModule.Next;
end;
end;
procedure AddModuleUnloadProc(Proc: TModuleUnloadProc);
begin
AddModuleUnloadProc(TModuleUnloadProcLW(Proc));
end;
procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProc);
begin
RemoveModuleUnloadProc(TModuleUnloadProcLW(Proc));
end;
procedure AddModuleUnloadProc(Proc: TModuleUnloadProcLW);
var
P: PModuleUnloadRec;
begin
New(P);
P.Next := ModuleUnloadList;
@P.Proc := @Proc;
ModuleUnloadList := P;
end;
procedure RemoveModuleUnloadProc(Proc: TModuleUnloadProcLW);
var
P, C: PModuleUnloadRec;
begin
P := ModuleUnloadList;
if (P <> nil) and (@P.Proc = @Proc) then
begin
ModuleUnloadList := ModuleUnloadList.Next;
Dispose(P);
end else
begin
C := P;
while C <> nil do
begin
if (C.Next <> nil) and (@C.Next.Proc = @Proc) then
begin
P := C.Next;
C.Next := C.Next.Next;
Dispose(P);
Break;
end;
C := C.Next;
end;
end;
end;
procedure NotifyModuleUnload(HInstance: LongWord);
var
P: PModuleUnloadRec;
begin
P := ModuleUnloadList;
while P <> nil do
begin
try
P.Proc(HInstance);
except
// Make sure it doesn't stop notifications
end;
P := P.Next;
end;
end;
procedure RegisterModule(LibModule: PLibModule);
begin
LibModule.Next := LibModuleList;
LibModuleList := LibModule;
end;
{X- procedure UnregisterModule(LibModule: PLibModule); -renamed }
procedure UnRegisterModuleSafely( LibModule: PLibModule );
var
CurModule: PLibModule;
begin
try
NotifyModuleUnload(LibModule.Instance);
finally
if LibModule = LibModuleList then
LibModuleList := LibModule.Next
else
begin
CurModule := LibModuleList;
while CurModule <> nil do
begin
if CurModule.Next = LibModule then
begin
CurModule.Next := LibModule.Next;
Break;
end;
CurModule := CurModule.Next;
end;
end;
end;
end;
{X+} // "Light" version of UnRegisterModule - without using of try-except
procedure UnRegisterModuleLight( LibModule: PLibModule );
var
P: PModuleUnloadRec;
begin
P := ModuleUnloadList;
while P <> nil do
begin
P.Proc(LibModule.Instance);
P := P.Next;
end;
end;
{X-}
{ ResString support function }
function LoadResString(ResStringRec: PResStringRec): string;
var
Buffer: array[0..1023] of Char;
begin
if ResStringRec <> nil then
if ResStringRec.Identifier < 64*1024 then
SetString(Result, Buffer, LoadString(FindResourceHInstance(ResStringRec.Module^),
ResStringRec.Identifier, Buffer, SizeOf(Buffer)))
else
Result := PChar(ResStringRec.Identifier);
end;
procedure _IntfClear(var Dest: IUnknown);
asm
MOV EDX,[EAX]
TEST EDX,EDX
JE @@1
MOV DWORD PTR [EAX],0
PUSH EAX
PUSH EDX
MOV EAX,[EDX]
CALL [EAX].vmtRelease.Pointer
POP EAX
@@1:
end;
procedure _IntfCopy(var Dest: IUnknown; const Source: IUnknown);
asm
MOV ECX,[EAX] { save dest }
MOV [EAX],EDX { assign dest }
TEST EDX,EDX { need to addref source before releasing dest }
JE @@1 { to make self assignment (I := I) work right }
PUSH ECX
PUSH EDX
MOV EAX,[EDX]
CALL [EAX].vmtAddRef.Pointer
POP ECX
@@1: TEST ECX,ECX
JE @@2
PUSH ECX
MOV EAX,[ECX]
CALL [EAX].vmtRelease.Pointer
@@2:
end;
procedure _IntfCast(var Dest: IUnknown; const Source: IUnknown; const IID: TGUID);
asm
TEST EDX,EDX
JE _IntfClear
PUSH EAX
PUSH ECX
PUSH EDX
MOV ECX,[EAX]
TEST ECX,ECX
JE @@1
PUSH ECX
MOV EAX,[ECX]
CALL [EAX].vmtRelease.Pointer
MOV EDX,[ESP]
@@1: MOV EAX,[EDX]
CALL [EAX].vmtQueryInterface.Pointer
TEST EAX,EAX
JE @@2
MOV AL,reIntfCastError
JMP Error
@@2:
end;
procedure _IntfAddRef(const Dest: IUnknown);
begin
if Dest <> nil then Dest._AddRef;
end;
procedure TInterfacedObject.AfterConstruction;
begin
// Release the constructor's implicit refcount
InterlockedDecrement(FRefCount);
end;
procedure TInterfacedObject.BeforeDestruction;
begin
if RefCount <> 0 then Error(reInvalidPtr);
end;
// Set an implicit refcount so that refcounting
// during construction won't destroy the object.
class function TInterfacedObject.NewInstance: TObject;
begin
Result := inherited NewInstance;
TInterfacedObject(Result).FRefCount := 1;
end;
function TInterfacedObject.QueryInterface(const IID: TGUID; out Obj): HResult;
const
E_NOINTERFACE = HResult($80004002);
begin
if GetInterface(IID, Obj) then Result := 0 else Result := E_NOINTERFACE;
end;
function TInterfacedObject._AddRef: Integer;
begin
Result := InterlockedIncrement(FRefCount);
end;
function TInterfacedObject._Release: Integer;
begin
Result := InterlockedDecrement(FRefCount);
if Result = 0 then
Destroy;
end;
procedure _CheckAutoResult;
asm
TEST EAX,EAX
JNS @@2
MOV ECX,SafeCallErrorProc
TEST ECX,ECX
JE @@1
MOV EDX,[ESP]
CALL ECX
@@1: MOV AL,reSafeCallError
JMP Error
@@2:
end;
procedure _IntfDispCall;
asm
JMP DispCallByIDProc
end;
procedure _IntfVarCall;
asm
end;
function CompToDouble(acomp: Comp): Double; cdecl;
begin
Result := acomp;
end;
procedure DoubleToComp(adouble: Double; var result: Comp); cdecl;
begin
result := adouble;
end;
function CompToCurrency(acomp: Comp): Currency; cdecl;
begin
Result := acomp;
end;
procedure CurrencyToComp(acurrency: Currency; var result: Comp); cdecl;
begin
result := acurrency
end;
function GetMemory(Size: Integer): Pointer; cdecl;
begin
Result := {X- SysGetMem(Size); -replaced to use current memory manager}
MemoryManager.GetMem( Size );
end;
function FreeMemory(P: Pointer): Integer; cdecl;
begin
if P = nil then
Result := 0
else
Result := {X- SysFreeMem(P); - replaced to use current memory manager}
MemoryManager.FreeMem( P );
end;
function ReallocMemory(P: Pointer; Size: Integer): Pointer; cdecl;
begin
{X- Result := SysReallocMem(P, Size); - replaced to use current memory manager}
Result := MemoryManager.ReallocMem( P, Size );
end;
function GetCurrentThreadId: DWORD; stdcall; external kernel name 'GetCurrentThreadId';
{X} // convert var CmdLine : PChar to a function:
{X} function CmdLine : PChar;
{X} begin
{X} Result := GetCommandLine;
{X} end;
initialization
{X- initialized by 0 anyway
ExitCode := 0;
ErrorAddr := nil;
RandSeed := 0;
X+}
{X- initialized statically
FileMode := 2;
Test8086 := 2;
Test8087 := 3;
X+}
{X- moved to SysVarnt.pas
TVarData(Unassigned).VType := varEmpty;
TVarData(Null).VType := varNull;
TVarData(EmptyParam).VType := varError;
TVarData(EmptyParam).VError := $80020004; //DISP_E_PARAMNOTFOUND
ClearAnyProc := @VarInvalidOp;
ChangeAnyProc := @VarCastError;
RefAnyProc := @VarInvalidOp;
X+}
{X-
if _isNECWindows then _FpuMaskInit;
FpuInit();
X+}
{X- to use Input/Output, call UseInputOutput (or include
following two lines into your code and call Close(Input),
Close(Output) at the end of execution).
_Assign( Input, '' );
_Assign( Output, '' );
X+}
{X- CmdLine := GetCommandLine; converted to a function }
{X- CmdShow := GetCmdShow; converted to a function }
MainThreadID := GetCurrentThreadID;
finalization
{X}if assigned( CloseInputOutput ) then
{X} CloseInputOutput;
{X-
Close(Input);
Close(Output);
X+}
{X UninitAllocator; - replaced with call to UninitMemoryManager handler. }
UninitMemoryManager;
end.
Reference in New Issue Copy Permalink