OS/2 Shareware BBS: 10 Tools/10-Tools.zip/vp21beta.zip/ARTLSRC.RAR/VPDBGAPI.PAS

Pascal/Delphi Source File | 2000-08-15 | 45KB | 1,506 lines

unit VPDbgApi;

{&Z-,AlignRec-}

interface

uses Use32;

const
  // Object Pascal Exception Codes
  opecException    = $0EEDFACE;
  opecReRaise      = $0EEDFACF;
  opecExcept       = $0EEDFAD0;
  opecFinally      = $0EEDFAD1;
  opecTerminate    = $0EEDFAD2;
  opecUnhandled    = $0EEDFAD3;
  opecSysException = $0EEDFAD4;

  // Debug Event Codes
  decSingleStep    = 0;
  decBreakpoint    = 1;
  decWatchpoint    = 2;
  decException     = 3;
  decStop          = 4;
  decProcessEnded  = 5;
  decError         = 6;
  decLast          = 6;

type
  TSysDbgPlatform = (dpOS2, dpWin32);
  TSysDbgPlatforms = set of TSysDbgPlatform;

  PSysDbgFlatInfo = ^TSysDbgFlatInfo;
  TSysDbgFlatInfo = record
    Flat_CS: Word;      // Flat code selector
    Flat_DS: Word;      // Flat data selector
  end;

  PSysDbgThreadIds = ^TSysDbgThreadIds;
  TSysDbgThreadIds = record
    ThreadID: Longint;
    ThreadHandle: Longint;
    ThreadOrdinal: Longint;
  end;

  TSysDbgSegDef = record
    FlatOfs: Longint;
    Size:    Longint;
  end;

  PSysDbgEvent = ^TSysDbgEvent;
  TSysDbgEvent = record
    deCode: Integer;
    deError: Integer;
    deThreadID: Integer;
    deXcptCode: Integer;
    deXcptAddress: Longint;
    deXcptParam1: Integer;
    deXcptParam2: Integer;
    deWatchPtMask: Integer;
  end;

  PSysDbgInterface = ^TSysDbgInterface;
  TSysDbgInterface = record
    GetThreadParam: function(No: Integer): PSysDbgThreadIds;
    ThreadCreated: procedure(ThreadID,ThreadHandle,ThreadOrdinal: Longint);
    ThreadExited: procedure(ThreadID,ExitCode: Longint);
    DllLoaded: procedure(DllName: PChar; DllHandle,SegCount: Longint; const SegTable: array of TSysDbgSegDef);
    DllUnloaded: procedure(DllHandle: Longint);
    ProcessExited: procedure(ExitCode,ExitType: Integer);
    NotifyException: procedure(const DbgEvent: TSysDbgEvent);
    StopOnException: function(Code: Longint): Boolean;
  end;

  PSysDbgCPURegisters = ^TSysDbgCPURegisters;
  TSysDbgCPURegisters = record
    ThreadID: Longint;
    ThreadHandle: Longint;
    ThreadOrdinal: Longint;
    EAX: Longint;
    ECX: Longint;
    EDX: Longint;
    EBX: Longint;
    ESP: Longint;
    EBP: Longint;
    ESI: Longint;
    EDI: Longint;
    EFlags: Longint;
    EIP: Longint;
    CS: SmallWord;
    DS: SmallWord;
    ES: SmallWord;
    FS: SmallWord;
    GS: SmallWord;
    SS: SmallWord;
  end;

  PSysDbgFSaveFormat = ^TSysDbgFSaveFormat;
  TSysDbgFSaveFormat = record
    CW: SmallWord;                  // Control Word
    Reserved1: SmallWord;           // Reserved
    SW: SmallWord;                  // Status word
    Reserved2: SmallWord;           // Reserved
    Tag: SmallWord;                 // Tag Word
    Reserved3: SmallWord;           // Reserved
    IPtrOffset: Longint;            // Instruction Pointer Offset
    IPtrSelector: SmallWord;        // Instruction Pointer Selector
    IPtrOpcode: SmallWord;          // Instruction Opcode
    DPtrOffset: Longint;            // Data Pointer Offset
    DPtrSelector: SmallWord;        // Data Pointer Selector
    Reserved4: SmallWord;           // Reserved
    Regs: array [0..7] of Extended; // Floating Point registers
  end;

  PSysDbgThreadState = ^TSysDbgThreadState;
  TSysDbgThreadState = record
    IsFrozen: Boolean;
    Schedule:  Byte;
    Priority: SmallWord;
  end;

  TSysDbgIDEInterface = record
    SysDbgVersion: Longint;
    SysDbgPlatforms: TSysDbgPlatforms;
    SysDbgInitialize: procedure;
    SysDbgGetFlatInfo: procedure(var FlatInfo: TSysDbgFlatInfo);
    SysDbgSetInterface: procedure(var DbgInt: TSysDbgInterface);
    SysDbgStartProcess: function(const FileName,CmdLine: String; AppType: Longint; var ProcessID,SesID,EntryAddr: Longint): Longint;
    SysDbgTerminateProcess: function: Longint;
    SysDbgSelToFlat: function(Sel,Ofs: Longint): Longint;
    SysDbgReadMemory: function(Sel,Ofs: Longint; Buffer: Pointer; Size: Longint): Longint;
    SysDbgWriteMemory: function(Sel,Ofs: Longint; Buffer: Pointer; Size: Longint): Longint;
    SysDbgReadRegisters: function(Regs: PSysDbgCPURegisters; FPUState: PSysDbgFSaveFormat): Boolean;
    SysDbgWriteRegisters: function(Regs: PSysDbgCPURegisters; FPUState: PSysDbgFSaveFormat): Boolean;
    SysDbgFreezeThread: function(const Regs: TSysDbgCPURegisters): Boolean;
    SysDbgResumeThread: function(const Regs: TSysDbgCPURegisters): Boolean;
    SysDbgGetThreadState: function(const Regs: TSysDbgCPURegisters; var State: TSysDbgThreadState): Boolean;
    SysDbgSetWatchPoint: function(LinAddr: Longint; BkptLen,BkptType: Byte; ThreadID: Longint): Longint;
    SysDbgClearWatchPoint: procedure(Id: Longint);
    SysDbgExecute: procedure(Step: Boolean; Regs: TSysDbgCPURegisters; var DbgEvent: TSysDbgEvent);
    SysDbgWaitUserScreen: procedure(Delay: Longint);
    SysDbgSetHardMode: procedure(Hard: Boolean);
    SysDbgSwitchScreen: procedure(User: Boolean);
  end;

procedure SysDbgGetIDEInterface(var IDEInt: TSysDbgIDEInterface); orgname; {$IFDEF VPDBGDLL} export; {$ENDIF}

implementation

{$IFDEF Win32}
  uses Windows,
{$ELSE}
  uses Os2Def, Os2Base,
{$ENDIF}
    Strings, VPSysLow, ExeHdr;

