tracer.pas

Turbo Pascal 6.0编译器源码

unit Tracer;

{$O+,F+,S-,X+,V-}

interface

uses Objects, TDos, TEdit, CompVars;

procedure Bpts2Editor(P: PFileRec);
procedure Editor2Bpts(P: PFileRec);
procedure ConnectAllBpts;
function  FinDBpt(var B: TBreakpoint): Integer;
procedure SetBpt(I: Integer; var B: TBreakpoint);
procedure DeleteBpt(I: Integer);
procedure ShowBpt(I: Integer);
procedure DeleteAllBpts;
procedure Trace(Action: Integer);
procedure ResetTracer;

implementation

uses Drivers, Mem, Memory, Views, App, TVars, VSwap, Debug, FNames, Compiler,
  Editor, Utils, StrNames;

procedure Repaint(P: PFileRec);
begin
  EditFunc(P^.Editor, edInvalidateScreen, nil, 0);
end;

procedure StorePagesInfo;
var P: PFileRec;
begin
  P := LoadedFiles;
  while P <> nil do
  begin
    EditFunc(P^.Editor, edStorePagesInfo, nil, 0);
    P := P^.Next;
  end;
end;

procedure Bpts2Editor(P: PFileRec);
var
  I, J: Integer;
  B: PBreakpoint;
  T: TPoint;
begin
  I := 0;
  J := 0;
  while J < BptCount do
  begin
    B := BptArr[J];
    if (B^.FileName = P^.FileName) and (I < MaxBpt) then
    begin
      T.X := 1;
      T.Y := B^.LineNumber;
      P^.Breakpoints.EBpt[I].Pos := T;
      P^.Breakpoints.Bpt[I] := B;
      inc(I);
    end;
    inc(J);
  end;
  P^.Breakpoints.Count := I;
end;

procedure Editor2Bpts(P: PFileRec);
var
  Invalid: Boolean;
  I: Integer;
  T: TPoint;
  B: PBreakpoint;
begin
  Invalid := False;
  I := 0;
  while I < P^.Breakpoints.Count do
  begin
    T := P^.Breakpoints.EBpt[I].Pos;
    B := P^.Breakpoints.Bpt[I];
    if T.X > 0 then
      B^.LineNumber := T.Y
    else
    begin
      DeleteBpt(FinDBpt(B^));
      Invalid := True;
    end;
    Inc(I);
  end;
  if Invalid then Bpts2Editor(P);
end;

procedure ConnectAllBpts;
var
  P: PFileRec;
  I: Integer;
begin
  P := LoadedFiles;
  while P <> nil do
  begin
    I := P^.Breakpoints.Count;
    Bpts2Editor(P);
    if (I <> 0) or (P^.Breakpoints.Count <> 0) then
      Repaint(P);
    P := P^.Next;
  end;
end;

function CountBpts(var S: PathStr; K: Integer): Integer;
var
  I, J: Integer;
begin
  J := 0;
  for I := 0 to BptCount - 1 do
    if (I <> K) and (BptArr[I]^.FileName = S) then
      Inc(J);
  CountBpts := J;
end;

function Equals(var B1,B2: TBreakpoint): Boolean;
begin
  Equals := (B1.FileName = B2.FileName) and (B1.LineNumber = B2.LineNumber);
end;

function InitBpt(var B: TBreakpoint): Boolean;
var
  T: TSrcPoint;
  P: PFileRec;
  L: Word;
begin
  T.Fn := FindSourceName(B.FileName);
  if T.Fn <> 0 then
  begin
    T.Ln := B.LineNumber;
    P := FindFile(B.FileName);
    if P <> nil then
      T.Ln := EditFunc(P^.Editor, edGetNewLineNumber, Pointer(T.Ln), 0);
    if FindCode(T, B.Adr, L) = 0 then
      T.Fn := 0;
  end;
  B.Position := T;
  B.CurPassCount := B.PassCount;
  InitBpt := T.Fn <> 0;
end;

function FinDBpt(var B: TBreakpoint): Integer;
var
  I: Integer;
begin
  I := 0;
  while (I < BptCount) and not Equals(BptArr[I]^, B) do
    Inc(I);
  FinDBpt := I;
end;

procedure SetBpt(I: Integer; var B: TBreakpoint);
var
  P: PBreakpoint;
  L: array[0..1] of Longint;
begin
  if (Longint(ExecPos) <> 0) and not InitBpt(B) then
  begin
    L[0] := Longint(@B.FileName);
    L[1] := B.LineNumber;
    if MessageBox(sSetInvaliDBpt, @L, mfWarning + mfYesNoCancel) <> cmYes then
      Exit;
  end;
  if CountBpts(B.FileName, I) >= MaxBpt then
  begin
    MessageBox(sTooManyBptsInFile, nil, mfError + mfOkButton);
    Exit;
  end;
  if I = BptCount then
  begin
    if BptCount = MaxDBpt then
    begin
      MessageBox(sTooManyBpts, nil, mfError + mfOkButton);
      Exit;
    end;
    P:=MemAlloc(SizeOf(TBreakpoint));
    if P = nil then
    begin
      OutOfMemory;
      Exit;
    end;
    BptArr[BptCount] := P;
    Inc(BptCount);
  end;
  BptArr[I]^ := B;
