sysutils.pp 8.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1998 by Florian Klaempfl
  5. member of the Free Pascal development team
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. unit sysutils;
  13. interface
  14. {$MODE objfpc}
  15. uses
  16. {$ifdef linux}
  17. linux
  18. {$else}
  19. {$ifdef win32}
  20. dos,windows
  21. {$else}
  22. {$ifdef go32v2}
  23. go32
  24. {$endif go32v2}
  25. {$endif win32}
  26. {$endif linux}
  27. ;
  28. type
  29. { some helpful data types }
  30. tprocedure = procedure;
  31. tfilename = string;
  32. longrec = packed record
  33. lo,hi : word;
  34. end;
  35. wordrec = packed record
  36. lo,hi : byte;
  37. end;
  38. { exceptions }
  39. exception = class(TObject)
  40. private
  41. fmessage : string;
  42. fhelpcontext : longint;
  43. public
  44. constructor create(const msg : string);
  45. constructor createfmt(const msg : string; const args : array of const);
  46. constructor createres(ident : longint);
  47. { !!!! }
  48. property helpcontext : longint read fhelpcontext write fhelpcontext;
  49. property message : string read fmessage write fmessage;
  50. end;
  51. exceptclass = class of exception;
  52. { integer math exceptions }
  53. EInterror = Class(Exception);
  54. EDivByZero = Class(EIntError);
  55. ERangeError = Class(EIntError);
  56. EIntOverflow = Class(EIntError);
  57. { General math errors }
  58. EMathError = Class(Exception);
  59. EInvalidOp = Class(EMathError);
  60. EZeroDivide = Class(EMathError);
  61. EOverflow = Class(EMathError);
  62. EUnderflow = Class(EMathError);
  63. { Run-time and I/O Errors }
  64. EInOutError = class(Exception)
  65. public
  66. ErrorCode : Longint;
  67. end;
  68. EInvalidPointer = Class(Exception);
  69. EOutOfMemory = Class(Exception);
  70. EAccessViolation = Class(Exception);
  71. EInvalidCast = Class(Exception);
  72. { String conversion errors }
  73. EConvertError = class(Exception);
  74. { Other errors }
  75. EAbort = Class(Exception);
  76. EAbstractError = Class(Exception);
  77. EAssertionFailed = Class(Exception);
  78. { Read date & Time function declarations }
  79. {$i datih.inc}
  80. { Read String Handling functions declaration }
  81. {$i sysstrh.inc}
  82. { Read pchar handling functions declration }
  83. {$i syspchh.inc}
  84. { Read filename handling functions declaration }
  85. {$i finah.inc}
  86. { Read other file handling function declarations }
  87. {$i filutilh.inc}
  88. { Read disk function declarations }
  89. {$i diskh.inc}
  90. implementation
  91. { Read message string definitions }
  92. {
  93. Add a language with IFDEF LANG_NAME
  94. just befor the final ELSE. This way English will always be the default.
  95. }
  96. {$IFDEF LANG_GERMAN}
  97. {$i strg.inc} // Does not exist yet !!
  98. {$ELSE}
  99. {$i stre.inc}
  100. {$ENDIF}
  101. { Read filename handling functions implementation }
  102. {$i fina.inc}
  103. { Read other file handling function implementations }
  104. {$i filutil.inc}
  105. { Read disk function implementations }
  106. {$i disk.inc}
  107. { Read date & Time function implementations }
  108. {$i dati.inc}
  109. { Read String Handling functions implementation }
  110. {$i sysstr.inc}
  111. { Read pchar handling functions implementation }
  112. {$i syspch.inc}
  113. constructor exception.create(const msg : string);
  114. begin
  115. inherited create;
  116. fmessage:=msg;
  117. end;
  118. constructor exception.createfmt(const msg : string; const args : array of const);
  119. begin
  120. inherited create;
  121. fmessage:=Format(msg,args);
  122. end;
  123. constructor exception.createres(ident : longint);
  124. begin
  125. inherited create;
  126. {!!!!!}
  127. end;
  128. Procedure CatchUnhandledException (Obj : TObject; Addr: Pointer);
  129. Var
  130. Message : String;
  131. begin
  132. {$ifndef USE_WINDOWS}
  133. Writeln ('An unhandled exception occurred at ',HexStr(Longint(Addr),8),' : ');
  134. if Obj is exception then
  135. begin
  136. Message:=Exception(Obj).Message;
  137. Writeln (Message);
  138. end
  139. else
  140. Writeln ('Exception object ',Obj.ClassName,' is not of class Exception.');
  141. Halt(217);
  142. {$else}
  143. {$endif}
  144. end;
  145. Var OutOfMemory : EOutOfMemory;
  146. InValidPointer : EInvalidPointer;
  147. Procedure RunErrorToExcept (ErrNo : Longint; Address : Pointer);
  148. Var E : Exception;
  149. S : String;
  150. begin
  151. Case Errno of
  152. 1,203 : E:=OutOfMemory;
  153. //!! ?? 2 is a 'file not found error' ??
  154. 2,204 : E:=InvalidPointer;
  155. 3,4,5,6,100,101,102,103,105,106 : { I/O errors }
  156. begin
  157. Case Errno of
  158. 3 : S:=SInvalidFileName;
  159. 4 : S:=STooManyOpenFiles;
  160. 5 : S:=SAccessDenied;
  161. 6 : S:=SInvalidFileHandle;
  162. 15 : S:=SInvalidDrive;
  163. 100 : S:=SEndOfFile;
  164. 101 : S:=SDiskFull;
  165. 102 : S:=SFileNotAssigned;
  166. 103 : S:=SFileNotOpen;
  167. 104 : S:=SFileNotOpenForInput;
  168. 105 : S:=SFileNotOpenForOutput;
  169. 106 : S:=SInvalidInput;
  170. end;
  171. E:=EinOutError.Create (S);
  172. EInoutError(E).ErrorCode:=IOresult; // Clears InOutRes !!
  173. end;
  174. // We don't set abstracterrorhandler, but we do it here.
  175. // Unless the use sets another handler we'll get here anyway...
  176. 200 : E:=EDivByZero.Create(SDivByZero);
  177. 201 : E:=ERangeError.Create(SRangeError);
  178. 211 : E:=EAbstractError.Create(SAbstractError);
  179. 216 : E:=EAccessViolation.Create(SAccessViolation);
  180. 219 : E:=EInvalidCast.Create(SInvalidCast);
  181. 227 : E:=EAssertionFailed.Create(SAssertionFailed);
  182. else
  183. E:=Exception.CreateFmt (SUnKnownRunTimeError,[Errno]);
  184. end;
  185. Raise E {at Address};
  186. end;
  187. Procedure AssertErrorHandler (Const Msg,FN : String;LineNo,TheAddr : Longint);
  188. Var
  189. S : String;
  190. begin
  191. If Msg='' then
  192. S:=SAssertionFailed
  193. else
  194. S:=Msg;
  195. Raise EAssertionFailed.Createfmt(SAssertError,[S,Fn,LineNo]); // at Pointer(theAddr);
  196. end;
  197. Procedure InitExceptions;
  198. {
  199. Must install uncaught exception handler (ExceptProc)
  200. and install exceptions for system exceptions or signals.
  201. (e.g: SIGSEGV -> ESegFault or so.)
  202. }
  203. begin
  204. ExceptProc:=@CatchUnhandledException;
  205. // Create objects that may have problems when there is no memory.
  206. OutOfMemory:=EOutOfMemory.Create(SOutOfMemory);
  207. InvalidPointer:=EInvalidPointer.Create(SInvalidPointer);
  208. AssertErrorProc:=@AssertErrorHandler;
  209. ErrorProc:=@RunErrorToExcept;
  210. end;
  211. {Initialization code.}
  212. begin
  213. InitExceptions;
  214. end.
  215. {
  216. $Log$
  217. Revision 1.20 1999-02-09 12:38:44 michael
  218. * Fixed INt() proble. Defined THandle, included Filemode constants
  219. Revision 1.19 1999/02/03 16:18:58 michael
  220. + Uses Windows on win32 platform
  221. Revision 1.18 1998/12/15 22:43:12 peter
  222. * removed temp symbols
  223. Revision 1.17 1998/10/20 19:26:37 michael
  224. + Forgot to include disk functions
  225. Revision 1.16 1998/10/11 12:23:41 michael
  226. + More sysutils calls.
  227. Revision 1.15 1998/10/10 09:53:10 michael
  228. Added assertion handling
  229. Revision 1.14 1998/10/03 15:08:05 florian
  230. * EInvalidCast added (from runerror 219)
  231. Revision 1.13 1998/10/02 13:00:11 michael
  232. + More RTL error handling
  233. Revision 1.12 1998/10/02 12:17:18 michael
  234. + Made sure it compiles with official 0.99.8
  235. Revision 1.11 1998/10/01 16:04:11 michael
  236. + Added RTL error handling
  237. Revision 1.10 1998/09/24 23:45:27 peter
  238. * updated for auto objpas loading
  239. Revision 1.9 1998/09/24 16:13:49 michael
  240. Changes in exception and open array handling
  241. Revision 1.8 1998/09/18 23:57:26 michael
  242. * Changed use_excepions to useexceptions
  243. Revision 1.7 1998/09/16 14:34:38 pierre
  244. * go32v2 did not compile
  245. * wrong code in systr.inc corrected
  246. Revision 1.6 1998/09/16 08:28:44 michael
  247. Update from gertjan Schouten, plus small fix for linux
  248. Revision 1.5 1998/09/04 08:49:07 peter
  249. * 0.99.5 doesn't compile a whole objpas anymore to overcome crashes
  250. Revision 1.4 1998/08/10 15:52:27 peter
  251. * fixed so 0.99.5 compiles it, but no exception class
  252. Revision 1.3 1998/07/29 15:44:32 michael
  253. included sysutils and math.pp as target. They compile now.
  254. }