paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-22 19:29:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

* backtraces for exceptions are now only generated from the place of the

Browse Source 
exception
  * frame is also pushed for exceptions
  * raise statement enhanced with [,<frame>]
This commit is contained in:
peter 2000-04-24 11:11:50 +00:00
parent 70d3d42a5c
commit ebbf2e578f
9 changed files with 163 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
compiler/cg386flw.pas
View File

@ -559,43 +559,47 @@ do_jmp:
var
a : pasmlabel;
begin
if assigned(p^.left) then
begin
{ generate the address }
{ multiple parameters? }
if assigned(p^.right) then
begin
secondpass(p^.right);
if codegenerror then
exit;
emit_push_loc(p^.right^.location);
{ push frame }
if assigned(p^.frametree) then
begin
secondpass(p^.frametree);
if codegenerror then
exit;
emit_push_loc(p^.frametree^.location);
end
else
emit_const(A_PUSH,S_L,0);
{ push address }
secondpass(p^.right);
if codegenerror then
exit;
emit_push_loc(p^.right^.location);
end
else
begin
getlabel(a);
emitlab(a);
emit_const(A_PUSH,S_L,0);
emit_sym(A_PUSH,S_L,a);
end;
{ push object }
secondpass(p^.left);
if codegenerror then
exit;
case p^.left^.location.loc of
LOC_MEM,LOC_REFERENCE:
emit_ref(A_PUSH,S_L,
newreference(p^.left^.location.reference));
LOC_CREGISTER,LOC_REGISTER : emit_reg(A_PUSH,S_L,
p^.left^.location.register);
else CGMessage(type_e_mismatch);
end;
emit_push_loc(p^.left^.location);
emitcall('FPC_RAISEEXCEPTION');
end
else
begin
emitcall('FPC_POPADDRSTACK');
emitcall('FPC_RERAISE');
end;
end
else
begin
emitcall('FPC_POPADDRSTACK');
emitcall('FPC_RERAISE');
end;
end;
@ -1210,7 +1214,13 @@ do_jmp:
end.
{
$Log$
Revision 1.72 2000-04-22 15:29:26 jonas
Revision 1.73 2000-04-24 11:11:50 peter
* backtraces for exceptions are now only generated from the place of the
exception
* frame is also pushed for exceptions
* raise statement enhanced with [,<frame>]
Revision 1.72 2000/04/22 15:29:26 jonas
* cleaner register (de)allocation in secondfor (for optimizer)
Revision 1.71 2000/04/16 08:08:44 jonas

31
compiler/pstatmnt.pas
View File

@ -486,27 +486,32 @@ unit pstatmnt;
function raise_statement : ptree;
var
p1,p2 : ptree;
p,pobj,paddr,pframe : ptree;
begin
p1:=nil;
p2:=nil;
pobj:=nil;
paddr:=nil;
pframe:=nil;
consume(_RAISE);
if not(token in [_SEMICOLON,_END]) then
begin
p1:=comp_expr(true);
if (idtoken=_AT) then
{ object }
pobj:=comp_expr(true);
if try_to_consume(_AT) then
begin
consume(_ID);
p2:=comp_expr(true);
paddr:=comp_expr(true);
if try_to_consume(_COMMA) then
pframe:=comp_expr(true);
end;
end
else
begin
if (block_type<>bt_except) then
Message(parser_e_no_reraise_possible);
Message(parser_e_no_reraise_possible);
end;
raise_statement:=gennode(raisen,p1,p2);
p:=gennode(raisen,pobj,paddr);
p^.frametree:=pframe;
raise_statement:=p;
end;
@ -1368,7 +1373,13 @@ unit pstatmnt;
end.
{
$Log$
Revision 1.127 2000-03-19 14:17:05 florian
Revision 1.128 2000-04-24 11:11:50 peter
* backtraces for exceptions are now only generated from the place of the
exception
* frame is also pushed for exceptions
* raise statement enhanced with [,<frame>]
Revision 1.127 2000/03/19 14:17:05 florian
* crash when using exception classes without sysutils unit fixed
Revision 1.126 2000/03/19 11:16:44 peter

48
compiler/tcflw.pas
View File

@ -451,31 +451,35 @@ implementation
procedure firstraise(var p : ptree);
begin
p^.resulttype:=voiddef;
{
p^.registersfpu:=0;
p^.registers32:=0;
}
if assigned(p^.left) then
begin
{ first para must be a _class_ }
firstpass(p^.left);
{ this must be a _class_ }
if (p^.left^.resulttype^.deftype<>objectdef) or
not(pobjectdef(p^.left^.resulttype)^.is_class) then
CGMessage(type_e_mismatch);
p^.registersfpu:=p^.left^.registersfpu;
p^.registers32:=p^.left^.registers32;
{$ifdef SUPPORT_MMX}
p^.registersmmx:=p^.left^.registersmmx;
{$endif SUPPORT_MMX}
if codegenerror then
exit;
{ insert needed typeconvs for addr,frame }
if assigned(p^.right) then
begin
firstpass(p^.right);
p^.right:=gentypeconvnode(p^.right,s32bitdef);
firstpass(p^.right);
left_right_max(p);
end;
begin
{ addr }
firstpass(p^.right);
p^.right:=gentypeconvnode(p^.right,s32bitdef);
firstpass(p^.right);
if codegenerror then
exit;
{ frame }
if assigned(p^.frametree) then
begin
firstpass(p^.frametree);
p^.frametree:=gentypeconvnode(p^.frametree,s32bitdef);
firstpass(p^.frametree);
if codegenerror then
exit;
end;
end;
left_right_max(p);
end;
end;
@ -628,7 +632,13 @@ implementation
end.
{
$Log$
Revision 1.36 2000-03-19 14:17:05 florian
Revision 1.37 2000-04-24 11:11:50 peter
* backtraces for exceptions are now only generated from the place of the
exception
* frame is also pushed for exceptions
* raise statement enhanced with [,<frame>]
Revision 1.36 2000/03/19 14:17:05 florian
* crash when using exception classes without sysutils unit fixed
Revision 1.35 2000/02/17 14:53:43 florian

30
compiler/tree.pas
View File

@ -156,7 +156,8 @@ unit tree;
{ allows to determine which elementes are to be replaced }
tdisposetyp = (dt_nothing,dt_leftright,dt_left,dt_leftrighthigh,
dt_mbleft,dt_typeconv,dt_inlinen,dt_leftrightmethod,
dt_mbleft_and_method,dt_loop,dt_case,dt_with,dt_onn);
dt_mbleft_and_method,dt_loop,dt_case,dt_with,dt_onn,
dt_leftrightframe);
{ different assignment types }
@ -239,6 +240,7 @@ unit tree;
{$ENDIF}
is_first_funcret : boolean);
subscriptn : (vs : pvarsym);
raisen : (frametree : ptree);
vecn : (memindex,memseg:boolean;callunique : boolean);
stringconstn : (value_str : pchar;length : longint; lab_str : pasmlabel;stringtype : tstringtype);
typeconvn : (convtyp : tconverttype;explizit : boolean);
@ -459,6 +461,15 @@ unit tree;
if assigned(p^.hightree) then
hp^.left:=getcopy(p^.hightree);
end;
dt_leftrightframe :
begin
if assigned(p^.left) then
hp^.left:=getcopy(p^.left);
if assigned(p^.right) then
hp^.right:=getcopy(p^.right);
if assigned(p^.frametree) then
hp^.left:=getcopy(p^.frametree);
end;
dt_leftrightmethod :
begin
if assigned(p^.left) then
@ -562,6 +573,15 @@ unit tree;
if assigned(p^.hightree) then
disposetree(p^.hightree);
end;
dt_leftrightframe :
begin
if assigned(p^.left) then
disposetree(p^.left);
if assigned(p^.right) then
disposetree(p^.right);
if assigned(p^.frametree) then
disposetree(p^.frametree);
end;
dt_leftrightmethod :
begin
if assigned(p^.left) then
@ -2090,7 +2110,13 @@ unit tree;
end.
{
$Log$
Revision 1.117 2000-04-08 16:22:11 jonas
Revision 1.118 2000-04-24 11:11:50 peter
* backtraces for exceptions are now only generated from the place of the
exception
* frame is also pushed for exceptions
* raise statement enhanced with [,<frame>]
Revision 1.117 2000/04/08 16:22:11 jonas
* fixed concat_string optimization and enabled it when
-dnewoptimizations is used

20
rtl/inc/except.inc
View File

@ -37,7 +37,8 @@ Type
PExceptObject = ^TExceptObject;
TExceptObject = record
FObject : TObject;
Addr : pointer;
Addr,
Frame : pointer;
Next : PExceptObject;
end;
@ -77,7 +78,7 @@ begin
end;
Procedure PushExceptObj (Obj : TObject; AnAddr : Pointer); [Public, Alias : 'FPC_PUSHEXCEPTOBJECT'];
Procedure PushExceptObj (Obj : TObject; AnAddr,AFrame : Pointer); [Public, Alias : 'FPC_PUSHEXCEPTOBJECT'];
var
Newobj : PExceptObject;
begin
@ -97,6 +98,7 @@ begin
end;
ExceptObjectStack^.FObject:=Obj;
ExceptObjectStack^.Addr:=AnAddr;
ExceptObjectStack^.Frame:=AFrame;
end;
@ -104,18 +106,18 @@ Procedure DoUnHandledException;
begin
If ExceptProc<>Nil then
If ExceptObjectStack<>Nil then
TExceptPRoc(ExceptProc)(ExceptObjectStack^.FObject,ExceptObjectStack^.Addr);
TExceptPRoc(ExceptProc)(ExceptObjectStack^.FObject,ExceptObjectStack^.Addr,ExceptObjectStack^.Frame);
RunError(217);
end;
Function Raiseexcept (Obj : TObject; AnAddr : Pointer) : TObject;[Public, Alias : 'FPC_RAISEEXCEPTION'];
Function Raiseexcept (Obj : TObject; AnAddr,AFrame : Pointer) : TObject;[Public, Alias : 'FPC_RAISEEXCEPTION'];
begin
{$ifdef excdebug}
writeln ('In RaiseException');
{$endif}
Raiseexcept:=nil;
PushExceptObj(Obj,AnAddr);
PushExceptObj(Obj,AnAddr,AFrame);
If ExceptAddrStack=Nil then
DoUnhandledException;
longjmp(ExceptAddrStack^.Buf^,FPC_Exception);
@ -242,7 +244,13 @@ begin
end;
{
$Log$
Revision 1.17 2000-02-09 22:16:50 florian
Revision 1.18 2000-04-24 11:11:50 peter
* backtraces for exceptions are now only generated from the place of the
exception
* frame is also pushed for exceptions
* raise statement enhanced with [,<frame>]
Revision 1.17 2000/02/09 22:16:50 florian
+ popsecondobjectstack added
Revision 1.16 2000/02/09 16:59:29 peter

12
rtl/inc/objpash.inc
View File

@ -146,10 +146,10 @@
}
end;
TExceptProc = Procedure (Obj : TObject; Addr: Pointer);
TExceptProc = Procedure (Obj : TObject; Addr,Frame: Pointer);
Const
ExceptProc : Pointer {TExceptProc} = Nil;
ExceptProc : TExceptProc = Nil;
{*****************************************************************************
@ -220,7 +220,13 @@
end;
{
$Log$
Revision 1.8 2000-02-09 16:59:31 peter
Revision 1.9 2000-04-24 11:11:50 peter
* backtraces for exceptions are now only generated from the place of the
exception
* frame is also pushed for exceptions
* raise statement enhanced with [,<frame>]
Revision 1.8 2000/02/09 16:59:31 peter
* truncated log
Revision 1.7 2000/01/07 16:41:36 daniel

10
rtl/inc/system.inc
View File

@ -464,7 +464,7 @@ end;
Procedure HandleErrorAddrFrame (Errno : longint;addr,frame : longint);
begin
If pointer(ErrorProc)<>Nil then
ErrorProc(Errno,pointer(addr));
ErrorProc(Errno,pointer(addr),pointer(frame));
errorcode:=Errno;
exitcode:=Errno;
erroraddr:=pointer(addr);
@ -621,7 +621,13 @@ end;
{
$Log$
Revision 1.87 2000-04-14 12:17:12 pierre
Revision 1.88 2000-04-24 11:11:50 peter
* backtraces for exceptions are now only generated from the place of the
exception
* frame is also pushed for exceptions
* raise statement enhanced with [,<frame>]
Revision 1.87 2000/04/14 12:17:12 pierre
+ get longer backtrace when redirected to file
Revision 1.86 2000/04/02 09:39:25 florian

10
rtl/inc/systemh.inc
View File

@ -413,7 +413,7 @@ Procedure SysAssert(Const Msg,FName:ShortString;LineNo,ErrorAddr:Longint);
{ Error handlers }
Type
TBackTraceStrFunc = Function (Addr: Longint): ShortString;
TErrorProc = Procedure (ErrNo : Longint; Address : Pointer);
TErrorProc = Procedure (ErrNo : Longint; Address,Frame : Pointer);
TAbstractErrorProc = Procedure;
TAssertErrorProc = Procedure(const msg,fname:ShortString;lineno,erroraddr:longint);
const
@ -438,7 +438,13 @@ const
{
$Log$
Revision 1.80 2000-03-26 11:36:28 jonas
Revision 1.81 2000-04-24 11:11:50 peter
* backtraces for exceptions are now only generated from the place of the
exception
* frame is also pushed for exceptions
* raise statement enhanced with [,<frame>]
Revision 1.80 2000/03/26 11:36:28 jonas
+ $maxfpuregisters 0 for i386 in systemh (to avoid requiring too much
empty FPU registers for sysstem routines
* fixed bug in str_real when using :x:0

19
rtl/objpas/sysutils.pp
View File

@ -192,7 +192,7 @@ type
{$define STACKCHECK_WAS_ON}
{$S-}
{$endif OPT S }
Procedure CatchUnhandledException (Obj : TObject; Addr: Pointer);
Procedure CatchUnhandledException (Obj : TObject; Addr,Frame: Pointer);
Var
Message : String;
begin
@ -204,8 +204,11 @@ begin
end
else
Writeln(stdout,'Exception object ',Obj.ClassName,' is not of class Exception.');
{ to get a nice symify }
Writeln(stdout,BackTraceStrFunc(Longint(Addr)));
Dump_Stack(stdout,longint(frame));
Writeln(stdout,'');
Runerror(217);
Halt(217);
end;
@ -213,7 +216,7 @@ Var OutOfMemory : EOutOfMemory;
InValidPointer : EInvalidPointer;
Procedure RunErrorToExcept (ErrNo : Longint; Address : Pointer);
Procedure RunErrorToExcept (ErrNo : Longint; Address,Frame : Pointer);
Var E : Exception;
S : String;
@ -257,7 +260,7 @@ begin
else
E:=Exception.CreateFmt (SUnKnownRunTimeError,[Errno]);
end;
Raise E at longint(Address);
Raise E at longint(Address),longint(Frame);
end;
@ -303,7 +306,13 @@ Finalization
end.
{
$Log$
Revision 1.43 2000-03-30 13:54:15 pierre
Revision 1.44 2000-04-24 11:11:50 peter
* backtraces for exceptions are now only generated from the place of the
exception
* frame is also pushed for exceptions
* raise statement enhanced with [,<frame>]
Revision 1.43 2000/03/30 13:54:15 pierre
No stack check inside CatchUnhandledException
Revision 1.42 2000/02/10 22:56:43 florian