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

    exception
  * frame is also pushed for exceptions
  * raise statement enhanced with [,<frame>]

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 [,<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

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 [,<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

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 [,<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

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 [,<frame>]
+
+  Revision 1.117  2000/04/08 16:22:11  jonas
     * fixed concat_string optimization and enabled it when
       -dnewoptimizations is used
 

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 [,<frame>]
+
+  Revision 1.17  2000/02/09 22:16:50  florian
     + popsecondobjectstack added
 
   Revision 1.16  2000/02/09 16:59:29  peter

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 [,<frame>]
+
+  Revision 1.8  2000/02/09 16:59:31  peter
     * truncated log
 
   Revision 1.7  2000/01/07 16:41:36  daniel

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 [,<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

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 [,<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

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 [,<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