{$IFDEF VPDBGDLL}

var
  FlatInfo: TSysDbgFlatInfo;
  DbgInterface: TSysDbgInterface;

{$IFNDEF WIN32}

type
  KeyPacket = record           // Key packet record for Keyboard Monitor
    MonFlags  : SmallWord;
    ASCII     : Byte;          // Fields that start here are equivalent
    Scan      : Byte;          // to thoses defined in KbdTrans
    IDontCare : array [1..8] of Byte;
    DdFlags   : Word;
  end;

var
  ProcessID: Longint;
  SesID: Longint;

procedure SysDbgGetFlatInfo(var FlatInfo: TSysDbgFlatInfo);
begin
  with FlatInfo do
  begin
    Flat_CS := CSeg; // GDT selectors, so they are common for all tasks
    Flat_DS := DSeg;
  end;
end;

procedure SysDbgWaitUserScreen(Delay: Longint);
var
  RC,MSec,StartMSec: Longint;
  MonHandle,ReadCount: SmallWord;
  Kp: KeyPacket;
  InBuf,OutBuf: array [0..63] of SmallWord;

procedure Wait;
begin
  if MSec = 0 then
    MSec := Delay;
  SysCtrlSleep(MSec);
end;

begin
  MSec := 0;
  if DosMonOpen('\DEV\KBD$', MonHandle) <> 0 then
    Wait
  else
    begin
      InBuf[0]  := SizeOf(InBuf);
      OutBuf[0] := SizeOf(OutBuf);  {Front}  { Current screen Group }
      if DosMonReg(MonHandle, @InBuf, @OutBuf, 1, SesID) <> 0 then
        begin
          DosMonClose(MonHandle);
          Wait;
        end
      else
        begin
          StartMSec := SysSysMsCount;
          repeat
            ReadCount := SizeOf(KeyPacket);
            RC := DosMonRead(@InBuf, 1, @Kp, ReadCount); // No Wait
            if RC <> 0 then
            begin
              if (RC <> error_Mon_Buffer_Empty) and (MSec = 0) then
                MSec := Delay;
              Kp.DdFlags := 0;
            end;
          until ((MSec <> 0) and ((SysSysMsCount - StartMSec) >= MSec)) // Time elapsed
            or (((Kp.DdFlags and $40) <> 0) and (Kp.Scan <> 0));        // or any key is pressed
          DosMonClose(MonHandle);
        end;
    end;
end;

procedure SysDbgSetHardMode(Hard: Boolean);
var
  HK: HotKey;
  ParmLen,Handle: ULong;
const
  HardDbgMode: Boolean = False;
begin
  if (Hard <> HardDbgMode) and (SysFileOpen('\DEV\KBD$', $40, Handle) = 0) then
  begin
    HardDbgMode := Hard;
    FillChar(HK, SizeOf(HK), 0);
    HK.idHotKey := $FFFF;     // Ctrl-Esc, Alt-Esc, Ctrl-Alt-Del
    ParmLen := SizeOf(HK);
    DosDevIOCtl(Handle, ioctl_Keyboard, kbd_SetSesMgrHotKey, @HK, SizeOf(HK),
      @ParmLen, nil, 0, nil);
    SysFileClose(Handle);
  end;
end;

procedure SysDbgSwitchScreen(User: Boolean);
var
  SID: Longint;
begin
  if User then
    SID := SesID
  else
    SID := 0;
  DosSelectSession(SID);
end;

procedure HandleNotification(var DB: Debug_Buffer);
var
  I: Integer;
  SegTable: array[0..49] of TSysDbgSegDef;
  Buffer: array[0..255] of Char;
  DB1: Debug_Buffer;
begin
  case DB.Cmd of
    DBG_N_ModuleLoad:
      begin
        Buffer[0] := #0;                // DB.Value = Module Handle
        DosQueryModuleName(DB.Value, SizeOf(Buffer), Buffer);
        I := 0;
        repeat
          DB1.Pid := ProcessID;
          DB1.Value := I+1;             // Object number 1,2...
          DB1.MTE := DB.Value;          // in module
          DB1.Cmd := DBG_C_NumToAddr;   // Get segment address
          if (DosDebug(DB1) <> 0) or (DB1.Cmd <> DBG_N_SUCCESS) then
            Break;
          with SegTable[I] do
          begin
            FlatOfs := DB1.Addr;
            Size := 0;
            DB1.Cmd := DBG_C_AddrToObject;
            if (DosDebug(DB1) = 0) and (DB1.Cmd = DBG_N_SUCCESS) then
              Size := DB1.Len;
          end;
          Inc(I);
        until I >= High(SegTable);
        DbgInterface.DllLoaded(Buffer, DB.Value, I, SegTable);
      end;

    DBG_N_ModuleFree:
      DbgInterface.DllUnloaded(DB.Value);

    DBG_N_ThreadCreate:
      DbgInterface.ThreadCreated(DB.Tid, DB.Tid, DB.Tid);

    DBG_N_ThreadTerm:
      DbgInterface.ThreadExited(DB.Tid, DB.Value);

    DBG_N_ProcTerm:
      DbgInterface.ProcessExited(DB.Value, DB.Index);
  end;
end;

procedure HandlePendingNotifications;
var
  RC: Longint;
  DB: Debug_Buffer;
begin
  repeat
    DB.Pid := ProcessID;
    DB.Cmd := DBG_C_Stop;
    RC := DosDebug(DB);
    if RC = 0 then
      HandleNotification(DB);
  until (RC <> 0) or (DB.Cmd = DBG_N_SUCCESS);
end;

function SysDbgSelToFlat(Sel,Ofs: Longint): Longint;
var
  Selector: SmallWord;
  DB: Debug_Buffer;
begin
  Selector := Sel;
  if (Selector = FlatInfo.Flat_DS) or (Selector = FlatInfo.Flat_CS) then
    Result := Ofs
  else
    begin
      DB.Pid := ProcessID;
      DB.Value := Selector;
      DB.Index := Ofs;
      DB.Cmd := DBG_C_SelToLin;
      DosDebug(DB);
      Result := DB.Addr;
    end;
end;

function SysDbgReadMemory(Sel,Ofs: Longint; Buffer: Pointer; Size: Longint): Longint;
var
  DB: Debug_Buffer;
begin
  DB.Addr := SysDbgSelToFlat(Sel, Ofs);
  DB.Pid := ProcessID;
  DB.Buffer := Longint(Buffer);
  DB.Len := Size;
  DB.Cmd := DBG_C_ReadMemBuf;
  if (DosDebug(DB) <> 0) or (DB.Cmd <> DBG_N_SUCCESS) then
    Result := 0
  else
    Result := Size;
end;

function SysDbgWriteMemory(Sel,Ofs: Longint; Buffer: Pointer; Size: Longint): Longint;
var
  DB: Debug_Buffer;
