summaryrefslogtreecommitdiff
path: root/fpcsrc/tests/tbs/tb0001.pp
blob: b1d6be095ad6c96c2f3950e35ae1d3dd67435893 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
{ %CPU=i386 }
{ %OPT=-O2  }
{ Old file: tbs0002.pp }
{  tests for the endless bugs in the optimizer          OK 0.9.2 }

unit tb0001;

  interface

  implementation

{$message starting hexstr}
    function hexstr(val : longint;cnt : byte) : string;

      const
         hexval : string[16]=('0123456789ABCDEF');

      var
         s : string;
         l2,i : integer;
         l1 : longInt;

      begin
         s[0]:=char(cnt);
         l1:=longint($f) shl (4*(cnt-1));
         for i:=1 to cnt do
           begin
              l2:=(val and l1) shr (4*(cnt-i));
              l1:=l1 shr 4;
              s[i]:=hexval[l2+1];
           end;
         hexstr:=s;
      end;

{$message starting dump_stack}

    procedure dump_stack(bp : longint);

{$message starting get_next_frame}

      function get_next_frame(bp : longint) : longint;

        begin
           asm
              movl bp,%eax
              movl (%eax),%eax
              movl %eax,__RESULT
           end ['EAX'];
        end;

      procedure dump_frame(addr : longint);

        begin
           { to be used by symify }
           writeln('  0x',HexStr(addr,8));
        end;

{$message starting get_addr}

      function get_addr(BP : longint) : longint;

        begin
           asm
              movl BP,%eax
              movl 4(%eax),%eax
              movl %eax,__RESULT
           end ['EAX'];
        end;

{$message starting main}

      var
         i,prevbp : longint;

      begin
         prevbp:=bp-1;
         i:=0;
         while bp > prevbp do
           begin
              dump_frame(get_addr(bp));
              i:=i+1;
              if i>max_frame_dump then exit;
              prevbp:=bp;
              bp:=get_next_frame(bp);
           end;
      end;

end.