* lineinfo unit added which uses stabs to get lineinfo for backtraces

rtl/go32v2/Makefile

@@ -1,5 +1,5 @@
 #
-# Makefile generated by fpcmake v0.99.13 [2000/01/28]
+# Makefile generated by fpcmake v0.99.13 [2000/01/30]
 #
 
 defaultrule: all
@@ -193,7 +193,7 @@ endif
 # Targets
 
 override LOADEROBJECTS+=prt0 exceptn fpu
-override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings go32  dpmiexcp initc profile dxeload emu387 dos crt objects printer graph sysutils math typinfo cpu mmx getopts heaptrc msmouse ports
+override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings go32 dpmiexcp initc ports profile dxeload emu387 dos crt objects printer graph sysutils math typinfo cpu mmx getopts heaptrc lineinfo msmouse
 
 # Clean
 
@@ -1158,6 +1158,8 @@ dxeload$(PPUEXT) : dxeload.pp $(SYSTEMPPU)
 emu387$(PPUEXT) : emu387.pp fpu$(OEXT) strings$(PPUEXT) dxeload$(PPUEXT) \
 		  dpmiexcp$(PPUEXT)
 
+ports$(PPUEXT) : ports.pp objpas$(PPUEXT) $(SYSTEMPPU)
+
 #
 # TP7 Compatible RTL Units
 #
@@ -1209,6 +1211,11 @@ getopts$(PPUEXT) : $(INC)/getopts.pp $(SYSTEMPPU)
 heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMPPU)
 	$(COMPILER) -Sg $(INC)/heaptrc.pp $(REDIR)
 
-msmouse$(PPUEXT) : msmouse.pp $(SYSTEMPPU)
+lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMPPU)
 
-ports$(PPUEXT) : ports.pp objpas$(PPUEXT) $(SYSTEMPPU)
+
+#
+# Other system-dependent RTL Units
+#
+
+msmouse$(PPUEXT) : msmouse.pp $(SYSTEMPPU)

rtl/go32v2/Makefile.fpc

@@ -5,11 +5,11 @@
 [targets]
 loaders=prt0 exceptn fpu
 units=$(SYSTEMUNIT) objpas strings \
-      go32  dpmiexcp initc profile dxeload emu387 \
+      go32 dpmiexcp initc ports profile dxeload emu387 \
       dos crt objects printer graph \
       sysutils math typinfo \
-      cpu mmx getopts heaptrc \
+      cpu mmx getopts heaptrc lineinfo \
-      msmouse ports
+      msmouse
 
 [require]
 rtl=0
@@ -103,6 +103,8 @@ dxeload$(PPUEXT) : dxeload.pp $(SYSTEMPPU)
 emu387$(PPUEXT) : emu387.pp fpu$(OEXT) strings$(PPUEXT) dxeload$(PPUEXT) \
                   dpmiexcp$(PPUEXT)
 
+ports$(PPUEXT) : ports.pp objpas$(PPUEXT) $(SYSTEMPPU)
+
 #
 # TP7 Compatible RTL Units
 #
@@ -154,7 +156,13 @@ getopts$(PPUEXT) : $(INC)/getopts.pp $(SYSTEMPPU)
 heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMPPU)
         $(COMPILER) -Sg $(INC)/heaptrc.pp $(REDIR)
 
+lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMPPU)
+
+
+#
+# Other system-dependent RTL Units
+#
+
 msmouse$(PPUEXT) : msmouse.pp $(SYSTEMPPU)
 
-ports$(PPUEXT) : ports.pp objpas$(PPUEXT) $(SYSTEMPPU)
 

rtl/inc/lineinfo.pp