begin
  DB.Addr := SysDbgSelToFlat(Sel, Ofs);
  DB.Pid := ProcessID;
  DB.Buffer := Longint(Buffer);
  DB.Len := Size;
  DB.Cmd := DBG_C_WriteMemBuf;
  if (DosDebug(DB) <> 0) or (DB.Cmd <> DBG_N_SUCCESS) then
    Result := 0
  else
    Result := Size;
end;

function SysDbgStartProcess(const FileName,CmdLine: String; AppType: Longint; var ProcessID,SesID,EntryAddr: Longint): Longint;
var
  SD: StartData;
  DB: Debug_Buffer;
  TitleBuf: array[0..259] of Char;
  FileNameBuf: array[0..259] of Char;
  CmdLineBuf: array[0..259] of Char;
begin
  EntryAddr := 0; // The IDE determines it itself
  FillChar(SD, SizeOf(StartData), 0);
  SD.Length := 32;                    // So it can start session without PM
  SD.Related := ssf_Related_Child;    // Related
  SD.FgBg := ssf_Fgbg_Back;           // BackGround
  SD.Traceopt  := ssf_TraceOpt_Trace; // Debugging trace
  SD.PgmTitle  := StrPCopy(TitleBuf, 'VP debugging: ' + FileName);
  SD.PgmName   := StrPCopy(FileNameBuf, FileName);
  SD.PgmInputs := StrPCopy(CmdLineBuf, CmdLine);
  SD.TermQ := nil;
  SD.Environment := nil;              // Inherit
  SD.InheritOpt := ssf_InhertOpt_Parent; // Parent environment
  SD.SessionType := AppType;
  Result := DosStartSession(SD, SesID, ProcessID);
  if Result <> 0 then
    begin
      SesID := $FFFFFFFF;
      ProcessID := $FFFFFFFF;
    end
  else
    begin
      DB.Pid   := ProcessID;    // Debuggee PID
      DB.Tid   := 0;            // Reserved, must be 0
      DB.Value := dbg_l_386;    // Debugging Level Number
      DB.Cmd   := DBG_C_Connect;
      Result := DosDebug(DB);
      if (Result = 0) and (DB.Cmd <> DBG_N_SUCCESS) then
        Result := DB.Value;     // Error Code
    end;
  VPDbgAPI.ProcessID := ProcessID;
  VPDbgAPI.SesID := SesID;
  if Result = 0 then
    HandlePendingNotifications;
end;

// Restores context of the debuggee (DB.Len should contain context address)

procedure RestoreContext(DB: Debug_Buffer);
var
  XcptContext: ContextRecord;
begin
  SysDbgReadMemory(FlatInfo.Flat_DS, DB.Len, @XcptContext, SizeOf(XcptContext));
  DB.EAX := XcptContext.ctx_RegEAX;
  DB.ECX := XcptContext.ctx_RegECX;
  DB.EDX := XcptContext.ctx_RegEDX;
  DB.EBX := XcptContext.ctx_RegEBX;
  DB.ESP := XcptContext.ctx_RegESP;
  DB.EBP := XcptContext.ctx_RegEBP;
  DB.ESI := XcptContext.ctx_RegESI;
  DB.EDI := XcptContext.ctx_RegEDI;
  DB.EFlags := XcptContext.ctx_EFlags;
  DB.EIP := XcptContext.ctx_RegEIP;
  DB.CS := XcptContext.ctx_SegCS;
  DB.DS := XcptContext.ctx_SegDS;
  DB.ES := XcptContext.ctx_SegES;
  DB.FS := XcptContext.ctx_SegFS;
  DB.GS := XcptContext.ctx_SegGS;
  DB.SS := XcptContext.ctx_SegSS;
  DB.Cmd := DBG_C_WriteReg;
  DosDebug(DB);
end;

procedure SysDbgExecute(Step: Boolean; Regs: TSysDbgCPURegisters; var DbgEvent: TSysDbgEvent);
var
  Done: Boolean;
  Value,Command,BytesRead: Longint;
  DB: Debug_Buffer;
  XcptReport: ExceptionReportRecord;
begin
  if Step then
    Command := DBG_C_SStep
  else
    Command := DBG_C_Go;
  DB.Pid := ProcessID;
  DB.Tid := Regs.ThreadID;
  Done := False;
  with DbgEvent do
  begin
    deWatchPtMask := 0;
    deCode := decStop;
    case Command of
      DBG_C_Go:   Value := XCPT_CONTINUE_SEARCH;
      DBG_C_Stop: Value := XCPT_CONTINUE_STOP;
    end;
    repeat
      DB.Cmd := Command;
      DB.Value := Value;
      deError := DosDebug(DB);
      if deError <> 0 then
      begin
        DB.Cmd := DBG_N_Error;
        DB.Value := deError;
      end;
      Command := DBG_C_Continue;
      HandleNotification(DB);
      case DB.Cmd of
        DBG_N_ThreadTerm,DBG_N_ThreadCreate,DBG_N_NewProc,DBG_N_AliasFree,
        DBG_N_ModuleLoad,DBG_N_ModuleFree: ;    // Simply skip

        DBG_N_ProcTerm:                         // Stop execution
          begin
            Value := XCPT_CONTINUE_STOP;
            deCode := decProcessEnded;
          end;

        DBG_N_AsyncStop:
          begin
            deCode := decStop;
            Done := True;                       // Exit
          end;

        DBG_N_Watchpoint:                       // Record watchpoint ID
          begin
            deWatchPtMask := deWatchPtMask or (1 shl DB.Index);
            Value := XCPT_CONTINUE_STOP;
            deCode := decWatchpoint;
          end;

        DBG_N_Error:
          begin
            deCode := decError;
            deError := DB.Value;
            Done := True;
          end;

        DBG_N_Exception:
          begin
            deXcptCode := DB.Buffer;
            deXcptAddress := DB.Addr;
            case DB.Value of // Exception Chance
              0: // Prefirst chance exception
                if deXcptCode = XCPT_SINGLE_STEP then
                  begin
                    Value := XCPT_CONTINUE_STOP;
                    deCode := decSingleStep;
                  end
                else
                  if deXcptCode = XCPT_BREAKPOINT then
                  begin
                    Value := XCPT_CONTINUE_STOP;
                    deCode := decBreakpoint;
                  end;

              1: // First chance exception
                begin
                  deCode := decException;
                  SysDbgReadMemory(FlatInfo.Flat_DS, DB.Buffer, @XcptReport, SizeOf(XcptReport));
                  deXcptParam1 := XcptReport.ExceptionInfo[0];
                  deXcptParam2 := XcptReport.ExceptionInfo[1];
                  deXcptCode := XcptReport.ExceptionNum;
                  case deXcptCode of
                    opecReRaise..opecSysException:
                      begin
                        DbgInterface.NotifyException(DbgEvent);
                        Value := XCPT_CONTINUE_EXECUTION;
                      end;
                    else
                      if DbgInterface.StopOnException(deXcptCode) then
                        begin
                          Value := XCPT_CONTINUE_STOP; // Break
                          RestoreContext(DB);
                        end
                      else
                        Value := XCPT_CONTINUE_SEARCH; // Pass to exception handler
                  end;
                end;
              // Second chance exception
              2: Value := XCPT_CONTINUE_SEARCH; // Perform default system action
              // Invalid stack
              3: Value := XCPT_CONTINUE_SEARCH;
            end; // Case
          end;

        else                                    // DBG_N_SUCCESS and others
          Done := True;
      end;
    until Done;

    deThreadID := DB.Tid;
  end;
