[movitz-cvs] CVS update: movitz/losp/x86-pc/debugger.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/x86-pc
In directory common-lisp.net:/tmp/cvs-serv7331

Modified Files:
	debugger.lisp 
Log Message:
Added find-function-name.

Date: Tue Mar  1 00:34:02 2005
Author: ffjeld

Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.34 movitz/losp/x86-pc/debugger.lisp:1.35
--- movitz/losp/x86-pc/debugger.lisp:1.34	Mon Feb 28 17:44:37 2005
+++ movitz/losp/x86-pc/debugger.lisp	Tue Mar  1 00:34:02 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Nov 22 10:09:18 2002
 ;;;;                
-;;;; $Id: debugger.lisp,v 1.34 2005/02/28 16:44:37 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.35 2005/02/28 23:34:02 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -606,3 +606,20 @@
 			   c)))))))
   (values))
 
+(defun find-function-name (instruction-location)
+  "Try to find a name bound to a function whose code-vector matches instruction-location."
+  (check-type instruction-location fixnum)
+  (or (loop for (slot-name type) in (slot-value (class-of (current-run-time-context)) 'slot-map)
+	  do (when (and (eq type 'code-vector-word)
+			(location-in-object-p (%run-time-context-slot slot-name)
+					      instruction-location))
+	       (return (values slot-name :run-time-context))))
+      (do-all-symbols (symbol)
+	(when (and (fboundp symbol)
+		   (location-in-code-vector-p%unsafe (funobj-code-vector (symbol-function symbol))
+						     instruction-location))
+	  (return symbol))
+	(when (and (boundp symbol)
+		   (typep (symbol-value symbol) 'code-vector)
+		   (location-in-code-vector-p%unsafe (symbol-value symbol) instruction-location))
+	  (return (values symbol :symbol-value))))))