1
0
mirror of https://github.com/moparisthebest/Simba synced 2024-12-23 07:48:50 -05:00
Simba/Units/PascalScript/uPSDebugger.pas
2010-03-12 18:10:10 +01:00

655 lines
15 KiB
ObjectPascal

unit uPSDebugger;
{$I PascalScript.inc}
interface
uses
SysUtils, uPSRuntime, uPSUtils;
type
TDebugMode = (dmRun
, dmStepOver
, dmStepInto
, dmPaused
);
TPSCustomDebugExec = class(TPSExec)
protected
FDebugDataForProcs: TIfList;
FLastProc: TPSProcRec;
FCurrentDebugProc: Pointer;
FProcNames: TIFStringList;
FGlobalVarNames: TIfStringList;
FCurrentSourcePos, FCurrentRow, FCurrentCol: Cardinal;
FCurrentFile: tbtstring;
function GetCurrentProcParams: TIfStringList;
function GetCurrentProcVars: TIfStringList;
protected
procedure ClearDebug; virtual;
public
function GetCurrentProcNo: Cardinal;
function GetCurrentPosition: Cardinal;
function TranslatePosition(Proc, Position: Cardinal): Cardinal;
function TranslatePositionEx(Proc, Position: Cardinal; var Pos, Row, Col: Cardinal; var Fn: tbtstring): Boolean;
procedure LoadDebugData(const Data: tbtstring);
procedure Clear; override;
property GlobalVarNames: TIfStringList read FGlobalVarNames;
property ProcNames: TIfStringList read FProcNames;
property CurrentProcVars: TIfStringList read GetCurrentProcVars;
property CurrentProcParams: TIfStringList read GetCurrentProcParams;
function GetGlobalVar(I: Cardinal): PIfVariant;
function GetProcVar(I: Cardinal): PIfVariant;
function GetProcParam(I: Cardinal): PIfVariant;
constructor Create;
destructor Destroy; override;
end;
TPSDebugExec = class;
TOnSourceLine = procedure (Sender: TPSDebugExec; const Name: tbtstring; Position, Row, Col: Cardinal);
TOnIdleCall = procedure (Sender: TPSDebugExec);
TPSDebugExec = class(TPSCustomDebugExec)
private
FDebugMode: TDebugMode;
FStepOverProc: TPSInternalProcRec;
FStepOverStackBase: Cardinal;
FOnIdleCall: TOnIdleCall;
FOnSourceLine: TOnSourceLine;
FDebugEnabled: Boolean;
protected
procedure SourceChanged;
procedure ClearDebug; override;
procedure RunLine; override;
public
constructor Create;
function LoadData(const s: tbtstring): Boolean; override;
procedure Pause; override;
procedure Run;
procedure StepInto;
procedure StepOver;
procedure Stop; override;
property DebugMode: TDebugMode read FDebugMode;
property OnSourceLine: TOnSourceLine read FOnSourceLine write FOnSourceLine;
property OnIdleCall: TOnIdleCall read FOnIdleCall write FOnIdleCall;
property DebugEnabled: Boolean read FDebugEnabled write FDebugEnabled;
end;
TIFPSDebugExec = TPSDebugExec;
implementation
{$IFDEF DELPHI3UP }
resourceString
{$ELSE }
const
{$ENDIF }
RPS_ExpectedReturnAddressStackBase = 'Expected return address at stack base';
type
PPositionData = ^TPositionData;
TPositionData = packed record
FileName: tbtstring;
Position,
Row,
Col,
SourcePosition: Cardinal;
end;
PFunctionInfo = ^TFunctionInfo;
TFunctionInfo = packed record
Func: TPSProcRec;
FParamNames: TIfStringList;
FVariableNames: TIfStringList;
FPositionTable: TIfList;
end;
{ TPSCustomDebugExec }
procedure TPSCustomDebugExec.Clear;
begin
inherited Clear;
if FGlobalVarNames <> nil then ClearDebug;
end;
procedure TPSCustomDebugExec.ClearDebug;
var
i, j: Longint;
p: PFunctionInfo;
begin
FCurrentDebugProc := nil;
FLastProc := nil;
FProcNames.Clear;
FGlobalVarNames.Clear;
FCurrentSourcePos := 0;
FCurrentRow := 0;
FCurrentCol := 0;
FCurrentFile := '';
for i := 0 to FDebugDataForProcs.Count -1 do
begin
p := FDebugDataForProcs[I];
for j := 0 to p^.FPositionTable.Count -1 do
begin
Dispose(PPositionData(P^.FPositionTable[J]));
end;
p^.FPositionTable.Free;
p^.FParamNames.Free;
p^.FVariableNames.Free;
Dispose(p);
end;
FDebugDataForProcs.Clear;
end;
constructor TPSCustomDebugExec.Create;
begin
inherited Create;
FCurrentSourcePos := 0;
FCurrentRow := 0;
FCurrentCol := 0;
FCurrentFile := '';
FDebugDataForProcs := TIfList.Create;
FLastProc := nil;
FCurrentDebugProc := nil;
FProcNames := TIFStringList.Create;
FGlobalVarNames := TIfStringList.Create;
end;
destructor TPSCustomDebugExec.Destroy;
begin
Clear;
FDebugDataForProcs.Free;
FProcNames.Free;
FGlobalVarNames.Free;
FGlobalVarNames := nil;
inherited Destroy;
end;
function TPSCustomDebugExec.GetCurrentPosition: Cardinal;
begin
Result := TranslatePosition(GetCurrentProcNo, 0);
end;
function TPSCustomDebugExec.GetCurrentProcNo: Cardinal;
var
i: Longint;
begin
for i := 0 to FProcs.Count -1 do
begin
if FProcs[i]= FCurrProc then
begin
Result := I;
Exit;
end;
end;
Result := Cardinal(-1);
end;
function TPSCustomDebugExec.GetCurrentProcParams: TIfStringList;
begin
if FCurrentDebugProc <> nil then
begin
Result := PFunctionInfo(FCurrentDebugProc)^.FParamNames;
end else Result := nil;
end;
function TPSCustomDebugExec.GetCurrentProcVars: TIfStringList;
begin
if FCurrentDebugProc <> nil then
begin
Result := PFunctionInfo(FCurrentDebugProc)^.FVariableNames;
end else Result := nil;
end;
function TPSCustomDebugExec.GetGlobalVar(I: Cardinal): PIfVariant;
begin
Result := FGlobalVars[I];
end;
function TPSCustomDebugExec.GetProcParam(I: Cardinal): PIfVariant;
begin
Result := FStack[Cardinal(Longint(FCurrStackBase) - Longint(I) - 1)];
end;
function TPSCustomDebugExec.GetProcVar(I: Cardinal): PIfVariant;
begin
Result := FStack[Cardinal(Longint(FCurrStackBase) + Longint(I) + 1)];
end;
function GetProcDebugInfo(FProcs: TIFList; Proc: TPSProcRec): PFunctionInfo;
var
i: Longint;
c: PFunctionInfo;
begin
if Proc = nil then
begin
Result := nil;
exit;
end;
for i := FProcs.Count -1 downto 0 do
begin
c := FProcs.Data^[I];
if c^.Func = Proc then
begin
Result := c;
exit;
end;
end;
new(c);
c^.Func := Proc;
c^.FPositionTable := TIfList.Create;
c^.FVariableNames := TIfStringList.Create;
c^.FParamNames := TIfStringList.Create;
FProcs.Add(c);
REsult := c;
end;
procedure TPSCustomDebugExec.LoadDebugData(const Data: tbtstring);
var
CP, I: Longint;
c: tbtchar;
CurrProcNo, LastProcNo: Cardinal;
LastProc: PFunctionInfo;
NewLoc: PPositionData;
s: tbtstring;
begin
ClearDebug;
if FStatus = isNotLoaded then exit;
CP := 1;
LastProcNo := Cardinal(-1);
LastProc := nil;
while CP <= length(Data) do
begin
c := Data[CP];
inc(cp);
case c of
#0:
begin
i := cp;
if i > length(data) then exit;
while Data[i] <> #0 do
begin
if Data[i] = #1 then
begin
FProcNames.Add(Copy(Data, cp, i-cp));
cp := I + 1;
end;
inc(I);
if I > length(data) then exit;
end;
cp := i + 1;
end;
#1:
begin
i := cp;
if i > length(data) then exit;
while Data[i] <> #0 do
begin
if Data[i] = #1 then
begin
FGlobalVarNames.Add(Copy(Data, cp, i-cp));
cp := I + 1;
end;
inc(I);
if I > length(data) then exit;
end;
cp := i + 1;
end;
#2:
begin
if cp + 4 > Length(data) then exit;
CurrProcNo := Cardinal((@Data[cp])^);
if CurrProcNo = Cardinal(-1) then Exit;
if CurrProcNo <> LastProcNo then
begin
LastProcNo := CurrProcNo;
LastProc := GetProcDebugInfo(FDebugDataForProcs, FProcs[CurrProcNo]);
if LastProc = nil then exit;
end;
inc(cp, 4);
i := cp;
if i > length(data) then exit;
while Data[i] <> #0 do
begin
if Data[i] = #1 then
begin
LastProc^.FParamNames.Add(Copy(Data, cp, i-cp));
cp := I + 1;
end;
inc(I);
if I > length(data) then exit;
end;
cp := i + 1;
end;
#3:
begin
if cp + 4 > Length(data) then exit;
CurrProcNo := Cardinal((@Data[cp])^);
if CurrProcNo = Cardinal(-1) then Exit;
if CurrProcNo <> LastProcNo then
begin
LastProcNo := CurrProcNo;
LastProc := GetProcDebugInfo(FDebugDataForProcs, FProcs[CurrProcNo]);
if LastProc = nil then exit;
end;
inc(cp, 4);
i := cp;
if i > length(data) then exit;
while Data[i] <> #0 do
begin
if Data[i] = #1 then
begin
LastProc^.FVariableNames.Add(Copy(Data, cp, i-cp));
cp := I + 1;
end;
inc(I);
if I > length(data) then exit;
end;
cp := i + 1;
end;
#4:
begin
i := cp;
if i > length(data) then exit;
while Data[i] <> #0 do
begin
if Data[i] = #1 then
begin
s := Copy(Data, cp, i-cp);
cp := I + 1;
Break;
end;
inc(I);
if I > length(data) then exit;
end;
if cp + 4 > Length(data) then exit;
CurrProcNo := Cardinal((@Data[cp])^);
if CurrProcNo = Cardinal(-1) then Exit;
if CurrProcNo <> LastProcNo then
begin
LastProcNo := CurrProcNo;
LastProc := GetProcDebugInfo(FDebugDataForProcs, FProcs[CurrProcNo]);
if LastProc = nil then exit;
end;
inc(cp, 4);
if cp + 16 > Length(data) then exit;
new(NewLoc);
NewLoc^.Position := Cardinal((@Data[Cp])^);
NewLoc^.FileName := s;
NewLoc^.SourcePosition := Cardinal((@Data[Cp+4])^);
NewLoc^.Row := Cardinal((@Data[Cp+8])^);
NewLoc^.Col := Cardinal((@Data[Cp+12])^);
inc(cp, 16);
LastProc^.FPositionTable.Add(NewLoc);
end;
else
begin
ClearDebug;
Exit;
end;
end;
end;
end;
function TPSCustomDebugExec.TranslatePosition(Proc, Position: Cardinal): Cardinal;
var
D1, D2: Cardinal;
s: tbtstring;
begin
if not TranslatePositionEx(Proc, Position, Result, D1, D2, s) then
Result := 0;
end;
function TPSCustomDebugExec.TranslatePositionEx(Proc, Position: Cardinal;
var Pos, Row, Col: Cardinal; var Fn: tbtstring): Boolean;
// Made by Martijn Laan (mlaan@wintax.nl)
var
i: LongInt;
fi: PFunctionInfo;
pt: TIfList;
r: PPositionData;
lastfn: tbtstring;
LastPos, LastRow, LastCol: Cardinal;
pp: TPSProcRec;
begin
fi := nil;
pp := FProcs[Proc];
for i := 0 to FDebugDataForProcs.Count -1 do
begin
fi := FDebugDataForProcs[i];
if fi^.Func = pp then
Break;
fi := nil;
end;
LastPos := 0;
LastRow := 0;
LastCol := 0;
if fi <> nil then begin
pt := fi^.FPositionTable;
for i := 0 to pt.Count -1 do
begin
r := pt[I];
if r^.Position >= Position then
begin
if r^.Position = Position then
begin
Pos := r^.SourcePosition;
Row := r^.Row;
Col := r^.Col;
Fn := r^.Filename;
end
else
begin
Pos := LastPos;
Row := LastRow;
Col := LastCol;
Fn := LastFn;
end;
Result := True;
exit;
end else
begin
LastPos := r^.SourcePosition;
LastRow := r^.Row;
LastCol := r^.Col;
LastFn := r^.FileName;
end;
end;
Pos := LastPos;
Row := LastRow;
Col := LastCol;
Result := True;
end else
begin
Result := False;
end;
end;
{ TPSDebugExec }
procedure TPSDebugExec.ClearDebug;
begin
inherited;
FDebugMode := dmRun;
end;
function TPSDebugExec.LoadData(const s: tbtstring): Boolean;
begin
Result := inherited LoadData(s);
FDebugMode := dmRun;
end;
procedure TPSDebugExec.RunLine;
var
i: Longint;
pt: TIfList;
r: PPositionData;
begin
inherited RunLine;
if not DebugEnabled then exit;
if FCurrProc <> FLastProc then
begin
FLastProc := FCurrProc;
FCurrentDebugProc := nil;
for i := 0 to FDebugDataForProcs.Count -1 do
begin
if PFunctionInfo(FDebugDataForProcs[I])^.Func = FLastProc then
begin
FCurrentDebugProc := FDebugDataForProcs[I];
break;
end;
end;
end;
if FCurrentDebugProc <> nil then
begin
pt := PFunctionInfo(FCurrentDebugProc)^.FPositionTable;
for i := 0 to pt.Count -1 do
begin
r := pt[I];
if r^.Position = FCurrentPosition then
begin
FCurrentSourcePos := r^.SourcePosition;
FCurrentRow := r^.Row;
FCurrentCol := r^.Col;
FCurrentFile := r^.FileName;
SourceChanged;
break;
end;
end;
end else
begin
FCurrentSourcePos := 0;
FCurrentRow := 0;
FCurrentCol := 0;
FCurrentFile := '';
end;
while FDebugMode = dmPaused do
begin
if @FOnIdleCall <> nil then
begin
FOnIdleCall(Self);
end else break; // endless loop
end;
end;
procedure TPSDebugExec.SourceChanged;
function StepOverShouldPause: Boolean;
var
I: Cardinal;
V: PPSVariant;
begin
if (FCurrProc <> FStepOverProc) or (FCurrStackBase <> FStepOverStackBase) then
begin
{ We're not inside the function being stepped, so scan the call stack to
see if we're inside a function called by the function being stepped }
I := FCurrStackBase;
while Longint(I) > Longint(FStepOverStackBase) do
begin
V := FStack.Items[I];
if (V = nil) or (V.FType <> FReturnAddressType) then
raise Exception.Create(RPS_ExpectedReturnAddressStackBase);
if (PPSVariantReturnAddress(V).Addr.ProcNo = FStepOverProc) and
(PPSVariantReturnAddress(V).Addr.StackBase = FStepOverStackBase) then
begin
{ We are, so don't pause }
Result := False;
Exit;
end;
I := PPSVariantReturnAddress(V).Addr.StackBase;
end;
end;
Result := True;
end;
begin
case FDebugMode of
dmStepInto:
begin
FDebugMode := dmPaused;
end;
dmStepOver:
begin
if StepOverShouldPause then
begin
FDebugMode := dmPaused;
end;
end;
end;
if @FOnSourceLine <> nil then
FOnSourceLine(Self, FCurrentFile, FCurrentSourcePos, FCurrentRow, FCurrentCol);
end;
procedure TPSDebugExec.Pause;
begin
FDebugMode := dmPaused;
end;
procedure TPSDebugExec.Stop;
begin
FDebugMode := dmRun;
inherited Stop;
end;
procedure TPSDebugExec.Run;
begin
FDebugMode := dmRun;
end;
procedure TPSDebugExec.StepInto;
begin
FDebugMode := dmStepInto;
end;
procedure TPSDebugExec.StepOver;
begin
FStepOverProc := FCurrProc;
FStepOverStackBase := FCurrStackBase;
FDebugMode := dmStepOver;
end;
constructor TPSDebugExec.Create;
begin
inherited Create;
FDebugEnabled := True;
end;
end.