@@ -0,0 +1,420 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2000 by Peter Vreman
+
+    Stabs Line Info Retriever
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit lineinfo;
+interface
+
+implementation
+
+uses
+  strings;
+
+const
+  N_Function    = $24;
+  N_TextLine    = $44;
+  N_DataLine    = $46;
+  N_BssLine     = $48;
+  N_SourceFile  = $64;
+  N_IncludeFile = $84;
+
+  maxstabs = 40; { size of the stabs buffer }
+
+type
+  pstab=^tstab;
+  tstab=packed record
+    strpos  : longint;
+    ntype   : byte;
+    nother  : byte;
+    ndesc   : word;
+    nvalue  : longint;
+  end;
+
+{ We use static variable so almost no stack is required, and is thus
+  more safe when an error has occured in the program }
+var
+  opened     : boolean; { set if the file is already open }
+  f          : file;    { current file }
+  stabcnt,              { amount of stabs }
+  stabofs,              { absolute stab section offset in executable }
+  stabstrofs : longint; { absolute stabstr section offset in executable }
+  stabs      : array[0..maxstabs-1] of tstab;  { buffer }
+  funcstab,             { stab with current function info }
+  linestab,             { stab with current line info }
+  filestab   : tstab;   { stab with current file info }
+
+
+{****************************************************************************
+                             Executable Loaders
+****************************************************************************}
+
+{$ifdef go32v2}
+function LoadGo32Coff:boolean;
+type
+  tcoffheader=packed record
+    mach   : word;
+    nsects : word;
+    time   : longint;
+    sympos : longint;
+    syms   : longint;
+    opthdr : word;
+    flag   : word;
+    other  : array[0..27] of byte;
+  end;
+  tcoffsechdr=packed record
+    name     : array[0..7] of char;
+    vsize    : longint;
+    rvaofs   : longint;
+    datalen  : longint;
+    datapos  : longint;
+    relocpos : longint;
+    lineno1  : longint;
+    nrelocs  : word;
+    lineno2  : word;
+    flags    : longint;
+  end;
+var
+  coffheader : tcoffheader;
+  coffsec    : tcoffsechdr;
+  i : longint;
+begin
+  LoadCoff:=false;
+  stabofs:=-1;
+  stabstrofs:=-1;
+  { read and check header }
+  if filesize(f)<2048+sizeof(tcoffheader) then
+   exit;
+  seek(f,2048);
+  blockread(f,coffheader,sizeof(tcoffheader));
+  if coffheader.mach<>$14c then
+   exit;
+  { read section info }
+  for i:=1to coffheader.nSects do
+   begin
+     blockread(f,coffsec,sizeof(tcoffsechdr));
+     if (coffsec.name[4]='b') and
+        (coffsec.name[1]='s') and
+        (coffsec.name[2]='t') then
+      begin
+        if (coffsec.name[5]='s') and
+           (coffsec.name[6]='t') then
+         stabstrofs:=coffsec.datapos+2048
+        else
+         begin
+           stabofs:=coffsec.datapos+2048;
+           stabcnt:=coffsec.datalen div sizeof(tstab);
+         end;
+      end;
+   end;
+  LoadCoff:=(stabofs<>-1) and (stabstrofs<>-1);
+end;
+{$endif Go32v2}
+
+
+{$ifdef win32}
+function LoadPeCoff:boolean;
+type
+  tdosheader = packed record
+     e_magic : word;
+     e_cblp : word;
+     e_cp : word;
+     e_crlc : word;
+     e_cparhdr : word;
+     e_minalloc : word;
+     e_maxalloc : word;
+     e_ss : word;
+     e_sp : word;
+     e_csum : word;
+     e_ip : word;
+     e_cs : word;
+     e_lfarlc : word;
+     e_ovno : word;
+     e_res : array[0..3] of word;
+     e_oemid : word;
+     e_oeminfo : word;
+     e_res2 : array[0..9] of word;
+     e_lfanew : longint;
+  end;
+  tpeheader = packed record
+     PEMagic : longint;
+     Machine : word;
+     NumberOfSections : word;
+     TimeDateStamp : longint;
+     PointerToSymbolTable : longint;
+     NumberOfSymbols : longint;
+     SizeOfOptionalHeader : word;
+     Characteristics : word;
+     Magic : word;
+     MajorLinkerVersion : byte;
+     MinorLinkerVersion : byte;
+     SizeOfCode : longint;
+     SizeOfInitializedData : longint;
+     SizeOfUninitializedData : longint;
+     AddressOfEntryPoint : longint;
+     BaseOfCode : longint;
+     BaseOfData : longint;
+     ImageBase : longint;
+     SectionAlignment : longint;
+     FileAlignment : longint;
+     MajorOperatingSystemVersion : word;
+     MinorOperatingSystemVersion : word;
+     MajorImageVersion : word;
+     MinorImageVersion : word;
+     MajorSubsystemVersion : word;
+     MinorSubsystemVersion : word;
+     Reserved1 : longint;
+     SizeOfImage : longint;
+     SizeOfHeaders : longint;
+     CheckSum : longint;
+     Subsystem : word;
+     DllCharacteristics : word;
+     SizeOfStackReserve : longint;
+     SizeOfStackCommit : longint;
+     SizeOfHeapReserve : longint;
+     SizeOfHeapCommit : longint;
+     LoaderFlags : longint;
+     NumberOfRvaAndSizes : longint;
+     DataDirectory : array[1..$80] of byte;
+  end;
+  tcoffsechdr=packed record
+    name     : array[0..7] of char;
+    vsize    : longint;
+    rvaofs   : longint;
+    datalen  : longint;
+    datapos  : longint;
+    relocpos : longint;
+    lineno1  : longint;
+    nrelocs  : word;
+    lineno2  : word;
+    flags    : longint;
+  end;
+var
+  dosheader  : tdosheader;
+  peheader   : tpeheader;
+  coffsec    : tcoffsechdr;
+  i : longint;
+begin
+  LoadPeCoff:=false;
+  stabofs:=-1;
+  stabstrofs:=-1;
+  { read and check header }
+  if filesize(f)<sizeof(dosheader) then
+   exit;
+  blockread(f,dosheader,sizeof(tdosheader));
+  seek(f,dosheader.e_lfanew);
+  blockread(f,peheader,sizeof(tpeheader));
+  if peheader.pemagic<>$4550 then
+   exit;
+  { read section info }
+  for i:=1to peheader.NumberOfSections do
+   begin
+     blockread(f,coffsec,sizeof(tcoffsechdr));
+     if (coffsec.name[4]='b') and
+        (coffsec.name[1]='s') and
+        (coffsec.name[2]='t') then
+      begin
+        if (coffsec.name[5]='s') and
+           (coffsec.name[6]='t') then
+         stabstrofs:=coffsec.datapos
+        else
+         begin
+           stabofs:=coffsec.datapos;
+           stabcnt:=coffsec.datalen div sizeof(tstab);
+         end;
+      end;
+   end;
+  LoadPeCoff:=(stabofs<>-1) and (stabstrofs<>-1);
+end;
+{$endif Win32}
+
+
+{****************************************************************************
+                          Executable Open/Close
+****************************************************************************}
+
+procedure CloseStabs;
+begin
+  close(f);
+  opened:=false;
+end;
+
+
+function OpenStabs:boolean;
+var
+  ofm : word;
+begin
+  OpenStabs:=false;
+  assign(f,paramstr(0));
+  {$I-}
+   ofm:=filemode;
+   filemode:=$40;
+   reset(f,1);
+   filemode:=ofm;
+  {$I+}
+  if ioresult<>0 then
+   exit;
+  opened:=true;
+{$ifdef go32v2}
+  if LoadGo32Coff then
+   begin
+     OpenStabs:=true;
+     exit;
+   end;
+{$endif}
+{$ifdef win32}
+  if LoadPECoff then
+   begin
+     OpenStabs:=true;
+     exit;
+   end;
+{$endif}
+  CloseStabs;
+end;
+
+
+procedure GetLineInfo(addr:longint;var func,source:string;var line:longint);
+var
+  res : {$ifdef tp}integer{$else}longint{$endif};
+  stabsleft,
+  stabscnt,i : longint;
+  found : boolean;
+  lastfunc : tstab;
+begin
+  fillchar(func,high(func)+1,0);
+  fillchar(source,high(source)+1,0);
+  line:=0;
+  if not opened then
+   begin
+     if not OpenStabs then
+      exit;
+   end;
+  fillchar(funcstab,sizeof(tstab),0);
+  fillchar(filestab,sizeof(tstab),0);
+  fillchar(linestab,sizeof(tstab),0);
+  fillchar(lastfunc,sizeof(tstab),0);
+  found:=false;
+  seek(f,stabofs);
+  stabsleft:=stabcnt;
+  repeat
+    if stabsleft>maxstabs then
+     stabscnt:=maxstabs
+    else
+     stabscnt:=stabsleft;
+    blockread(f,stabs,stabscnt*sizeof(tstab),res);
+    stabscnt:=res div sizeof(tstab);
+    for i:=0 to stabscnt-1 do
+     begin
+       case stabs[i].ntype of
+         N_BssLine,
+         N_DataLine,
+         N_TextLine :
+           begin
+             inc(stabs[i].nvalue,lastfunc.nvalue);
+             if (stabs[i].nvalue<=addr) and
+                ((addr-stabs[i].nvalue)<(addr-linestab.nvalue)) then
+              begin
+                { if it's equal we can stop and take the last info }
+                if stabs[i].nvalue=addr then
+                 found:=true
+                else
+                 linestab:=stabs[i];
+              end;
+           end;
+         N_Function :
+           begin
+             lastfunc:=stabs[i];
+             if (stabs[i].nvalue<=addr) and
+                ((addr-stabs[i].nvalue)<(addr-funcstab.nvalue)) then
+              begin
+                funcstab:=stabs[i];
+                fillchar(linestab,sizeof(tstab),0);
+              end;
+           end;
+         N_SourceFile,
+         N_IncludeFile :
+           begin
+             if (stabs[i].nvalue<=addr) and
+                ((addr-stabs[i].nvalue)<(addr-filestab.nvalue)) then
+              begin
+                filestab:=stabs[i];
+                fillchar(linestab,sizeof(tstab),0);
+              end;
+           end;
+       end;
+     end;
+    dec(stabsleft,stabscnt);
+  until found or (stabsleft=0);
+{ get the line,source,function info }
+  line:=linestab.ndesc;
+  if filestab.ntype<>0 then
+   begin
+     seek(f,stabstrofs+filestab.strpos);
+     blockread(f,source[1],high(source)-1,res);
+     source[0]:=chr(strlen(@source[1]));
+   end;
+  if funcstab.ntype<>0 then
+   begin
+     seek(f,stabstrofs+funcstab.strpos);
+     blockread(f,func[1],high(func)-1,res);
+     func[0]:=chr(strlen(@func[1]));
+     i:=pos(':',func);
+     if i>0 then
+      Delete(func,i,255);
+   end;
+end;
+
+
+function StabBackTraceStr(addr:longint):string;
+var
+  func,
+  source : string;
+  hs     : string[32];
+  line   : longint;
+begin
+  GetLineInfo(addr,func,source,line);
+{ if there was an error with opening reset the hook to the system default }
+  if not Opened then
+   BackTraceStrFunc:=@SysBackTraceStr;
+{ create string }
+  StabBackTraceStr:='  0x'+HexStr(addr,8);
+  if func<>'' then
+   StabBackTraceStr:=StabBackTraceStr+'  '+func;
+  if source<>'' then
+   begin
+     if func<>'' then
+      StabBackTraceStr:=StabBackTraceStr+', ';
+     if line<>0 then
+      begin
+        str(line,hs);
+        StabBackTraceStr:=StabBackTraceStr+' line '+hs;
+      end;
+     StabBackTraceStr:=StabBackTraceStr+' of '+source;
+   end;
+end;
+
+
+initialization
+  BackTraceStrFunc:=@StabBackTraceStr;
+
+finalization
+  if opened then
+   CloseStabs;
+
+end.
+{
+  $Log$
+  Revision 1.1  2000-02-06 17:19:22  peter
+    * lineinfo unit added which uses stabs to get lineinfo for backtraces
+
+}

rtl/inc/system.inc

@@ -416,6 +416,12 @@ end;
                           Error / Exit / ExitProc
 *****************************************************************************}
 
