1 {
2 ***************************************************************************
3 * *
4 * This source is free software; you can redistribute it and/or modify *
5 * it under the terms of the GNU General Public License as published by *
6 * the Free Software Foundation; either version 2 of the License, or *
7 * (at your option) any later version. *
8 * *
9 * This code is distributed in the hope that it will be useful, but *
10 * WITHOUT ANY WARRANTY; without even the implied warranty of *
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
12 * General Public License for more details. *
13 * *
14 * A copy of the GNU General Public License is available on the World *
15 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
16 * obtain it by writing to the Free Software Foundation, *
17 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
18 * *
19 ***************************************************************************
20
21 Author: Mattias Gaertner
22
23 Abstract:
24 Functions to parse GDB stacktraces, dismangle FPC identifiers and
25 find the stacktrace identifiers in Pascal sources.
26
27 ToDo:
28 - unit names with underscores
29 - unit names with points
30 - procs starting with underscore
31 }
32 unit CodetoolGDBTracer;
33
34 {$mode objfpc}{$H+}
35
36 interface
37
38 uses
39 Classes, SysUtils, LazLoggerBase, KeywordFuncLists, contnrs;
40
41 type
42 TCTGDBMangledItemKind = (
43 cgmiNone,
44 cgmiUnknown, // '??'
45 cgmiProgram, // program, e.g. P$identifier
likenull46 cgmiCompiler, // compiler function, like start, _start, PASCALMAIN
47 cgmiUnit, // unit, e.g. SYSTEM
48 cgmiStructure, // class, procedure
49 cgmiParameter, // function parameter name
50 cgmiParameterType, // function parameter type
51 cgmiResultType, // result type
52 cgmiError // syntax error
53 );
54 TCTGDBMangledItemTypes = set of TCTGDBMangledItemKind;
55
56 { TCTGDBMangledItem }
57
58 TCTGDBMangledItem = class
59 public
60 Kind: TCTGDBMangledItemKind;
61 Identifier: string;
AsStringnull62 function AsString: string;
63 end;
64
65 TCTArrayOfGDBMangledItems = array of TCTGDBMangledItem;
66
67
68 { TCTGDBTraceLine }
69
70 TCTGDBTraceLine = class
71 public
72 LineNumber: integer; // 1 based
73 Source: string;
74 Depth: integer;
75 MangledIdentifier: string;
76 GDBAddress: string; // e.g. '0x007489de'
77 GDBFilename: string;
78 GDBLine, GDBCol: integer;
79 MangledItems: TCTArrayOfGDBMangledItems;
80 Error: string;
81 ErrorCol: integer;
82 constructor Create;
83 destructor Destroy; override;
84 procedure WriteToStream(Indent: integer; s: TStream);
85 procedure Parse;
86 end;
87
88 { TCTGDBTracer }
89
90 TCTGDBTracer = class
91 private
92 fLines: TObjectList; // list of TCTGDBTraceLine
93 FTraceText: string;
94 fCurP: PChar;
95 fLineStart: PChar;
96 fLineNumber: integer;
GetCurrentLinenull97 function GetCurrentLine: string;
98 procedure AddUnknownLine;
GetLineCountnull99 function GetLineCount: integer;
GetLinesnull100 function GetLines(Index: integer): TCTGDBTraceLine;
101 procedure SetTraceText(AValue: string);
102 procedure SkipLine;
103 procedure TraceToLines;
104 public
105 constructor Create;
106 destructor Destroy; override;
107 procedure Clear;
108 property TraceText: string read FTraceText write SetTraceText;
109 property LineCount: integer read GetLineCount;
110 property Lines[Index: integer]: TCTGDBTraceLine read GetLines;
AsStringnull111 function AsString: string;
112 procedure WriteToStream(s: TStream);
113 procedure ParseLines;
114 end;
115
116 procedure DemangleGDBIdentifier(Mangled: string;
117 var MangledItems: TCTArrayOfGDBMangledItems);
118
dbgsnull119 function dbgs(k: TCTGDBMangledItemKind): string; overload;
dbgsnull120 function dbgs(Mangles: TCTArrayOfGDBMangledItems): string; overload;
121
122 implementation
123
124 procedure DemangleGDBIdentifier(Mangled: string;
125 var MangledItems: TCTArrayOfGDBMangledItems);
126 { examples:
127 fpc_raiseexception
128 SYSUTILS_RUNERRORTOEXCEPT$LONGINT$POINTER$POINTER
129 ??
130 EXTTOOLEDITDLG_TEXTERNALTOOLMENUITEMS_$__LOAD$TCONFIGSTORAGE$$TMODALRESULT
131 PASCALMAIN
132 SYSTEM_FPC_SYSTEMMAIN$LONGINT$PPCHAR$PPCHAR
133
134 P$TESTSTACKTRACE1_TMAINCLASS_$_TSUBCLASS_$__RAISESOMETHING$ANSISTRING
135 start
136 }
137
138 procedure Add(Kind: TCTGDBMangledItemKind; const Identifier: string);
139 var
140 l: Integer;
141 Item: TCTGDBMangledItem;
142 begin
143 Item:=TCTGDBMangledItem.Create;
144 Item.Kind:=Kind;
145 Item.Identifier:=Identifier;
146 l:=length(MangledItems);
147 SetLength(MangledItems,l+1);
148 MangledItems[l]:=Item;
149 end;
150
151 var
152 p: PChar;
153 StartP: PChar;
154
Extractnull155 function Extract: string;
156 begin
157 Result:=copy(Mangled,StartP-PChar(Mangled)+1,p-StartP);
158 end;
159
160 procedure ExpectedButFound(const Expected: string);
161 begin
162 Add(cgmiError,'expected '+Expected+', but found '
163 +dbgstr(p^)+' after "'+dbgstr(Mangled,1,p-PChar(Mangled))+'"');
164 end;
165
ReadIdentifiernull166 function ReadIdentifier: boolean;
167 begin
168 if not (p^ in ['a'..'z','A'..'Z']) then begin
169 ExpectedButFound('identifier');
170 exit(false);
171 end;
172 StartP:=p;
173 while p^ in ['a'..'z','A'..'Z'] do inc(p);
174 Result:=true;
175 end;
176
177 var
178 Identifier: String;
179 begin
180 SetLength(MangledItems,0);
181 if Mangled='' then exit;
182 p:=PChar(Mangled);
183 if p^='?' then begin
184 // for example: ??
185 Add(cgmiUnknown,Mangled);
186 exit;
187 end;
188 if (p^='P') and (p^='$') then begin
189 // program, for example: P$TESTSTACKTRACE1
190 inc(p,2);
191 StartP:=p;
192 while p^ in ['a'..'z','A'..'Z'] do inc(p);
193 Add(cgmiProgram,Extract);
194 end else if p^ in ['A'..'Z','a'..'z'] then begin
195 StartP:=p;
196 while p^ in ['a'..'z','A'..'Z'] do inc(p);
197 Identifier:=Extract;
198 if p^=#0 then begin
e.g.null199 // Compiler function, e.g. start, _start, PASCALMAIN
200 Add(cgmiCompiler,Identifier);
201 exit;
202 end;
203 // unit, for example SYSTEM
204 Add(cgmiUnit,Identifier);
205 end else begin
206 // syntax error
207 Add(cgmiError,'unknown format');
208 exit;
209 end;
210
211 repeat
212 // read sub identifiers
213 if p^='_' then begin
214 inc(p);
215 if (p^='$') then begin
216 // for example _$_ or _$__
217 inc(p);
218 if p^<>'_' then begin
219 ExpectedButFound('_');
220 exit;
221 end;
222 inc(p);
223 if p^='_' then begin
224 // _$__
225 inc(p);
226 end;
227 end;
228 end else if p^='$' then begin
229 // parameters, p1$p2$p3
230 if MangledItems[length(MangledItems)-1].Kind<>cgmiStructure then begin
231 ExpectedButFound('_');
232 exit;
233 end;
234 repeat
235 inc(p);
236 // read parameter type
237 if not ReadIdentifier then exit;
238 Add(cgmiParameterType,Extract);
239 until (p^<>'$') or (not IsIdentStartChar[p[1]]);
240 if (p^='$') and (p[1]='$') then begin
resultnull241 // function result type
242 inc(p,2);
243 if not ReadIdentifier then exit;
244 Add(cgmiResultType,Extract);
245 end;
246 continue;
247 end else if p^=#0 then begin
248 exit;
249 end else begin
250 ExpectedButFound('_');
251 exit;
252 end;
253
254 if not ReadIdentifier then exit;
255 Add(cgmiStructure,Extract);
256 until false;
257 end;
258
dbgsnull259 function dbgs(k: TCTGDBMangledItemKind): string;
260 begin
261 case k of
262 cgmiNone: Result:='None';
263 cgmiUnknown: Result:='Unknown';
264 cgmiProgram: Result:='Program';
265 cgmiCompiler: Result:='Compiler';
266 cgmiUnit: Result:='Unit';
267 cgmiStructure: Result:='Structure';
268 cgmiParameter: Result:='Parameter';
269 cgmiParameterType: Result:='ParameterType';
270 cgmiResultType: Result:='ResultType';
271 cgmiError: Result:='Error';
272 else Result:='?';
273 end;
274 end;
275
dbgsnull276 function dbgs(Mangles: TCTArrayOfGDBMangledItems): string;
277 var
278 i: Integer;
279 begin
280 Result:='[';
281 for i:=0 to length(Mangles)-1 do begin
282 if i>0 then Result+=',';
283 Result+=Mangles[i].AsString;
284 end;
285 Result+=']';
286 end;
287
288 { TCTGDBMangledItem }
289
AsStringnull290 function TCTGDBMangledItem.AsString: string;
291 begin
292 Result:=dbgs(Kind)+':'+Identifier;
293 end;
294
295 { TCTGDBTraceLine }
296
297 constructor TCTGDBTraceLine.Create;
298 begin
299 Depth:=-1;
300 end;
301
302 destructor TCTGDBTraceLine.Destroy;
303 begin
304 inherited Destroy;
305 end;
306
307 procedure TCTGDBTraceLine.WriteToStream(Indent: integer; s: TStream);
308
309 procedure w(const h: string);
310 begin
311 if h='' then exit;
312 s.Write(h[1],length(h));
313 end;
314
315 begin
316 // source
317 w(Space(Indent));
318 w('Source={'+Source+'}');
319 w(LineEnding);
320 // error
321 if Error<>'' then begin
322 w(Space(Indent));
323 w('Error(');
324 w(IntToStr(LineNumber));
325 if ErrorCol>0 then begin
326 w(',');
327 w(IntToStr(ErrorCol));
328 end;
329 w('): '+Error);
330 w(LineEnding);
331 end;
332 if MangledIdentifier<>'' then begin
333 w(Space(Indent));
334 w('MangledIdentifier='+MangledIdentifier);
335 w(LineEnding);
336 if length(MangledItems)>0 then begin
337 w(Space(Indent));
338 w('Demangled='+dbgs(MangledItems));
339 w(LineEnding);
340 end;
341 end;
342 if GDBFilename<>'' then begin
343 w(Space(Indent));
344 w('GDB Source position='+GDBFilename+'('+IntToStr(GDBLine)+','+IntToStr(GDBCol)+')');
345 w(LineEnding);
346 end;
347 end;
348
349 procedure TCTGDBTraceLine.Parse;
350 { Examples:
351 #0 0x00020e16 in fpc_raiseexception ()
352 #2 0x00024e48 in SYSTEM_HANDLEERRORADDRFRAME$LONGINT$POINTER$POINTER ()
353 #3 0xbffff548 in ?? ()
354 #9 0x00011124 in PASCALMAIN ()
355
356 #0 DOHANDLEMOUSEACTION (this=0x14afae00, ANACTIONLIST=0x14a96af8,ANINFO=...) at synedit.pp:3000
357 }
358 var
359 p: PChar;
360 i: Integer;
361 StartP: PChar;
362 Level: Integer;
363
364 procedure UnexpectedError(Expected: string);
365 begin
366 ErrorCol:=p-PChar(Source)+1;
367 Error:='expected ' +Expected+', but found '+DbgStr(p^);
368 end;
369
370 begin
371 Depth:=-1;
372 MangledIdentifier:='';
373 GDBAddress:='';
374 GDBFilename:='';
375 GDBLine:=0;
376 GDBCol:=0;
377
378 if Source='' then begin
379 Error:='Empty line';
380 exit;
381 end;
382 p:=PChar(Source);
383
384 // read #
385 while p^ in [' ',#9] do inc(p);
386 if p^<>'#' then begin
387 UnexpectedError('#');
388 exit;
389 end;
390 inc(p);
391
392 // read stack depth number (decimal)
393 if not (p^ in ['0'..'9']) then begin
394 UnexpectedError('decimal number');
395 exit;
396 end;
397 i:=0;
398 while p^ in ['0'..'9'] do begin
399 if i>100000 then begin
400 UnexpectedError('short decimal number');
401 exit;
402 end;
403 i:=i*10+ord(p^)-ord('0');
404 inc(p);
405 end;
406 Depth:=i;
407
408 // skip space
409 while p^ in [' ',#9] do inc(p);
410
411 if (p^='0') and (p[1]='x') then begin
412 // format: <hexnumber> in <mangledidentifier> ()
413 StartP:=p;
414 inc(p,2);
415 while IsHexNumberChar[p^] do inc(p);
416 GDBAddress:=copy(Source,StartP-PChar(Source)+1,p-StartP);
417
418 // skip space
419 while p^ in [' ',#9] do inc(p);
420
421 // read 'in'
422 if (p^<>'i') or (p[1]<>'n') then begin
423 UnexpectedError('in');
424 exit;
425 end;
426 inc(p,2);
427
428 // skip space
429 while p^ in [' ',#9] do inc(p);
430 end;
431
432 if (p^ in ['A'..'Z','a'..'z','_','?','$']) then begin
433 // format: <gdbidentifier> (<parameter list>) at gdbfilename:gdbline
434 // format: <mangledidentifier> ()
435
436 // read identifier
437 StartP:=p;
438 while p^ in ['a'..'z','A'..'Z','0'..'9','_','?','$'] do inc(p);
439 MangledIdentifier:=copy(Source,StartP-PChar(Source)+1,p-StartP);
440
441 // skip space
442 while p^ in [' ',#9] do inc(p);
443
444 if p^='(' then begin
445 // read parameters
446 Level:=0;
447 repeat
448 case p^ of
449 '(':
450 begin
451 inc(Level);
452 inc(p);
453 end;
454 ')':
455 begin
456 inc(p);
457 dec(Level);
458 if Level=0 then break;
459 end;
460 #0:
461 exit;
462 else
463 inc(p);
464 end;
465 until false;
466 // skip space
467 while p^ in [' ',#9] do inc(p);
468 end;
469
470 // read 'at'
471 if (p^='a') and (p[1]='t') then begin
472 inc(p,2);
473
474 // skip space
475 while p^ in [' ',#9] do inc(p);
476
477 // read gdbfilename:gdbline
478 StartP:=p;
479 while not (p^ in [#0,':']) do inc(p);
480 GDBFilename:=copy(Source,StartP-PChar(Source)+1,p-StartP);
481 if p^=#0 then exit;
482 inc(p);
483 StartP:=p;
484 while p^ in ['0'..'9'] do inc(p);
485 GDBLine:=StrToIntDef(copy(Source,StartP-PChar(Source)+1,p-StartP),0);
486 end else if (p^='f') and (p[1]='r') and (p[2]='o') and (p[3]='m') then begin
487 // from <filename>
488 end else if p^=#0 then begin
489 // no source position => mangled
490 DemangleGDBIdentifier(MangledIdentifier,MangledItems);
491 end else begin
492 UnexpectedError('at');
493 exit;
494 end;
495
496 end else begin
497 // unknown format
498 UnexpectedError('hexnumber');
499 exit;
500 end;
501 end;
502
503 { TCTGDBTracer }
504
505 procedure TCTGDBTracer.SetTraceText(AValue: string);
506 begin
507 if FTraceText=AValue then Exit;
508 Clear;
509 FTraceText:=AValue;
510 TraceToLines;
511 end;
512
TCTGDBTracer.GetLineCountnull513 function TCTGDBTracer.GetLineCount: integer;
514 begin
515 Result:=fLines.Count;
516 end;
517
GetLinesnull518 function TCTGDBTracer.GetLines(Index: integer): TCTGDBTraceLine;
519 begin
520 Result:=TCTGDBTraceLine(fLines[Index]);
521 end;
522
523 procedure TCTGDBTracer.SkipLine;
524 var
525 c: Char;
526 begin
527 while not (fCurP^ in [#0,#10,#13]) do inc(fCurP);
528 repeat
529 c:=fCurP^;
530 if not (c in [#10,#13]) then break;
531 inc(fCurP);
532 inc(fLineNumber);
533 if (fCurP^ in [#10,#13]) and (c<>fCurP^) then
534 inc(fCurP);
535 until false;
536 fLineStart:=fCurP;
537 end;
538
TCTGDBTracer.GetCurrentLinenull539 function TCTGDBTracer.GetCurrentLine: string;
540 var
541 LineEnd: PChar;
542 begin
543 LineEnd:=fCurP;
544 while not (LineEnd^ in [#0,#10,#13]) do inc(LineEnd);
545 Result:=copy(FTraceText,fLineStart-PChar(FTraceText)+1,LineEnd-fLineStart);
546 end;
547
548 procedure TCTGDBTracer.AddUnknownLine;
549 var
550 Line: TCTGDBTraceLine;
551 begin
552 Line:=TCTGDBTraceLine.Create;
553 Line.LineNumber:=fLineNumber;
554 Line.Source:=GetCurrentLine;
555 Line.Error:='invalid format';
556 fLines.Add(Line);
557 SkipLine;
558 end;
559
560 procedure TCTGDBTracer.TraceToLines;
561 { Example:
562
563 #0 0x00020e16 in fpc_raiseexception ()
564 #1 0x0004cb37 in SYSUTILS_RUNERRORTOEXCEPT$LONGINT$POINTER$POINTER ()
565 #3 0xbffff548 in ?? ()
566 #4 0x007489de in EXTTOOLEDITDLG_TEXTERNALTOOLMENUITEMS_$__LOAD$TCONFIGSTORAGE$$TMODALRESULT ()
567 #7 0x0007e620 in MAIN_TMAINIDE_$__LOADGLOBALOPTIONS ()
568 #9 0x00011124 in PASCALMAIN ()
569 #10 0x0002f416 in SYSTEM_FPC_SYSTEMMAIN$LONGINT$PPCHAR$PPCHAR ()
570
571 #0 0x0001136d in P$TESTSTACKTRACE1_TMAINCLASS_$_TSUBCLASS_$__RAISESOMETHING$ANSISTRING ()
572 #5 0x0001114a in start ()
573
574 ~"#0 DOHANDLEMOUSEACTION (this=0x14afae00, ANACTIONLIST=0x14a96af8,
575 ANINFO=...) at synedit.pp:3000\n"
576 ~"#1 0x00aea3e9 in FINDANDHANDLEMOUSEACTION (this=0x14afae00,
577 ABUTTON=MBLEFT, ASHIFT=..., X=233, Y=241, ACCOUNT=CCSINGLE, ADIR=CDDOWN,
578 ANAC
579 TIONRESULT=..., AWHEELDELTA=0) at synedit.pp:3307\n"
580 ~"#3 0x005e083b in DOMOUSEDOWN (this=0x14afae00, MESSAGE=...,
581 BUTTON=MBLEFT, SHIFT=...) at include/control.inc:2135\n"
582 ~"#5 0x0040d096 in DISPATCH (this=0xeebf6d4, MESSAGE=0) at
583 ../inc/objpas.inc:592\n"
584 ~"#8 0x00af3b76 in WNDPROC (this=0x14afae00, MSG=...) at synedit.pp:5740\n"
585 ~"#11 0x7673fd72 in ?? () from C:\\Windows\\system32\\user32.dll\n"
586 ~"#20 0x0040358f in main () at lazarus.pp:128\n"
587
588 }
589
590 procedure ReadLine;
591 var
592 StartP: PChar;
593 Line: String;
594 CopyStartP: PChar;
595 StartLineNumber: Integer;
596 NewLine: TCTGDBTraceLine;
597 c: Char;
598
599 procedure ConcatLine;
600 begin
601 if fCurP=CopyStartP then exit;
602 Line+=copy(FTraceText,CopyStartP-PChar(FTraceText)+1,fCurP-CopyStartP);
603 end;
604
605 begin
606 while (fCurP^ in [' ',#9]) do inc(fCurP);
607 if fCurP^='~' then begin
608 // quoted format ~"<line>"
609 inc(fCurP);
610 if fCurP^<>'"' then begin
611 AddUnknownLine;
612 exit;
613 end;
614 inc(fCurP);
615 StartP:=fCurP;
616 Line:='';
617 CopyStartP:=StartP;
618 StartLineNumber:=fLineNumber;
619 repeat
620 case fCurP^ of
621 #0:
622 begin
623 // missing closing quote
624 fCurP:=StartP;
625 fLineNumber:=StartLineNumber;
626 AddUnknownLine;
627 exit;
628 end;
629 #10,#13:
630 begin
631 ConcatLine;
632 repeat
633 c:=fCurP^;
634 if not (c in [#10,#13]) then break;
635 inc(fLineNumber);
636 inc(fCurP);
637 if (fCurP^ in [#10,#13]) and (c<>fCurP^) then
638 inc(fCurP);
639 until false;
640 CopyStartP:=fCurP;
641 end;
642 '\':
643 begin
644 ConcatLine;
645 inc(fCurP);
646 case fCurP^ of
647 'n': // ignore line breaks
648 inc(fCurP);
649 #0:
650 break;
651 else
652 Line+=fCurP^;
653 end;
654 CopyStartP:=fCurP;
655 end;
656 '"':
657 begin
658 ConcatLine;
659 inc(fCurP);
660 break;
661 end;
662 else
663 inc(fCurP);
664 end;
665 until false;
666 NewLine:=TCTGDBTraceLine.Create;
667 NewLine.LineNumber:=StartLineNumber;
668 NewLine.Source:=Line;
669 fLines.Add(NewLine);
670 // skip the rest of the line
671 SkipLine;
672 exit;
673 end else if fCurP^='#' then begin
674 // non quoted format
675 NewLine:=TCTGDBTraceLine.Create;
676 NewLine.LineNumber:=fLineNumber;
677 NewLine.Source:=GetCurrentLine;
678 fLines.Add(NewLine);
679 // skip the rest of the line
680 SkipLine;
681 exit;
682 end;
683 // unknown format
684 AddUnknownLine;
685 end;
686
687 begin
688 fLines.Clear;
689 if FTraceText='' then exit;
690 fLineNumber:=1;
691 fCurP:=PChar(FTraceText);
692 fLineStart:=fCurP;
693 while fCurP^<>#0 do
694 ReadLine;
695 end;
696
697 procedure TCTGDBTracer.ParseLines;
698 var
699 i: Integer;
700 Line: TCTGDBTraceLine;
701 begin
702 for i:=0 to LineCount-1 do begin
703 Line:=Lines[i];
704 if Line.Error<>'' then continue;
705 Line.Parse;
706 end;
707 end;
708
709 constructor TCTGDBTracer.Create;
710 begin
711 fLines:=TObjectList.Create(true);
712 end;
713
714 destructor TCTGDBTracer.Destroy;
715 begin
716 Clear;
717 FreeAndNil(fLines);
718 inherited Destroy;
719 end;
720
721 procedure TCTGDBTracer.Clear;
722 begin
723 fLines.Clear;
724 end;
725
AsStringnull726 function TCTGDBTracer.AsString: string;
727 var
728 ms: TMemoryStream;
729 begin
730 ms:=TMemoryStream.Create;
731 try
732 WriteToStream(ms);
733 ms.Position:=0;
734 SetLength(Result,ms.Size);
735 if Result<>'' then
736 ms.Read(Result[1],length(Result));
737 finally
738 ms.Free;
739 end;
740 end;
741
742 procedure TCTGDBTracer.WriteToStream(s: TStream);
743
744 procedure w(const h: string);
745 begin
746 if h='' then exit;
747 s.Write(h[1],length(h));
748 end;
749
750 var
751 i: Integer;
752 Line: TCTGDBTraceLine;
753 begin
754 for i:=0 to LineCount-1 do begin
755 Line:=Lines[i];
756 w(IntToStr(i+1)+'/'+IntToStr(LineCount)+': ');
757 Line.WriteToStream(2,s);
758 w(LineEnding);
759 end;
760 end;
761
762 end.
763
764