sysutils.inc 17 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 1999-2000 by Florian Klaempfl
  4. member of the Free Pascal development team
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. { MCBS functions }
  12. {$i sysansi.inc}
  13. {$i syscodepages.inc}
  14. {$macro on}
  15. {$define PathStr:=UnicodeString}
  16. {$define PathPChar:=PWideChar}
  17. {$define SYSUTILSUNICODE}
  18. { Read filename handling functions implementation }
  19. {$i fina.inc}
  20. { Read disk function implementations }
  21. {$i disk.inc}
  22. {$undef SYSUTILSUNICODE}
  23. {$define PathStr:=RawByteString}
  24. {$define PathPChar:=PAnsiChar}
  25. { Read filename handling functions implementation }
  26. {$i fina.inc}
  27. { Read disk function implementations }
  28. {$i disk.inc}
  29. {$undef PathStr}
  30. {$undef PathPChar}
  31. { Read file utility functions implementation }
  32. {$i filutil.inc}
  33. { variant error codes }
  34. {$i varerror.inc}
  35. {$ifndef OS_FILEISREADONLY}
  36. Function FileIsReadOnly(const FileName: RawByteString): Boolean;
  37. begin
  38. Result := (FileGetAttr(FileName) and faReadOnly) <> 0;
  39. end;
  40. Function FileIsReadOnly(const FileName: UnicodeString): Boolean;
  41. begin
  42. Result := (FileGetAttr(FileName) and faReadOnly) <> 0;
  43. end;
  44. {$endif OS_FILEISREADONLY}
  45. {$ifndef OS_FILESETDATEBYNAME}
  46. Function FileSetDate (Const FileName : RawByteString;Age : Longint) : Longint;
  47. Var
  48. fd : THandle;
  49. begin
  50. { at least windows requires fmOpenWrite here }
  51. fd:=FileOpen(FileName,fmOpenWrite);
  52. If (Fd<>feInvalidHandle) then
  53. try
  54. Result:=FileSetDate(fd,Age);
  55. finally
  56. FileClose(fd);
  57. end
  58. else
  59. {$ifdef HAS_OSERROR}
  60. Result:=GetLastOSError;
  61. {$else}
  62. Result:=-1;
  63. {$endif}
  64. end;
  65. Function FileSetDate (Const FileName : UnicodeString;Age : Longint) : Longint;
  66. Var
  67. fd : THandle;
  68. begin
  69. { at least windows requires fmOpenWrite here }
  70. fd:=FileOpen(FileName,fmOpenWrite);
  71. If (Fd<>feInvalidHandle) then
  72. try
  73. Result:=FileSetDate(fd,Age);
  74. finally
  75. FileClose(fd);
  76. end
  77. else
  78. {$ifdef HAS_OSERROR}
  79. Result:=GetLastOSError;
  80. {$else}
  81. Result:=-1;
  82. {$endif}
  83. end;
  84. {$endif}
  85. { Read String Handling functions implementation }
  86. {$i sysstr.inc}
  87. { Read date & Time function implementations }
  88. {$ifndef FPUNONE}
  89. {$i dati.inc}
  90. {$endif}
  91. {$IFNDEF HAS_GETTICKCOUNT}
  92. function GetTickCount: LongWord;
  93. begin
  94. Result := LongWord(GetTickCount64);
  95. end;
  96. {$ENDIF}
  97. {$IFNDEF HAS_GETTICKCOUNT64}
  98. function GetTickCount64: QWord;
  99. begin
  100. {$IFDEF FPU_NONE}
  101. {$IFDEF HAS_SYSTIMERTICK}
  102. Result := SysTimerTick;
  103. {$ELSE}
  104. Result := 0;
  105. {$ENDIF}
  106. {$ELSE}
  107. Result := Trunc(Now * 24 * 60 * 60 * 1000);
  108. {$ENDIF}
  109. end;
  110. {$ENDIF}
  111. { Read pchar handling functions implementation }
  112. {$i syspch.inc}
  113. { generic internationalisation code }
  114. {$i sysint.inc}
  115. { wide string functions }
  116. {$i syswide.inc}
  117. {$ifdef FPC_HAS_UNICODESTRING}
  118. { unicode string functions }
  119. {$i sysuni.inc}
  120. {$i sysencoding.inc}
  121. {$endif FPC_HAS_UNICODESTRING}
  122. { threading stuff }
  123. {$i sysuthrd.inc}
  124. { OS utility code }
  125. {$i osutil.inc}
  126. procedure FreeAndNil(var obj);
  127. var
  128. temp: tobject;
  129. begin
  130. temp:=tobject(obj);
  131. pointer(obj):=nil;
  132. temp.free;
  133. end;
  134. { Interfaces support }
  135. {$i sysuintf.inc}
  136. constructor Exception.Create(const msg : string);
  137. begin
  138. inherited create;
  139. fmessage:=msg;
  140. end;
  141. constructor Exception.CreateFmt(const msg : string; const args : array of const);
  142. begin
  143. inherited create;
  144. fmessage:=Format(msg,args);
  145. end;
  146. constructor Exception.CreateRes(ResString: PString);
  147. begin
  148. inherited create;
  149. fmessage:=ResString^;
  150. end;
  151. constructor Exception.CreateResFmt(ResString: PString; const Args: array of const);
  152. begin
  153. inherited create;
  154. fmessage:=Format(ResString^,args);
  155. end;
  156. constructor Exception.CreateHelp(const Msg: string; AHelpContext: Integer);
  157. begin
  158. inherited create;
  159. fmessage:=Msg;
  160. fhelpcontext:=AHelpContext;
  161. end;
  162. constructor Exception.CreateFmtHelp(const Msg: string; const Args: array of const;
  163. AHelpContext: Integer);
  164. begin
  165. inherited create;
  166. fmessage:=Format(Msg,args);
  167. fhelpcontext:=AHelpContext;
  168. end;
  169. constructor Exception.CreateResHelp(ResString: PString; AHelpContext: Integer);
  170. begin
  171. inherited create;
  172. fmessage:=ResString^;
  173. fhelpcontext:=AHelpContext;
  174. end;
  175. constructor Exception.CreateResFmtHelp(ResString: PString; const Args: array of const;
  176. AHelpContext: Integer);
  177. begin
  178. inherited create;
  179. fmessage:=Format(ResString^,args);
  180. fhelpcontext:=AHelpContext;
  181. end;
  182. procedure EHeapMemoryError.FreeInstance;
  183. begin
  184. if AllowFree then
  185. inherited FreeInstance;
  186. end;
  187. Constructor EVariantError.CreateCode (Code : longint);
  188. begin
  189. case Code of
  190. VAR_OK:
  191. Create(SNoError);
  192. VAR_PARAMNOTFOUND:
  193. Create(SVarParamNotFound);
  194. VAR_TYPEMISMATCH:
  195. Create(SInvalidVarCast);
  196. VAR_BADVARTYPE:
  197. Create(SVarBadType);
  198. VAR_OVERFLOW:
  199. Create(SVarOverflow);
  200. VAR_BADINDEX:
  201. Create(SVarArrayBounds);
  202. VAR_ARRAYISLOCKED:
  203. Create(SVarArrayLocked);
  204. VAR_NOTIMPL:
  205. Create(SVarNotImplemented);
  206. VAR_OUTOFMEMORY:
  207. Create(SVarOutOfMemory);
  208. VAR_INVALIDARG:
  209. Create(SVarInvalid);
  210. VAR_UNEXPECTED,
  211. VAR_EXCEPTION:
  212. Create(SVarUnexpected);
  213. else
  214. CreateFmt(SUnknownErrorCode,[Code]);
  215. end;
  216. ErrCode:=Code;
  217. end;
  218. {$ifdef windows}
  219. function EExternal.GetExceptionRecord: PExceptionRecord;
  220. begin
  221. result:=@FExceptionRecord;
  222. end;
  223. {$endif windows}
  224. {$push}
  225. {$S-}
  226. Procedure CatchUnhandledException (Obj : TObject; Addr: Pointer; FrameCount: Longint; Frames: PPointer);[public,alias:'FPC_BREAK_UNHANDLED_EXCEPTION'];
  227. Var
  228. i : longint;
  229. hstdout : ^text;
  230. begin
  231. hstdout:=@stdout;
  232. Writeln(hstdout^,'An unhandled exception occurred at $',HexStr(Addr),':');
  233. if Obj is exception then
  234. Writeln(hstdout^,Obj.ClassName,': ',Exception(Obj).Message)
  235. else
  236. Writeln(hstdout^,'Exception object ',Obj.ClassName,' is not of class Exception.');
  237. Writeln(hstdout^,BackTraceStrFunc(Addr));
  238. if (FrameCount>0) then
  239. begin
  240. for i:=0 to FrameCount-1 do
  241. Writeln(hstdout^,BackTraceStrFunc(Frames[i]));
  242. end;
  243. Writeln(hstdout^,'');
  244. end;
  245. type
  246. PExceptMapEntry=^TExceptMapEntry;
  247. TExceptMapEntry=record
  248. code: byte;
  249. cls: ExceptClass;
  250. {$IFDEF FPC_HAS_FEATURE_RESOURCES} // This is necessary for 2.4.4, which does not have reasources as a separate feature
  251. msg: PResStringRec;
  252. {$else FPC_HAS_FEATURE_RESOURCES}
  253. msg: PString;
  254. {$endif FPC_HAS_FEATURE_RESOURCES}
  255. end;
  256. const
  257. exceptmap: array[0..28] of TExceptMapEntry = (
  258. (code: 200; cls: EDivByZero; msg: @SDivByZero),
  259. (code: 201; cls: ERangeError; msg: @SRangeError),
  260. (code: 202; cls: EStackOverflow; msg: @SStackOverflow),
  261. (code: 205; cls: EOverflow; msg: @SOverflow),
  262. (code: 206; cls: EUnderflow; msg: @SUnderflow),
  263. (code: 207; cls: EInvalidOp; msg: @SInvalidOp),
  264. { Delphi distinguishes reDivByZero from reZeroDivide, but maps both to code 200. }
  265. (code: 208; cls: EZeroDivide; msg: @SZeroDivide),
  266. (code: 210; cls: EObjectCheck; msg: @SObjectCheckError),
  267. (code: 211; cls: EAbstractError; msg: @SAbstractError),
  268. (code: 212; cls: EExternalException; msg: @SExternalException),
  269. (code: 214; cls: EBusError; msg: @SBusError),
  270. (code: 215; cls: EIntOverflow; msg: @SIntOverflow),
  271. (code: 216; cls: EAccessViolation; msg: @SAccessViolation),
  272. (code: 217; cls: EControlC; msg: @SControlC),
  273. (code: 218; cls: EPrivilege; msg: @SPrivilege),
  274. (code: 219; cls: EInvalidCast; msg: @SInvalidCast),
  275. (code: 220; cls: EVariantError; msg: @SInvalidVarCast),
  276. (code: 221; cls: EVariantError; msg: @SInvalidVarOp),
  277. (code: 222; cls: EVariantError; msg: @SDispatchError),
  278. (code: 223; cls: EVariantError; msg: @SVarArrayCreate),
  279. (code: 224; cls: EVariantError; msg: @SVarNotArray),
  280. (code: 225; cls: EVariantError; msg: @SVarArrayBounds),
  281. (code: 227; cls: EAssertionFailed; msg: @SAssertionFailed),
  282. (code: 228; cls: EIntfCastError; msg: @SIntfCastError),
  283. (code: 229; cls: ESafecallException; msg: @SSafecallException),
  284. (code: 231; cls: EConvertError; msg: @SiconvError),
  285. (code: 232; cls: ENoThreadSupport; msg: @SNoThreadSupport),
  286. (code: 233; cls: ENoWideStringSupport; msg: @SSigQuit),
  287. (code: 234; cls: ENoWideStringSupport; msg: @SMissingWStringManager)
  288. );
  289. function FindExceptMapEntry(err: longint): PExceptMapEntry;
  290. var
  291. i: longint;
  292. begin
  293. for i:=low(exceptmap) to high(exceptmap) do
  294. if err=exceptmap[i].code then
  295. begin
  296. result:=@exceptmap[i];
  297. exit;
  298. end;
  299. result:=nil;
  300. end;
  301. Var OutOfMemory : EOutOfMemory;
  302. InValidPointer : EInvalidPointer;
  303. Procedure RunErrorToExcept (ErrNo : Longint; Address,Frame : Pointer);
  304. var
  305. E: Exception;
  306. HS: PString;
  307. Entry: PExceptMapEntry;
  308. begin
  309. Case Errno of
  310. 1,203 : E:=OutOfMemory;
  311. 204 : E:=InvalidPointer;
  312. else
  313. Entry:=FindExceptMapEntry(ErrNo);
  314. if Assigned(Entry) then
  315. E:=Entry^.cls.CreateRes(Entry^.msg)
  316. else
  317. begin
  318. HS:=nil;
  319. Case Errno of
  320. 2 : HS:=@SFileNotFound;
  321. 3 : HS:=@SInvalidFileName;
  322. 4 : HS:=@STooManyOpenFiles;
  323. 5 : HS:=@SAccessDenied;
  324. 6 : HS:=@SInvalidFileHandle;
  325. 15 : HS:=@SInvalidDrive;
  326. 100 : HS:=@SEndOfFile;
  327. 101 : HS:=@SDiskFull;
  328. 102 : HS:=@SFileNotAssigned;
  329. 103 : HS:=@SFileNotOpen;
  330. 104 : HS:=@SFileNotOpenForInput;
  331. 105 : HS:=@SFileNotOpenForOutput;
  332. 106 : HS:=@SInvalidInput;
  333. end;
  334. if Assigned(HS) then
  335. E:=EInOutError.CreateRes(HS)
  336. else
  337. E:=EInOutError.CreateResFmt(@SUnknownRunTimeError,[errno]);
  338. // this routine can be called from FPC_IOCHECK,
  339. // which clears inoutres and then passes its
  340. // original value to HandleErrorFrame() (which calls
  341. // us). So use errno rather than IOResult, and clear
  342. // InOutRes explicitly in case we can also be called
  343. // from a place that does not clear InOutRes explicitly
  344. EInoutError(E).ErrorCode:=errno;
  345. inoutres:=0;
  346. end;
  347. end;
  348. Raise E at Address,Frame;
  349. end;
  350. {$IFDEF HAS_OSERROR}
  351. Procedure RaiseLastOSError;overload;
  352. begin
  353. RaiseLastOSError(GetLastOSError);
  354. end;
  355. Procedure RaiseLastOSError(LastError: Integer);overload;
  356. var
  357. E : EOSError;
  358. begin
  359. If (LastError<>0) then
  360. E:=EOSError.CreateFmt(SOSError, [LastError, SysErrorMessage(LastError)])
  361. else
  362. E:=EOSError.Create(SUnkOSError);
  363. E.ErrorCode:=LastError;
  364. Raise E;
  365. end;
  366. {$else}
  367. Procedure RaiseLastOSError;overload;
  368. begin
  369. Raise Exception.Create('RaiseLastOSError not implemented on this platform.');
  370. end;
  371. Procedure RaiseLastOSError(LastError: Integer);overload;
  372. begin
  373. RaiseLastOSError;
  374. end;
  375. {$endif}
  376. Procedure AssertErrorHandler (Const Msg,FN : ShortString;LineNo:longint; TheAddr : pointer);
  377. Var
  378. S : String;
  379. begin
  380. If Msg='' then
  381. S:=SAssertionFailed
  382. else
  383. S:=Msg;
  384. Raise EAssertionFailed.Createfmt(SAssertError,[S,Fn,LineNo]) at get_caller_addr(theAddr), get_caller_frame(theAddr);
  385. end;
  386. {$pop} //{$S-} for Error handling functions
  387. Procedure InitExceptions;
  388. {
  389. Must install uncaught exception handler (ExceptProc)
  390. and install exceptions for system exceptions or signals.
  391. (e.g: SIGSEGV -> ESegFault or so.)
  392. }
  393. begin
  394. ExceptionClass := Exception;
  395. ExceptProc:=@CatchUnhandledException;
  396. // Create objects that may have problems when there is no memory.
  397. OutOfMemory:=EOutOfMemory.Create(SOutOfMemory);
  398. OutOfMemory.AllowFree:=false;
  399. InvalidPointer:=EInvalidPointer.Create(SInvalidPointer);
  400. InvalidPointer.AllowFree:=false;
  401. AssertErrorProc:=@AssertErrorHandler;
  402. ErrorProc:=@RunErrorToExcept;
  403. OnShowException:=Nil;
  404. end;
  405. Procedure DoneExceptions;
  406. begin
  407. OutOfMemory.AllowFree:=true;
  408. OutOfMemory.Free;
  409. InValidPointer.AllowFree:=true;
  410. InValidPointer.Free;
  411. end;
  412. { Exception handling routines }
  413. function ExceptObject: TObject;
  414. begin
  415. If RaiseList=Nil then
  416. Result:=Nil
  417. else
  418. Result:=RaiseList^.FObject;
  419. end;
  420. function ExceptAddr: Pointer;
  421. begin
  422. If RaiseList=Nil then
  423. Result:=Nil
  424. else
  425. Result:=RaiseList^.Addr;
  426. end;
  427. function ExceptFrameCount: Longint;
  428. begin
  429. If RaiseList=Nil then
  430. Result:=0
  431. else
  432. Result:=RaiseList^.Framecount;
  433. end;
  434. function ExceptFrames: PPointer;
  435. begin
  436. If RaiseList=Nil then
  437. Result:=Nil
  438. else
  439. Result:=RaiseList^.Frames;
  440. end;
  441. function ExceptionErrorMessage(ExceptObject: TObject; ExceptAddr: Pointer;
  442. Buffer: PChar; Size: Integer): Integer;
  443. Var
  444. S : AnsiString;
  445. Len : Integer;
  446. begin
  447. S:=Format(SExceptionErrorMessage,[ExceptAddr,ExceptObject.ClassName]);
  448. If ExceptObject is Exception then
  449. S:=Format('%s:'#10'%s',[S,Exception(ExceptObject).Message]);
  450. Len:=Length(S);
  451. If S[Len]<>'.' then
  452. begin
  453. S:=S+'.';
  454. Inc(len);
  455. end;
  456. If Len>Size then
  457. Len:=Size;
  458. if Len > 0 then
  459. Move(S[1],Buffer^,Len);
  460. Result:=Len;
  461. end;
  462. procedure ShowException(ExceptObject: TObject; ExceptAddr: Pointer);
  463. // use shortstring. On exception, the heap may be corrupt.
  464. Var
  465. Buf : ShortString;
  466. begin
  467. SetLength(Buf,ExceptionErrorMessage(ExceptObject,ExceptAddr,@Buf[1],255));
  468. If IsConsole Then
  469. writeln(Buf)
  470. else
  471. If Assigned(OnShowException) Then
  472. OnShowException (Buf);
  473. end;
  474. procedure Abort;
  475. begin
  476. Raise EAbort.Create(SAbortError) at Pointer(Get_Caller_addr(Get_Frame));
  477. end;
  478. procedure OutOfMemoryError;
  479. begin
  480. Raise OutOfMemory;
  481. end;
  482. { ---------------------------------------------------------------------
  483. Initialization/Finalization/exit code
  484. ---------------------------------------------------------------------}
  485. Type
  486. PPRecord = ^TPRecord;
  487. TPRecord = Record
  488. Func : TTerminateProc;
  489. NextFunc : PPRecord;
  490. end;
  491. Const
  492. TPList : PPRecord = Nil;
  493. procedure AddTerminateProc(TermProc: TTerminateProc);
  494. Var
  495. TPR : PPRecord;
  496. begin
  497. New(TPR);
  498. With TPR^ do
  499. begin
  500. NextFunc:=TPList;
  501. Func:=TermProc;
  502. end;
  503. TPList:=TPR;
  504. end;
  505. function CallTerminateProcs: Boolean;
  506. Var
  507. TPR : PPRecord;
  508. begin
  509. Result:=True;
  510. TPR:=TPList;
  511. While Result and (TPR<>Nil) do
  512. begin
  513. Result:=TPR^.Func();
  514. TPR:=TPR^.NextFunc;
  515. end;
  516. end;
  517. { ---------------------------------------------------------------------
  518. Diskh functions, OS independent.
  519. ---------------------------------------------------------------------}
  520. Function GetCurrentDir: {$ifdef FPC_UNICODE_RTL}UnicodeString{$else}AnsiString{$endif};
  521. begin
  522. GetDir(0,Result);
  523. end;
  524. { ---------------------------------------------------------------------
  525. Other functions, OS independent.
  526. ---------------------------------------------------------------------}
  527. Var
  528. GUIDCalledRandomize : Boolean = False;
  529. Procedure GetRandomBytes(Var Buf; NBytes : Integer);
  530. Var
  531. I : Integer;
  532. P : PByte;
  533. begin
  534. P:=@Buf;
  535. If Not GUIDCalledRandomize then
  536. begin
  537. Randomize;
  538. GUIDCalledRandomize:=True;
  539. end;
  540. For I:=0 to NBytes-1 do
  541. P[i]:=Random(256);
  542. end;
  543. {$IFDEF HASCREATEGUID}
  544. Function SysCreateGUID(out GUID : TGUID) : Integer; forward;
  545. {$ENDIF}
  546. Function CreateGUID(out GUID : TGUID) : Integer;
  547. begin
  548. If Assigned(OnCreateGUID) then
  549. Result:=OnCreateGUID(GUID)
  550. else
  551. begin
  552. {$IFDEF HASCREATEGUID}
  553. Result:=SysCreateGUID(GUID);
  554. {$ELSE}
  555. GetRandomBytes(GUID,SizeOf(Guid));
  556. guid.clock_seq_hi_and_reserved:=(guid.clock_seq_hi_and_reserved and $3F) + 64;
  557. guid.time_hi_and_version :=(guid.time_hi_and_version and $0FFF)+ $4000;
  558. Result:=0;
  559. {$ENDIF}
  560. end;
  561. end;
  562. function SafeLoadLibrary(const FileName: AnsiString;
  563. ErrorMode: DWord = {$ifdef windows}SEM_NOOPENFILEERRORBOX{$else windows}0{$endif windows}): HMODULE;
  564. {$if defined(cpui386) or defined(cpux86_64)}
  565. var
  566. mode : DWord;
  567. fpucw : Word;
  568. ssecw : DWord;
  569. {$endif}
  570. begin
  571. {$if defined(win64) or defined(win32)}
  572. mode:=SetErrorMode(ErrorMode);
  573. {$endif}
  574. try
  575. {$if defined(cpui386) or defined(cpux86_64)}
  576. fpucw:=Get8087CW;
  577. {$ifdef cpui386}
  578. if has_sse_support then
  579. {$endif cpui386}
  580. ssecw:=GetSSECSR;
  581. {$endif}
  582. {$if defined(windows) or defined(win32)}
  583. Result:=LoadLibraryA(PChar(Filename));
  584. {$else}
  585. Result:=0;
  586. {$endif}
  587. finally
  588. {$if defined(cpui386) or defined(cpux86_64)}
  589. Set8087CW(fpucw);
  590. {$ifdef cpui386}
  591. if has_sse_support then
  592. {$endif cpui386}
  593. SetSSECSR(ssecw);
  594. {$endif}
  595. {$if defined(win64) or defined(win32)}
  596. SetErrorMode(mode);
  597. {$endif}
  598. end;
  599. end;
  600. function GetModuleName(Module: HMODULE): string;
  601. begin
  602. {$ifdef MSWINDOWS}
  603. SetLength(Result,MAX_PATH);
  604. SetLength(Result,GetModuleFileName(Module, Pchar(Result),Length(Result)));
  605. {$ELSE}
  606. Result:='';
  607. {$ENDIF}
  608. end;
  609. { Beep support }
  610. procedure Beep;
  611. begin
  612. If Assigned(OnBeep) then
  613. OnBeep;
  614. end;