except.inc 9.8 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 1999-2000 by Michael Van Canneyt
  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. {****************************************************************************
  12. Exception support
  13. ****************************************************************************}
  14. Const
  15. { Type of exception. Currently only one. }
  16. FPC_EXCEPTION = 1;
  17. { types of frames for the exception address stack }
  18. cExceptionFrame = 1;
  19. cFinalizeFrame = 2;
  20. Type
  21. PExceptAddr = ^TExceptAddr;
  22. TExceptAddr = record
  23. buf : pjmp_buf;
  24. next : PExceptAddr;
  25. frametype : Longint;
  26. end;
  27. Const
  28. CatchAllExceptions = PtrInt(-1);
  29. ThreadVar
  30. ExceptAddrStack : PExceptAddr;
  31. ExceptObjectStack : PExceptObject;
  32. Function RaiseList : PExceptObject;
  33. begin
  34. RaiseList:=ExceptObjectStack;
  35. end;
  36. function AcquireExceptionObject: Pointer;
  37. var
  38. _ExceptObjectStack : PExceptObject;
  39. begin
  40. _ExceptObjectStack:=ExceptObjectStack;
  41. If _ExceptObjectStack<>nil then
  42. begin
  43. Inc(_ExceptObjectStack^.refcount);
  44. AcquireExceptionObject := _ExceptObjectStack^.FObject;
  45. end
  46. else
  47. RunError(231);
  48. end;
  49. procedure ReleaseExceptionObject;
  50. var
  51. _ExceptObjectStack : PExceptObject;
  52. begin
  53. _ExceptObjectStack:=ExceptObjectStack;
  54. If _ExceptObjectStack <> nil then
  55. begin
  56. if _ExceptObjectStack^.refcount > 0 then
  57. Dec(_ExceptObjectStack^.refcount);
  58. end
  59. else
  60. RunError(231);
  61. end;
  62. Function fpc_PushExceptAddr (Ft: Longint;_buf,_newaddr : pointer): PJmp_buf ;
  63. [Public, Alias : 'FPC_PUSHEXCEPTADDR'];compilerproc;
  64. var
  65. _ExceptAddrstack : ^PExceptAddr;
  66. begin
  67. {$ifdef excdebug}
  68. writeln ('In PushExceptAddr');
  69. {$endif}
  70. _ExceptAddrstack:=@ExceptAddrstack;
  71. PExceptAddr(_newaddr)^.Next:=_ExceptAddrstack^;
  72. _ExceptAddrStack^:=PExceptAddr(_newaddr);
  73. PExceptAddr(_newaddr)^.Buf:=PJmp_Buf(_buf);
  74. PExceptAddr(_newaddr)^.FrameType:=ft;
  75. result:=PJmp_Buf(_buf);
  76. end;
  77. Procedure PushExceptObject(Obj : TObject; AnAddr,AFrame : Pointer);
  78. var
  79. Newobj : PExceptObject;
  80. _ExceptObjectStack : ^PExceptObject;
  81. framebufsize,
  82. framecount : longint;
  83. frames : PPointer;
  84. prev_frame,
  85. curr_frame,
  86. curr_addr,
  87. caller_frame,
  88. caller_addr : Pointer;
  89. begin
  90. {$ifdef excdebug}
  91. writeln ('In PushExceptObject');
  92. {$endif}
  93. _ExceptObjectStack:=@ExceptObjectStack;
  94. New(NewObj);
  95. NewObj^.Next:=_ExceptObjectStack^;
  96. _ExceptObjectStack^:=NewObj;
  97. NewObj^.FObject:=Obj;
  98. NewObj^.Addr:=AnAddr;
  99. NewObj^.refcount:=0;
  100. { Backtrace }
  101. curr_frame:=AFrame;
  102. curr_addr:=AnAddr;
  103. prev_frame:=get_caller_frame(curr_addr, curr_frame);
  104. frames:=nil;
  105. framebufsize:=0;
  106. framecount:=0;
  107. while (framecount<RaiseMaxFrameCount) and (curr_frame > prev_frame) and
  108. (curr_frame<(StackBottom + StackLength)) do
  109. Begin
  110. caller_addr := get_caller_addr(curr_frame, curr_addr);
  111. caller_frame := get_caller_frame(curr_frame, curr_addr);
  112. if (caller_addr=nil) or
  113. (caller_frame=nil) then
  114. break;
  115. if (framecount>=framebufsize) then
  116. begin
  117. inc(framebufsize,16);
  118. reallocmem(frames,framebufsize*sizeof(pointer));
  119. end;
  120. frames[framecount]:=caller_addr;
  121. inc(framecount);
  122. prev_frame:=curr_frame;
  123. curr_addr:=caller_addr;
  124. curr_frame:=caller_frame;
  125. End;
  126. NewObj^.framecount:=framecount;
  127. NewObj^.frames:=frames;
  128. end;
  129. Procedure DoUnHandledException;
  130. var
  131. _ExceptObjectStack : PExceptObject;
  132. begin
  133. _ExceptObjectStack:=ExceptObjectStack;
  134. If (ExceptProc<>Nil) and (_ExceptObjectStack<>Nil) then
  135. with _ExceptObjectStack^ do
  136. begin
  137. TExceptProc(ExceptProc)(FObject,Addr,FrameCount,Frames);
  138. halt(217)
  139. end;
  140. if erroraddr = nil then
  141. RunError(217)
  142. else
  143. Halt(errorcode);
  144. end;
  145. {$ifndef FPC_SYSTEM_HAS_RAISEEXCEPTION}
  146. Function fpc_RaiseException (Obj : TObject; AnAddr,AFrame : Pointer) : TObject;[Public, Alias : 'FPC_RAISEEXCEPTION']; compilerproc;
  147. var
  148. _ExceptObjectStack : PExceptObject;
  149. _ExceptAddrstack : PExceptAddr;
  150. begin
  151. {$ifdef excdebug}
  152. writeln ('In RaiseException');
  153. {$endif}
  154. fpc_Raiseexception:=nil;
  155. PushExceptObject(Obj,AnAddr,AFrame);
  156. _ExceptAddrstack:=ExceptAddrStack;
  157. If _ExceptAddrStack=Nil then
  158. DoUnhandledException;
  159. _ExceptObjectStack:=ExceptObjectStack;
  160. if (RaiseProc <> nil) and (_ExceptObjectStack <> nil) then
  161. with _ExceptObjectStack^ do
  162. RaiseProc(FObject,Addr,FrameCount,Frames);
  163. longjmp(_ExceptAddrStack^.Buf^,FPC_Exception);
  164. end;
  165. {$endif FPC_SYSTEM_HAS_RAISEEXCEPTION}
  166. Procedure fpc_PopAddrStack;[Public, Alias : 'FPC_POPADDRSTACK']; compilerproc;
  167. var
  168. hp : ^PExceptAddr;
  169. begin
  170. {$ifdef excdebug}
  171. writeln ('In Popaddrstack');
  172. {$endif}
  173. hp:=@ExceptAddrStack;
  174. If hp^=nil then
  175. begin
  176. {$ifdef excdebug}
  177. writeln ('At end of ExceptionAddresStack');
  178. {$endif}
  179. halt (255);
  180. end
  181. else
  182. begin
  183. hp^:=hp^^.Next;
  184. end;
  185. end;
  186. function fpc_PopObjectStack : TObject;[Public, Alias : 'FPC_POPOBJECTSTACK']; compilerproc;
  187. var
  188. hp,_ExceptObjectStack : PExceptObject;
  189. begin
  190. {$ifdef excdebug}
  191. writeln ('In PopObjectstack');
  192. {$endif}
  193. _ExceptObjectStack:=ExceptObjectStack;
  194. If _ExceptObjectStack=nil then
  195. begin
  196. {$ifdef excdebug}
  197. writeln ('At end of ExceptionObjectStack');
  198. {$endif}
  199. halt (1);
  200. end
  201. else
  202. begin
  203. { we need to return the exception object to dispose it }
  204. if _ExceptObjectStack^.refcount = 0 then begin
  205. fpc_PopObjectStack:=_ExceptObjectStack^.FObject;
  206. end else begin
  207. fpc_PopObjectStack:=nil;
  208. end;
  209. hp:=_ExceptObjectStack;
  210. ExceptObjectStack:=_ExceptObjectStack^.next;
  211. if assigned(hp^.frames) then
  212. freemem(hp^.frames);
  213. dispose(hp);
  214. erroraddr:=nil;
  215. end;
  216. end;
  217. { this is for popping exception objects when a second exception is risen }
  218. { in an except/on }
  219. function fpc_PopSecondObjectStack : TObject;[Public, Alias : 'FPC_POPSECONDOBJECTSTACK']; compilerproc;
  220. var
  221. hp,_ExceptObjectStack : PExceptObject;
  222. begin
  223. {$ifdef excdebug}
  224. writeln ('In PopObjectstack');
  225. {$endif}
  226. _ExceptObjectStack:=ExceptObjectStack;
  227. If not(assigned(_ExceptObjectStack)) or
  228. not(assigned(_ExceptObjectStack^.next)) then
  229. begin
  230. {$ifdef excdebug}
  231. writeln ('At end of ExceptionObjectStack');
  232. {$endif}
  233. halt (1);
  234. end
  235. else
  236. begin
  237. if _ExceptObjectStack^.next^.refcount=0 then
  238. { we need to return the exception object to dispose it if refcount=0 }
  239. fpc_PopSecondObjectStack:=_ExceptObjectStack^.next^.FObject
  240. else
  241. fpc_PopSecondObjectStack:=nil;
  242. hp:=_ExceptObjectStack^.next;
  243. _ExceptObjectStack^.next:=hp^.next;
  244. if assigned(hp^.frames) then
  245. freemem(hp^.frames);
  246. dispose(hp);
  247. end;
  248. end;
  249. {$ifndef FPC_SYSTEM_HAS_RERAISE}
  250. Procedure fpc_ReRaise;[Public, Alias : 'FPC_RERAISE']; compilerproc;
  251. var
  252. _ExceptAddrStack : PExceptAddr;
  253. begin
  254. {$ifdef excdebug}
  255. writeln ('In reraise');
  256. {$endif}
  257. _ExceptAddrStack:=ExceptAddrStack;
  258. If _ExceptAddrStack=Nil then
  259. DoUnHandledException;
  260. ExceptObjectStack^.refcount := 0;
  261. longjmp(_ExceptAddrStack^.Buf^,FPC_Exception);
  262. end;
  263. {$endif FPC_SYSTEM_HAS_RERAISE}
  264. function Internal_PopSecondObjectStack : TObject; external name 'FPC_POPSECONDOBJECTSTACK';
  265. function Internal_PopObjectStack: TObject; external name 'FPC_POPOBJECTSTACK';
  266. procedure Internal_Reraise; external name 'FPC_RERAISE';
  267. Function fpc_Catches(Objtype : TClass) : TObject;[Public, Alias : 'FPC_CATCHES']; compilerproc;
  268. var
  269. _ExceptObjectStack : PExceptObject;
  270. begin
  271. _ExceptObjectStack:=ExceptObjectStack;
  272. If _ExceptObjectStack=Nil then
  273. begin
  274. {$ifdef excdebug}
  275. Writeln ('Internal error.');
  276. {$endif}
  277. halt (255);
  278. end;
  279. if Not ((Objtype = TClass(CatchAllExceptions)) or
  280. (_ExceptObjectStack^.FObject is ObjType)) then
  281. fpc_Catches:=Nil
  282. else
  283. begin
  284. // catch !
  285. fpc_Catches:=_ExceptObjectStack^.FObject;
  286. { this can't be done, because there could be a reraise (PFV)
  287. PopObjectStack;
  288. Also the PopAddrStack shouldn't be done, we do it now
  289. immediatly in the exception handler (FK)
  290. PopAddrStack; }
  291. end;
  292. end;
  293. Procedure fpc_DestroyException(o : TObject);[Public, Alias : 'FPC_DESTROYEXCEPTION']; compilerproc;
  294. begin
  295. { with free we're on the really safe side }
  296. o.Free;
  297. end;
  298. { TODO: no longer used, clean up }
  299. function fpc_GetExceptionAddr : Pointer;[Public, Alias : 'FPC_GETEXCEPTIONADDR']; compilerproc;
  300. var
  301. _ExceptObjectStack : PExceptObject;
  302. begin
  303. _ExceptObjectStack:=ExceptObjectStack;
  304. if _ExceptObjectStack=nil then
  305. fpc_GetExceptionAddr:=nil
  306. else
  307. fpc_GetExceptionAddr:=_ExceptObjectStack^.Addr;
  308. end;
  309. Procedure SysInitExceptions;
  310. {
  311. Initialize exceptionsupport
  312. }
  313. begin
  314. ExceptObjectstack:=Nil;
  315. ExceptAddrStack:=Nil;
  316. end;
  317. procedure fpc_doneexception;[public,alias:'FPC_DONEEXCEPTION'] compilerproc;
  318. begin
  319. Internal_PopObjectStack.Free;
  320. end;
  321. procedure fpc_raise_nested;[public,alias:'FPC_RAISE_NESTED']compilerproc;
  322. begin
  323. Internal_PopSecondObjectStack.Free;
  324. Internal_Reraise;
  325. end;
  326. function fpc_safecallhandler(obj: TObject): HResult; [public,alias:'FPC_SAFECALLHANDLER']; compilerproc;
  327. var
  328. raiselist: PExceptObject;
  329. adr: Pointer;
  330. exc: TObject;
  331. begin
  332. raiselist:=ExceptObjectStack;
  333. if Assigned(raiseList) then
  334. adr:=raiseList^.Addr
  335. else
  336. adr:=nil;
  337. exc:=Internal_PopObjectStack;
  338. if Assigned(obj) and Assigned(exc) then
  339. result:=obj.SafeCallException(exc,adr)
  340. else
  341. result:=E_UNEXPECTED;
  342. exc.Free;
  343. end;