← Back to branch summary

~ubuntu-branches/ubuntu/saucy/lazarus/saucy

« back to all changes in this revision

Viewing changes to components/lazutils/ttdebug.pas

  • Committer: Package Import Robot
  • Author(s): Paul Gevers, Abou Al Montacir, Bart Martens, Paul Gevers
  • Date: 2013-06-08 14:12:17 UTC
  • mfrom: (1.1.9)
  • Revision ID: package-import@ubuntu.com-20130608141217-7k0cy9id8ifcnutc
Tags: 1.0.8+dfsg-1
http://bugs.debian.org/708695
[ Abou Al Montacir ]
* New upstream major release and multiple maintenace release offering many
  fixes and new features marking a new milestone for the Lazarus development
  and its stability level.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_fixes_branch
* LCL changes:
  - LCL is now a normal package.
      + Platform independent parts of the LCL are now in the package LCLBase
      + LCL is automatically recompiled when switching the target platform,
        unless pre-compiled binaries for this target are already installed.
      + No impact on existing projects.
      + Linker options needed by LCL are no more added to projects that do
        not use the LCL package.
  - Minor changes in LCL basic classes behaviour
      + TCustomForm.Create raises an exception if a form resource is not
        found.
      + TNotebook and TPage: a new implementation of these classes was added.
      + TDBNavigator: It is now possible to have focusable buttons by setting
        Options = [navFocusableButtons] and TabStop = True, useful for
        accessibility and for devices with neither mouse nor touch screen.
      + Names of TControlBorderSpacing.GetSideSpace and GetSpace were swapped
        and are now consistent. GetSideSpace = Around + GetSpace.
      + TForm.WindowState=wsFullscreen was added
      + TCanvas.TextFitInfo was added to calculate how many characters will
        fit into a specified Width. Useful for word-wrapping calculations.
      + TControl.GetColorResolvingParent and
        TControl.GetRGBColorResolvingParent were added, simplifying the work
        to obtain the final color of the control while resolving clDefault
        and the ParentColor.
      + LCLIntf.GetTextExtentExPoint now has a good default implementation
        which works in any platform not providing a specific implementation.
        However, Widgetset specific implementation is better, when available.
      + TTabControl was reorganized. Now it has the correct class hierarchy
        and inherits from TCustomTabControl as it should.
  - New unit in the LCL:
      + lazdialogs.pas: adds non-native versions of various native dialogs,
        for example TLazOpenDialog, TLazSaveDialog, TLazSelectDirectoryDialog.
        It is used by widgetsets which either do not have a native dialog, or
        do not wish to use it because it is limited. These dialogs can also be
        used by user applications directly.
      + lazdeviceapis.pas: offers an interface to more hardware devices such
        as the accelerometer, GPS, etc. See LazDeviceAPIs
      + lazcanvas.pas: provides a TFPImageCanvas descendent implementing
        drawing in a LCL-compatible way, but 100% in Pascal.
      + lazregions.pas. LazRegions is a wholly Pascal implementation of
        regions for canvas clipping, event clipping, finding in which control
        of a region tree one an event should reach, for drawing polygons, etc.
      + customdrawncontrols.pas, customdrawndrawers.pas,
        customdrawn_common.pas, customdrawn_android.pas and
        customdrawn_winxp.pas: are the Lazarus Custom Drawn Controls -controls
        which imitate the standard LCL ones, but with the difference that they
        are non-native and support skinning.
  - New APIs added to the LCL to improve support of accessibility software
    such as screen readers.
* IDE changes:
  - Many improvments.
  - The detailed list of changes can be found here:
    http://wiki.lazarus.freepascal.org/New_IDE_features_since#v1.0_.282012-08-29.29
    http://wiki.lazarus.freepascal.org/Lazarus_1.0_release_notes#IDE_Changes
* Debugger / Editor changes:
  - Added pascal sources and breakpoints to the disassembler
  - Added threads dialog.
