Source file: /~heha/hs/kcemu/kcemusrc.zip/KCDEB.PAS

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	{Codel„nge 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-H”he}
  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 "Zeilenl„nge" (in Bytes).
 Hauptsache, der betrachtete Speicher ist zusammenh„ngend.
 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 fr die einzelnen Eintr„ge}
  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	{Listenl„nge auf ganze Eintr„ge 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-L„nge mit User-Eintr„gen 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: selbstfllend, 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	{L„nge 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;			{L„nge=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;			{L„nge=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-80