end;

function SysDbgTerminateProcess: Longint;
var
  DB: Debug_Buffer;
begin
  DB.Pid := ProcessID;
  DB.Cmd := DBG_C_Term;
  Result := DosDebug(DB);
  if (Result = 0) and (DB.Cmd <> DBG_N_SUCCESS) then
    Result := DB.Value;
end;

function SysDbgReadRegisters(Regs: PSysDbgCPURegisters; FPUState: PSysDbgFSaveFormat): Boolean;
var
  DB: Debug_Buffer;
begin
  with Regs^ do
  begin
    DB.PID := ProcessID;
    DB.TID := ThreadID;
    if FPUState = nil then
      begin
        DB.Cmd := DBG_C_ReadReg;
        Result := (DosDebug(DB) = 0) and (DB.Cmd = DBG_N_SUCCESS);
        if Result then
        begin
          EAX := DB.EAX;
          ECX := DB.ECX;
          EDX := DB.EDX;
          EBX := DB.EBX;
          ESP := DB.ESP;
          EBP := DB.EBP;
          ESI := DB.ESI;
          EDI := DB.EDI;
          EFlags:= DB.EFlags;
          EIP := DB.EIP;
          CS := DB.CS;
          DS := DB.DS;
          ES := DB.ES;
          FS := DB.FS;
          GS := DB.GS;
          SS := DB.SS;
        end;
      end
    else
      begin
        DB.Value  := dbg_co_387;             // Coprocessor type 80387
        DB.Len    := SizeOf(TSysDbgFSaveFormat);   // Length of the coprcessor context
        DB.Buffer := Longint(FPUState);      // Address of the Ncp context buffer
        DB.Index  := 0;                      // Reserved, must be 0
        DB.Cmd    := dbg_c_ReadCoRegs;
        Result := (DosDebug(DB) = 0) and (DB.Cmd = DBG_N_SUCCESS);
      end;
  end;
end;

function SysDbgWriteRegisters(Regs: PSysDbgCPURegisters; FPUState: PSysDbgFSaveFormat): Boolean;
var
  DB: Debug_Buffer;
begin
  FillChar(DB, SizeOf(DB), 0);
  with Regs^ do
  begin
    DB.PID := ProcessID;
    DB.TID := ThreadID;
    if FPUState = nil then
      begin
        DB.Cmd := DBG_C_WriteReg;
        DB.EAX := EAX;
        DB.ECX := ECX;
        DB.EDX := EDX;
        DB.EBX := EBX;
        DB.ESP := ESP;
        DB.EBP := EBP;
        DB.ESI := ESI;
        DB.EDI := EDI;
        DB.EFlags := EFlags;
        DB.EIP := EIP;
        DB.CS := CS;
        DB.DS := DS;
        DB.ES := ES;
        DB.FS := FS;
        DB.GS := GS;
        DB.SS := SS;
        Result := (DosDebug(DB) = 0) and (DB.Cmd = DBG_N_SUCCESS);
      end
    else
      begin
        DB.Value  := dbg_co_387;            // Coprocessor type 80387
        DB.Len    := SizeOf(TSysDbgFSaveFormat);  // Length of the coprcessor context
        DB.Buffer := Longint(FPUState);     // Address of the Ncp context buffer
        DB.Index  := 0;                     // Reserved, must be 0
        DB.Cmd    := DBG_C_WriteCoRegs;
        Result := (DosDebug(DB) = 0) and (DB.Cmd = DBG_N_SUCCESS);
      end;
  end;
end;

function SysDbgFreezeThread(const Regs: TSysDbgCPURegisters): Boolean;
var
  DB: Debug_Buffer;
begin
  DB.Pid := ProcessID;
  DB.Tid := Regs.ThreadID;
  DB.Cmd := DBG_C_Freeze;
  Result := (DosDebug(DB) = 0) and (DB.Cmd = DBG_N_SUCCESS);
end;

function SysDbgResumeThread(const Regs: TSysDbgCPURegisters): Boolean;
var
  DB: Debug_Buffer;
begin
  DB.Pid := ProcessID;
  DB.Tid := Regs.ThreadID;
  DB.Cmd := DBG_C_Resume;
  Result := (DosDebug(DB) = 0) and (DB.Cmd = DBG_N_SUCCESS);
end;

function SysDbgGetThreadState(const Regs: TSysDbgCPURegisters; var State: TSysDbgThreadState): Boolean;
var
  DB: Debug_Buffer;
begin
  DB.Pid := ProcessID;
  DB.Tid := Regs.ThreadID;
  DB.Buffer := Longint(@State);
  DB.Len := 4;  // IsFrozen db ? ; State db ? ; Priority dw ?
  DB.Cmd := DBG_C_ThrdStat;
  Result := (DosDebug(DB) = 0) and (DB.Cmd = DBG_N_SUCCESS);
end;

function SysDbgSetWatchPoint(LinAddr: Longint; BkptLen,BkptType: Byte; ThreadID: Longint): Longint;
var
  DB: Debug_Buffer;
begin
  DB.Pid := ProcessID;
  DB.Addr := LinAddr;
  DB.Len := BkptLen;
  DB.Index := 0;                            // Reserved, must be 0
  DB.Value := 2+Longint(BkptType) shl 16;   // Watchpoint type and Scope
  DB.Cmd := DBG_C_SetWatch;                 // Scope = Local (2)
  if (DosDebug(DB) <> 0) or (DB.Cmd <> DBG_N_SUCCESS) then
    Result := 0
  else
    Result := DB.Index;
end;

procedure SysDbgClearWatchPoint(Id: Longint);
var
  DB: Debug_Buffer;
begin
  DB.Pid := ProcessID;
  DB.Index := Id;
  DB.Cmd := DBG_C_ClearWatch;
  DosDebug(DB);
end;

{$ELSE}

const
  DBG_EXCEPTION_NOT_HANDLED       = $80010001;
  DBG_CONTINUE                    = $00010002;
  DBG_TERMINATE_PROCESS           = $40010004;

var
  ProcessInfo: TProcessInformation;
  ProcessName: array[0..259] of Char;
  DebugEvent: TDebugEvent;
  ThreadNumber: Longint;
  ProcessStartAddr: Longint;

const
  WatchPtCount: Longint = 0;
  ProcessTerminated: Boolean = True;

function SetResult(Success: Boolean): Longint;
begin
  Result := 0;
  if not Success then
    Result := GetLastError;
