* changes from r21697, 21707, 21843, 21861, 21701, 21887, 21899 and 21900

    to systemh.inc/system.inc/compproc.inc 'merged' into as of yet still
    JVM-specific copies of those files

git-svn-id: trunk@22125 -

rtl/java/jcompproc.inc

@@ -30,8 +30,10 @@ type
 
 { used by Default() in code blocks }
 //procedure fpc_zeromem(p:pointer;len:ptruint);compilerproc;
+//procedure fpc_fillmem(out data;len:ptruint;b : byte);compilerproc;
 
 procedure fpc_Shortstr_SetLength(var s:shortstring;len:SizeInt); compilerproc;
+//procedure fpc_shortstr_assign(len:longint;sstr,dstr:pointer); compilerproc;
 procedure fpc_shortstr_to_shortstr(out res:shortstring; const sstr: shortstring); compilerproc;
 { JVM-specific }
 procedure fpc_Char_To_ShortStr(out res : shortstring;const c : AnsiChar) compilerproc;

rtl/java/jsystem.inc

@@ -80,6 +80,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;
 
 {$ifdef FPC_HAS_FEATURE_TEXTIO}
 type
@@ -686,29 +688,63 @@ End;
                              Miscellaneous
 *****************************************************************************}
 
+{$ifndef FPC_SYSTEM_HAS_GET_PC_ADDR}
+  { 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;
+begin
+  get_pc_addr:=nil;
+end;
+{$endif ndef FPC_SYSTEM_HAS_GET_PC_ADDR}
+
+{$ifndef FPC_SYSTEM_HAS_GET_CALLER_STACKINFO}
+  { This provides a simple implementation
+    of get_caller_stackinfo procedure,
+    using get_caller_addr and get_caller_frame
+    functions. }
+procedure get_caller_stackinfo(var framebp,addr : pointer);
+var
+  nextbp,nextaddr : pointer;
+begin
+  nextbp:=get_caller_frame(framebp,addr);
+  nextaddr:=get_caller_addr(framebp,addr);
+  framebp:=nextbp;
+  addr:=nextaddr;
+end;
+{$endif ndef FPC_SYSTEM_HAS_GET_CALLER_STACKINFO}
+
+
 procedure fpc_rangeerror;[public,alias:'FPC_RANGEERROR']; compilerproc;
 begin
-  HandleErrorFrame(201,get_frame);
+  HandleErrorAddrFrameInd(201,get_pc_addr,get_frame);
 end;
 
 
 procedure fpc_divbyzero;[public,alias:'FPC_DIVBYZERO']; compilerproc;
 begin
-  HandleErrorFrame(200,get_frame);
+  HandleErrorAddrFrameInd(200,get_pc_addr,get_frame);
 end;
 
 
 procedure fpc_overflow;[public,alias:'FPC_OVERFLOW']; compilerproc;
 begin
-  HandleErrorFrame(215,get_frame);
+  HandleErrorAddrFrameInd(215,get_pc_addr,get_frame);
 end;
 
 
 procedure fpc_threaderror; [public,alias:'FPC_THREADERROR'];
 begin
-  HandleErrorFrame(6,get_frame);
+  HandleErrorAddrFrameInd(6,get_pc_addr,get_frame);
+end;
+
+
+procedure fpc_invalidpointer; [public,alias:'FPC_INVALIDPOINTER'];
+begin
+  HandleErrorAddrFrameInd(216,get_pc_addr,get_frame);
 end;
 
+
 (*
 procedure fpc_iocheck;[public,alias:'FPC_IOCHECK']; compilerproc;
 var
@@ -720,7 +756,7 @@ begin
    begin
      l:=HInOutRes^;
      HInOutRes^:=0;
-     HandleErrorFrame(l,get_frame);
+     HandleErrorAddrFrameInd(l,get_pc_addr,get_frame)
    end;
 end;
 
@@ -749,7 +785,7 @@ begin
     begin
       if assigned(SafeCallErrorProc) then
         SafeCallErrorProc(res,get_frame);
-      HandleErrorFrame(229,get_frame);
+      HandleErrorAddrFrameInd(229,get_pc_addr,get_frame);
     end;
   result:=res;
 end;
@@ -894,7 +930,7 @@ begin
      Writeln(pstdout^,'Runtime error ',Errorcode,' at $',hexstr(erroraddr));
      { to get a nice symify }
      Writeln(pstdout^,BackTraceStrFunc(Erroraddr));
-     dump_stack(pstdout^,ErrorBase);
+     dump_stack(pstdout^,ErrorBase,ErrorAddr);
      Writeln(pstdout^,'');
    End;
 
@@ -1036,6 +1072,15 @@ begin
 *)
 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);
