unit KCDeb;
{$C MOVEABLE PRELOAD PERMANENT} {gleiche Attribute wie Unit SYSTEM}
interface
uses WinProcs,WinTypes,Win31,WUtils,KCHdr;
function DebugListProc(Wnd:HWnd; Msg,wParam:Word; lParam:LongInt):LongInt;
export;
function DebugProc(Wnd:HWnd; Msg,wParam:Word; lParam:LongInt):Bool; export;
implementation
type
TDebDraw=record
action: Word;
state: Word;
wnd: HWnd;
dc: HDC;
rect: TRect;
idata: LongRec; {Lo: KC-Speicheradresse}
curs: Integer; {horizontale Cursor-Position}
end;
function GetFontHeight(Fnt:HFont):Integer;
var {Stack sparen ist der Zweck dieser Funktion}
LF: TLogFont;
begin
GetObject(Fnt,sizeof(LF),@LF);
GetFontHeight:=LF.lfHeight;
end;
procedure PutHexB; assembler;
asm push ax
shr al,4
call @@a
pop ax
and al,0fh
@@a: add al,90h
daa
adc al,40h
daa
stosb
end;
procedure PutHexW; assembler;
asm xchg al,ah
call PutHexB
xchg al,ah
jmp PutHexB
end;
{$L DISASM}
function LCode(var Code):Integer; external;
procedure Reas(Code:Pointer; S:PChar); external;
procedure DebDrawReas(var DD:TDebDraw); far;
var
S: array[0..39] of Char;
begin
FillChar(S,sizeof(S),' ');
asm les di,[DD]
mov si,es:TDebDraw[di].idata.Lo
push si
push [MemKCSel]
push si
call LCode {Codelnge berechnen: AX}
xchg cx,ax
pop si
push ss
pop es
lea di,S
cld
mov ax,si
call PutHexW
inc di
push ds
mov ds,[MemKCSel]
push si
push cx
@@l: lodsb
call PutHexB
inc di
loop @@l
pop cx
pop si
lea di,S[17]
@@l2: lodsb
and al,7fh
cmp al,' '
jnc @@1
mov al,'.'
@@1: stosb
loop @@l2
pop ds
end;
Reas(Ptr(MemKCSel,DD.idata.Lo),S+22);
ExtTextOut(DD.dc,DD.rect.left,DD.rect.top,ETO_Clipped or ETO_Opaque,
@DD.rect,S,sizeof(S),nil);
end;
procedure DebDrawItem(var DD:TDebDraw); far;
var
S: array[0..39] of Char;
begin
asm les di,[DD]
mov si,es:TDebDraw[di].idata.Lo
push ss
pop es
mov cx,8 {8spaltig}
lea di,S
cld
mov ax,si
call PutHexW
mov al,' '
stosb
push ds
mov ds,[MemKCSel]
push si
push cx
@@l: lodsb
call PutHexB
mov al,' '
stosb
loop @@l
stosb {2 Leerzeichen zwischen Bytes und Zeichen}
pop cx
pop si
@@l2: lodsb
and al,7Fh
cmp al,' '
jnc @@1
mov al,'.'
@@1: stosb
loop @@l2
mov al,0
stosb {nullterminieren}
pop ds
end;
ExtTextOut(DD.dc,DD.rect.left,DD.rect.top,ETO_Clipped or ETO_Opaque,
@DD.rect,S,lstrlen(S),nil);
end;
procedure DebDrawStack(var DD:TDebDraw); far;
var
S: array[0..7] of Char;
begin
ExtTextOut(DD.dc,DD.rect.left,DD.rect.top,ETO_Clipped or ETO_Opaque,
@DD.rect,S,wvsprintf(S,' %04X',MemW[MemKCSel:DD.idata.Lo]),nil);
end;
{$Q-,R-}
function DebNewReas(addr: Word; Dir:Integer):Word; far;
var
addrs: array[0..64] of Word;
I,K: Word;
begin
if Dir>=0 then begin
for I:=1 to Dir do Inc(addr,LCode(Mem[MemKCSel:addr]));
DebNewReas:=addr;
end else begin
K:=addr-64;
I:=0;
repeat
addrs[I]:=K; {Vorhergehende Adressen speichern}
Inc(K,LCode(Mem[MemKCSel:K]));
Inc(I);
until Integer(K-addr)>=0;
DebNewReas:=addrs[I+Dir];
end;
end;
function DebNewItem(addr: Word; Dir:Integer):Word; far;
begin
DebNewItem:=(addr and not 7)+8*Dir;
end;
function DebNewStack(addr: Word; Dir:Integer):Word; far;
begin
DebNewStack:=(addr and not 1)+2*Dir;
end;
{$IFOPT D+} {$Q+,R+} {$ENDIF}
type
PListMem=^TListMem;
TListMem=record
drawp: procedure(var DD:TDebDraw);
newp: function(addr: Word; Dir: Integer):Word;
font: HFont;
curs: Integer; {Gerade aktive Zeile}
focus: Boolean;
framey:Byte;
itemh: Integer; {Item-Hhe}
items: Integer; {Anzahl Items}
addrs: LongRec; {Anfangs- und Endadresse
des KC-Speichers zwecks nderungstest}
idata: array[0..32] of LongRec; {variable Item-Daten}
end;
const
ListMemSize=sizeof(TListMem)-256*sizeof(LongRec);
function DebugListProc(Wnd:HWnd; Msg,wParam:Word; lParam:LongInt):LongInt;
{Fensterfunktion zum Auflisten von Speicherinhalten
mit beliebiger (programmierbarer) Erscheinung und "Zeilenlnge" (in Bytes).
Hauptsache, der betrachtete Speicher ist zusammenhngend.
Anwendung als ASM-, Daten- und Stackfenster}
var
CallOld: Boolean;
lPar: LongRec absolute lParam;
csp: PCreateStruct absolute lParam;
rcp: PRect absolute lParam;
pwp: PWindowPos absolute lParam;
{ ncc: PNCCalcsize_Params absolute lParam;}
PS: TPaintStruct;
OldFont: HFont;
hList: THandle; {Adreáliste fr die einzelnen Eintrge}
DebDraw: TDebDraw;
i: Integer;
R: TRect;
procedure MakeFocusRect(curs:Integer);
begin
PS.hDC:=GetDC(Wnd);
if SendMessageP(Wnd,LB_GetItemRect,curs,@R)=0
then DrawFocusRect(PS.hDC,R);
ReleaseDC(Wnd,PS.hDC);
end;
begin
CallOld:=false;
DebugListProc:=0;
hList:=GetWindowWord(Wnd,0);
if hList=0 then begin
hList:=LocalAlloc(LPtr,{ListMemSize}sizeof(TListMem));
SetWindowWord(Wnd,0,hList);
end;
with PListMem(LocalLock(hList))^ do case Msg of {optimiert!}
WM_Create: begin
{PChar(@drawp):=csp^.lpCreateParams;}
drawp:=DebDrawItem;
newp:=DebNewItem;
font:=GetStockObject(Ansi_Fixed_Font);
itemh:=GetFontHeight(font)+1;
SetScrollRange(Wnd,SB_Vert,0,$7FFF,false);
GetClientRect(Wnd,R);
framey:=csp^.cy-R.bottom;
end;
WM_WindowPosChanging: begin
GetClientRect(Wnd,R);
Dec(pwp^.cy,(pwp^.cy-framey) mod itemh);
end;
WM_Size: begin {Listenlnge auf ganze Eintrge abrunden!}
if itemh<=0 then asm int 3 end;
i:=lPar.Hi mod itemh;
if lPar.Hi<itemh then i:=lPar.Hi-itemh; {Negativ: zu klein!}
(*
if i<>0 then begin {oder positiv: zu groá}
asm int 3 end;
GetWindowRect(Wnd,R);
Dec(R.right,R.left); Dec(R.bottom,R.top+i);
ScreenToClient(GetParent(Wnd),PPoint(@R)^);
MoveWindow(Wnd,R.left,R.top,R.right,R.bottom,true);
end else*) begin {Listen-Lnge mit User-Eintrgen neu berechnen}
i:=lPar.Hi div itemh;
items:=i;
{ SetWindowWord(Wnd,0,
LocalReAlloc(hList,(i shl 2)+ListMemSize,0));}
SendMessage(Wnd,LB_ResetContent,addrs.Lo,0);
end;
end;
WM_LButtonDown: begin
SetFocus(Wnd);
PostMessage(Wnd,LB_SetCaretIndex,lPar.Hi div itemh,0);
end;
WM_SetFocus: if not focus then begin
MakeFocusRect(curs);
focus:=true;
end;
WM_KillFocus: if focus then begin
MakeFocusRect(curs);
focus:=false;
end;
WM_GetDlgCode: DebugListProc:=DLGC_HasSetSel or DLGC_WantArrows;
LB_GetItemRect: begin
if (wParam<0) or (wParam>=items)
then DebugListProc:=-1 {Fehler melden}
else begin
GetClientRect(Wnd,rcp^);
rcp^.top:=wParam*itemh;
rcp^.bottom:=rcp^.top+itemh;
end;
end;
LB_GetItemData: begin
if (wParam<0) or (wParam>=items)
then DebugListProc:=-1 {Fehler melden}
else DebugListProc:=LongInt(idata[i]);
end;
LB_SetItemData: begin
if (wParam<0) or (wParam>=items)
then DebugListProc:=-1 {Fehler melden}
else idata[i]:=lPar;
end;
LB_SetItemHeight: if lPar.Lo<=256 then begin
itemh:=lPar.Lo;
GetClientRect(Wnd,R);
SendMessageWW(Wnd,WM_Size,SIZE_Restored,R.bottom,R.right);
end;
LB_GetItemHeight: begin
DebugListProc:=itemh;
end;
{$Q-,R-}
LB_SetCaretIndex: begin
if focus then MakeFocusRect(curs);
curs:=wParam;
if focus then MakeFocusRect(curs);
end;
WM_User+100: LongInt(@drawp):=lParam; {Pointer setzen}
WM_User+101: LongInt(@newp):=lParam;
LB_ResetContent: begin {hier: selbstfllend, wParam=Startadresse}
SetScrollPos(Wnd,SB_Vert,wParam shr 1,true);
addrs.Lo:=wParam;
for i:=0 to items-1 do with idata[i] do begin
Lo:=wParam; {Anfangsadresse in den Low-Teil}
wParam:=newp(wParam,1);
Hi:=wParam-Lo {Lnge in den High-Teil setzen}
end;
addrs.Hi:=wParam;
InvalidateRect(Wnd,nil,true);
end;
WM_VScroll: case wParam of
SB_LineUp: with idata[0] do begin
if focus then MakeFocusRect(curs);
GetClientRect(Wnd,R);
addrs.Lo:=newp(Lo,-1); {Neue untere Adresse}
addrs.Hi:=idata[items-1].Lo; {Adresse aus idata[] ist obere}
ScrollWindow(Wnd,0,itemh,nil,@R);
Move(idata[0],idata[1],(items-1) shl 2);
Hi:=Lo-addrs.Lo; {Lnge=Speicheranfang-alte Adresse}
Lo:=addrs.Lo; {neuen Anfang setzen}
SetScrollPos(Wnd,SB_Vert,addrs.Lo shr 1,true);
Inc(curs); if curs>=items then curs:=items-1;
if focus then MakeFocusRect(curs);
end;
SB_LineDown: with idata[items-1] do begin
if focus then MakeFocusRect(curs);
GetClientRect(Wnd,R);
ScrollWindow(Wnd,0,-itemh,nil,@R);
Move(idata[1],idata[0],(items-1) shl 2);
Lo:=addrs.Hi; {Adresse ist altes Ende}
addrs.Hi:=newp(addrs.Hi,1); {Neue obere Adresse}
Hi:=addrs.Hi-Lo; {Lnge=Speicherende-altes Ende}
SetScrollPos(Wnd,SB_Vert,addrs.Lo shr 1,true);
Dec(curs); if curs<0 then curs:=0;
if focus then MakeFocusRect(curs);
end;
SB_PageUp: SendMessage(Wnd,LB_ResetContent,
newp(addrs.Lo,-items),0); {genau in Seiten steuern}
SB_PageDown: SendMessage(Wnd,LB_ResetContent,addrs.Hi,0);
SB_ThumbPosition, SB_ThumbTrack: {querfeldein}
SendMessage(Wnd,LB_ResetContent,newp(lPar.Lo shl 1,0),0);
SB_Top: SendMessage(Wnd,LB_ResetContent,0,0);
SB_Bottom: SendMessage(Wnd,LB_ResetContent,newp(0,-items),0);
end;
WM_KeyDown: case wParam of
VK_Prior: SendMessage(Wnd,WM_VScroll,SB_PageUp,0);
VK_Next: SendMessage(Wnd,WM_VScroll,SB_PageDown,0);
VK_Up: begin
if curs=0 then SendMessage(Wnd,WM_VScroll,SB_LineUp,0);
SendMessage(Wnd,LB_SetCaretIndex,curs-1,0);
end;
VK_Down: begin
if curs=items-1 then SendMessage(Wnd,WM_VScroll,SB_LineDown,0);
SendMessage(Wnd,LB_SetCaretIndex,curs+1,0);
end;
end;
{$IFOPT D+} {$Q+,R+} {$ENDIF}
WM_Paint: begin
BeginPaint(Wnd,PS);
OldFont:=SelectObject(PS.hDC,font);
DebDraw.wnd:=Wnd;
DebDraw.dc:=PS.hDC;
for i:=0 to items-1 do begin
DebDraw.idata:=idata[i];
SendMessageP(Wnd,LB_GetItemRect,i,@DebDraw.rect);
if IntersectRect(R,DebDraw.rect,PS.rcPaint)<>0
then begin
drawp(DebDraw); {Bedingt neuzeichnen}
if focus and (i=curs) then DrawFocusRect(PS.hDC,DebDraw.rect);
end;
end;
SelectObject(PS.hDC,OldFont);
EndPaint(Wnd,PS);
end;
WM_NCDestroy: begin
SetWindowWord(Wnd,0,LocalFree(hList)); {máte 0 schreiben}
CallOld:=true;
end;
else CallOld:=true;
end;
if CallOld then DebugListProc:=DefWindowProc(Wnd,Msg,wParam,lParam);
end;
procedure GetWndR(W: HWnd; var R: TRect);
begin
GetWindowRect(W,R);
Dec(R.right,R.left);
Dec(R.bottom,R.top); {Gráe als Differenz}
ScreenToClient(GetParent(W),PPoint(@R)^); {links oben fest}
end;
function DebugProc(Wnd:HWnd; Msg,wParam:Word; lParam:LongInt):Bool;
var
lPar: LongRec absolute lParam;
delis: PDeleteItemStruct absolute lParam;
dis: PDrawItemStruct absolute lParam;
mis: PMeasureItemStruct absolute lParam;
mmi: PMinMaxInfo absolute lParam;
LF: TLogFont;
OldFont: HFont;
DC: HDC;
S: array[0..32] of char;
W: HWnd;
PS: TPaintStruct;
WP: TWindowPlacement;
R: TRect;
const
DebugIcon: HIcon=0;
begin
DebugProc:=false;
case Msg of
WM_InitDialog: begin
if DebugIcon=0
then DebugIcon:=LoadIcon(Seg(HInstance),MakeIntResource(301));
W:=GetDlgItem(Wnd,101);
SendMessageP(W,WM_User+100,0,@DebDrawReas);
SendMessageP(W,WM_User+101,0,@DebNewReas);
SendMessage(W,LB_ResetContent,$F000,0);
W:=GetDlgItem(Wnd,102);
SendMessage(W,WM_SetFont,GetStockObject(Ansi_Fixed_Font),0);
W:=GetDlgItem(Wnd,104);
SendMessageP(W,WM_User+100,0,@DebDrawStack);
SendMessageP(W,WM_User+101,0,@DebNewStack);
SendMessage(W,LB_ResetContent,Regs.SP_,0);
DebugProc:=true;
end;
WM_GetMinMaxInfo: with WP.rcNormalPosition do begin
WP.length:=sizeof(WP);
GetWindowPlacement(Wnd,@WP);
Dec(right,left); {Fensterbreite}
{HACK!} if right<40 then exit;
mmi^.ptMaxSize.x:=right; {auf Gedeih und Verderb festhalten!}
mmi^.ptMinTrackSize.x:=right;
mmi^.ptMaxTrackSize.x:=right;
end;
WM_Size: begin
W:=GetDlgItem(Wnd,101);
GetWndR(W,R);
MoveWindow(W,R.left,R.top,R.right,R.bottom,true);
W:=GetDlgItem(Wnd,103);
GetWndR(W,R);
R.bottom:=lPar.Hi-2-R.top;
MoveWindow(W,R.left,R.top,R.right,R.bottom,true);
W:=GetDlgItem(Wnd,104);
GetWndR(W,R);
R.bottom:=lPar.Hi-2-R.top;
MoveWindow(W,R.left,R.top,R.right,R.bottom,true);
end;
WM_Activate: if wParam<>0 then hKBWnd:=Wnd else hKBWnd:=0;
WM_EnterIdle: SendMessage(MainWnd,Msg,wParam,lParam);
WM_QueryDragIcon: DebugProc:=Bool(DebugIcon);
WM_Paint: if IsIconic(Wnd) then begin
BeginPaint(Wnd,PS);
DefWindowProc(Wnd,WM_IconEraseBkgnd,PS.hDC,0);
DrawIcon(PS.hDC,0,0,DebugIcon);
EndPaint(Wnd,PS);
DebugProc:=true;
end;
WM_Command: case wParam of
ID_Cancel: DestroyWindow(Wnd);
end;
WM_Destroy: hDebug:=0;
end;
end;
end.
| Detected encoding: UTF-8 | 0
|