system.pas

多数代码可以直接在Delphi6和Delphi7环境下运行。部分涉及.NET技术内容的代码

//procedure _DestroyException(Exc: PRaisedException);
procedure _DestroyException;
{$ENDIF}
procedure _RaiseExcept;
procedure _RaiseAgain;
procedure _DoneExcept;
{$IFNDEF PC_MAPPED_EXCEPTIONS}
procedure _TryFinallyExit;
{$ENDIF}
procedure _HandleAnyException;
procedure _HandleFinally;
procedure _HandleOnException;
{$IFDEF PC_MAPPED_EXCEPTIONS}
procedure _HandleOnExceptionPIC;
{$ENDIF}
procedure _HandleAutoException;
{$IFDEF PC_MAPPED_EXCEPTIONS}
procedure _ClassHandleException;
{$ENDIF}

procedure _CallDynaInst;
procedure _CallDynaClass;
procedure _FindDynaInst;
procedure _FindDynaClass;

procedure _LStrClr(var S);
procedure _LStrArrayClr(var StrArray; cnt: longint);
procedure _LStrAsg(var dest; const source);
procedure _LStrLAsg(var dest; const source);
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(const s: 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};
function _LStrAddRef(var str): Pointer;
function _LStrToPChar(const s: 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(s: PShortString; newLength: Byte);
procedure _SetString(s: PShortString; buffer: PChar; len: Byte);

procedure UniqueString(var str: AnsiString); overload;
procedure UniqueString(var str: WideString); overload;
procedure _UniqueStringA(var str: AnsiString);
procedure _UniqueStringW(var str: WideString);


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 };
function _NewAnsiString(length: Longint): Pointer;      { for debugger purposes only }
function _NewWideString(CharLength: Longint): Pointer;

procedure _WStrClr(var S);
procedure _WStrArrayClr(var StrArray; Count: Integer);
procedure _WStrAsg(var Dest: WideString; const Source: WideString);
procedure _WStrLAsg(var Dest: WideString; const Source: WideString);
function _WStrToPWChar(const S: WideString): PWideChar;
function _WStrLen(const S: WideString): Integer;
procedure _WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer);
procedure _WStrFromPWCharLen(var Dest: WideString; Source: PWideChar; CharLength: 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);
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 _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;
function _WStrAddRef(var str: WideString): Pointer;

procedure _Initialize(p: Pointer; typeInfo: Pointer);
procedure _InitializeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal);
procedure _InitializeRecord(p: Pointer; typeInfo: Pointer);
procedure _Finalize(p: Pointer; typeInfo: Pointer);
procedure _FinalizeArray(p: Pointer; typeInfo: Pointer; elemCount: Cardinal);
procedure _FinalizeRecord(P: Pointer; typeInfo: Pointer);
procedure _AddRef;
procedure _AddRefArray;
procedure _AddRefRecord;
procedure _CopyArray;
procedure _CopyRecord;
procedure _CopyObject;

function _New(size: Longint; typeInfo: Pointer): Pointer;
procedure _Dispose(p: Pointer; typeInfo: Pointer);

