AROS: BackTraceStrFunc for AROS via debug.library, enable with EnableBackTraceStr()

git-svn-id: trunk@33261 -

rtl/aros/i386/execf.inc

@@ -54,6 +54,9 @@ procedure RawPutChar(c: Char); syscall AOS_ExecBase 86;
 //function RawDoFmt(const formatString : pCHAR;const dataStream : POINTER; putChProc : tPROCEDURE; putChData : POINTER): pointer;
 function RawDoFmt(const formatString : pCHAR;const dataStream : POINTER; putChProc : POINTER; putChData : POINTER): pointer; syscall LocalExecBase 87;
 
+// Debugbase
+function DecodeLocation(Addr1: Pointer; Tags: Pointer): Integer; syscall SysDebugBase 7;
+
 function GetLibAdress(Base: Pointer; Offset: LongInt): Pointer; inline;
 begin
   if Base = nil then
@@ -61,7 +64,7 @@ begin
     RawDoFmt('FPC_FILE_DEBUG: Error! Illegal library access with not opened library: %d !'+#10,@Offset,pointer(1),nil);
     Debugln('Illegal library access with not opened library');
     Halt(1);
-  end;  
+  end;
   GetLibAdress := Pointer((Base -(Offset * SizeOf(Pointer)))^);
 end;
 

rtl/aros/system.pp

@@ -71,6 +71,8 @@ var
   AOS_ConName  : PChar ='CON:10/30/620/100/FPC Console Output/AUTO/CLOSE/WAIT';
   AOS_ConHandle: THandle;
 
+  SysDebugBase: Pointer = nil;
+
   argc: LongInt;
   argv: PPChar;
   envp: PPChar;
@@ -79,6 +81,7 @@ var
 function GetLibAdress(Base: Pointer; Offset: LongInt): Pointer;
 procedure Debug(s: string);
 procedure Debugln(s: string);
+procedure EnableBackTraceStr;
 
 implementation
 
@@ -132,13 +135,19 @@ begin
     if (oldDirLock<>0) and (oldDirLock<>ASYS_origDir) then
       Unlock(oldDirLock);
   end;
+  // debug lib
+  if SysDebugBase <> nil then
+    CloseLibrary(SysDebugBase);
+  SysDebugBase := nil;
+  // utility
   if AOS_UtilityBase <> nil then
     CloseLibrary(AOS_UtilityBase);
+  // Heap
   if ASYS_heapPool <> nil then
     DeletePool(ASYS_heapPool);
   AOS_UtilityBase := nil;
   ASYS_HeapPool := nil;
-  //
+  // dos
   if AOS_DOSBase<>nil then
     CloseLibrary(AOS_DOSBase);
   AOS_DOSBase := nil;
@@ -428,7 +437,11 @@ begin
   if AOS_wbMsg = nil then begin
     StdInputHandle := THandle(dosInput);
     StdOutputHandle := THandle(dosOutput);
+    {$ifdef CPU64}
+    StdErrorHandle := THandle(DosOutput);
+    {$else}
     StdErrorHandle := THandle(DosError1);
+    {$endif}
   end else begin
     AOS_ConHandle := Open(AOS_ConName, MODE_OLDFILE);
     if AOS_ConHandle <> 0 then begin
@@ -440,6 +453,52 @@ begin
   end;
 end;
 
+function AROSBackTraceStr(Addr: CodePointer): ShortString;
+const
+  DL_Dummy = TAG_USER + $03e00000;
+  DL_ModuleName = DL_Dummy + 1;
+  DL_SymbolName = DL_Dummy + 7;
+var
+  SymName, ModName: PChar;
+  Tags: array[0..5] of PtrUInt;
+  s: AnsiString;
+  Res: AnsiString;
+begin
+  if Assigned(SysDebugBase) then
+  begin
+    ModName := nil;
+    SymName := nil;
+    Tags[0] := DL_Modulename;
+    Tags[1] := PtrUInt(@ModName);
+    Tags[2] := DL_SymbolName;
+    Tags[3] := PtrUInt(@SymName);
+    Tags[4] := 0;
+    Tags[5] := 0;
+    DecodeLocation(Addr, @Tags[0]);
+    s := '-';
+    if not Assigned(ModName) then
+      ModName := @S[1];
+    if not Assigned(SymName) then
+      SymName := @S[1];
+    Res := '  $' + HexStr(Addr) + ' ' + ModName  + ' ' + SymName;
+    AROSBackTraceStr := Copy(Res, 1, 254);
+  end
+  else
+  begin
+    AROSBackTraceStr := '  $' + HexStr(Addr) + ' - ';
+  end;
+end;
+
+procedure EnableBackTraceStr;
+begin
+  if not Assigned(SysDebugBase) then
+  begin
+    SysDebugBase := OpenLibrary('debug.library', 0);
+    if Assigned(SysDebugBase) then
+      BackTraceStrFunc := @AROSBackTraceStr;
+  end;
+end;
+
 
 procedure SysInitStdIO;
 begin