cco/cl-scopes
3
0
Fork 0
Code Issues 1 Pull requests Releases Wiki Activity Actions

forge: decompile all codewhen tracing calls

Browse source
This commit is contained in:
Helmut Merz 2024-05-30 10:39:44 +02:00
parent b5dabdb73b
commit c0f51af40d
2 changed files with 25 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

36
forge/forge.lisp
View file

@ -106,12 +106,15 @@
(code (popd))) (code (popd)))
(register-comp-word name #'(lambda () (call code)) :code code))) (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 () (defun do-comp ()
(let* ((sym (read-next)) (let* ((sym (read-next))
(w (get-word sym))) (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))))) (comp-item (gethash w (comp-words)))))
(defun setup-builtins () (defun setup-builtins ()
@ -133,14 +136,21 @@
(activate-package :sf-user)) (activate-package :sf-user))
;;; compiler, interpreter ;;; trace functionality
(defun do-trace (code) (defun decompile-item (item)
(format t "~%~a" (or (gethash item (slot-value *forge-env* 'words-rev))
(mapcar (typecase item
#'(lambda (f) (cons (decompile item))
(or (gethash f (slot-value *forge-env* 'words-rev)) f)) (t item))))
code)))
(defun decompile (code)
(mapcar #'decompile-item code))
(defun trace-call (code)
(format t "~%call: ~a" (decompile code)))
;;; compiler, interpreter
(defun exec-str (s) (defun exec-str (s)
(exec (read-from-string (exec (read-from-string
@ -155,17 +165,19 @@
(call (comp code))) (call (comp code)))
(defun call (code) (defun call (code)
#+forge-trace (do-trace code) #+forge-trace (trace-call code)
(let ((old-ip (fip)) (let ((old-ip (fip))
(ip (make-iseq code))) (ip (make-iseq code)))
(setf (slot-value *forge-env* 'ip) ip) (setf (slot-value *forge-env* 'ip) ip)
(do ((item (isq-next ip) (isq-next ip))) (do ((item (isq-next ip) (isq-next ip)))
((null item)) ((null item))
(funcall 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) (defun comp (slist)
#+forge-trace (print slist) #+forge-trace (format t "~%comp: ~a" slist)
(let ((cp (make-iseq)) (let ((cp (make-iseq))
(inp (make-iseq slist))) (inp (make-iseq slist)))
(setf (slot-value *forge-env* 'cp) cp) (setf (slot-value *forge-env* 'cp) cp)

2
testing.lisp
View file

@ -22,7 +22,7 @@
(defun show-result () (defun show-result ()
(let ((suite *test-suite*)) (let ((suite *test-suite*))
(format t "=== ~a Tests ===~%" (name suite) ) (format t "~%=== ~a Tests ===~%" (name suite) )
(dolist (res (reverse (result suite))) (dolist (res (reverse (result suite)))
(let ((tst (reverse res))) (let ((tst (reverse res)))
(format t "~a: ~a~%" (car tst) (cdr tst)))) (format t "~a: ~a~%" (car tst) (cdr tst))))