[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-serv7872

Modified Files:
	debugger.lisp 
Log Message:
Rename find-function-name to locate-function, and improve it.

Date: Wed Mar  9 08:22:32 2005
Author: ffjeld

Index: movitz/losp/x86-pc/debugger.lisp
diff -u movitz/losp/x86-pc/debugger.lisp:1.36 movitz/losp/x86-pc/debugger.lisp:1.37
--- movitz/losp/x86-pc/debugger.lisp:1.36	Tue Mar  1 01:41:32 2005
+++ movitz/losp/x86-pc/debugger.lisp	Wed Mar  9 08:22:32 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.36 2005/03/01 00:41:32 ffjeld Exp $
+;;;; $Id: debugger.lisp,v 1.37 2005/03/09 07:22:32 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -606,39 +606,46 @@
 			   c)))))))
   (values))
 
-(defun find-function-name (instruction-location)
-  "Try to find a name bound to a function whose code-vector matches instruction-location."
+(defun locate-function (instruction-location)
+  "Try to find a function whose code-vector matches instruction-location, or just a code-vector."
   (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))))
-      (with-hash-table-iterator (hashis (get-global-property :setf-namespace))
-	(do () (nil)
-	  (multiple-value-bind (morep setf-name symbol)
-	      (hashis)
-	    (cond
-	     ((not morep)
-	      (return nil))
-	     ((and (fboundp symbol)
-		   (location-in-code-vector-p%unsafe (funobj-code-vector (symbol-function symbol))
-						     instruction-location))
-	      (return (list 'setf setf-name)))))))
-      (do-all-symbols (symbol)
-	(when (fboundp symbol)
-	  (let ((f (symbol-function symbol)))
-	    (when (location-in-code-vector-p%unsafe (funobj-code-vector f)
-						    instruction-location)
-	      (return symbol))
-	    (when (typep f 'generic-function)
-	      (dolist (m (generic-function-methods f))
-		(when (location-in-code-vector-p%unsafe (funobj-code-vector (method-function m))
-							instruction-location)
-		  (return-from find-function-name
-		    (funobj-name (method-function m))))))))
-	(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))))))
+  (labels ((match-funobj (function instruction-location &optional (limit 5))
+	     (cond
+	      ((location-in-code-vector-p%unsafe (funobj-code-vector function)
+						 instruction-location)
+	       function)
+	      ((not (plusp limit))
+	       nil)			; recurse no more.
+	      ;; Search for a local function.
+	      ((loop for i from (funobj-num-jumpers function) below (funobj-num-constants function)
+		   as x = (funobj-constant-ref function i)
+		   thereis (and (typep x 'function)
+				(match-funobj x instruction-location (1- limit)))))
+	      ;; Search a GF's method functions.
+	      ((when (typep function 'generic-function)
+		 (loop for m in (generic-function-methods function)
+		     thereis (match-funobj (method-function m) instruction-location (1- limit))))))))
+    (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))))
+	(with-hash-table-iterator (hashis (get-global-property :setf-namespace))
+	  (do () (nil)
+	    (multiple-value-bind (morep setf-name symbol)
+		(hashis)
+	      (cond
+	       ((not morep)
+		(return nil))
+	       ((fboundp symbol)
+		(let ((it (match-funobj (symbol-function symbol) instruction-location)))
+		  (when it (return it))))))))
+	(do-all-symbols (symbol)
+	  (when (fboundp symbol)
+	    (let ((it (match-funobj (symbol-function symbol) instruction-location)))
+	      (when it (return it))))
+	  (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)))))))