paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-09 06:08:55 +02:00
Code Issues Packages Projects Releases Wiki Activity

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

Browse Source 
git-svn-id: trunk@33261 -
This commit is contained in:
marcus 2016-03-17 19:12:56 +00:00
parent 2fe3a342f2
commit 62c4ff0e21
2 changed files with 64 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
rtl/aros/i386/execf.inc
View File

@ -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;

61
rtl/aros/system.pp
View File

@ -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