From 1f846a56c81997b5cafe20d8dbd2234a88314a63 Mon Sep 17 00:00:00 2001
From: Martijn Laan <martijnlaan@gmail.com>
Date: Thu, 15 Aug 2019 08:13:39 +0200
Subject: [PATCH] Added call stack functionality. Taken from #203 by Vizit0r,
 with fixes and cleanup. Does not yet display parameter values, nor does it
 return position information.

---
 Source/uPSDebugger.pas | 78 +++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 77 insertions(+), 1 deletion(-)

diff --git a/Source/uPSDebugger.pas b/Source/uPSDebugger.pas
index 3b58393..be85699 100644
--- a/Source/uPSDebugger.pas
+++ b/Source/uPSDebugger.pas
@@ -56,7 +56,9 @@ type
     function GetProcVar(I: Cardinal): PIfVariant;
 	
     function GetProcParam(I: Cardinal): PIfVariant;
-    
+  
+    function GetCallStack(var Count: Cardinal): tbtString;
+  
     constructor Create;
 	
     destructor Destroy; override;
@@ -500,6 +502,80 @@ begin
   end;
 end;
 
+function TPSCustomDebugExec.GetCallStack(var Count: Cardinal): tbtString;
+
+  function GetProcIndex(Proc: TPSInternalProcRec): Cardinal;
+  var
+    I: Longint;
+  begin
+    for I := 0 to FProcs.Count -1 do
+    begin
+      if FProcs[I] = Proc then
+      begin
+        Result := I;
+        Exit;
+      end;
+    end;
+    Result := Cardinal(-1);
+  end;
+
+  function ParseParams(ParamList: TIfStringList; StackBase: Cardinal): tbtString;
+  var
+    I: Integer;
+  begin
+    Result := '';
+    if ParamList.Count > 0 then
+    for I := 0 to ParamList.Count do
+      if (ParamList.Items[I] = 'Result') or (ParamList.Items[I] = '') then
+        Continue
+      else
+        Result:= Result + ParamList.Items[I] + ': ' +
+                 PSVariantToString(NewTPSVariantIFC(FStack[Cardinal(Longint(StackBase) - Longint(I) - 1)], False), '') + '; ';
+    Result := tbtString(String(Result).Remove(Length(Result)-2));
+  end;
+
+var
+  StackBase: Cardinal;
+  DebugProc: PFunctionInfo;
+  Name: tbtString;
+  I: Integer;
+begin
+  Result := ProcNames[GetProcIndex(FCurrProc)] + '(' +
+            ParseParams(GetCurrentProcParams, FCurrStackBase) + ')';
+  Count := 1;
+
+  StackBase := FCurrStackBase;
+
+  while StackBase > 0 do
+  begin
+    DebugProc := nil;
+
+    for I := 0 to FDebugDataForProcs.Count -1 do
+      if PFunctionInfo(FDebugDataForProcs[I])^.Func = PPSVariantReturnAddress(FStack[StackBase]).Addr.ProcNo then
+      begin
+        DebugProc := FDebugDataForProcs[I];
+        Break;
+      end;
+
+    I := GetProcIndex(PPSVariantReturnAddress(FStack[StackBase]).Addr.ProcNo);
+    if I <= 0 then
+      if Assigned(PPSVariantReturnAddress(FStack[StackBase]).Addr.ProcNo) then
+        Name := PPSVariantReturnAddress(FStack[StackBase]).Addr.ProcNo.ExportName
+      else
+        Exit
+    else
+      Name := ProcNames[I];
+
+    StackBase := PPSVariantReturnAddress(FStack[StackBase]).Addr.StackBase;
+    if Assigned(DebugProc) then
+      Result := Result + #13#10 + Name + '(' + ParseParams(DebugProc.FParamNames, StackBase) + ')'
+    else
+      Result := Result + #13#10 + Name + '(???)';
+
+    Inc(Count);
+  end;
+end;
+
 { TPSDebugExec }
 procedure TPSDebugExec.ClearDebug;
 begin