end;

procedure DeleteBpt(I: Integer);
begin
  if I < BptCount then
  begin
    Dispose(BptArr[I]);
    Dec(BptCount);
    Move(BptArr[I+1], BptArr[I], (BptCount - I) * SizeOf(PBreakpoint));
  end;
end;

procedure ShowBpt(I: Integer);
begin
  with BptArr[I]^ do
    GoFileLine(FileName, LineNumber, gfAlways);
end;

procedure DeleteAllBpts;
begin
  while BptCount>0 do DeleteBpt(0);
end;

function ValidateBpts: Boolean;
var
  SaveInvalid, Changed: Boolean;
  I: Integer;
  B: PBreakpoint;
  L: array[0..1] of Longint;
begin
  ValidateBpts := False;
  SaveInvalid := True;
  Changed := False;
  I := 0;
  while I < BptCount do
  begin
    B := BptArr[I];
    if InitBpt(B^) then
      Inc(I)
    else
    begin
      if SaveInvalid then
      begin
        SaveInvalid := False;
        if GoFileLine(B^.FileName, B^.LineNumber, 0) then
        begin
          L[0] := Longint(@B^.FileName);
          L[1] := B^.LineNumber;
          case MessageBox(sClearInvaliDBpt, @L, mfWarning + mfYesNoCancel) of
            cmNo:
              SaveInvalid := True;
            cmCancel:
              Exit;
          end;
        end;
      end;
      if SaveInvalid then
        Inc(I)
      else
      begin
        DeleteBpt(I);
        Changed := True;
      end;
    end;
  end;
  if Changed then
    ConnectAllBpts;
  ValidateBpts := True;
end;

procedure ResetBpts;
var
  I: Integer;
begin
  I := 0;
  while I < BptCount do
  begin
    BptArr[I]^.Position.Fn := 0;
    Inc(I);
  end;
end;

procedure ClearExecBar;
var
  P: PEditView;
begin
  if ExecPos.Fn <> 0 then
  begin
    P := FindEditor(GetSourceName(ExecPos.Fn));
    if P <> nil then
    begin
      P^.EditData^.ExecBar := 0;
      P^.Repaint;
    end;
  end;
end;

procedure ShowSource;
begin
  if ExecPos.Fn <> 0 then
    GoFileLine(GetSourceName(ExecPos.Fn)^, ExecPos.Ln,
      gfProgram + gfExec + gfAlways + gfNoTop);
end;

procedure HookInt10; assembler;
asm
@@1:    MOV     AH,1
        INT     16H
        JZ      @@3
        MOV     AH,0
        INT     16H
        JMP     @@1
@@2:    IRET
@@3:    PUSH    DS
        XOR     AX,AX
        MOV     DS,AX
        MOV     AX,CS
        XCHG    AX,DS:42H
        PUSH    AX
        MOV     AX,OFFSET @@2
        XCHG    AX,DS:40H
        PUSH    AX
        MOV     AH,0BH
        INT     21H
        POP     WORD PTR DS:40H
        POP     WORD PTR DS:42H
        POP     DS
end;

procedure ResetPrg;
begin
  StopProgram;
  InitDebugger;
  ResetBpts;
end;

function DoTrace(Action: Integer): Longint;
var
  DBptCount: Integer;
  Err: Word;
  T: TSrcPoint;
  Adr: Pointer;
  L: array[0..3] of Longint;
  DBpts: DBptArr;
  S: string[79];

function SwapAndShow(N: Word; Flags: Word): Word;
begin
  SwapScreen(scTurbo, True);
  ClearExecBar;
  SwapAndShow := MessageBox(N, @L, Flags);
end;

procedure AddDBpt(P: Pointer);
var
  I: Integer;
begin
  I := 0;
  while (I < DBptCount) and (DBpts[I].Adr <> P) do
    Inc(I);
  if I = DBptCount then
  begin
    DBpts[DBptCount].Adr := P;
    Inc(DBptCount);
  end;
end;

function CreateDBpt: Boolean;
var
  B: TBreakpoint;
begin
  CreateDBpt := False;
  FindEditor(nil)^.SetBpt(B);
  if InitBpt(B) then
  begin
    AddDBpt(B.Adr);
    Adr := B.Adr;
    CreateDBpt := True;
  end;
end;

procedure Bpts2DBpts;
var
  I: Integer;
begin
  I := 0;
  while I < BptCount do
    with BptArr[I]^ do
    begin
      if Position.Fn <> 0 then
        AddDBpt(Adr);
      Inc(I);
  end;