+function SysBackTraceStr (Addr: longint): ShortString;
+begin
+  SysBackTraceStr:='  0x'+HexStr(addr,8);
+end;
+
+
 Procedure HandleErrorFrame (Errno : longint;frame : longint);
 {
   Procedure to handle internal errors, i.e. not user-invoked errors
@@ -476,7 +482,7 @@ Begin
   i:=0;
   while bp > prevbp Do
    Begin
-     Writeln(f,'  0x',HexStr(get_caller_addr(bp),8));
+     Writeln(f,BackTraceStrFunc(get_caller_addr(bp)));
      Inc(i);
      If i>max_frame_dump Then
       exit;
@@ -506,7 +512,7 @@ Begin
    Begin
      Writeln(stdout,'Runtime error ',Errorcode,' at 0x',hexstr(Longint(Erroraddr),8));
      { to get a nice symify }
-     Writeln(stdout,'  0x',HexStr(Longint(Erroraddr),8));
+     Writeln(stdout,BackTraceStrFunc(Longint(Erroraddr)));
      dump_stack(stdout,ErrorBase);
      Writeln(stdout,'');
    End;
@@ -599,7 +605,10 @@ end;
 
 {
   $Log$
-  Revision 1.80  2000-01-10 09:54:30  peter
+  Revision 1.81  2000-02-06 17:19:22  peter
+    * lineinfo unit added which uses stabs to get lineinfo for backtraces
+
+  Revision 1.80  2000/01/10 09:54:30  peter
     * primitives added
 
   Revision 1.79  2000/01/07 16:41:36  daniel

rtl/inc/systemh.inc

@@ -397,14 +397,17 @@ Procedure halt;
 *****************************************************************************}
 
 procedure AbstractError;
+Function  SysBackTraceStr(Addr: Longint): ShortString;
 Procedure SysAssert(Const Msg,FName:ShortString;LineNo,ErrorAddr:Longint);
 
 { Error handlers }
 Type
+  TBackTraceStrFunc = Function (Addr: Longint): ShortString;
   TErrorProc = Procedure (ErrNo : Longint; Address : Pointer);
   TAbstractErrorProc = Procedure;
   TAssertErrorProc = Procedure(const msg,fname:ShortString;lineno,erroraddr:longint);
 const
+  BackTraceStrFunc  : TBackTraceStrFunc = @SysBackTraceStr;
   ErrorProc         : TErrorProc = nil;
   AbstractErrorProc : TAbstractErrorProc = nil;
   AssertErrorProc   : TAssertErrorProc = @SysAssert;
@@ -425,7 +428,10 @@ const
 
 {
   $Log$
-  Revision 1.76  2000-01-21 15:32:07  jonas
+  Revision 1.77  2000-02-06 17:19:22  peter
+    * lineinfo unit added which uses stabs to get lineinfo for backtraces
+
+  Revision 1.76  2000/01/21 15:32:07  jonas
     * set FPUInt64 to false for i386, because comp mul and div code for int64 is
       commented out in int64.inc
 

rtl/linux/Makefile

@@ -202,7 +202,7 @@ endif
 # Targets
 
 override LOADEROBJECTS+=prt0 cprt0 gprt0 cprt21 gprt21
-override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings initc linux ports dos crt objects printer graph sysutils typinfo math cpu mmx getopts heaptrc errors sockets gpm ipc
+override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings linux ports initc dos crt objects printer graph sysutils typinfo math cpu mmx getopts heaptrc lineinfo errors sockets gpm ipc
 
 # Clean
 
@@ -1231,6 +1231,8 @@ getopts$(PPUEXT) : $(INC)/getopts.pp $(SYSTEMPPU)
 heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMPPU)
 	$(COMPILER) -Sg $(INC)/heaptrc.pp $(REDIR)
 
+lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMPPU)
+
 #
 # Other system-dependent RTL Units
 #

