* updated all the RTL helper functions related to exceptions and stack traces to use codepointer instead of pointer

git-svn-id: trunk@25513 -

rtl/i8086/i8086.inc

@@ -53,26 +53,32 @@ asm
 end;
 
 {$define FPC_SYSTEM_HAS_GET_CALLER_ADDR}
-function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;nostackframe;assembler;
+function get_caller_addr(framebp:pointer;addr:codepointer=nil):codepointer;nostackframe;assembler;
 asm
   push bp
   mov bp, sp
-  mov ax, ss:[bp + 6 + extra_param_offset]  // framebp
+{$ifdef FPC_X86_CODE_FAR}
+  xor dx, dx
+{$endif FPC_X86_CODE_FAR}
+  mov ax, ss:[bp + 6 + extra_param_offset + extra_param_offset]  // framebp
   or ax, ax
   jz @@Lg_a_null
   xchg ax, bx
   mov bx, [bx+2]
+{$ifdef FPC_X86_CODE_FAR}
+  mov dx, [bx+4]
+{$endif FPC_X86_CODE_FAR}
   xchg ax, bx
 @@Lg_a_null:
   pop bp
 end;
 
 {$define FPC_SYSTEM_HAS_GET_CALLER_FRAME}
-function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;nostackframe;assembler;
+function get_caller_frame(framebp:pointer;addr:codepointer=nil):pointer;nostackframe;assembler;
 asm
   push bp
   mov bp, sp
-  mov ax, ss:[bp + 6 + extra_param_offset]  // framebp
+  mov ax, ss:[bp + 6 + extra_param_offset + extra_param_offset]  // framebp
   or ax, ax
   jz @@Lgnf_null
   xchg ax, bx

rtl/inc/compproc.inc