end;

function GethThread(ThreadId: Longint): Longint;
var
  P: PSysDbgThreadIds;
  I: Integer;
begin
  I := 0;
  repeat
    P := DbgInterface.GetThreadParam(I);
    if (P <> nil) and (P^.ThreadId = ThreadId) then
    begin
      Result := P^.ThreadHandle;
      Exit;
    end;
    Inc(I);
  until P = nil;
  Result := 0;
end;

function GetIdThread(ThreadHandle: Longint): Longint;
var
  P: PSysDbgThreadIds;
  I: Integer;
begin
  I := 0;
  repeat
    P := DbgInterface.GetThreadParam(I);
    if (P <> nil) and (P^.ThreadHandle = ThreadHandle) then
    begin
      Result := P^.ThreadID;
      Exit;
    end;
    Inc(I);
  until P = nil;
  Result := 0;
end;

procedure SysDbgGetFlatInfo(var FlatInfo: TSysDbgFlatInfo);
begin
  FlatInfo := VPDbgAPI.FlatInfo;
end;

procedure SetupFlatInfo;
var
  CX: TContext;
begin
  CX.ContextFlags := CONTEXT_SEGMENTS or CONTEXT_CONTROL;
  GetThreadContext(ProcessInfo.hThread, CX);
  FlatInfo.Flat_CS := CX.SegCs;
  FlatInfo.Flat_DS := CX.SegDs;
end;


procedure SysDbgWaitUserScreen(Delay: Longint);
begin
  SysCtrlSleep(Delay);
end;

procedure SysDbgSetHardMode(Hard: Boolean);
begin
end;

type
  TWindowTitle = array[0..259] of Char;
  PSearchWindowParam = ^TSearchWindowParam;
  TSearchWindowParam = record
    swpPID: DWord;
    swpWnd: HWnd;
    swpConsoleTitle: TWindowTitle;
  end;

function EnumWindowFunc(Wnd: HWnd; Param: PSearchWindowParam): Bool; stdcall;
var
  PID: DWord;
  WindowTitle: TWindowTitle;
begin
  with Param do
  begin
    GetWindowThreadProcessId(Wnd, @PID);
    Result := swpPID <> PID;
    if swpConsoleTitle[0] <> #0 then
    begin
      GetWindowText(Wnd, WindowTitle, SizeOf(WindowTitle));
      Result := StrIComp(swpConsoleTitle, WindowTitle) <> 0;
    end;
    if not Result then
      Param.swpWnd := Wnd;
  end;
end;

procedure SysDbgSwitchScreen(User: Boolean);
var
  Param: TSearchWindowParam;
begin
  with Param do
  begin
    swpWnd := 0;
    swpConsoleTitle[0] := #0;
    swpPID := ProcessInfo.dwProcessId;
    if not User then
      swpPID := GetCurrentProcessId;
    EnumWindows(@EnumWindowFunc, DWord(@Param));
    if not User and (swpWnd = 0) then
    begin
      GetConsoleTitle(swpConsoleTitle, SizeOf(swpConsoleTitle));
      EnumWindows(@EnumWindowFunc, DWord(@Param));
    end;
    if Param.swpWnd <> 0 then
    begin
      SetForegroundWindow(Param.swpWnd);
    end;
  end;
end;

function SysDbgSelToFlat(Sel,Ofs: Longint): Longint;
var
  Selector: SmallWord;
begin
  Selector := Sel;
  if (Selector = FlatInfo.Flat_DS) or (Selector = FlatInfo.Flat_CS) then
    Result := Ofs
  else
    Result := 0;
end;

function SysDbgReadMemory(Sel,Ofs: Longint; Buffer: Pointer; Size: Longint): Longint;
begin
  if not ReadProcessMemory(ProcessInfo.hProcess, Pointer(SysDbgSelToFlat(Sel, Ofs)),
    Buffer, Size, Result) then
      Result := 0;
end;

function SysDbgWriteMemory(Sel,Ofs: Longint; Buffer: Pointer; Size: Longint): Longint;
begin
  if not WriteProcessMemory(ProcessInfo.hProcess, Pointer(SysDbgSelToFlat(Sel, Ofs)),
    Buffer, Size, Result) then
      Result := 0;
end;

procedure ReadPChar(Ofs: Longint; Buffer: PChar; BufSize: Longint; Unicode: Boolean);
var
  I: Integer;
  WordBuffer: array[0..1024] of SmallWord;
begin
  I := 0;
  if Unicode then
    begin
      while (I < BufSize-1) and (SysDbgReadMemory(FlatInfo.Flat_CS, Ofs+I*2, @WordBuffer[I], 2) = 2) and (WordBuffer[I] <> 0) do
        Inc(I);
      WordBuffer[I] := 0;
      WideCharToMultiByte(0, 0, @WordBuffer, I, Buffer, BufSize, nil, nil);
    end
  else
    begin
      while (I < BufSize-1) and (SysDbgReadMemory(FlatInfo.Flat_CS, Ofs+I, @Buffer[I], 1) = 1) and (Buffer[I] <> #0) do
        Inc(I);
      Buffer[I] := #0;
    end;
end;

function ReadDWord(Ofs: Longint): Longint;
begin
  if SysDbgReadMemory(FlatInfo.Flat_CS, Ofs, @Result, 4) <> 4 then
    Result := 0;
end;

type
  PDLLData = ^TDLLData;
  TDLLData = record
    // Input
    hFile: THandle;
    BaseOfs: Longint;
    // Output
    Name: array[0..255] of Char;
    Size: Longint;
  end;

procedure GetDLLParams(var DLLData: TDllData);
var
  I,Ofs: Longint;
  Actual: Longint;
  ExeHdr: TImageDosHeader;
  PEHdr: record
    Signature: Longint;
    FileHdr: TImageFileHeader;
    OptionalHdr: TImageOptionalHeader;
  end;
  ExpDir: TImageExportDirectory;
begin
  with DLLData do
  begin
    Name[0] := #0;
    Size := 0;
    SysFileSeek(hFile, 0, 0, Actual);
    SysFileRead(hFile, ExeHdr, SizeOf(ExeHdr), Actual);
    if (ExeHdr.e_magic = image_DOS_Signature) and (ExeHdr.e_lfanew <> 0) and (Actual = SizeOf(ExeHdr)) then
    begin
      SysFileSeek(hFile, ExeHdr.e_lfanew, 0, Actual);
      SysFileRead(hFile, PEHdr, SizeOf(PEHdr), Actual);
      if (PEHdr.Signature = image_NT_Signature) and (Actual = SizeOf(PEHdr)) then
      begin
        Ofs := BaseOfs + PEHdr.OptionalHdr.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT].VirtualAddress;
        if SysDbgReadMemory(FlatInfo.Flat_CS, Ofs, @ExpDir, SizeOf(ExpDir)) = SizeOf(ExpDir) then
          ReadPChar(BaseOfs + ExpDir.Name, Name, SizeOf(Name), False);
        Ofs := 0;
        with PEHdr.OptionalHdr do
        begin
          I := Low(DataDirectory);
          while I <= High(DataDirectory) do
          with DataDirectory[I] do
          begin
            if Ofs < VirtualAddress + Size then
              Ofs := VirtualAddress + Size;
            Inc(I);
          end;
        end;
        Size := Ofs;
      end;
    end;
  end;