rtl/linux/Makefile.fpc

@@ -4,11 +4,11 @@
 
 [targets]
 loaders=prt0 cprt0 gprt0 cprt21 gprt21
-units=$(SYSTEMUNIT) objpas strings initc \
+units=$(SYSTEMUNIT) objpas strings \
-      linux ports \
+      linux ports initc \
       dos crt objects printer graph \
       sysutils typinfo math \
-      cpu mmx getopts heaptrc \
+      cpu mmx getopts heaptrc lineinfo \
       errors sockets gpm ipc
 
 [require]
@@ -183,6 +183,8 @@ getopts$(PPUEXT) : $(INC)/getopts.pp $(SYSTEMPPU)
 heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMPPU)
         $(COMPILER) -Sg $(INC)/heaptrc.pp $(REDIR)
 
+lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMPPU)
+
 #
 # Other system-dependent RTL Units
 #

rtl/win32/Makefile

@@ -1,5 +1,5 @@
 #
-# Makefile generated by fpcmake v0.99.13 [2000/01/28]
+# Makefile generated by fpcmake v0.99.13 [2000/01/30]
 #
 
 defaultrule: all
@@ -198,7 +198,7 @@ endif
 # Targets
 
 override LOADEROBJECTS+=wprt0 wdllprt0
-override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings windows ole2 opengl32 winsock sockets initc dos crt objects graph sysutils typinfo math cpu mmx getopts heaptrc wincrt winmouse
+override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings windows ole2 opengl32 winsock initc dos crt objects graph sysutils typinfo math cpu mmx getopts heaptrc lineinfo wincrt winmouse sockets
 
 # Clean
 
