diff --git a/compiler/cg386flw.pas b/compiler/cg386flw.pas
index 5865463873..8981892be4 100644
--- a/compiler/cg386flw.pas
+++ b/compiler/cg386flw.pas
@@ -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 [,]
+
+ 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
diff --git a/compiler/pstatmnt.pas b/compiler/pstatmnt.pas
index 42e5a74f2e..f835318797 100644
--- a/compiler/pstatmnt.pas
+++ b/compiler/pstatmnt.pas
@@ -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 [,]
+
+ 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
diff --git a/compiler/tcflw.pas b/compiler/tcflw.pas
index 2b03de8b34..857714d268 100644
--- a/compiler/tcflw.pas
+++ b/compiler/tcflw.pas
@@ -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 [,]
+
+ 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
diff --git a/compiler/tree.pas b/compiler/tree.pas
index 1505e21634..6c1dc47396 100644
--- a/compiler/tree.pas
+++ b/compiler/tree.pas
@@ -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 [,]
+
+ Revision 1.117 2000/04/08 16:22:11 jonas
* fixed concat_string optimization and enabled it when
-dnewoptimizations is used
diff --git a/rtl/inc/except.inc b/rtl/inc/except.inc
index 9d35736759..fe8a0fc5a5 100644
--- a/rtl/inc/except.inc
+++ b/rtl/inc/except.inc
@@ -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 [,]
+
+ Revision 1.17 2000/02/09 22:16:50 florian
+ popsecondobjectstack added
Revision 1.16 2000/02/09 16:59:29 peter
diff --git a/rtl/inc/objpash.inc b/rtl/inc/objpash.inc
index 35408d2385..a74b72132b 100644
--- a/rtl/inc/objpash.inc
+++ b/rtl/inc/objpash.inc
@@ -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 [,]
+
+ Revision 1.8 2000/02/09 16:59:31 peter
* truncated log
Revision 1.7 2000/01/07 16:41:36 daniel
diff --git a/rtl/inc/system.inc b/rtl/inc/system.inc
index 7d913aaa04..c9b0687f9a 100644
--- a/rtl/inc/system.inc
+++ b/rtl/inc/system.inc
@@ -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 [,]
+
+ 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
diff --git a/rtl/inc/systemh.inc b/rtl/inc/systemh.inc
index a02436b2e8..9118a5aee6 100644
--- a/rtl/inc/systemh.inc
+++ b/rtl/inc/systemh.inc
@@ -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 [,]
+
+ 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
diff --git a/rtl/objpas/sysutils.pp b/rtl/objpas/sysutils.pp
index b99ba25e04..f660feb757 100644
--- a/rtl/objpas/sysutils.pp
+++ b/rtl/objpas/sysutils.pp
@@ -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 [,]
+
+ 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