(******************************************************************* * * TTDebug.Pas 1.2 * * This unit is only used by the debugger. * * Copyright 1996 David Turner, Robert Wilhelm and Werner Lemberg * * This file is part of the FreeType project, and may only be used * modified and distributed under the terms of the FreeType project * license, LICENSE.TXT. By continuing to use, modify or distribute * this file you indicate that you have read the license and * understand and accept it fully. * ******************************************************************) unit TTDebug; interface uses TTTypes, TTTables, TTObjs, TTInterp; type ByteHexStr = string[2]; (* hex representation of a byte *) ShortHexStr = string[4]; (* " " " short *) LongHexStr = string[8]; (* " " " long *) DebugStr = string[128]; (* disassembled line output *) { TBreakPoint } { A simple record to hold breakpoint information } { it may be completed later with pass count, etc.. } { They must be in a sorted linked list } PBreakPoint = ^TBreakPoint; TBreakPoint = record Next : PBreakPoint; Range : Int; Address : Int; end; { TRangeRec } { a record to store line number information and breakpoints list } PRangeRec = ^TRangeRec; TRangeRec = record Code : PByte; Size : Int; index : Int; NLines : Int; Disassembled : PUShort; Breaks : PBreakPoint; end; { Generate_Range : Generate Line Number information specific to } { a given range } procedure Generate_Range( CR : PCodeRange; index : Int; var RR : TRangeRec ); { Throw_Range : Discard Line Number Information } procedure Throw_Range( var RR : TRangeRec ); { Toggle_Break : Toggle a breakpoint } procedure Toggle_Break( var Head : PBreakPoint; Range, Adr : Int ); { Set_Break : Set a breakpoint on a given address } procedure Set_Break ( var Head : PBreakPoint; Range, Adr : Int ); { Clear_Break : Clear one specific breakpoint } procedure Clear_Break( var Head : PBreakPoint; Bp : PBreakPoint ); { Clear_All_Breaks : Clear breakpoint list } procedure Clear_All_Breaks( var Head : PBreakPoint ); { Find_Breakpoint : find one breakpoint at a given address } function Find_BreakPoint( Head : PBreakPoint; Range, IP : Int ) : PBreakPoint; { Cur_U_Line : returns the current disassembled line at Code(IP) } function Cur_U_Line( Code : PByte; IP : Int ) : DebugStr; { Get_Length : returns the length of the current opcode at Code(IP) } function Get_Length( Code : PByte; IP : Int ) : Int; function Get_Dis_Line( var cr : TRangeRec; addr : Int ) : Int; { Hex_N : returns an hexadecimal string } function Hex8 ( B : Byte ) : ByteHexStr; function Hex16( W : word ) : ShortHexStr; function Hex32( L : Long ) : LongHexStr; implementation type PStorageLong = ^TStorageLong; TStorageLong = record (* do-it-all union record type *) case Byte of 0 : ( L : LongInt ); 1 : ( S1, S2 : Integer ); 2 : ( W1, W2 : Word ); 3 : ( B1, B2, B3, B4 : Byte ); 4 : ( P : Pointer ); end; var OpSize : int; const OpStr : array[ 0..255 ] of String[10] = ( 'SVTCA y', (* Set vectors to coordinate axis y *) 'SVTCA x', (* Set vectors to coordinate axis x *) 'SPvTCA y', (* Set Proj. vec. to coord. axis y *) 'SPvTCA x', (* Set Proj. vec. to coord. axis x *) 'SFvTCA y', (* Set Free. vec. to coord. axis y *) 'SFvTCA x', (* Set Free. vec. to coord. axis x *) 'SPvTL //', (* Set Proj. vec. parallel to segment *) 'SPvTL +', (* Set Proj. vec. normal to segment *) 'SFvTL //', (* Set Free. vec. parallel to segment *) 'SFvTL +', (* Set Free. vec. normal to segment *) 'SPvFS', (* Set Proj. vec. from stack *) 'SFvFS', (* Set Free. vec. from stack *) 'GPV', (* Get projection vector *) 'GFV', (* Get freedom vector *) 'SFvTPv', (* Set free. vec. to proj. vec. *) 'ISECT', (* compute intersection *) 'SRP0', (* Set reference point 0 *) 'SRP1', (* Set reference point 1 *) 'SRP2', (* Set reference point 2 *) 'SZP0', (* Set Zone Pointer 0 *) 'SZP1', (* Set Zone Pointer 1 *) 'SZP2', (* Set Zone Pointer 2 *) 'SZPS', (* Set all zone pointers *) 'SLOOP', (* Set loop counter *) 'RTG', (* Round to Grid *) 'RTHG', (* Round to Half-Grid *) 'SMD', (* Set Minimum Distance *) 'ELSE', (* Else *) 'JMPR', (* Jump Relative *) 'SCvTCi', (* Set CVT *) 'SSwCi', (* *) 'SSW', (* *) 'DUP', 'POP', 'CLEAR', 'SWAP', 'DEPTH', 'CINDEX', 'MINDEX', 'AlignPTS', 'INS_$28', 'UTP', 'LOOPCALL', 'CALL', 'FDEF', 'ENDF', 'MDAP[-]', 'MDAP[r]', 'IUP[y]', 'IUP[x]', 'SHP[0]', 'SHP[1]', 'SHC[0]', 'SHC[1]', 'SHZ[0]', 'SHZ[1]', 'SHPIX', 'IP', 'MSIRP[0]', 'MSIRP[1]', 'AlignRP', 'RTDG', 'MIAP[-]', 'MIAP[r]', 'NPushB', 'NPushW', 'WS', 'RS', 'WCvtP', 'RCvt', 'GC[0]', 'GC[1]', 'SCFS', 'MD[0]', 'MD[1]', 'MPPEM', 'MPS', 'FlipON', 'FlipOFF', 'DEBUG', 'LT', 'LTEQ', 'GT', 'GTEQ', 'EQ', 'NEQ', 'ODD', 'EVEN', 'IF', 'EIF', 'AND', 'OR', 'NOT', 'DeltaP1', 'SDB', 'SDS', 'ADD', 'SUB', 'DIV', 'MUL', 'ABS', 'NEG', 'FLOOR', 'CEILING', 'ROUND[G]', 'ROUND[B]', 'ROUND[W]', 'ROUND[?]', 'NROUND[G]', 'NROUND[B]', 'NROUND[W]', 'NROUND[?]', 'WCvtF', 'DeltaP2', 'DeltaP3', 'DeltaC1', 'DeltaC2', 'DeltaC3', 'SROUND', 'S45Round', 'JROT', 'JROF', 'ROFF', 'INS_$7B', 'RUTG', 'RDTG', 'SANGW', 'AA', 'FlipPT', 'FlipRgON', 'FlipRgOFF', 'INS_$83', 'INS_$84', 'ScanCTRL', 'SDPVTL[0]', 'SDPVTL[1]', 'GetINFO', 'IDEF', 'ROLL', 'MAX', 'MIN', 'ScanTYPE', 'IntCTRL', 'INS_$8F', 'INS_$90', 'INS_$91', 'INS_$92', 'INS_$93', 'INS_$94', 'INS_$95', 'INS_$96', 'INS_$97', 'INS_$98', 'INS_$99', 'INS_$9A', 'INS_$9B', 'INS_$9C', 'INS_$9D', 'INS_$9E', 'INS_$9F', 'INS_$A0', 'INS_$A1', 'INS_$A2', 'INS_$A3', 'INS_$A4', 'INS_$A5', 'INS_$A6', 'INS_$A7', 'INS_$A8', 'INS_$A9', 'INS_$AA', 'INS_$AB', 'INS_$AC', 'INS_$AD', 'INS_$AE', 'INS_$AF', 'PushB[0]', 'PushB[1]', 'PushB[2]', 'PushB[3]', 'PushB[4]', 'PushB[5]', 'PushB[6]', 'PushB[7]', 'PushW[0]', 'PushW[1]', 'PushW[2]', 'PushW[3]', 'PushW[4]', 'PushW[5]', 'PushW[6]', 'PushW[7]', 'MDRP[G]', 'MDRP[B]', 'MDRP[W]', 'MDRP[?]', 'MDRP[rG]', 'MDRP[rB]', 'MDRP[rW]', 'MDRP[r?]', 'MDRP[mG]', 'MDRP[mB]', 'MDRP[mW]', 'MDRP[m?]', 'MDRP[mrG]', 'MDRP[mrB]', 'MDRP[mrW]', 'MDRP[mr?]', 'MDRP[pG]', 'MDRP[pB]', 'MDRP[pW]', 'MDRP[p?]', 'MDRP[prG]', 'MDRP[prB]', 'MDRP[prW]', 'MDRP[pr?]', 'MDRP[pmG]', 'MDRP[pmB]', 'MDRP[pmW]', 'MDRP[pm?]', 'MDRP[pmrG]', 'MDRP[pmrB]', 'MDRP[pmrW]', 'MDRP[pmr?]', 'MIRP[G]', 'MIRP[B]', 'MIRP[W]', 'MIRP[?]', 'MIRP[rG]', 'MIRP[rB]', 'MIRP[rW]', 'MIRP[r?]', 'MIRP[mG]', 'MIRP[mB]', 'MIRP[mW]', 'MIRP[m?]', 'MIRP[mrG]', 'MIRP[mrB]', 'MIRP[mrW]', 'MIRP[mr?]', 'MIRP[pG]', 'MIRP[pB]', 'MIRP[pW]', 'MIRP[p?]', 'MIRP[prG]', 'MIRP[prB]', 'MIRP[prW]', 'MIRP[pr?]', 'MIRP[pmG]', 'MIRP[pmB]', 'MIRP[pmW]', 'MIRP[pm?]', 'MIRP[pmrG]', 'MIRP[pmrB]', 'MIRP[pmrW]', 'MIRP[pmr?]' ); const HexStr : string[16] = '0123456789abcdef'; (******************************************************************* * * Function : Hex8 * * Description : Returns the string hexadecimal representation * of a Byte. * * Input : B byte * * Output : two-chars string * *****************************************************************) function Hex8( B : Byte ) : ByteHexStr; var S : ByteHexStr; begin S[0] :=#2; S[1] := HexStr[ 1+( B shr 4 ) ]; S[2] := HexStr[ 1+( B and 15 )]; Hex8 := S; end; (******************************************************************* * * Function : Hex16 * * Description : Returns the string hexadecimal representation * of a Short. * * Input : W word * * Output : four-chars string * *****************************************************************) function Hex16( W : word ) : ShortHexStr; begin Hex16 := Hex8( Hi(w) )+Hex8( Lo(w) ); end; (******************************************************************* * * Function : Hex32 * * Description : Returns the string hexadecimal representation * of a Long. * * Input : L Long * * Output : eight-chars string * *****************************************************************) function Hex32( L : Long ) : LongHexStr; begin Hex32 := Hex16( TStorageLong(L).W2 )+Hex16( TStorageLong(L).W1 ); end; (******************************************************************* * * Function : Cur_U_Line * * Description : Returns a string of the current unassembled * line at Code^[IP]. * * Input : Code base code range * IP current instruction pointer * * Output : line string * *****************************************************************) function Cur_U_Line( Code : PByte; IP : Int ) : DebugStr; var Op : Byte; N, I : Int; S : DebugStr; begin Op := Code^[IP]; S := Hex16(IP)+': '+Hex8(Op)+' '+OpStr[Op]; case Op of $40 : begin n := Code^[IP+1]; S := S+'('+Hex8(n)+')'; for i := 1 to n do S := S+' $'+Hex8( Code^[Ip+i+1] ); end; $41 : begin n := Code^[IP+1]; S := S+'('+Hex8(n)+')'; for i := 1 to n do S := S+' $'+Hex8( Code^[Ip+i*2+1] )+Hex8( Code^[Ip+i*2+2] ); end; $B0..$B7 : begin n := Op-$B0; for i := 0 to N do S := S+' $'+Hex8( Code^[Ip+i+1] ); end; $B8..$BF : begin n := Op-$B8; for i := 0 to N do S := S+' $'+Hex8( Code^[IP+i*2+1] )+Hex8( Code^[Ip+i*2+2] ); end; end; Cur_U_Line := S; end; (******************************************************************* * * Function : Get_Length * * Description : Returns the length in bytes of the instruction at * current instruction pointer. * * Input : Code base code range * IP current instruction pointer * * Output : Length in bytes * *****************************************************************) function Get_Length( Code : PByte; IP : Int ) : Int; var Op : Byte; N : Int; begin Op := Code^[IP]; case Op of $40 : N := 2 + Code^[IP+1]; $41 : N := 2 + Code^[IP+1]*2; $B0..$B7 : N := 2 + ( Op-$B0 ); $B8..$BF : N := 3 + ( Op-$B8 )*2 else N := 1; end; Get_Length := N; end; (******************************************************************* * * Function : Generate_Range * * Description : Create a list of unassembled lines for a * given code range * * Input : * * Output : * *****************************************************************) procedure Generate_Range( CR : PCodeRange; index : Int; var RR : TRangeRec ); var Adr, Line, N : Int; Code : PByte; begin N := CR^.Size; RR.Code := PByte( CR^.Base ); RR.Size := N; Line := 0; if N > 0 then begin Adr := 0; GetMem( RR.Disassembled, sizeof(Short) * N ); while Adr < N do begin RR.Disassembled^[Line] := Adr; inc( Line ); inc( Adr, Get_Length( RR.Code, Adr )); end; end; RR.NLines := Line; RR.Index := index; RR.Breaks := nil; end; (******************************************************************* * * Function : Get_Dis_Line * * Description : Returns the line index of address 'addr' * in the coderange 'cr' * *****************************************************************) function Get_Dis_Line( var cr : TRangeRec; addr : Int ) : Int; var l, r, m : Int; begin if (cr.NLines = 0) or (addr > cr.Disassembled^[cr.Nlines-1] ) then begin Get_Dis_Line := -1; exit; end; l := 0; r := cr.NLines-1; while ( r-l > 1 ) do begin if cr.Disassembled^[l] = addr then begin Get_Dis_Line := l; exit; end; if cr.Disassembled^[r] = addr then begin Get_Dis_Line := r; exit; end; m := (l+r) shr 1; if cr.Disassembled^[m] = addr then begin Get_Dis_Line := m; exit; end else if cr.Disassembled^[m] < addr then l := m else r := m; end; if cr.Disassembled^[r] = addr then begin Get_Dis_Line := r; exit; end; Get_Dis_Line := l; end; (******************************************************************* * * Function : Throw_Range * * Description : Destroys a list of unassembled lines for a * given code range * * Input : * * Output : * *****************************************************************) procedure Throw_Range( var RR : TRangeRec ); var B, Bnext : PBreakPoint; begin if RR.Size > 0 then FreeMem( RR.Disassembled, RR.Size * sizeof(Short) ); RR.Disassembled := nil; RR.Size := 0; RR.Code := nil; RR.NLines := 0; B := RR.Breaks; RR.Breaks := nil; while B<>nil do begin Bnext := B^.Next; Dispose( B ); B := Bnext; end; end; (******************************************************************* * * Function : Set_Break * * Description : Sets a Breakpoint ON * * Input : * * Output : * *****************************************************************) procedure Set_Break( var Head : PBreakPoint; Range : Int; Adr : Int ); var BP, Old, Cur : PBreakPoint; begin Old := nil; Cur := Head; while (Cur <> nil) and (Cur^.Address < Adr) do begin Old := Cur; Cur := Cur^.Next; end; { No duplicates } if Cur <> nil then if (Cur^.Address = Adr) and (Cur^.Range = Range) then exit; New( BP ); BP^.Address := Adr; BP^.Range := Range; BP^.Next := Cur; if Old = nil then Head := BP else Old^.Next := BP; end; (******************************************************************* * * Function : Clear_Break * * Description : Clears a breakpoint OFF * * Input : * * Output : * *****************************************************************) procedure Clear_Break( var Head : PBreakPoint; Bp : PBreakPoint ); var Old, Cur : PBreakPoint; begin Old := nil; Cur := Head; while (Cur <> nil) and (Cur <> Bp) do begin Old := Cur; Cur := Cur^.Next; end; if Cur = nil then exit; if Old = nil then Head := Cur^.Next else Old^.Next := Cur^.Next; end; procedure Toggle_Break( var Head : PBreakPoint; Range, Adr : Int ); var Bp : PBreakPoint; begin Bp := Find_BreakPoint( Head, Range, Adr ); if Bp <> nil then Clear_Break( Head, Bp ) else Set_Break( Head, Range, Adr ); end; (******************************************************************* * * Function : Clear_All_Breaks * * Description : Clears all breakpoints * * Input : * * Output : * *****************************************************************) procedure Clear_All_Breaks( var Head : PBreakPoint ); var Old, Cur : PBreakPoint; begin Cur := Head; Head := Nil; while Cur <> nil do begin Old := Cur; Cur := Cur^.Next; Dispose( Old ); end; end; (******************************************************************* * * Function : Find_BreakPoint * * Description : Find a breakpoint at address IP * * Input : Head break points sorted linked list * IP address of expected breakpoint * * Output : pointer to breakpoint if found * nil otherwise. * *****************************************************************) function Find_BreakPoint( Head : PBreakPoint; Range, IP : Int ) : PBreakPoint; var Cur : PBreakPoint; Res : PBreakPoint; begin Cur := Head; Res := nil; while Cur <> nil do begin if (Cur^.Address = IP ) and (Cur^.Range = Range) then Res := Cur; if (Cur^.Address >= IP) then Cur := nil else Cur := Cur^.Next; end; Find_BreakPoint := Res; end; end.