@@ -1222,6 +1222,8 @@ getopts$(PPUEXT) : $(INC)/getopts.pp $(SYSTEMPPU)
 heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMPPU)
 	$(COMPILER) -Sg $(INC)/heaptrc.pp $(REDIR)
 
+lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMPPU)
+
 #
 # Other system-dependent RTL Units
 #

rtl/win32/Makefile.fpc

@@ -5,11 +5,11 @@
 [targets]
 loaders=wprt0 wdllprt0
 units=$(SYSTEMUNIT) objpas strings \
-      windows ole2 opengl32 winsock \
+      windows ole2 opengl32 winsock initc \
-      sockets initc \
       dos crt objects graph \
       sysutils typinfo math \
-      cpu mmx getopts heaptrc wincrt winmouse
+      cpu mmx getopts heaptrc lineinfo \
+      wincrt winmouse sockets
 
 [require]
 rtl=0
@@ -167,6 +167,8 @@ getopts$(PPUEXT) : $(INC)/getopts.pp $(SYSTEMPPU)
 heaptrc$(PPUEXT) : $(INC)/heaptrc.pp $(SYSTEMPPU)
         $(COMPILER) -Sg $(INC)/heaptrc.pp $(REDIR)
 
+lineinfo$(PPUEXT) : $(INC)/lineinfo.pp $(SYSTEMPPU)
+
 #
 # Other system-dependent RTL Units
 #