end;

procedure HandleEvent(var Event: TDebugEvent);
var
  I: Integer;
  SegEntry: TSysDbgSegDef;
  DLLData: TDLLData;
begin
  with Event do
  case dwDebugEventCode of
    CREATE_THREAD_DEBUG_EVENT:
      begin
        Inc(ThreadNumber);
        DbgInterface.ThreadCreated(dwThreadId, CreateThread.hThread, ThreadNumber);
      end;

    EXIT_THREAD_DEBUG_EVENT:
      DbgInterface.ThreadExited(dwThreadId, ExitThread.dwExitCode);

    EXIT_PROCESS_DEBUG_EVENT:
      begin
        ProcessTerminated := True;
        DbgInterface.ThreadExited(ProcessInfo.dwThreadId, ProcessInfo.hThread);
        DbgInterface.ProcessExited(ExitProcess.dwExitCode, 0);
        ContinueDebugEvent(DebugEvent.dwProcessId, DebugEvent.dwThreadId, dbg_Continue);
      end;

    LOAD_DLL_DEBUG_EVENT:
      begin
        DLLData.hFile := LoadDll.hFile;
        DLLData.BaseOfs := Longint(LoadDll.lpBaseOfDll);;
        GetDLLParams(DLLData);
        SegEntry.FlatOfs := DLLData.BaseOfs;
        SegEntry.Size := DLLData.Size;
        DbgInterface.DllLoaded(DLLData.Name, DLLData.BaseOfs, 1, SegEntry);
        if DLLData.Name[0] = #0 then
          ReadPChar(ReadDWord(Longint(LoadDll.lpImageName)), DLLData.Name,
            SizeOf(DLLData.Name), LoadDll.fUnicode <> 0);
      end;

    UNLOAD_DLL_DEBUG_EVENT:
      DbgInterface.DllUnloaded(Longint(UnloadDll.lpBaseOfDll));

    CREATE_PROCESS_DEBUG_EVENT:
      begin
        DLLData.hFile := CreateProcessInfo.hFile;
        DLLData.BaseOfs := Longint(CreateProcessInfo.lpBaseOfImage);
        GetDLLParams(DLLData);
        SegEntry.FlatOfs := DLLData.BaseOfs;
        SegEntry.Size := DLLData.Size;
        StrCopy(DLLData.Name, ProcessName);
        DbgInterface.DllLoaded(DLLData.Name, DLLData.BaseOfs, 1, SegEntry);
        ProcessStartAddr := Longint(CreateProcessInfo.lpStartAddress);
      end;
  end;
end;

// The starting point of the program is not reported properly, because
// the entry point resides in Pharlap ETS code, not in VP generated code as
// the VP debugger expects it to be. To workaround this, the following hack
// is used: the code at the reported starting point is as follows:
//
// cs:215669C              pushfd
// cs:21567 60              pushad
// cs:21568 06              push   es
// cs:21569 E8220F0000      call   22490h
// cs:2156E 07              pop    es
// cs:2156F 61              popad
// cs:21570 9D              popfd
// cs:21571 E981EBFFFF      jmp    200F7h

// where the last JMP instruction goes to the actual starting entry point
// of the program. Calculate the target address of JMP and report it
// as the entry address. Unfortunately, this technique might not work in
// future if Pharlap decide to change this startup code.

{$IFDEF PharlapETS}

procedure PharlapHack;
var
  JmpInstr: record
    Opcode: Byte;
    Disp:   Longint;
  end;
begin
  if (SysDbgReadMemory(FlatInfo.Flat_CS, ProcessStartAddr+11, @JmpInstr, SizeOf(JmpInstr)) = SizeOf(JmpInstr)) and
    (JmpInstr.Opcode = $E9) then
      Inc(ProcessStartAddr, 11 + JmpInstr.Disp + 5);
end;

{$ENDIF}

function SysDbgStartProcess(const FileName,CmdLine: String; AppType: Longint; var ProcessID,SesID,EntryAddr: Longint): Longint;
var
  StartupInfo: TStartupInfo;
  TitleBuf: array[0..259] of Char;
  FileNameBuf: array[0..259] of Char;
  CmdLineBuf: array[0..512] of Char;
  QuotedName: String;
begin
  WatchPtCount := 0;
  ProcessStartAddr := 0;
  if Pos(' ',FileName) > 0 then
    QuotedName := '"' + FileName + '"'
  else
    QuotedName := FileName;
  StrPCopy(CmdLineBuf, QuotedName + ' ');
  StrPCopy(StrEnd(CmdLineBuf), CmdLine);
  StrPCopy(ProcessName, FileName);
  FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
  with StartupInfo do
  begin
    cb := SizeOf(TStartupInfo);
    dwFlags := startf_UseShowWindow;
    if AppType = 1 then
      dwFlags := dwFlags or StartF_RunFullScreen;
    wShowWindow := sw_ShowNormal;
    lpTitle := StrPCopy(TitleBuf, 'VP debugging: ' + FileName);
  end;
  Result := SetResult(CreateProcess(
    StrPCopy(FileNameBuf, FileName)     , // FileName
    CmdLineBuf                          , // Command Line
    nil                                 , // Process attributes
    nil                                 , // Thread attributes
    False                               , // Inherit handles
    debug_Only_This_Process + create_New_Console,
    nil                                 , // Environment
    nil                                 , // Current directory
    StartupInfo                         ,
    ProcessInfo
  ));
  if Result = 0 then
  begin
    SetUpFlatInfo;
    ProcessTerminated := False;
    ThreadNumber := 1;
    DbgInterface.ThreadCreated(ProcessInfo.dwThreadId, ProcessInfo.hThread, 1);
    ProcessID := ProcessInfo.hProcess;
    SesID := ProcessInfo.hProcess;
    while WaitForDebugEvent(DebugEvent, Infinite) do
    begin
      HandleEvent(DebugEvent);
      if DebugEvent.dwDebugEventCode = EXCEPTION_DEBUG_EVENT then
        Break;
      ContinueDebugEvent(DebugEvent.dwProcessId, DebugEvent.dwThreadId, dbg_Continue);
    end;
  end;
{$IFDEF PharlapETS}
  PharlapHack;
{$ENDIF}
  EntryAddr := ProcessStartAddr;
end;

procedure SysDbgExecute(Step: Boolean; Regs: TSysDbgCPURegisters; var DbgEvent: TSysDbgEvent);
var
  Done: Boolean;
  hThread: THandle;
  DbgContinueFlag: Longint;
  CX: TContext;