+begin
+  get_caller_stackinfo (frame, addr);
+  HandleErrorAddrFrame (Errno,addr,frame);
+end;
+
 Procedure HandleErrorFrame (Errno : longint;frame : Pointer);
 {
   Procedure to handle internal errors, i.e. not user-invoked errors
@@ -1053,7 +1098,7 @@ Procedure fpc_handleerror (Errno : longint); compilerproc; [public,alias : 'FPC_
   Internal function should ALWAYS call HandleError instead of RunError.
 }
 begin
-  HandleErrorFrame(Errno,get_frame);
+  HandleErrorAddrFrame(Errno,get_pc_addr,get_frame);
 end;
 
 
@@ -1061,8 +1106,8 @@ procedure RunError(w : word);[alias: 'FPC_RUNERROR'];
 begin
   errorcode:=w;
 (*
-  erroraddr:=get_caller_addr(get_frame);
-  errorbase:=get_caller_frame(get_frame);
+  erroraddr:=get_caller_addr(get_frame,get_pc_addr,);
+  errorbase:=get_caller_frame(get_frame,get_pc_addr);
   *)
   Halt(errorcode);
 end;
@@ -1088,10 +1133,11 @@ end;
 
 
 {$ifndef CPUJVM}
-Procedure dump_stack(var f : text;bp : Pointer);
+Procedure dump_stack(var f : text;bp,addr : Pointer);
 var
   i : Longint;
   prevbp : Pointer;
+  prevaddr : pointer;
   is_dev : boolean;
   caller_frame,
   caller_addr : Pointer;
@@ -1100,12 +1146,13 @@ Begin
   try
 {$endif FPC_HAS_FEATURE_EXCEPTIONS}
     prevbp:=bp-1;
+    prevaddr:=nil;
     i:=0;
     is_dev:=do_isdevice(textrec(f).Handle);
     while bp > prevbp Do
      Begin
-       caller_addr := get_caller_addr(bp);
-       caller_frame := get_caller_frame(bp);
+       caller_addr := get_caller_addr(bp,addr);
+       caller_frame := get_caller_frame(bp,addr);
        if (caller_addr=nil) then
          break;
        Writeln(f,BackTraceStrFunc(caller_addr));
@@ -1115,7 +1162,9 @@ Begin
        If ((i>max_frame_dump) and is_dev) or (i>256) Then
          break;
        prevbp:=bp;
+       prevaddr:=addr;
        bp:=caller_frame;
+       addr:=caller_addr;
      End;
 {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
    except
@@ -1305,7 +1354,7 @@ begin
   If pointer(AbstractErrorProc)<>nil then
     AbstractErrorProc();
 *)
-  HandleErrorFrame(211,get_frame);
+  HandleErrorAddrFrameInd(211,get_pc_addr,get_frame);
 end;
 
 
@@ -1315,7 +1364,7 @@ begin
   if pointer(AssertErrorProc)<>nil then
     AssertErrorProc(Msg,FName,LineNo,ErrorAddr)
   else
-    HandleErrorFrame(227,get_frame);
+    HandleErrorAddrFrameInd(227,get_pc_addr,get_frame);
 *)
   raise JLAssertionError.Create(JLObject(Fname+'('+unicodestring(JLInteger.valueOf(LineNo).toString)+'): '+Msg));
 end;

rtl/java/jsystemh.inc

@@ -597,7 +597,11 @@ function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;[INTERNPROC:
 {$ELSE}
 function get_frame:pointer;{$ifdef SYSTEMINLINE}inline;{$endif}
 {$ENDIF}
+
+Function Get_pc_addr : Pointer;
+
 (*
+procedure get_caller_stackinfo(var framebp,addr : pointer);
 function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;
 function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;
 *)
@@ -684,7 +688,7 @@ Function  ParamStr(l:Longint):string;
 {$endif FPC_HAS_FEATURE_COMMANDARGS}
 
 {$ifndef JVM}
-Procedure Dump_Stack(var f : text;bp:pointer);
+Procedure Dump_Stack(var f : text;bp:pointer;addr : pointer = nil);
 {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
 procedure DumpExceptionBackTrace(var f:text);
 {$endif FPC_HAS_FEATURE_EXCEPTIONS}