From c0f51af40d9beefdba1f13934a942410979e7a4b Mon Sep 17 00:00:00 2001
From: Helmut Merz <helmutm@cy55.de>
Date: Thu, 30 May 2024 10:39:44 +0200
Subject: [PATCH] forge: decompile all codewhen tracing calls

---
 forge/forge.lisp | 36 ++++++++++++++++++++++++------------
 testing.lisp     |  2 +-
 2 files changed, 25 insertions(+), 13 deletions(-)

diff --git a/forge/forge.lisp b/forge/forge.lisp
index e7e1eca..4b1b87e 100644
--- a/forge/forge.lisp
+++ b/forge/forge.lisp
@@ -106,12 +106,15 @@
          (code (popd)))
     (register-comp-word name #'(lambda () (call code)) :code code)))
 
-(defun do-quote () (comp-item #'lit) (comp-item (read-next)))
+(defun do-quote () 
+  (let ((quoted (read-next)))
+    #+forge-trace (format t " - do-quote: ~a" quoted)
+    (comp-item #'lit) (comp-item quoted)))
 
 (defun do-comp () 
   (let* ((sym (read-next))
          (w (get-word sym)))
-    #+forge-trace (format t "~%do-comp ~a ~a ~a" sym w (gethash w (comp-words)))
+    ;#+forge-trace (format t "~%do-comp ~a ~a ~a" sym w (gethash w (comp-words)))
     (comp-item (gethash w (comp-words)))))
 
 (defun setup-builtins ()
@@ -133,14 +136,21 @@
 
   (activate-package :sf-user))
 
-;;; compiler, interpreter
+;;; trace functionality
 
-(defun do-trace (code)
-  (format t "~%~a" 
-    (mapcar 
-      #'(lambda (f) 
-          (or (gethash f (slot-value *forge-env* 'words-rev)) f)) 
-      code)))
+(defun decompile-item (item)
+  (or (gethash item (slot-value *forge-env* 'words-rev))
+      (typecase item
+        (cons (decompile item))
+        (t item))))
+
+(defun decompile (code)
+  (mapcar #'decompile-item code))
+
+(defun trace-call (code)
+  (format t "~%call: ~a" (decompile code)))
+
+;;; compiler, interpreter
 
 (defun exec-str (s)
   (exec (read-from-string 
@@ -155,17 +165,19 @@
   (call (comp code)))
 
 (defun call (code)
-  #+forge-trace (do-trace code)
+  #+forge-trace (trace-call code)
   (let ((old-ip (fip))
         (ip (make-iseq code)))
     (setf (slot-value *forge-env* 'ip) ip)
     (do ((item (isq-next ip) (isq-next ip)))
         ((null item))
       (funcall item))
-    (setf (slot-value *forge-env* 'ip) old-ip)))
+    (setf (slot-value *forge-env* 'ip) old-ip)
+    #+forge-trace (format t " - stack: ~a" (dstack))
+    (dstack)))
 
 (defun comp (slist)
-  #+forge-trace (print slist)
+  #+forge-trace (format t "~%comp: ~a" slist)
   (let ((cp (make-iseq))
         (inp (make-iseq slist)))
     (setf (slot-value *forge-env* 'cp) cp)
diff --git a/testing.lisp b/testing.lisp
index 96116f7..8a7e89c 100644
--- a/testing.lisp
+++ b/testing.lisp
@@ -22,7 +22,7 @@
 
 (defun show-result ()
   (let ((suite *test-suite*))
-    (format t "=== ~a Tests ===~%" (name suite) )
+    (format t "~%=== ~a Tests ===~%" (name suite) )
     (dolist (res (reverse (result suite)))
       (let ((tst (reverse res)))
         (format t "~a: ~a~%" (car tst) (cdr tst))))