mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-16 05:19:29 +02:00
430 lines
11 KiB
PHP
430 lines
11 KiB
PHP
{
|
|
This file is part of the Free Pascal run time library.
|
|
Copyright (c) 1999-2000 by Michael Van Canneyt
|
|
member of the Free Pascal development team
|
|
|
|
See the file COPYING.FPC, included in this distribution,
|
|
for details about the copyright.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
|
|
**********************************************************************}
|
|
|
|
{****************************************************************************
|
|
Exception support
|
|
****************************************************************************}
|
|
|
|
|
|
Const
|
|
{ Type of exception. Currently only one. }
|
|
FPC_EXCEPTION = 1;
|
|
|
|
{ types of frames for the exception address stack }
|
|
cExceptionFrame = 1;
|
|
cFinalizeFrame = 2;
|
|
|
|
Type
|
|
PExceptAddr = ^TExceptAddr;
|
|
TExceptAddr = record
|
|
buf : pjmp_buf;
|
|
next : PExceptAddr;
|
|
{$ifdef CPU16}
|
|
frametype : Smallint;
|
|
{$else CPU16}
|
|
frametype : Longint;
|
|
{$endif CPU16}
|
|
end;
|
|
|
|
Const
|
|
CatchAllExceptions = PtrInt(-1);
|
|
|
|
{$ifdef FPC_HAS_FEATURE_THREADING}
|
|
ThreadVar
|
|
{$else FPC_HAS_FEATURE_THREADING}
|
|
Var
|
|
{$endif FPC_HAS_FEATURE_THREADING}
|
|
ExceptAddrStack : PExceptAddr;
|
|
ExceptObjectStack : PExceptObject;
|
|
ExceptTryLevel : longint;
|
|
|
|
Function RaiseList : PExceptObject;
|
|
begin
|
|
RaiseList:=ExceptObjectStack;
|
|
end;
|
|
|
|
|
|
function AcquireExceptionObject: Pointer;
|
|
var
|
|
_ExceptObjectStack : PExceptObject;
|
|
begin
|
|
_ExceptObjectStack:=ExceptObjectStack;
|
|
If _ExceptObjectStack<>nil then
|
|
begin
|
|
Inc(_ExceptObjectStack^.refcount);
|
|
AcquireExceptionObject := _ExceptObjectStack^.FObject;
|
|
end
|
|
else
|
|
RunError(231);
|
|
end;
|
|
|
|
|
|
procedure ReleaseExceptionObject;
|
|
var
|
|
_ExceptObjectStack : PExceptObject;
|
|
begin
|
|
_ExceptObjectStack:=ExceptObjectStack;
|
|
If _ExceptObjectStack <> nil then
|
|
begin
|
|
if _ExceptObjectStack^.refcount > 0 then
|
|
Dec(_ExceptObjectStack^.refcount);
|
|
end
|
|
else
|
|
RunError(231);
|
|
end;
|
|
|
|
|
|
Function fpc_PushExceptAddr (Ft: {$ifdef CPU16}SmallInt{$else}Longint{$endif};_buf,_newaddr : pointer): PJmp_buf ;
|
|
[Public, Alias : 'FPC_PUSHEXCEPTADDR'];compilerproc;
|
|
var
|
|
_ExceptAddrstack : ^PExceptAddr;
|
|
begin
|
|
{$ifdef excdebug}
|
|
writeln ('In PushExceptAddr');
|
|
{$endif}
|
|
_ExceptAddrstack:=@ExceptAddrstack;
|
|
PExceptAddr(_newaddr)^.Next:=_ExceptAddrstack^;
|
|
_ExceptAddrStack^:=PExceptAddr(_newaddr);
|
|
PExceptAddr(_newaddr)^.Buf:=PJmp_Buf(_buf);
|
|
PExceptAddr(_newaddr)^.FrameType:=ft;
|
|
result:=PJmp_Buf(_buf);
|
|
end;
|
|
|
|
|
|
{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
|
|
{ get_caller_XX funxctions can generate exceptions on their own
|
|
for instance ifd the stack got corrupted
|
|
Here we protect calls to those function by a
|
|
try/except bloc, with a global indicator TryExceptLevel
|
|
to avoid calling get_caller_XXX functions again if
|
|
any exception appears while calling them }
|
|
{$define FPC_CHECK_GET_CALLER_EXCEPTIONS}
|
|
{$endif}
|
|
|
|
Procedure PushExceptObject(Obj : TObject; AnAddr,AFrame : Pointer);
|
|
var
|
|
Newobj : PExceptObject;
|
|
_ExceptObjectStack : ^PExceptObject;
|
|
framebufsize,
|
|
framecount : longint;
|
|
frames : PPointer;
|
|
prev_frame,
|
|
curr_frame,
|
|
curr_addr,
|
|
caller_frame,
|
|
caller_addr : Pointer;
|
|
begin
|
|
{$ifdef excdebug}
|
|
writeln ('In PushExceptObject');
|
|
{$endif}
|
|
_ExceptObjectStack:=@ExceptObjectStack;
|
|
New(NewObj);
|
|
NewObj^.Next:=_ExceptObjectStack^;
|
|
_ExceptObjectStack^:=NewObj;
|
|
|
|
NewObj^.FObject:=Obj;
|
|
NewObj^.Addr:=AnAddr;
|
|
NewObj^.refcount:=0;
|
|
|
|
{ Backtrace }
|
|
curr_frame:=AFrame;
|
|
curr_addr:=AnAddr;
|
|
frames:=nil;
|
|
framebufsize:=0;
|
|
framecount:=0;
|
|
if ExceptTryLevel = 0 then
|
|
begin
|
|
Inc(ExceptTrylevel);
|
|
{$ifdef FPC_CHECK_GET_CALLER_EXCEPTIONS}
|
|
try
|
|
{$endif FPC_CHECK_GET_CALLER_EXCEPTIONS}
|
|
prev_frame:=get_caller_frame(curr_frame, curr_addr);
|
|
{$ifdef FPC_CHECK_GET_CALLER_EXCEPTIONS}
|
|
except
|
|
halt(217);
|
|
end;
|
|
{$endif FPC_CHECK_GET_CALLER_EXCEPTIONS}
|
|
while (framecount<RaiseMaxFrameCount) and (curr_frame > prev_frame) and
|
|
(curr_frame<(StackBottom + StackLength)) do
|
|
Begin
|
|
{$ifdef FPC_CHECK_GET_CALLER_EXCEPTIONS}
|
|
try
|
|
caller_addr := get_caller_addr(curr_frame, curr_addr);
|
|
except
|
|
halt(217);
|
|
end;
|
|
try
|
|
caller_frame := get_caller_frame(curr_frame, curr_addr);
|
|
except
|
|
halt(217);
|
|
end;
|
|
{$else not FPC_CHECK_GET_CALLER_EXCEPTIONS}
|
|
caller_addr := get_caller_addr(curr_frame, curr_addr);
|
|
caller_frame := get_caller_frame(curr_frame, curr_addr);
|
|
{$endif FPC_CHECK_GET_CALLER_EXCEPTIONS}
|
|
if (caller_addr=nil) or
|
|
(caller_frame=nil) then
|
|
break;
|
|
if (framecount>=framebufsize) then
|
|
begin
|
|
inc(framebufsize,16);
|
|
reallocmem(frames,framebufsize*sizeof(pointer));
|
|
end;
|
|
frames[framecount]:=caller_addr;
|
|
inc(framecount);
|
|
prev_frame:=curr_frame;
|
|
curr_addr:=caller_addr;
|
|
curr_frame:=caller_frame;
|
|
End;
|
|
Dec(ExceptTryLevel);
|
|
end;
|
|
NewObj^.framecount:=framecount;
|
|
NewObj^.frames:=frames;
|
|
end;
|
|
|
|
Procedure DoUnHandledException;
|
|
var
|
|
_ExceptObjectStack : PExceptObject;
|
|
begin
|
|
_ExceptObjectStack:=ExceptObjectStack;
|
|
If (ExceptProc<>Nil) and (_ExceptObjectStack<>Nil) then
|
|
with _ExceptObjectStack^ do
|
|
begin
|
|
TExceptProc(ExceptProc)(FObject,Addr,FrameCount,Frames);
|
|
halt(217)
|
|
end;
|
|
if erroraddr = nil then
|
|
RunError(217)
|
|
else
|
|
Halt(errorcode);
|
|
end;
|
|
|
|
{$ifndef FPC_SYSTEM_HAS_RAISEEXCEPTION}
|
|
Function fpc_RaiseException (Obj : TObject; AnAddr,AFrame : Pointer) : TObject;[Public, Alias : 'FPC_RAISEEXCEPTION']; compilerproc;
|
|
var
|
|
_ExceptObjectStack : PExceptObject;
|
|
_ExceptAddrstack : PExceptAddr;
|
|
begin
|
|
{$ifdef excdebug}
|
|
writeln ('In RaiseException');
|
|
{$endif}
|
|
fpc_Raiseexception:=nil;
|
|
PushExceptObject(Obj,AnAddr,AFrame);
|
|
_ExceptAddrstack:=ExceptAddrStack;
|
|
If _ExceptAddrStack=Nil then
|
|
DoUnhandledException;
|
|
_ExceptObjectStack:=ExceptObjectStack;
|
|
if (RaiseProc <> nil) and (_ExceptObjectStack <> nil) then
|
|
with _ExceptObjectStack^ do
|
|
RaiseProc(FObject,Addr,FrameCount,Frames);
|
|
longjmp(_ExceptAddrStack^.Buf^,FPC_Exception);
|
|
end;
|
|
{$endif FPC_SYSTEM_HAS_RAISEEXCEPTION}
|
|
|
|
|
|
Procedure fpc_PopAddrStack;[Public, Alias : 'FPC_POPADDRSTACK']; compilerproc;
|
|
var
|
|
hp : ^PExceptAddr;
|
|
begin
|
|
{$ifdef excdebug}
|
|
writeln ('In Popaddrstack');
|
|
{$endif}
|
|
hp:=@ExceptAddrStack;
|
|
If hp^=nil then
|
|
begin
|
|
{$ifdef excdebug}
|
|
writeln ('At end of ExceptionAddresStack');
|
|
{$endif}
|
|
halt (255);
|
|
end
|
|
else
|
|
begin
|
|
hp^:=hp^^.Next;
|
|
end;
|
|
end;
|
|
|
|
|
|
function fpc_PopObjectStack : TObject;[Public, Alias : 'FPC_POPOBJECTSTACK']; compilerproc;
|
|
var
|
|
hp,_ExceptObjectStack : PExceptObject;
|
|
begin
|
|
{$ifdef excdebug}
|
|
writeln ('In PopObjectstack');
|
|
{$endif}
|
|
_ExceptObjectStack:=ExceptObjectStack;
|
|
If _ExceptObjectStack=nil then
|
|
begin
|
|
{$ifdef excdebug}
|
|
writeln ('At end of ExceptionObjectStack');
|
|
{$endif}
|
|
halt (1);
|
|
end
|
|
else
|
|
begin
|
|
{ we need to return the exception object to dispose it }
|
|
if _ExceptObjectStack^.refcount = 0 then begin
|
|
fpc_PopObjectStack:=_ExceptObjectStack^.FObject;
|
|
end else begin
|
|
fpc_PopObjectStack:=nil;
|
|
end;
|
|
hp:=_ExceptObjectStack;
|
|
ExceptObjectStack:=_ExceptObjectStack^.next;
|
|
if assigned(hp^.frames) then
|
|
freemem(hp^.frames);
|
|
dispose(hp);
|
|
erroraddr:=nil;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ this is for popping exception objects when a second exception is risen }
|
|
{ in an except/on }
|
|
function fpc_PopSecondObjectStack : TObject;[Public, Alias : 'FPC_POPSECONDOBJECTSTACK']; compilerproc;
|
|
var
|
|
hp,_ExceptObjectStack : PExceptObject;
|
|
begin
|
|
{$ifdef excdebug}
|
|
writeln ('In PopObjectstack');
|
|
{$endif}
|
|
_ExceptObjectStack:=ExceptObjectStack;
|
|
If not(assigned(_ExceptObjectStack)) or
|
|
not(assigned(_ExceptObjectStack^.next)) then
|
|
begin
|
|
{$ifdef excdebug}
|
|
writeln ('At end of ExceptionObjectStack');
|
|
{$endif}
|
|
halt (1);
|
|
end
|
|
else
|
|
begin
|
|
if _ExceptObjectStack^.next^.refcount=0 then
|
|
{ we need to return the exception object to dispose it if refcount=0 }
|
|
fpc_PopSecondObjectStack:=_ExceptObjectStack^.next^.FObject
|
|
else
|
|
fpc_PopSecondObjectStack:=nil;
|
|
hp:=_ExceptObjectStack^.next;
|
|
_ExceptObjectStack^.next:=hp^.next;
|
|
if assigned(hp^.frames) then
|
|
freemem(hp^.frames);
|
|
dispose(hp);
|
|
end;
|
|
end;
|
|
|
|
{$ifndef FPC_SYSTEM_HAS_RERAISE}
|
|
Procedure fpc_ReRaise;[Public, Alias : 'FPC_RERAISE']; compilerproc;
|
|
var
|
|
_ExceptAddrStack : PExceptAddr;
|
|
begin
|
|
{$ifdef excdebug}
|
|
writeln ('In reraise');
|
|
{$endif}
|
|
_ExceptAddrStack:=ExceptAddrStack;
|
|
If _ExceptAddrStack=Nil then
|
|
DoUnHandledException;
|
|
ExceptObjectStack^.refcount := 0;
|
|
longjmp(_ExceptAddrStack^.Buf^,FPC_Exception);
|
|
end;
|
|
{$endif FPC_SYSTEM_HAS_RERAISE}
|
|
|
|
function Internal_PopSecondObjectStack : TObject; external name 'FPC_POPSECONDOBJECTSTACK';
|
|
function Internal_PopObjectStack: TObject; external name 'FPC_POPOBJECTSTACK';
|
|
procedure Internal_Reraise; external name 'FPC_RERAISE';
|
|
|
|
Function fpc_Catches(Objtype : TClass) : TObject;[Public, Alias : 'FPC_CATCHES']; compilerproc;
|
|
var
|
|
_ExceptObjectStack : PExceptObject;
|
|
begin
|
|
_ExceptObjectStack:=ExceptObjectStack;
|
|
If _ExceptObjectStack=Nil then
|
|
begin
|
|
{$ifdef excdebug}
|
|
Writeln ('Internal error.');
|
|
{$endif}
|
|
halt (255);
|
|
end;
|
|
if Not ((Objtype = TClass(CatchAllExceptions)) or
|
|
(_ExceptObjectStack^.FObject is ObjType)) then
|
|
fpc_Catches:=Nil
|
|
else
|
|
begin
|
|
// catch !
|
|
fpc_Catches:=_ExceptObjectStack^.FObject;
|
|
{ this can't be done, because there could be a reraise (PFV)
|
|
PopObjectStack;
|
|
|
|
Also the PopAddrStack shouldn't be done, we do it now
|
|
immediatly in the exception handler (FK)
|
|
PopAddrStack; }
|
|
end;
|
|
end;
|
|
|
|
Procedure fpc_DestroyException(o : TObject);[Public, Alias : 'FPC_DESTROYEXCEPTION']; compilerproc;
|
|
begin
|
|
{ with free we're on the really safe side }
|
|
o.Free;
|
|
end;
|
|
|
|
{ TODO: no longer used, clean up }
|
|
function fpc_GetExceptionAddr : Pointer;[Public, Alias : 'FPC_GETEXCEPTIONADDR']; compilerproc;
|
|
var
|
|
_ExceptObjectStack : PExceptObject;
|
|
begin
|
|
_ExceptObjectStack:=ExceptObjectStack;
|
|
if _ExceptObjectStack=nil then
|
|
fpc_GetExceptionAddr:=nil
|
|
else
|
|
fpc_GetExceptionAddr:=_ExceptObjectStack^.Addr;
|
|
end;
|
|
|
|
Procedure SysInitExceptions;
|
|
{
|
|
Initialize exceptionsupport
|
|
}
|
|
begin
|
|
ExceptObjectstack:=Nil;
|
|
ExceptAddrStack:=Nil;
|
|
end;
|
|
|
|
|
|
procedure fpc_doneexception;[public,alias:'FPC_DONEEXCEPTION'] compilerproc;
|
|
begin
|
|
Internal_PopObjectStack.Free;
|
|
end;
|
|
|
|
procedure fpc_raise_nested;[public,alias:'FPC_RAISE_NESTED']compilerproc;
|
|
begin
|
|
Internal_PopSecondObjectStack.Free;
|
|
Internal_Reraise;
|
|
end;
|
|
|
|
function fpc_safecallhandler(obj: TObject): HResult; [public,alias:'FPC_SAFECALLHANDLER']; compilerproc;
|
|
var
|
|
raiselist: PExceptObject;
|
|
adr: Pointer;
|
|
exc: TObject;
|
|
begin
|
|
raiselist:=ExceptObjectStack;
|
|
if Assigned(raiseList) then
|
|
adr:=raiseList^.Addr
|
|
else
|
|
adr:=nil;
|
|
exc:=Internal_PopObjectStack;
|
|
if Assigned(obj) and Assigned(exc) then
|
|
result:=obj.SafeCallException(exc,adr)
|
|
else
|
|
result:=E_UNEXPECTED;
|
|
exc.Free;
|
|
end;
|
|
|