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@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)))))))