begin
  DbgContinueFlag := dbg_Continue;
  if Step then
  begin
    hThread := GethThread(DebugEvent.dwThreadId);
    CX.ContextFlags := CONTEXT_CONTROL;
    GetThreadContext(hThread, CX);
    CX.EFlags := CX.EFlags or $0100; // Set Trap Flag
    SetThreadContext(hThread, CX);
  end;
  with DebugEvent,DbgEvent do
  repeat
    Done := True;
    deCode := decError;
    deError := SetResult(ContinueDebugEvent(DebugEvent.dwProcessId, DebugEvent.dwThreadId, DbgContinueFlag));
    DbgContinueFlag := dbg_Continue;
    if deError <> 0 then
      Exit;
    deError := SetResult(WaitForDebugEvent(DebugEvent, Infinite));
    HandleEvent(DebugEvent);
    deThreadID := DebugEvent.dwThreadId;
    if deError <> 0 then
      Exit;
    case dwDebugEventCode of
      EXCEPTION_DEBUG_EVENT:
        begin
          deXcptCode := Exception.ExceptionRecord.ExceptionCode;
          deXcptAddress := Longint(Exception.ExceptionRecord.ExceptionAddress);
          case deXcptCode of
            STATUS_SINGLE_STEP:
              deCode := decSingleStep;
            STATUS_BREAKPOINT:
              begin
                deCode := decBreakpoint;
                CX.ContextFlags := CONTEXT_CONTROL;
                hThread := GethThread(DebugEvent.dwThreadId);
                GetThreadContext(hThread, CX);
                Dec(CX.EIP);
                SetThreadContext(hThread, CX);
              end;
            else
              if Exception.dwFirstChance = 0 then
                Done := False
              else
                begin
                  deCode := decException;
                  deXcptParam1 := Exception.ExceptionRecord.ExceptionInformation[0];
                  deXcptParam2 := Exception.ExceptionRecord.ExceptionInformation[1];
                  case deXcptCode of
                    opecReRaise..opecSysException:
                      begin
                        DbgInterface.NotifyException(DbgEvent);
                        Done := False;
                      end;
                    else
                      if not DbgInterface.StopOnException(deXcptCode) then
                      begin
                        DbgContinueFlag := dbg_Exception_Not_Handled;
                        Done := False;
                      end;
                  end;
                end;
          end;
        end;

      EXIT_PROCESS_DEBUG_EVENT:
        deCode := decProcessEnded;

      RIP_EVENT:
        deError := RipInfo.dwError

      else
        Done := False;
    end;
  until Done;
end;

{$IFDEF PharlapETS}
function ETSTerminateProcess(hThread: THandle; ExitCode: Longint): LongBool; StdCall; external 'etsdebug.dll' name '_ETSTerminateProcess@8';
{$ENDIF}

function SysDbgTerminateProcess: Longint;
var
  Success: Boolean;
  CX: TContext;
  Regs: TSysDbgCPURegisters;
  DbgEvent: TSysDbgEvent;
begin
  if not ProcessTerminated then
  begin
  {$IFDEF PharlapETS}
    ETSTerminateProcess(ProcessInfo.hThread, 1);
  {$ELSE}
    Regs.ThreadHandle := ProcessInfo.hThread;
    Regs.ThreadID := ProcessInfo.dwThreadId;
    CX.ContextFlags := CONTEXT_CONTROL;
    GetThreadContext(ProcessInfo.hThread, CX);
    CX.EIP := Longint(GetProcAddress(GetModuleHandle('kernel32.dll'), 'ExitProcess'));
    SetThreadContext(ProcessInfo.hThread, CX);
    SysDbgExecute(False, Regs, DbgEvent);
    if not ProcessTerminated then
      repeat
        Success := ContinueDebugEvent(DebugEvent.dwProcessId, DebugEvent.dwThreadId, dbg_Terminate_Process);
        if Success then
        begin
          Success := WaitForDebugEvent(DebugEvent, Infinite);
          HandleEvent(DebugEvent);
        end;
      until not Success or
        (DebugEvent.dwDebugEventCode = EXIT_PROCESS_DEBUG_EVENT) or
        (DebugEvent.dwDebugEventCode = RIP_EVENT);
  {$ENDIF}
  end;
  Result := 0;
end;

function SysDbgReadRegisters(Regs: PSysDbgCPURegisters; FPUState: PSysDbgFSaveFormat): Boolean;
var
  CX: TContext;
begin
  if FPUState = nil then
    CX.ContextFlags := CONTEXT_FULL
  else
    CX.ContextFlags := CONTEXT_FLOATING_POINT;
  with Regs^ do
  begin
    Result := GetThreadContext(ThreadHandle, CX);
    if Result then
      if FPUState <> nil then
        Move(CX.FloatSave, FPUState^, SizeOf(FPUState^))
      else
        begin
          GS := CX.SegGs;
          FS := CX.SegFs;
          ES := CX.SegEs;
          DS := CX.SegDs;
          EDI := CX.Edi;
          ESI := CX.Esi;
          EBX := CX.Ebx;
          EDX := CX.Edx;
          ECX := CX.Ecx;
          EAX := CX.Eax;
          EBP := CX.Ebp;
          EIP := CX.Eip;
          CS := CX.SegCs;
          EFlags := CX.EFlags;
          ESP := CX.Esp;
          SS := CX.SegSs;
        end;
  end;
end;

function SysDbgWriteRegisters(Regs: PSysDbgCPURegisters; FPUState: PSysDbgFSaveFormat): Boolean;
var
  CX: TContext;
begin
  with Regs do
  begin
    if FPUState = nil then
      begin
        CX.ContextFlags := CONTEXT_FULL;
        CX.SegGs := GS;
        CX.SegFs := FS;
        CX.SegEs := ES;
        CX.SegDs := DS;
        CX.Edi := EDI;
        CX.Esi := ESI;
        CX.Ebx := EBX;
        CX.Edx := EDX;
        CX.Ecx := ECX;
        CX.Eax := EAX;
        CX.Ebp := EBP;
        CX.Eip := EIP;
        CX.SegCs := CS;
        CX.EFlags := EFlags;
        CX.Esp := ESP;
        CX.SegSs := SS;
      end
    else
      begin
        FillChar(CX, SizeOf(CX), 0);
        CX.ContextFlags := CONTEXT_FLOATING_POINT;
        Move(FPUState^, CX.FloatSave, SizeOf(FPUState^));
      end;
    Result := SetThreadContext(ThreadHandle, CX);
  end;
end;

function SysDbgFreezeThread(const Regs: TSysDbgCPURegisters): Boolean;
begin
  Result := SuspendThread(Regs.ThreadHandle) <> $FFFFFFFF;
end;

function SysDbgResumeThread(const Regs: TSysDbgCPURegisters): Boolean;
begin
  Result := ResumeThread(Regs.ThreadHandle) <> $FFFFFFFF;