end;

function ProcessBpt: Boolean;
var
  I: Integer;
  R: Longint;
  CsIp: Pointer;
begin
  ProcessBpt := True;
  if T.Fn <= 0 then
    Exit;
  PtrRec(CsIp).ofs := Rg[9];
  PtrRec(CsIp).Seg := Rg[10];
  if CsIp = Adr then Exit;
  I := 0;
  while I < BptCount do
    with BptArr[I]^ do
      if Adr <> CsIp then
        Inc(I)
      else
      begin
        if Condition <> '' then
        begin
          R := CheckCondition(Condition);
          if R = 0 then
          begin
            ProcessBpt := False;
            Exit
          end;
          if R > 0 then
          begin
            S := Strings^.Get(Word(R) + sErrorBase);
            L[0] := Longint(@S);
            SwapAndShow(sInvalidCondition, mfError + mfOkButton);
            Exit;
          end;
        end;
        if PassCount > 0 then
        begin
          Dec(CurPassCount);
          if CurPassCount > 0 then
          begin
            ProcessBpt := False;
            Exit
          end;
          CurPassCount := PassCount;
        end;
        if Condition <> '' then
        begin
          S := FileName;
          ConvertPath(S, 24);
          L[0] := Longint(@Condition);
          L[1] := Longint(@S);
          L[2] := LineNumber;
          SwapAndShow(sConditionTrue, mfInformation + mfOkButton);
        end;
        Exit;
      end;
end;

begin
  DoTrace := Longint(ExecPos);
  if Longint(ExecPos) = 0 then
  begin
    CheckUserScreen;
    StorePagesInfo;
    BuildPsp(CommandLine);
    Longint(T) := StartProgram;
    InitDebugger;
    if T.Fn < 0 then
    begin
      case T.Ln of
        -4:
          Err := sNoMemToRun;
        -7:
          Err := sCantRunUnit;
      else
        Err := sCantLoadExe;
      end;
      SwapAndShow(Err, mfError + mfOkButton);
      Exit;
    end;
    if not ValidateBpts then
    begin
      ResetPrg;
      Exit
    end;
    if Action < acRun then
      if T.Fn > 0 then
      begin
        DoTrace := Longint(T);
        Exit
      end else
      begin
        if SwapAndShow(sNoDebugInfo, mfWarning + mfYesNoCancel) <> cmYes then
        begin
          ResetPrg;
          Exit
        end;
        Action := acRun;
      end;
  end;
  DBptCount := 0;
  Adr := nil;
  if Action = acGotoCursor then
  begin
    if not CreateDBpt then
    begin
      SwapAndShow(sNoCodeForLine, mfError + mfOkButton);
      if Longint(ExecPos) = 0 then
        ResetPrg;
      Exit;
    end;
    Action := acRun;
  end;
  Bpts2DBpts;
  if ScreenSwapping = swAlways then
    SwapScreen(scUser, True);
  CtrlBreakHit := False;
  repeat
    if CtrlBreakHit then
      T.Fn := -T.Fn
    else
    begin
      RestoreEms;
      Longint(T) := Step(DBptCount, DBpts, Action);
      SaveEms;
    end;
    InitDebugger;
  until ProcessBpt;
  if T.Fn < 0 then
  begin
    SwapScreen(scTurbo, True);
    if T.Ln <= 0 then
    begin
      HookInt10;
      ResetPrg;
      SwapAndShow(sFatalBreak, mfInformation + mfOkButton);
      Longint(T) := 0;
    end else
    begin
      T.Fn := -T.Fn;
      S := GetSourceName(T.Fn)^;
      ConvertPath(S, 24);
      L[0] := Longint(@S);
      L[1] := T.Ln;
      SwapAndShow(sUserBreak, mfInformation + mfOkButton);
    end;
  end else if T.Fn = 0 then
    if T.Ln < 0 then
    begin
      SwapScreen(scTurbo, True);
      SwapAndShow(sLineTooComplex, mfWarning + mfOkButton);
      Longint(T) := Longint(ExecPos);
    end else
    begin
      HookInt10;
      ResetPrg;
      Longint(T) := 0;
    end;
    SwapScreen(scTurbo, True);
    DoTrace := Longint(T);
end;

procedure SetFile(P: TSrcPoint);
begin
  if ExecPos.Fn <> P.Fn then
    ClearExecBar;
  Longint(ExecPos) := Longint(P);
  ShowSource;
  Message(Desktop, evDebugger, cmRefreshInfo, nil);
end;

procedure Trace(Action: Integer);
var
  P: TSrcPoint;
begin
  Longint(P) := DoTrace(Action);
  SetFile(P);
end;

procedure ResetTracer;
const
  P: TSrcPoint = (Fn: 0; Ln: 0);
begin
  ResetPrg;
  SetFile(P);
end;

end.