@@ -592,14 +592,14 @@ procedure fpc_dispatch_by_id(Result: Pointer; const Dispatch: pointer;DispDesc:
 
 {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
 Function fpc_PushExceptAddr (Ft: {$ifdef CPU16}SmallInt{$else}Longint{$endif};_buf,_newaddr : pointer): PJmp_buf ; compilerproc;
-Function fpc_Raiseexception (Obj : TObject; AnAddr,AFrame : Pointer) : TObject; compilerproc;
+Function fpc_Raiseexception (Obj : TObject; AnAddr : CodePointer; AFrame : Pointer) : TObject; compilerproc;
 Procedure fpc_PopAddrStack; compilerproc;
 function fpc_PopObjectStack : TObject; compilerproc;
 function fpc_PopSecondObjectStack : TObject; compilerproc;
 Procedure fpc_ReRaise; compilerproc;
 Function fpc_Catches(Objtype : TClass) : TObject; compilerproc;
 Procedure fpc_DestroyException(o : TObject); compilerproc;
-function fpc_GetExceptionAddr : Pointer; compilerproc;
+function fpc_GetExceptionAddr : CodePointer; compilerproc;
 function fpc_safecallhandler(obj: TObject): HResult; compilerproc;
 function fpc_safecallcheck(res : hresult) : hresult; compilerproc; {$ifdef CPU86} register; {$endif}
 procedure fpc_doneexception; compilerproc;

rtl/inc/except.inc

@@ -112,18 +112,18 @@ end;
   {$define FPC_CHECK_GET_CALLER_EXCEPTIONS}
 {$endif}
 
-Procedure PushExceptObject(Obj : TObject; AnAddr,AFrame : Pointer);
+Procedure PushExceptObject(Obj : TObject; AnAddr : CodePointer; AFrame : Pointer);
 var
   Newobj : PExceptObject;
   _ExceptObjectStack : ^PExceptObject;
   framebufsize,
   framecount  : longint;
-  frames      : PPointer;
+  frames      : PCodePointer;
   prev_frame,
   curr_frame,
+  caller_frame : Pointer;
   curr_addr,
-  caller_frame,
-  caller_addr : Pointer;
+  caller_addr : CodePointer;
 begin
 {$ifdef excdebug}
   writeln ('In PushExceptObject');
@@ -179,7 +179,7 @@ begin
           if (framecount>=framebufsize) then
             begin
               inc(framebufsize,16);
-              reallocmem(frames,framebufsize*sizeof(pointer));
+              reallocmem(frames,framebufsize*sizeof(codepointer));
             end;
           frames[framecount]:=caller_addr;
           inc(framecount);
@@ -211,7 +211,7 @@ begin
 end;
 
 {$ifndef FPC_SYSTEM_HAS_RAISEEXCEPTION}
-Function fpc_RaiseException (Obj : TObject; AnAddr,AFrame : Pointer) : TObject;[Public, Alias : 'FPC_RAISEEXCEPTION']; compilerproc;
+Function fpc_RaiseException (Obj : TObject; AnAddr : CodePointer; AFrame : Pointer) : TObject;[Public, Alias : 'FPC_RAISEEXCEPTION']; compilerproc;
 var
   _ExceptObjectStack : PExceptObject;
   _ExceptAddrstack : PExceptAddr;
@@ -376,7 +376,7 @@ begin
 end;
 
 { TODO: no longer used, clean up }
-function fpc_GetExceptionAddr : Pointer;[Public, Alias : 'FPC_GETEXCEPTIONADDR']; compilerproc;
+function fpc_GetExceptionAddr : CodePointer;[Public, Alias : 'FPC_GETEXCEPTIONADDR']; compilerproc;
 var
   _ExceptObjectStack : PExceptObject;
 begin
@@ -411,7 +411,7 @@ end;
 function fpc_safecallhandler(obj: TObject): HResult; [public,alias:'FPC_SAFECALLHANDLER']; compilerproc;
 var
   raiselist: PExceptObject;
-  adr: Pointer;
+  adr: CodePointer;
   exc: TObject;
 begin
   raiselist:=ExceptObjectStack;

rtl/inc/heaptrc.pp

@@ -132,7 +132,7 @@ type
     release_sig : longword;
     prev_valid  : pheap_mem_info;
 {$endif EXTRA}
-    calls    : array [1..tracesize] of pointer;
+    calls    : array [1..tracesize] of codepointer;
     exact_info_size : word;
     extra_info_size : word;
     extra_info      : pheap_extra_info;
@@ -336,7 +336,8 @@ end;
 
 procedure dump_already_free(p : pheap_mem_info;var ptext : text);
 var
-  bp, pcaddr : pointer;
+  bp : pointer;
+  pcaddr : codepointer;
 begin
   Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' released');
   call_free_stack(p,ptext);
@@ -349,7 +350,8 @@ end;
 
 procedure dump_error(p : pheap_mem_info;var ptext : text);
 var
-  bp, pcaddr : pointer;
+  bp : pointer;
+  pcaddr : codepointer;
 begin
   Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
   Writeln(ptext,'Wrong signature $',hexstr(p^.sig,8),' instead of ',hexstr(calculate_sig(p),8));
@@ -382,7 +384,8 @@ end;
 
 procedure dump_wrong_size(p : pheap_mem_info;size : ptruint;var ptext : text);
 var
-  bp, pcaddr : pointer;
+  bp : pointer;
+  pcaddr : codepointer;
 begin
   Writeln(ptext,'Marked memory at $',HexStr(pointer(p)+sizeof(theap_mem_info)),' invalid');
   Writeln(ptext,'Wrong size : ',p^.size,' allocated ',size,' freed');
@@ -464,7 +467,8 @@ Function TraceGetMem(size:ptruint):pointer;
 var
   allocsize,i : ptruint;
   oldbp,
-  bp,pcaddr : pointer;
+  bp : pointer;
+  pcaddr : codepointer;
   pl : pdword;
   p  : pointer;
   pp : pheap_mem_info;
@@ -573,7 +577,8 @@ function CheckFreeMemSize(loc_info: pheap_info; pp: pheap_mem_info;
   size, ppsize: ptruint): boolean; inline;
 var
   i: ptruint;
-  bp,pcaddr : pointer;
+  bp : pointer;
+  pcaddr : codepointer;
   ptext : ^text;
 {$ifdef EXTRA}
   pp2 : pheap_mem_info;
@@ -798,8 +803,8 @@ var
   movesize,
   i  : ptruint;
   oldbp,
-  bp,
-  pcaddr : pointer;
+  bp : pointer;
+  pcaddr : codepointer;
   pl : pdword;
   pp : pheap_mem_info;
   oldsize,
@@ -1005,7 +1010,8 @@ var
 {$ifdef morphos}
   stack_top: longword;
 {$endif morphos}
-  bp,pcaddr : pointer;
+  bp : pointer;
+  pcaddr : codepointer;
   ptext : ^text;
 label
   _exit;

rtl/inc/lineinfo.pp

@@ -258,7 +258,7 @@ begin
 end;
 
 
-function StabBackTraceStr(addr:Pointer):shortstring;
+function StabBackTraceStr(addr:CodePointer):shortstring;
 var
   func,
   source : string;

rtl/inc/objpas.inc

@@ -501,7 +501,7 @@
         end;
 
       function TObject.SafeCallException(exceptobject : tobject;
-        exceptaddr : pointer) : HResult;
+        exceptaddr : codepointer) : HResult;
 
         begin
           safecallexception:=E_UNEXPECTED;

