From 45d04c07df78d792c5d6196d9705114117e1d26d Mon Sep 17 00:00:00 2001
From: rtoy <rtoy>
Date: Mon, 23 Jan 2006 14:11:02 +0000
Subject: [PATCH] Implement tracing of flet/labels functions.  This probably
 needs more work and could probably be implemented better.

With these changes (trace (labels foo bar)) will trace the labels
function FOO in the function BAR.  We only support encapsulate nil,
here.  No check is made for this.

code/ntrace.lisp:
o In TRACE-FDEFINITION, recognize a list as a valid function, and
  return the list as the value of TRACE-FDEFINITION.  This seems
  wrong, but I'm not sure if there's a real fdefinition for it, or if
  we could create a fake one.

code/debug-int.lisp:
o In FUNCTION-DEBUG-FUNCTION, recognize a list as the name of a
  function, and find the corresponding compiled-debug-function and
  create and return the new compiled-debug-function.
---
 code/debug-int.lisp | 25 +++++++++++++++++++++++--
 code/ntrace.lisp    |  6 +++++-
 2 files changed, 28 insertions(+), 3 deletions(-)

diff --git a/code/debug-int.lisp b/code/debug-int.lisp
index efc54e8a0..21dd47ecb 100644
--- a/code/debug-int.lisp
+++ b/code/debug-int.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.121 2005/03/18 05:33:12 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/debug-int.lisp,v 1.122 2006/01/23 14:11:02 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -1955,7 +1955,28 @@ The result is a symbol or nil if the routine cannot be found."
 	    (debug-function-from-pc component
 				    (* (- (kernel:function-word-offset fun)
 					  (kernel:get-header-data component))
-				       vm:word-bytes)))))))
+				       vm:word-bytes)))))
+    (#.vm:list-pointer-type
+     ;; FIXME: Kind of gross, but this is how we recognize LABELS/FLET
+     ;; functions: we're given a list of the function name.
+     (unless (valid-function-name-p fun)
+       (error "Invalid function name: ~A~%" fun))
+     (let* ((external (fdefinition (car (last fun))))
+	    (component (kernel:function-code-header external))
+	    (res 
+	     ;; Look through all the debug functions until we find one
+	     ;; that matches our name.
+	     (find-if
+	      #'(lambda (x)
+		  (and (c::compiled-debug-function-p x)
+		       (equal (c::compiled-debug-function-name x) fun)
+		       (eq (c::compiled-debug-function-kind x) nil)))
+	      (get-debug-info-function-map
+	       (kernel:%code-debug-info component)))))
+       (if res
+	   (make-compiled-debug-function res
+					 (kernel:function-code-header external))
+	   (error "No such function ~A~%" fun))))))
 
 
 ;;; DEBUG-FUNCTION-KIND -- Public.
diff --git a/code/ntrace.lisp b/code/ntrace.lisp
index 616843baa..88f4f691a 100644
--- a/code/ntrace.lisp
+++ b/code/ntrace.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.32 2005/12/17 17:52:15 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/ntrace.lisp,v 1.33 2006/01/23 14:11:02 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -164,6 +164,10 @@
 	       (t
 		(values (fdefinition x) t))))
 	(function x)
+	(list
+	 ;; An extended function name for flets/labels.  Should we
+	 ;; make this check?
+	 (values x nil))
 	(t (values (fdefinition x) t)))
     (if (eval:interpreted-function-p res)
 	(values res named-p (if (eval:interpreted-function-closure res)
-- 
GitLab