end;

function SysDbgGetThreadState(const Regs: TSysDbgCPURegisters; var State: TSysDbgThreadState): Boolean;
var
  Count: Integer;
begin
  with State, Regs do
  begin
    Count := SuspendThread(ThreadHandle);
    Result := Count <> $FFFFFFFF;
    IsFrozen := Count > 0;
    Schedule := 0;
    Priority := GetThreadPriority(ThreadHandle);
    ResumeThread(ThreadHandle);
  end;
end;

type
  PDRs = ^TDRs;
  TDRs = array [0..3] of DWord;

function SysDbgSetWatchPoint(LinAddr: Longint; BkptLen,BkptType: Byte; ThreadID: Longint): Longint;
var
  I,W: Integer;
  Success: Bool;
  P: PSysDbgThreadIds;
  CX: TContext;
const                         // Execute,Write,Read-Write
  DR7Types: array[1..3] of Byte = (0, 1, 3);
begin
  if WatchPtCount >= 4 then
    Result := 0
  else
    begin
      I := 0;
      repeat
        P := DbgInterface.GetThreadParam(I);
        if (P <> nil) and ((ThreadID = 0) or (P^.ThreadId = ThreadID)) then
        begin
          CX.ContextFlags := CONTEXT_DEBUG_REGISTERS;
          Success := GetThreadContext(P^.ThreadHandle, CX);
          if Success then
          begin
            W := WatchPtCount;
            PDRs(@CX.DR0)^[W] := LinAddr;
            CX.DR7 := (CX.DR7 and not ($F shl (16 + (W*4)))) or ($0001 shl (W*2)) or
              (DR7Types[BkptType] shl (16 + W*4)) or ((BkptLen-1) shl (18 + W*4));
            Success := SetThreadContext(P^.ThreadHandle, CX);
          end;
          if not Success then
          begin
            Result := 0;
            Exit;
          end;
        end;
        Inc(I);
      until P = nil;
      Inc(WatchPtCount);
      Result := WatchPtCount;
    end;
end;

procedure SysDbgClearWatchPoint(Id: Longint);
var
  I: Integer;
  P: PSysDbgThreadIds;
  CX: TContext;
begin
  Dec(Id);
  I := 0;
  repeat
    P := DbgInterface.GetThreadParam(I);
    if P <> nil then
    begin
      CX.ContextFlags := CONTEXT_DEBUG_REGISTERS;
      if GetThreadContext(P^.ThreadHandle, CX) then
      begin
        PDRs(@CX.DR0)^[Id] := 0;
        CX.DR7 := CX.DR7 and not (($1 shl (Id*2)) or ($F shl (16 + (Id*4))));
        SetThreadContext(P^.ThreadHandle, CX);
      end;
    end;
    Inc(I);
  until P = nil;
  Dec(WatchPtCount);
end;

{$ENDIF}

procedure SysDbgSetInterface(var DbgInt: TSysDbgInterface);
begin
  DbgInterface := DbgInt;
end;

procedure SysDbgInitialize;
begin
  SysDbgGetFlatInfo(FlatInfo);
end;

procedure SysDbgGetIDEInterface(var IDEInt: TSysDbgIDEInterface);
begin
  with IDEInt do
  begin
    SysDbgVersion           := 3;
  {$IFDEF WIN32}
    SysDbgPlatforms         := [dpWin32];
  {$ELSE}
    SysDbgPlatforms         := [dpOS2];
  {$ENDIF}
    SysDbgInitialize        := VPDbgAPI.SysDbgInitialize;
    SysDbgGetFlatInfo       := VPDbgAPI.SysDbgGetFlatInfo;
    SysDbgSetInterface      := VPDbgAPI.SysDbgSetInterface;
    SysDbgStartProcess      := VPDbgAPI.SysDbgStartProcess;
    SysDbgTerminateProcess  := VPDbgAPI.SysDbgTerminateProcess;
    SysDbgSelToFlat         := VPDbgAPI.SysDbgSelToFlat;
    SysDbgReadMemory        := VPDbgAPI.SysDbgReadMemory;
    SysDbgWriteMemory       := VPDbgAPI.SysDbgWriteMemory;
    SysDbgReadRegisters     := VPDbgAPI.SysDbgReadRegisters;
    SysDbgWriteRegisters    := VPDbgAPI.SysDbgWriteRegisters;
    SysDbgFreezeThread      := VPDbgAPI.SysDbgFreezeThread;
    SysDbgResumeThread      := VPDbgAPI.SysDbgResumeThread;
    SysDbgGetThreadState    := VPDbgAPI.SysDbgGetThreadState;
    SysDbgSetWatchPoint     := VPDbgAPI.SysDbgSetWatchPoint;
    SysDbgClearWatchPoint   := VPDbgAPI.SysDbgClearWatchPoint;
    SysDbgExecute           := VPDbgAPI.SysDbgExecute;
    SysDbgWaitUserScreen    := VPDbgAPI.SysDbgWaitUserScreen;
    SysDbgSetHardMode       := VPDbgAPI.SysDbgSetHardMode;
    SysDbgSwitchScreen      := VPDbgAPI.SysDbgSwitchScreen;
  end;
end;

{$ELSE}

type
  TGetIDEInterface = procedure(var IDEInt: TSysDbgIDEInterface);

var
  GetIDEInterface: Pointer;
  DllHandle: HModule;
  LoadError: Longint;

procedure SysDbgGetIDEInterface(var IDEInt: TSysDbgIDEInterface);
begin
  IDEInt.SysDbgVersion := - LoadError; // Not loaded
  if Assigned(GetIDEInterface) then
    TGetIDEInterface(GetIDEInterface)(IDEInt);
end;

{$IFDEF WIN32}
initialization
  DllHandle := LoadLibrary('VPDBGDLL.DLL');
  if DllHandle = 0 then
    LoadError := GetLastError;
  GetIDEInterface := GetProcAddress(DllHandle, 'SysDbgGetIDEInterface');
finalization
  FreeLibrary(DllHandle);

{$ELSE}

var
  FullDllName: array[0..260] of Char;
  DllNameStr: ShortString absolute FullDllName;

function MakeFullDllName(FileName: PChar): PChar;
var
  I: Integer;
begin
  DllNameStr := ParamStr(0);
  I := Length(DllNameStr);
  while (I > 1) and not (DllNameStr[I] in [':', '\']) do
    Dec(I);
  repeat
    Inc(I);
    DllNameStr[I] := FileName^;
    Inc(FileName);
  until (FileName-1)^ = #0;
  Result := @DllNameStr[1];
end;

initialization
  LoadError := DosLoadModule(nil, 0, MakeFullDllName('VPDBGDLL.DLL'), DllHandle);
  DosQueryProcAddr(DllHandle, 0, 'SysDbgGetIDEInterface', GetIDEInterface);
finalization
  DosFreeModule(DllHandle);
{$ENDIF}

{$ENDIF}

end.