rtl/inc/objpash.inc

@@ -196,7 +196,7 @@
           class function newinstance : tobject;virtual;
           procedure FreeInstance;virtual;
           function SafeCallException(exceptobject : tobject;
-            exceptaddr : pointer) : HResult;virtual;
+            exceptaddr : codepointer) : HResult;virtual;
           procedure DefaultHandler(var message);virtual;
 
           procedure Free;
@@ -322,17 +322,17 @@
        PInterface = PUnknown;
 
 
-       TExceptProc = Procedure (Obj : TObject; Addr : Pointer; FrameCount:Longint; Frame: PPointer);
+       TExceptProc = Procedure (Obj : TObject; Addr : CodePointer; FrameCount:Longint; Frame: PCodePointer);
 
        { Exception object stack }
        PExceptObject = ^TExceptObject;
        TExceptObject = record
          FObject    : TObject;
-         Addr       : pointer;
+         Addr       : codepointer;
          Next       : PExceptObject;
          refcount   : Longint;
          Framecount : Longint;
-         Frames     : PPointer;
+         Frames     : PCodePointer;
        end;
 
     Const

rtl/inc/system.inc

@@ -69,8 +69,8 @@ Const
 
 Procedure HandleError (Errno : Longint); external name 'FPC_HANDLEERROR';
 Procedure HandleErrorFrame (Errno : longint;frame : Pointer); forward;
-Procedure HandleErrorAddrFrame (Errno : longint;addr,frame : Pointer); forward;
-Procedure HandleErrorAddrFrameInd (Errno : longint;addr,frame : Pointer); forward;
+Procedure HandleErrorAddrFrame (Errno : longint;addr : CodePointer; frame : Pointer); forward;
+Procedure HandleErrorAddrFrameInd (Errno : longint;addr : CodePointer; frame : Pointer); forward;
 
 {$ifdef FPC_HAS_FEATURE_TEXTIO}
 type
@@ -686,7 +686,7 @@ End;
   { This provides a dummy implementation
     of get_pc_addr function, for CPU's that don't need
     the instruction address to walk the stack. }
-function get_pc_addr : pointer;
+function get_pc_addr : codepointer;
 begin
   get_pc_addr:=nil;
 end;
@@ -697,9 +697,10 @@ end;
     of get_caller_stackinfo procedure,
     using get_caller_addr and get_caller_frame
     functions. }
-procedure get_caller_stackinfo(var framebp,addr : pointer);
+procedure get_caller_stackinfo(var framebp : pointer; addr : codepointer);
 var
-  nextbp,nextaddr : pointer;
+  nextbp : pointer;
+  nextaddr : codepointer;
 begin
   nextbp:=get_caller_frame(framebp,addr);
   nextaddr:=get_caller_addr(framebp,addr);
@@ -967,7 +968,11 @@ Begin
   pstdout:=@stdout;
   If erroraddr<>nil Then
    Begin
+{$if defined(CPUI8086) and defined(FPC_X86_CODE_FAR)}
+     Writeln(pstdout^,'Runtime error ',Errorcode,' at $',hexstr(DWord(erroraddr) shr 16,4),':',hexstr(DWord(erroraddr) and $FFFF,4));
+{$else}
      Writeln(pstdout^,'Runtime error ',Errorcode,' at $',hexstr(erroraddr));
+{$endif}
      { to get a nice symify }
      Writeln(pstdout^,BackTraceStrFunc(Erroraddr));
      dump_stack(pstdout^,ErrorBase,ErrorAddr);
@@ -1041,13 +1046,17 @@ Begin
 end;
 
 
-function SysBackTraceStr (Addr: Pointer): ShortString;
+function SysBackTraceStr (Addr: CodePointer): ShortString;
 begin
+{$if defined(CPUI8086) and defined(FPC_X86_CODE_FAR)}
+  SysBackTraceStr:='  $'+hexstr(DWord(addr) shr 16,4)+':'+hexstr(DWord(addr) and $FFFF,4);
+{$else}
   SysBackTraceStr:='  $'+hexstr(addr);
+{$endif}
 end;
 
 
-Procedure HandleErrorAddrFrame (Errno : longint;addr,frame : Pointer);[public,alias:'FPC_BREAK_ERROR']; {$ifdef CPUI386} register; {$endif}
+Procedure HandleErrorAddrFrame (Errno : longint;addr : CodePointer; frame : Pointer);[public,alias:'FPC_BREAK_ERROR']; {$ifdef CPUI386} register; {$endif}
 begin
   If pointer(ErrorProc)<>Nil then
     ErrorProc(Errno,addr,frame);
