paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-13 12:29:14 +02:00
Code Issues Packages Projects Releases Wiki Activity

* added support for netware nlm (netware and netwlibc)

Browse Source
This commit is contained in:
armin 2004-09-18 11:06:52 +00:00
parent 3f10b1b4f6
commit 9e930c445d
1 changed files with 168 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

167
rtl/inc/lineinfo.pp
View File

@ -85,6 +85,152 @@ var
{$endif}
{$endif}
{$ifdef netwlibc}
{$define netware}
{$endif}
{$ifdef netware}
const SIZE_OF_NLM_INTERNAL_FIXED_HEADER = 130;
SIZE_OF_NLM_INTERNAL_VERSION_HEADER = 32;
SIZE_OF_NLM_INTERNAL_EXTENDED_HEADER = 124;
function loadNetwareNLM:boolean;
var valid : boolean;
name : string;
StabLength,
StabStrLength,
alignAmount,
hdrLength,
dataOffset,
dataLength : longint;
function getByte:byte;
begin
BlockRead (f,getByte,1);
end;
procedure Skip (bytes : longint);
var i : longint;
begin
for i := 1 to bytes do getbyte;
end;
function getLString : String;
var Res:string;
begin
blockread (F, res, 1);
if length (res) > 0 THEN
blockread (F, res[1], length (res));
getbyte;
getLString := res;
end;
function getFixString (Len : byte) : string;
var i : byte;
begin
getFixString := '';
for I := 1 to Len do
getFixString := getFixString + char (getbyte);
end;
function get0String : string;
var c : char;
begin
get0String := '';
c := char (getbyte);
while (c <> #0) do
begin
get0String := get0String + c;
c := char (getbyte);
end;
end;
function getword : word;
begin
blockread (F, getword, 2);
end;
function getint32 : longint;
begin
blockread (F, getint32, 4);
end;
begin
processaddress := 0;
LoadNetwareNLM:=false;
stabofs:=-1;
stabstrofs:=-1;
{ read and check header }
Skip (SIZE_OF_NLM_INTERNAL_FIXED_HEADER);
getLString; // NLM Description
getInt32; // Stacksize
getInt32; // Reserved
skip(5); // old Thread Name
getLString; // Screen Name
getLString; // Thread Name
hdrLength := -1;
dataOffset := -1;
dataLength := -1;
valid := true;
repeat
name := getFixString (8);
if (name = 'VeRsIoN#') then
begin
Skip (SIZE_OF_NLM_INTERNAL_VERSION_HEADER-8);
end else
if (name = 'CoPyRiGh') then
begin
getword; // T=
getLString; // Copyright String
end else
if (name = 'MeSsAgEs') then
begin
skip (SIZE_OF_NLM_INTERNAL_EXTENDED_HEADER - 8);
end else
if (name = 'CuStHeAd') then
begin
hdrLength := getInt32;
dataOffset := getInt32;
dataLength := getInt32;
Skip (8); // dataStamp
Valid := false;
end else
Valid := false;
until not valid;
if (hdrLength = -1) or (dataOffset = -1) or (dataLength = -1) then
exit;
(* The format of the section information is:
null terminated section name
zeroes to adjust to 4 byte boundary
4 byte section data file pointer
4 byte section size *)
Seek (F, dataOffset);
stabOfs := 0;
stabStrOfs := 0;
Repeat
Name := Get0String;
alignAmount := 4 - ((length (Name) + 1) MOD 4);
Skip (alignAmount);
if (Name = '.stab') then
begin
stabOfs := getInt32;
stabLength := getInt32;
stabcnt:=stabLength div sizeof(tstab);
end else
if (Name = '.stabstr') then
begin
stabStrOfs := getInt32;
stabStrLength := getInt32;
end else
Skip (8);
until (Name = '') or ((StabOfs <> 0) and (stabStrOfs <> 0));
Seek (F,stabOfs);
//if (StabOfs = 0) then __ConsolePrintf ('StabOfs = 0');
//if (StabStrOfs = 0) then __ConsolePrintf ('StabStrOfs = 0');
LoadNetwareNLM := ((stabOfs > 0) and (stabStrOfs > 0));
end;
{$endif}
{$ifdef go32v2}
function LoadGo32Coff:boolean;
type
@ -713,6 +859,13 @@ begin
OpenStabs:=true;
exit;
end;
{$endif}
{$ifdef netware}
if LoadNetwareNLM then
begin
OpenStabs:=true;
exit;
end;
{$endif}
CloseStabs;
end;
@ -740,6 +893,7 @@ begin
{ correct the value to the correct address in the file }
{ processaddress is set in OpenStabs }
addr := addr - processaddress;
//ScreenPrintfL1 (NWLoggerScreen,'addr: %x\n',addr);
fillchar(funcstab,sizeof(tstab),0);
fillchar(filestab,sizeof(tstab),0);
@ -812,6 +966,7 @@ begin
end;
dec(stabsleft,stabscnt);
until found or (stabsleft=0);
{ get the line,source,function info }
line:=linestab.ndesc;
if dirstab.ntype<>0 then
@ -850,11 +1005,18 @@ var
Store : TBackTraceStrFunc;
begin
{ reset to prevent infinite recursion if problems inside the code PM }
{$ifdef netware}
dec(addr,system.NWGetCodeStart); {we need addr relative to code start on netware}
{$endif}
Store:=BackTraceStrFunc;
BackTraceStrFunc:=@SysBackTraceStr;
GetLineInfo(ptruint(addr),func,source,line);
{ create string }
{$ifdef netware}
StabBackTraceStr:=' CodeStart + $'+HexStr(ptrint(addr),sizeof(ptrint)*2);
{$else}
StabBackTraceStr:=' $'+HexStr(ptrint(addr),sizeof(ptrint)*2);
{$endif}
if func<>'' then
StabBackTraceStr:=StabBackTraceStr+' '+func;
if source<>'' then
@ -883,7 +1045,10 @@ finalization
end.
{
$Log$
Revision 1.23 2004-04-28 20:48:20 peter
Revision 1.24 2004-09-18 11:06:52 armin
* added support for netware nlm (netware and netwlibc)
Revision 1.23 2004/04/28 20:48:20 peter
* ordinal-pointer conversions fixed
Revision 1.22 2004/04/22 21:10:35 peter