{ 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 DynArrayClear(var a: Pointer; typeInfo: Pointer);
procedure DynArraySetLength(var a: Pointer; typeInfo: Pointer; dimCnt: Longint; lengthVec: PLongint);
function DynArrayDim(typeInfo: PDynArrayTypeInfo): Integer;
{$NODEFINE DynArrayDim}

function _IntfClear(var Dest: IInterface): Pointer;
procedure _IntfCopy(var Dest: IInterface; const Source: IInterface);
procedure _IntfCast(var Dest: IInterface; const Source: IInterface; const IID: TGUID);
procedure _IntfAddRef(const Dest: IInterface);

{$IFDEF MSWINDOWS}
procedure _FSafeDivide;
procedure _FSafeDivideR;
{$ENDIF}

function _CheckAutoResult(ResultCode: HResult): HResult;

procedure FPower10;

procedure TextStart; deprecated;

// Conversion utility routines for C++ convenience.  Not for Delphi code.
function  CompToDouble(Value: Comp): Double; cdecl;
procedure DoubleToComp(Value: Double; var Result: Comp); cdecl;
function  CompToCurrency(Value: Comp): Currency; cdecl;
procedure CurrencyToComp(Value: 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;

{ Internal runtime error codes }

type
  TRuntimeError = (reNone, reOutOfMemory, reInvalidPtr, reDivByZero,
  reRangeError, reIntOverflow, reInvalidOp, reZeroDivide, reOverflow,
  reUnderflow, reInvalidCast, reAccessViolation, rePrivInstruction,
  reControlBreak, reStackOverflow,
  { reVar* used in Variants.pas }
  reVarTypeCast, reVarInvalidOp,
  reVarDispatch, reVarArrayCreate, reVarNotArray, reVarArrayBounds,
  reAssertionFailed,
  reExternalException, { not used here; in SysUtils }
  reIntfCastError, reSafeCallError
{$IFDEF LINUX}
  , reQuit, reCodesetConversion
{$ENDIF}
  );
{$NODEFINE TRuntimeError}

procedure Error(errorCode: TRuntimeError);
{$NODEFINE Error}

{ GetLastError returns the last error reported by an OS API call.  Calling
  this function usually resets the OS error state.
}

function GetLastError: Integer; {$IFDEF MSWINDOWS} stdcall; {$ENDIF}
{$EXTERNALSYM GetLastError}

{ SetLastError writes to the thread local storage area read by GetLastError. }

procedure SetLastError(ErrorCode: Integer); {$IFDEF MSWINDOWS} stdcall; {$ENDIF}

{$IFDEF LINUX}
{  To improve performance, some RTL routines cache module handles and data
   derived from modules.  If an application dynamically loads and unloads
   shared object libraries, packages, or resource packages, it is possible for
   the handle of the newly loaded module to match the handle of a recently
   unloaded module.  The resource caches have no way to detect when this happens.

   To address this issue, the RTL maintains an internal counter that is
   incremented every time a module is loaded or unloaded using RTL functions
   (like LoadPackage).  This provides a cache version level signature that
   can detect when modules have been cycled but have the same handle.

   If you load or unload modules "by hand" using dlopen or dlclose, you must call
   InvalidateModuleCache after each load or unload so that the RTL module handle
   caches will refresh themselves properly the next time they are used.  This is
   especially important if you manually tinker with the LibModuleList list of
   loaded modules, or manually add or remove resource modules in the nodes
   of that list.

   ModuleCacheID returns the "current generation" or version number kept by
   the RTL.  You can use this to implement your own refresh-on-next-use
   (passive) module handle caches as the RTL does.  The value changes each
   time InvalidateModuleCache is called.
}

function ModuleCacheID: Cardinal;
procedure InvalidateModuleCache;
{$ENDIF}

(* =================================================================== *)

implementation

uses
  SysInit;

{ This procedure should be at the very beginning of the }
{ text segment. It used to be used by _RunError to find    }
{ start address of the text segment, but is not used anymore.  }

procedure TextStart;
begin
end;

{$IFDEF PIC}
function GetGOT: LongWord; export;
begin
  asm
  MOV Result,EBX
  end;
end;
{$ENDIF}

{$IFDEF PC_MAPPED_EXCEPTIONS}
const
  UNWINDFI_TOPOFSTACK =   $BE00EF00;

const
{$IFDEF MSWINDOWS}
  unwind = 'unwind.dll';

type
  UNWINDPROC  = Pointer;
function UnwindRegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl;
  external unwind name '__BorUnwind_RegisterIPLookup';

function UnwindDelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl;
  external unwind name '__BorUnwind_DelphiLookup';

function UnwindRaiseException(Exc: Pointer): LongBool; cdecl;
  external unwind name '__BorUnwind_RaiseException';

function UnwindClosestHandler(Context: Pointer): LongWord; cdecl;
  external unwind name '__BorUnwind_ClosestDelphiHandler';
{$ENDIF}
{$IFDEF LINUX}
  unwind = 'libborunwind.so.6';
type
  UNWINDPROC  = Pointer;

//{$DEFINE STATIC_UNWIND}

{$IFDEF STATIC_UNWIND}
function _BorUnwind_RegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl;
  external;

procedure _BorUnwind_UnregisterIPLookup(StartAddr: LongInt); cdecl;  external;

function _BorUnwind_DelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl;  external;

function _BorUnwind_RaiseException(Exc: Pointer): LongBool; cdecl;  external;

//function _BorUnwind_AddressIsInPCMap(Addr: LongInt): LongBool; cdecl; external;
function _BorUnwind_ClosestDelphiHandler(Context: Pointer): LongWord; cdecl; external;
{$ELSE}

function _BorUnwind_RegisterIPLookup(fn: UNWINDPROC; StartAddr, EndAddr: LongInt; Context: Pointer; GOT: LongInt): LongBool; cdecl;
  external unwind name '_BorUnwind_RegisterIPLookup';

procedure _BorUnwind_UnregisterIPLookup(StartAddr: LongInt); cdecl;
  external unwind name '_BorUnwind_UnregisterIPLookup';

function _BorUnwind_DelphiLookup(Addr: LongInt; Context: Pointer): UNWINDPROC; cdecl;
  external unwind name '_BorUnwind_DelphiLookup';

function _BorUnwind_RaiseException(Exc: Pointer): LongBool; cdecl;
  external unwind name '_BorUnwind_RaiseException';

function _BorUnwind_ClosestDelphiHandler(Context: Pointer): LongWord; cdecl;
  external unwind name '_BorUnwind_ClosestDelphiHandler';
{$ENDIF}
{$ENDIF}
{$ENDIF}

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_CONTIN