* Components changes:
  - TAChart: many fixes and new features
  - CodeTool: support Delphi style generics and new syntax extensions.
  - AggPas: removed to honor free licencing. (Closes: Bug#708695)
[Bart Martens]
* New debian/watch file fixing issues with upstream RC release.
[Abou Al Montacir]
* Avoid changing files in .pc hidden directory, these are used by quilt for
  internal purpose and could lead to surprises during build.
[Paul Gevers]
* Updated get-orig-source target and it compinion script orig-tar.sh so that they
  repack the source file, allowing bug 708695 to be fixed.

Show diffs side-by-side

added added

removed removed

Lines of Context:
components/lazutils/ttdebug.pas
 
1
(*******************************************************************
 
2
 *
 
3
 *  TTDebug.Pas                                                 1.2
 
4
 *
 
5
 *    This unit is only used by the debugger.                
 
6
 *
 
7
 *  Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg
 
8
 *
 
9
 *  This file is part of the FreeType project, and may only be used
 
10
 *  modified and distributed under the terms of the FreeType project
 
11
 *  license, LICENSE.TXT. By continuing to use, modify or distribute
 
12
 *  this file you indicate that you have read the license and
 
13
 *  understand and accept it fully.
 
14
 *
 
15
 ******************************************************************)
 
16
 
 
17
unit TTDebug;
 
18
 
 
19
interface
 
20
 
 
21
{$mode Delphi}
 
22
 
 
23
uses SysUtils, TTTypes, TTObjs;
 
24
 
 
25
type
 
26
 
 
27
  ByteHexStr  = string[2];    (* hex representation of a byte  *)
 
28
  ShortHexStr = string[4];    (*  "         "         "  short *)
 
29
  LongHexStr  = string[8];    (*  "         "         "  long  *)
 
30
  DebugStr    = string[128];  (* disassembled line output      *)
 
31
 
 
32
  { TBreakPoint }
 
33
 
 
34
  { A simple record to hold breakpoint information   }
 
35
  { it may be completed later with pass count, etc.. }
 
36
  { They must be in a sorted linked list             }
 
37
 
 
38
  PBreakPoint = ^TBreakPoint;
 
39
  TBreakPoint = record
 
40
                  Next     : PBreakPoint;
 
41
                  Range    : Int;
 
42
                  Address  : Int;
 
43
                end;
 
44
 
 
45
  { TRangeRec }
 
46
 
 
47
  { a record to store line number information and breakpoints list }
 
48
 
 
49
  PRangeRec = ^TRangeRec;
 
50
  TRangeRec = record
 
51
                Code         : PByte;
 
52
                Size         : Int;
 
53
                index        : Int;
 
54
                NLines       : Int;
 
55
                Disassembled : PUShort;
 
56
                Breaks       : PBreakPoint;
 
57
              end;
 
58
 
 
59
 
 
60
{ Generate_Range : Generate Line Number information specific to }
 
61
{                  a given range                                }
 
62
 
 
63
procedure Generate_Range( CR     : PCodeRange;
 
64
                          index  : Int;
 
65
                          var RR : TRangeRec );
 
66
 
 
67
{ Throw_Range : Discard Line Number Information }
 
68
 
 
69
procedure Throw_Range( var RR : TRangeRec );
 
70
 
 
71
{ Toggle_Break : Toggle a breakpoint }
 
72
 
 
73
procedure Toggle_Break( var Head : PBreakPoint; Range, Adr : Int );
 
74
 
 
75
{ Set_Break : Set a breakpoint on a given address }
 
76
 
 
77
procedure Set_Break  ( var Head : PBreakPoint; Range, Adr : Int );
 
78
 
 
79
{ Clear_Break : Clear one specific breakpoint }
 
80
 
 
81
procedure Clear_Break( var Head : PBreakPoint; Bp : PBreakPoint );
 
82
 
 
83
{ Clear_All_Breaks : Clear breakpoint list }
 
84
 
 
85
procedure Clear_All_Breaks( var Head : PBreakPoint );
 
86
 
 
87
{ Find_Breakpoint : find one breakpoint at a given address }
 
88
 
 
89
function Find_BreakPoint( Head : PBreakPoint; Range, IP : Int ) : PBreakPoint;
 
90
 
 
91
{ Cur_U_Line : returns the current disassembled line at Code(IP) }
 
92
 
 
93
function Cur_U_Line( Code : PByte; IP : Int ) : DebugStr;
 
94
 
 
95
{ Get_Length : returns the length of the current opcode at Code(IP) }
 
96
 
 
97
function Get_Length( Code : PByte; IP : Int ) : Int;
 
98
 
 
99
function Get_Dis_Line( var cr : TRangeRec; addr : Int ) : Int;
 
100
 
 
101
 
 
102
{ Hex_N : returns an hexadecimal string }
 
103
 
 
104
function Hex8 ( B : Byte ) : ByteHexStr;
 
105
function Hex16( W : word ) : ShortHexStr;
 
106
function Hex32( L : Long ) : LongHexStr;
 
107
 
 
108
 
 
109
implementation
 
110
 
 
111
{type
 
112
  TStorageLong = record           (* do-it-all union record type *)
 
113
                   case Byte of
 
114
                    0 : ( L      : LongInt );
 
115
                    1 : ( S1, S2 : Integer );
 
116
                    2 : ( W1, W2 : Word );
 
117
                    3 : ( B1, B2,
 
118
                          B3, B4 : Byte );
 
119
                    4 : ( P      : Pointer );
 
120
                  end;
 
121
}
 
122
const
 
123
  OpStr : array[ 0..255 ] of String[10]
 
124
        = (
 
125
            'SVTCA y',       (* Set vectors to coordinate axis y    *)
 
126
            'SVTCA x',       (* Set vectors to coordinate axis x    *)
 
127
            'SPvTCA y',      (* Set Proj. vec. to coord. axis y     *)
 
128
            'SPvTCA x',      (* Set Proj. vec. to coord. axis x     *)
 
129
            'SFvTCA y',      (* Set Free. vec. to coord. axis y     *)
 
130
            'SFvTCA x',      (* Set Free. vec. to coord. axis x     *)
 
131
            'SPvTL //',      (* Set Proj. vec. parallel to segment  *)
 
132
            'SPvTL +',       (* Set Proj. vec. normal to segment    *)
 
133
            'SFvTL //',      (* Set Free. vec. parallel to segment  *)
 
134
            'SFvTL +',       (* Set Free. vec. normal to segment    *)
 
135
            'SPvFS',         (* Set Proj. vec. from stack           *)
 
136
            'SFvFS',         (* Set Free. vec. from stack           *)
 
137
            'GPV',           (* Get projection vector               *)
 
138
            'GFV',           (* Get freedom vector                  *)
 
139
            'SFvTPv',        (* Set free. vec. to proj. vec.        *)
 
140
            'ISECT',         (* compute intersection                *)
 
141
 
 
142
            'SRP0',          (* Set reference point 0               *)
 
143
            'SRP1',          (* Set reference point 1               *)
 
144
            'SRP2',          (* Set reference point 2               *)
 
145
            'SZP0',          (* Set Zone Pointer 0                  *)
 
146
            'SZP1',          (* Set Zone Pointer 1                  *)
 
147
            'SZP2',          (* Set Zone Pointer 2                  *)
 
148
            'SZPS',          (* Set all zone pointers               *)
 
149
            'SLOOP',         (* Set loop counter                    *)
 
150
            'RTG',           (* Round to Grid                       *)
 
151
            'RTHG',          (* Round to Half-Grid                  *)
 
152
            'SMD',           (* Set Minimum Distance                *)
 
153
            'ELSE',          (* Else                                *)
 
154
            'JMPR',          (* Jump Relative                       *)
 
155
            'SCvTCi',        (* Set CVT                             *)
 
156
            'SSwCi',         (*                                     *)
 
157
            'SSW',           (*                                     *)
 
158
 
 
159
            'DUP',
 
160
            'POP',
 
161
            'CLEAR',
 
162
            'SWAP',
 
163
            'DEPTH',
 
164
            'CINDEX',
 
165
            'MINDEX',
 
166
            'AlignPTS',
 
167
            'INS_$28',
 
168
            'UTP',
 
169
            'LOOPCALL',
 
170
            'CALL',
 
171
            'FDEF',
 
172
            'ENDF',
 
173
            'MDAP[-]',
 
174
            'MDAP[r]',
 
175
 
 
176
            'IUP[y]',
 
177
            'IUP[x]',
 
178
            'SHP[0]',
 
179
            'SHP[1]',
 
180
            'SHC[0]',
 
181
            'SHC[1]',
 
182
            'SHZ[0]',
 
183
            'SHZ[1]',
 
184
            'SHPIX',
 
185
            'IP',
 
186
            'MSIRP[0]',
 
187
            'MSIRP[1]',
 
188
            'AlignRP',
 
189
            'RTDG',
 
190
            'MIAP[-]',
 
191
            'MIAP[r]',
 
192
 
 
193
            'NPushB',
 
194
            'NPushW',
 
195
            'WS',
 
196
            'RS',
 
197
            'WCvtP',
 
198
            'RCvt',
 
199
            'GC[0]',
 
200
            'GC[1]',
 
201
            'SCFS',
 
202
            'MD[0]',
 
203
            'MD[1]',
 
204
            'MPPEM',
 
205
            'MPS',
 
206
            'FlipON',
 
207
            'FlipOFF',
 
208
            'DEBUG',
 
209
 
 
210
            'LT',
 
211
            'LTEQ',
 
212
            'GT',
 
213
            'GTEQ',
 
214
            'EQ',
 
215
            'NEQ',
 
216
            'ODD',
 
217
            'EVEN',
 
218
            'IF',
 
219
            'EIF',
 
220
            'AND',
 
221
            'OR',
 
222
            'NOT',
 
223
            'DeltaP1',
 
224
            'SDB',
 
225
            'SDS',
 
226
 
 
227
            'ADD',
 
228
            'SUB',
 
229
            'DIV',
 
230
            'MUL',
 
231
            'ABS',
 
232
            'NEG',
 
233
            'FLOOR',
 
234
            'CEILING',
 
235
            'ROUND[G]',
 
236
            'ROUND[B]',
 
237
            'ROUND[W]',
 
238
            'ROUND[?]',
 
239
            'NROUND[G]',
 
240
            'NROUND[B]',
 
241
            'NROUND[W]',
 
242
            'NROUND[?]',
 
243
 
 
244
            'WCvtF',
 
245
            'DeltaP2',
 
246
            'DeltaP3',
 
247
            'DeltaC1',
 
248
            'DeltaC2',
 
249
            'DeltaC3',
 
250
            'SROUND',
 
251
            'S45Round',
 
252
            'JROT',
 
253
            'JROF',
 
254
            'ROFF',
 
255
            'INS_$7B',
 
256
            'RUTG',
 
257
            'RDTG',
 
258
            'SANGW',
 
259
            'AA',
 
260
 
 
261
            'FlipPT',
 
262
            'FlipRgON',
 
263
            'FlipRgOFF',
 
264
            'INS_$83',
 
265
            'INS_$84',
 
266
            'ScanCTRL',
 
267
            'SDPVTL[0]',
 
268
            'SDPVTL[1]',
 
269
            'GetINFO',
 
270
            'IDEF',
 
271
            'ROLL',
 
272
            'MAX',
 
273
            'MIN',
 
274
            'ScanTYPE',
 
275
            'IntCTRL',
 
276
            'INS_$8F',
 
277
 
 
278
            'INS_$90',
 
279
            'INS_$91',
 
280
            'INS_$92',
 
281
            'INS_$93',
 
282
            'INS_$94',
 
283
            'INS_$95',
 
284
            'INS_$96',
 
285
            'INS_$97',
 
286
            'INS_$98',
 
287
            'INS_$99',
 
288
            'INS_$9A',
 
289
            'INS_$9B',
 
290
            'INS_$9C',
 
291
            'INS_$9D',
 
292
            'INS_$9E',
 
293
            'INS_$9F',
 
294
 
 
295
            'INS_$A0',
 
296
            'INS_$A1',
 
297
            'INS_$A2',
 
298
            'INS_$A3',
 
299
            'INS_$A4',
 
300
            'INS_$A5',
 
301
            'INS_$A6',
 
302
            'INS_$A7',
 
303
            'INS_$A8',
 
304
            'INS_$A9',
 
305
            'INS_$AA',
 
306
            'INS_$AB',
 
307
            'INS_$AC',
 
308
            'INS_$AD',
 
309
            'INS_$AE',
 
310
            'INS_$AF',
 
311
 
 
312
            'PushB[0]',
 
313
            'PushB[1]',
 
314
            'PushB[2]',
 
315
            'PushB[3]',
 
316
            'PushB[4]',
 
317
            'PushB[5]',
 
318
            'PushB[6]',
 
319
            'PushB[7]',
 
320
            'PushW[0]',
 
321
            'PushW[1]',
 
322
            'PushW[2]',
 
323
            'PushW[3]',
 
324
            'PushW[4]',
 
325
            'PushW[5]',
 
326
            'PushW[6]',
 
327
            'PushW[7]',
 
328
 
 
329
            'MDRP[G]',
 
330
            'MDRP[B]',
 
331
            'MDRP[W]',
 
332
            'MDRP[?]',
 
333
            'MDRP[rG]',
 
334
            'MDRP[rB]',
 
335
            'MDRP[rW]',
 
336
            'MDRP[r?]',
 
337
            'MDRP[mG]',
 
338
            'MDRP[mB]',
 
339
            'MDRP[mW]',
 
340
            'MDRP[m?]',
 
341
            'MDRP[mrG]',
 
342
            'MDRP[mrB]',
 
343
            'MDRP[mrW]',
 
344
            'MDRP[mr?]',
 
345
            'MDRP[pG]',
 
346
            'MDRP[pB]',
 
347
 
 
348
            'MDRP[pW]',
 
349
            'MDRP[p?]',
 
350
            'MDRP[prG]',
 
351
            'MDRP[prB]',
 
352
            'MDRP[prW]',
 
353
            'MDRP[pr?]',
 
354
            'MDRP[pmG]',
 
355
            'MDRP[pmB]',
 
356
            'MDRP[pmW]',
 
357
            'MDRP[pm?]',
 
358
            'MDRP[pmrG]',
 
359
            'MDRP[pmrB]',
 
360
            'MDRP[pmrW]',
 
361
            'MDRP[pmr?]',
 
362
 
 
363
            'MIRP[G]',
 
364
            'MIRP[B]',
 
365
            'MIRP[W]',
 
366
            'MIRP[?]',
 
367
            'MIRP[rG]',
 
368
            'MIRP[rB]',
 
369
            'MIRP[rW]',
 
370
            'MIRP[r?]',
 
371
            'MIRP[mG]',
 
372
            'MIRP[mB]',
 
373
            'MIRP[mW]',
 
374
            'MIRP[m?]',
 
375
            'MIRP[mrG]',
 
376
            'MIRP[mrB]',
 
377
            'MIRP[mrW]',
 
378
            'MIRP[mr?]',
 
379
            'MIRP[pG]',
 
380
            'MIRP[pB]',
 
381
 
 
382
            'MIRP[pW]',
 
383
            'MIRP[p?]',
 
384
            'MIRP[prG]',
 
385
            'MIRP[prB]',
 
386
            'MIRP[prW]',
 
387
            'MIRP[pr?]',
 
388
            'MIRP[pmG]',
 
389
            'MIRP[pmB]',
 
390
            'MIRP[pmW]',
 
391
            'MIRP[pm?]',
 
392
            'MIRP[pmrG]',
 
393
            'MIRP[pmrB]',
 
394
            'MIRP[pmrW]',
 
395
            'MIRP[pmr?]'
 
396
         );
 
397
 
 
398
const
 
399
  HexStr : string[16] = '0123456789abcdef';
 
400
 
 
401
(*******************************************************************
 
402
 *
 
403
 *  Function    :  Hex8
 
404
 *
 
405
 *  Description :  Returns the string hexadecimal representation
 
406
 *                 of a Byte.
 
407
 *
 
408
 *  Input  :  B  byte
 
409
 *
 
410
 *  Output :  two-chars string
 
411
 *
 
412
 *****************************************************************)
 
413
 
 
414
function Hex8( B : Byte ) : ByteHexStr;
 
415
var
 
416
  S : ByteHexStr;
 
417
begin
 
418
  S[0] :=#2;
 
419
  S[1] := HexStr[ 1+( B shr 4 ) ];
 
420
  S[2] := HexStr[ 1+( B and 15 )];
 
421
  Hex8 := S;
 
422
end;
 
423
 
 
424
(*******************************************************************
 
425
 *
 
426
 *  Function    :  Hex16
 
427
 *
 
428
 *  Description :  Returns the string hexadecimal representation
 
429
 *                 of a Short.
 
430
 *
 
431
 *  Input  :  W  word
 
432
 *
 
433
 *  Output :  four-chars string
 
434
 *
 
435
 *****************************************************************)
 
436
 
 
437
function Hex16( W : word ) : ShortHexStr;
 
438
begin
 
439
  Hex16 := Hex8( Hi(w) )+Hex8( Lo(w) );
 
440
end;
 
441
 
 
442
(*******************************************************************
 
443
 *
 
444
 *  Function    :  Hex32
 
445
 *
 
446
 *  Description :  Returns the string hexadecimal representation
 
447
 *                 of a Long.
 
448
 *
 
449
 *  Input  :  L  Long
 
450
 *
 
451
 *  Output :  eight-chars string
 
452
 *
 
453
 *****************************************************************)
 
454
 
 
455
function Hex32( L : Long ) : LongHexStr;
 
456
begin
 
457
  Result := SysUtils.IntToHex(L, 8);
 
458
//  Hex32 := Hex16( TStorageLong(L).W2 )+Hex16( TStorageLong(L).W1 );
 
459
end;
 
460
 
 
461
(*******************************************************************
 
462
 *
 
463
 *  Function    :  Cur_U_Line
 
464
 *
 
465
 *  Description :  Returns a string of the current unassembled
 
466
 *                 line at Code^[IP].
 
467
 *
 
468
 *  Input  :  Code    base code range
 
469
 *            IP      current instruction pointer
 
470
 *
 
471
 *  Output :  line string
 
472
 *
 
473
 *****************************************************************)
 
474
 
 
475
function Cur_U_Line( Code : PByte; IP : Int ) : DebugStr;
 
476
var
 
477
  Op   : Byte;
 
478
  N, I : Int;
 
479
  S    : DebugStr;
 
480
begin
 
481
 
 
482
  Op := Code^[IP];
 
483
  S  := Hex16(IP)+': '+Hex8(Op)+'  '+OpStr[Op];
 
484
 
 
485
  case Op of
 
486
 
 
487
    $40 : begin
 
488
           n := Code^[IP+1];
 
489
           S := S+'('+Hex8(n)+')';
 
490
           for i := 1 to n do
 
491
             S := S+' $'+Hex8( Code^[Ip+i+1] );
 
492
          end;
 
493
 
 
494
    $41 : begin
 
495
           n := Code^[IP+1];
 
496
           S := S+'('+Hex8(n)+')';
 
497
           for i := 1 to n do
 
498
             S := S+' $'+Hex8( Code^[Ip+i*2+1] )+Hex8( Code^[Ip+i*2+2] );
 
499
          end;
 
500
 
 
501
    $B0..$B7 : begin
 
502
                 n := Op-$B0;
 
503
                 for i := 0 to N do
 
504
                   S := S+' $'+Hex8( Code^[Ip+i+1] );
 
505
               end;
 
506
 
 
507
    $B8..$BF : begin
 
508
                 n := Op-$B8;
 
509
                 for i := 0 to N do
 
510
                   S := S+' $'+Hex8( Code^[IP+i*2+1] )+Hex8( Code^[Ip+i*2+2] );
 
511
               end;
 
512
 
 
513
  end;
 
514
 
 
515
  Cur_U_Line := S;
 
516
end;
 
517
 
 
518
(*******************************************************************
 
519
 *
 
520
 *  Function    :  Get_Length
 
521
 *
 
522
 *  Description :  Returns the length in bytes of the instruction at
 
523
 *                 current instruction pointer.
 
524
 *
 
525
 *  Input  :  Code  base code range
 
526
 *            IP    current instruction pointer
 
527
 *
 
528
 *  Output :  Length in bytes
 
529
 *
 
530
 *****************************************************************)
 
531
 
 
532
function Get_Length( Code : PByte; IP : Int ) : Int;
 
533
var
 
534
  Op    : Byte;
 
535
  N     : Int;
 
536
begin
 
537
 
 
538
  Op := Code^[IP];
 
539
 
 
540
  case Op of
 
541
 
 
542
    $40 : N := 2 + Code^[IP+1];
 
543
    $41 : N := 2 + Code^[IP+1]*2;
 
544
 
 
545
    $B0..$B7 : N := 2 + ( Op-$B0 );
 
546
    $B8..$BF : N := 3 + ( Op-$B8 )*2
 
547
 
 
548
  else
 
549
    N := 1;
 
550
  end;
 
551
 
 
552
  Get_Length := N;
 
553
 
 
554
end;
 
555
 
 
556
(*******************************************************************
 
557
 *
 
558
 *  Function    :  Generate_Range
 
559
 *
 
560
 *  Description :  Create a list of unassembled lines for a
 
561
 *                 given code range
 
562
 *
 
563
 *  Input  :
 
564
 *
 
565
 *  Output :
 
566
 *
 
567
 *****************************************************************)
 
568
 
 
569
procedure Generate_Range( CR     : PCodeRange;
 
570
                          index  : Int;
 
571
                          var RR : TRangeRec );
 
572
var
 
573
  Adr, Line, N : Int;
 
574
begin
 
575
 
 
576
  N    := CR^.Size;
 
577
 
 
578
  RR.Code := PByte( CR^.Base );
 
579
  RR.Size := N;
 
580
 
 
581
  Line := 0;
 
582
 
 
583
  if N > 0 then
 
584
  begin
 
585
    Adr  := 0;
 
586
    GetMem( RR.Disassembled, sizeof(Short) * N );
 
587
 
 
588
    while Adr < N do
 
589
      begin
 
590
        RR.Disassembled^[Line] := Adr;
 
591
        inc( Line );
 
592
        inc( Adr, Get_Length( RR.Code, Adr ));
 
593
      end;
 
594
  end;
 
595
 
 
596
  RR.NLines := Line;
 
597
  RR.Index  := index;
 
598
  RR.Breaks := nil;
 
599
end;
 
600
 
 
601
(*******************************************************************
 
602
 *
 
603
 *  Function    :  Get_Dis_Line
 
604
 *
 
605
 *  Description :  Returns the line index of address 'addr'
 
606
 *                 in the coderange 'cr'
 
607
 *
 
608
 *****************************************************************)
 
609
 
 
610
 function Get_Dis_Line( var cr : TRangeRec; addr : Int ) : Int;
 
611
 var
 
612
   l, r, m : Int;
 
613
 begin
 
614
   if (cr.NLines = 0) or
 
615
      (addr > cr.Disassembled^[cr.Nlines-1] ) then
 
616
     begin
 
617
       Get_Dis_Line := -1;
 
618
       exit;
 
619
     end;
 
620
 
 
621
   l := 0;
 
622
   r := cr.NLines-1;
 
623
 
 
624
   while ( r-l > 1 ) do
 
625
   begin
 
626
     if cr.Disassembled^[l] = addr then
 
627
       begin
 
628
         Get_Dis_Line := l;
 
629
         exit;
 
630
       end;
 
631
 
 
632
     if cr.Disassembled^[r] = addr then
 
633
       begin
 
634
         Get_Dis_Line := r;
 
635
         exit;
 
636
       end;
 
637
 
 
638
     m := (l+r) shr 1;
 
639
     if cr.Disassembled^[m] = addr then
 
640
       begin
 
641
         Get_Dis_Line := m;
 
642
         exit;
 
643
       end
 
644
     else
 
645
       if cr.Disassembled^[m] < addr then
 
646
         l := m
 
647
       else
 
648
         r := m;
 
649
   end;
 
650
 
 
651
   if cr.Disassembled^[r] = addr then
 
652
     begin
 
653
       Get_Dis_Line := r;
 
654
       exit;
 
655
     end;
 
656
 
 
657
   Get_Dis_Line := l;
 
658
 
 
659
 end;
 
660
 
 
661
(*******************************************************************
 
662
 *
 
663
 *  Function    :  Throw_Range
 
664
 *
 
665
 *  Description :  Destroys a list of unassembled lines for a
 
666
 *                 given code range
 
667
 *
 
668
 *  Input  :
 
669
 *
 
670
 *  Output :
 
671
 *
 
672
 *****************************************************************)
 
673
 
 
674
procedure Throw_Range( var RR : TRangeRec );
 
675
var
 
676
  B, Bnext : PBreakPoint;
 
677
begin
 
678
 
 
679
  if RR.Size > 0 then
 
680
    FreeMem( RR.Disassembled, RR.Size * sizeof(Short) );
 
681
 
 
682
  RR.Disassembled := nil;
 
683
  RR.Size         := 0;
 
684
  RR.Code         := nil;
 
685
  RR.NLines       := 0;
 
686
 
 
687
  B := RR.Breaks;
 
688
  RR.Breaks := nil;
 
689
 
 
690
  while B<>nil do
 
691
    begin
 
692
      Bnext := B^.Next;
 
693
      Dispose( B );
 
694
      B := Bnext;
 
695
    end;
 
696
end;
 
697
 
 
698
(*******************************************************************
 
699
 *
 
700
 *  Function    :  Set_Break
 
701
 *
 
702
 *  Description :  Sets a Breakpoint ON
 
703
 *
 
704
 *  Input  :
 
705
 *
 
706
 *  Output :
 
707
 *
 
708
 *****************************************************************)
 
709
 
 
710
procedure Set_Break( var Head : PBreakPoint;
 
711
                     Range    : Int;
 
712
                     Adr      : Int );
 
713
var
 
714
  BP,
 
715
  Old,
 
716
  Cur  : PBreakPoint;
 
717
begin
 
718
  Old := nil;
 
719
  Cur := Head;
 
720
 
 
721
  while (Cur <> nil) and (Cur^.Address < Adr) do
 
722
    begin
 
723
      Old := Cur;
 
724
      Cur := Cur^.Next;
 
725
    end;
 
726
 
 
727
  { No duplicates }
 
728
  if Cur <> nil then
 
729
    if (Cur^.Address = Adr) and (Cur^.Range = Range) then exit;
 
730
 
 
731
  New( BP );
 
732
  BP^.Address := Adr;
 
733
  BP^.Range   := Range;
 
734
  BP^.Next    := Cur;
 
735
 
 
736
  if Old = nil then
 
737
    Head := BP
 
738
  else
 
739
    Old^.Next := BP;
 
740
end;
 
741
 
 
742
(*******************************************************************
 
743
 *
 
744
 *  Function    :  Clear_Break
 
745
 *
 
746
 *  Description :  Clears a breakpoint OFF
 
747
 *
 
748
 *  Input  :
 
749
 *
 
750
 *  Output :
 
751
 *
 
752
 *****************************************************************)
 
753
 
 
754
procedure Clear_Break( var Head : PBreakPoint; Bp : PBreakPoint );
 
755
var
 
756
  Old,
 
757
  Cur  : PBreakPoint;
 
758
begin
 
759
  Old := nil;
 
760
  Cur := Head;
 
761
 
 
762
  while (Cur <> nil) and (Cur <> Bp) do
 
763
    begin
 
764
      Old := Cur;
 
765
      Cur := Cur^.Next;
 
766
    end;
 
767
 
 
768
  if Cur = nil then exit;
 
769
 
 
770
  if Old = nil then
 
771
    Head := Cur^.Next
 
772
  else
 
773
    Old^.Next := Cur^.Next;
 
774
end;
 
775
 
 
776
 
 
777
 
 
778
procedure Toggle_Break( var Head : PBreakPoint; Range, Adr : Int );
 
779
var
 
780
  Bp : PBreakPoint;
 
781
begin
 
782
 Bp := Find_BreakPoint( Head, Range, Adr );
 
783
 if Bp <> nil then Clear_Break( Head, Bp )
 
784
              else Set_Break( Head, Range, Adr );
 
785
end;
 
786
 
 
787
(*******************************************************************
 
788
 *
 
789
 *  Function    :  Clear_All_Breaks
 
790
 *
 
791
 *  Description :  Clears all breakpoints
 
792
 *
 
793
 *  Input  :
 
794
 *
 
795
 *  Output :
 
796
 *
 
797
 *****************************************************************)
 
798
 
 
799
procedure Clear_All_Breaks( var Head : PBreakPoint );
 
800
var
 
801
  Old,
 
802
  Cur  : PBreakPoint;
 
803
begin
 
804
  Cur  := Head;
 
805
  Head := Nil;
 
806
 
 
807
  while Cur <> nil do
 
808
    begin
 
809
      Old := Cur;
 
810
      Cur := Cur^.Next;
 
811
      Dispose( Old );
 
812
    end;
 
813
end;
 
814
 
 
815
(*******************************************************************
 
816
 *
 
817
 *  Function    :  Find_BreakPoint
 
818
 *
 
819
 *  Description :  Find a breakpoint at address IP
 
820
 *
 
821
 *  Input  :   Head     break points sorted linked list
 
822
 *             IP       address of expected breakpoint
 
823
 *
 
824
 *  Output :   pointer to breakpoint if found
 
825
 *             nil otherwise.
 
826
 *
 
827
 *****************************************************************)
 
828
 
 
829
function Find_BreakPoint( Head : PBreakPoint; Range, IP : Int ) : PBreakPoint;
 
830
var
 
831
  Cur : PBreakPoint;
 
832
  Res : PBreakPoint;
 
833
begin
 
834
  Cur := Head;
 
835
  Res := nil;
 
836
 
 
837
  while Cur <> nil do
 
838
  begin
 
839
    if (Cur^.Address = IP   ) and
 
840
       (Cur^.Range   = Range) then Res := Cur;
 
841
 
 
842
    if (Cur^.Address >= IP) then Cur := nil
 
843
                            else Cur := Cur^.Next;
 
844
  end;
 
845
 
 
846
  Find_BreakPoint := Res;
 
847
end;
 
848
 
 
849
end.