@@ -1064,7 +1073,7 @@ end;
 { This is used internally by system skip first level,
   and generated the same output as before, when
   HandleErrorFrame function was used internally. }
-Procedure HandleErrorAddrFrameInd (Errno : longint;addr,frame : Pointer);
+Procedure HandleErrorAddrFrameInd (Errno : longint;addr : CodePointer; frame : Pointer);
 begin
   get_caller_stackinfo (frame, addr);
   HandleErrorAddrFrame (Errno,addr,frame);
@@ -1093,7 +1102,8 @@ end;
 
 procedure RunError(w : word);[alias: 'FPC_RUNERROR'];
 var
-  bp,pcaddr : pointer;
+  bp : pointer;
+  pcaddr : codepointer;
 begin
   errorcode:=w;
   pcaddr:=get_pc_addr;
@@ -1123,14 +1133,14 @@ begin
 end;
 
 
-Procedure dump_stack(var f : text;fp,addr : Pointer);
+Procedure dump_stack(var f : text;fp : Pointer; addr : CodePointer);
 var
   i : Longint;
   prevfp : Pointer;
-  prevaddr : pointer;
+  prevaddr : CodePointer;
   is_dev : boolean;
-  caller_frame,
-  caller_addr : Pointer;
+  caller_frame : Pointer;
+  caller_addr : CodePointer;
 Begin
 {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
   try
@@ -1171,7 +1181,7 @@ procedure DumpExceptionBackTrace(var f:text);
 var
   FrameNumber,
   FrameCount   : longint;
-  Frames       : PPointer;
+  Frames       : PCodePointer;
 begin
   if RaiseList=nil then
     exit;

rtl/inc/systemh.inc

@@ -618,7 +618,7 @@ const
 
 { Exit Procedure handling consts and types  }
   ExitProc : codepointer = nil;
-  Erroraddr: pointer = nil;
+  Erroraddr: codepointer = nil;
   Errorcode: Word    = 0;
 
 { file input modes }
@@ -1258,11 +1258,11 @@ function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;[INTERNPROC:
 function get_frame:pointer;{$ifdef SYSTEMINLINE}inline;{$endif}
 {$ENDIF}
 
-Function Get_pc_addr : Pointer;
+Function Get_pc_addr : CodePointer;
 
-function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;
-function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;
-procedure get_caller_stackinfo(var framebp,addr : pointer);
+function get_caller_addr(framebp:pointer;addr:codepointer=nil):codepointer;
+function get_caller_frame(framebp:pointer;addr:codepointer=nil):pointer;
+procedure get_caller_stackinfo(var framebp : pointer; addr : codepointer);
 
 Function IOResult:Word;
 Function Sptr:Pointer;[internconst:fpc_in_const_ptr];
@@ -1344,7 +1344,7 @@ Function  Paramcount:Longint;
 Function  ParamStr(l:Longint):string;
 {$endif FPC_HAS_FEATURE_COMMANDARGS}
 
-Procedure Dump_Stack(var f : text;fp:pointer;addr : pointer = nil);
+Procedure Dump_Stack(var f : text;fp:pointer;addr : codepointer = nil);
 {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
 procedure DumpExceptionBackTrace(var f:text);
 {$endif FPC_HAS_FEATURE_EXCEPTIONS}
@@ -1387,7 +1387,7 @@ Function StringToPPChar(S: PChar;ReserveEntries:integer):ppchar;
 
 procedure AbstractError;external name 'FPC_ABSTRACTERROR';
 procedure EmptyMethod;external name 'FPC_EMPTYMETHOD';
-Function  SysBackTraceStr(Addr:Pointer): ShortString;
+Function  SysBackTraceStr(Addr:CodePointer): ShortString;
 Procedure SysAssert(const Msg,FName:ShortString;LineNo:Longint;ErrorAddr:Pointer);
 (* Supposed to return address of previous CtrlBreakHandler *)
 (* (may be nil), returned value of pointer (-1) means that *)
@@ -1396,8 +1396,8 @@ function SysSetCtrlBreakHandler (Handler: TCtrlBreakHandler): TCtrlBreakHandler;
 
 { Error handlers }
 Type
-  TBackTraceStrFunc = Function (Addr: Pointer): ShortString;
-  TErrorProc = Procedure (ErrNo : Longint; Address,Frame : Pointer);
+  TBackTraceStrFunc = Function (Addr: CodePointer): ShortString;
+  TErrorProc = Procedure (ErrNo : Longint; Address : CodePointer; Frame : Pointer);
   TAbstractErrorProc = Procedure;
   TAssertErrorProc = Procedure(const msg,fname:ShortString;lineno:longint;erroraddr:pointer);
   TSafeCallErrorProc = Procedure(error : HResult;addr : pointer);