Codebase list ilisp / bf9af97
Oops; new find-src.lisp code makes this functionality in sbcl.lisp redundant. rgrjr authored 21 years ago Barak A. Pearlmutter committed 14 years ago
1 changed file(s) with 1 addition(s) and 125 deletion(s). Raw diff Collapse all Expand all
+1
-125
sbcl.lisp less more
1010 ;;; Please refer to the file ACKNOWLEGDEMENTS for an (incomplete) list
1111 ;;; of present and past contributors.
1212 ;;;
13 ;;; $Id: sbcl.lisp,v 1.8 2002/03/26 09:41:04 anisotropy9 Exp $
13 ;;; $Id: sbcl.lisp,v 1.9 2003/04/02 02:53:37 rgrjr Exp $
1414
1515
1616 (in-package :ilisp)
6363
6464 (setq sb-debug:*flush-debug-errors* nil) ; allow multiple error levels.
6565
66
67 ;;;%% arglist/source-file utils.
68
69 (defun get-correct-fn-object (sym)
70 "Deduce how to get the \"right\" function object and return it."
71 (let ((fun (or (macro-function sym)
72 (and (fboundp sym) (symbol-function sym)))))
73 (cond (fun
74 (if (and (= (the-function-if-defined ((#:widetag-of :sb-impl)
75 (#:get-type :sb-impl)) fun)
76 ;; <3>
77 #.(the-symbol-if-defined
78 ((#:closure-header-widetag :sb-vm)
79 (#:closure-header-type :sb-vm) :eval-p t)))
80 (not (the-function-if-defined
81 ((#:interpreted-function-p :sb-eval) ()) fun)))
82 ;; <3>
83 (the-function-if-defined ((#:%closure-fun :sb-impl)
84 (#:closure-function :sb-impl))
85 fun)
86 ;; else just return the old function-object
87 fun))
88 (t
89 (error "Unknown function ~a. Check package." sym)
90 nil))))
91
9266 ;;; 2000-04-02: Martin Atzmueller
9367 ;;; better (more bulletproof) arglist code adapted from cmulisp.lisp:
94
95 (defun extract-function-info-from-name (sym)
96 (let ((mf (macro-function sym)))
97 (if mf
98 (values mf :macro)
99 (if (fboundp sym)
100 (values (symbol-function sym) :function)
101 (values nil nil)))))
10268
10369 (defun arglist (symbol package)
10470 (ilisp-errors
170136 ; be better.
171137 ))))))
172138
173 ;;; source-file symbol package type --
174 ;;; New version provided by Richard Harris <rharris@chestnut.com> with
175 ;;; suggestions by Larry Hunter <hunter@work.nlm.nih.gov>.
176
177 (defun source-file (symbol package type)
178 (declare (ignore type))
179 (ilisp-errors
180 (let* ((x (ilisp-find-symbol symbol package))
181 (fun (get-correct-fn-object x)))
182 (when (and fun
183 ;; <1>
184 (not (the-function-if-defined
185 ((#:interpreted-function-p :sb-eval) ()) fun)))
186 ;; The hack above is necessary because CMUCL does not
187 ;; correctly record source file information when 'loading'
188 ;; a non compiled file.
189 ;; In this case we fall back on the TAGS machinery.
190 ;; (At least as I underestand the code).
191 ;; Marco Antoniotti 11/22/94.
192 (cond ((sb-pcl::generic-function-p fun)
193 (dolist (method (sb-pcl::generic-function-methods fun))
194 (print-simple-source-info
195 (or (sb-pcl::method-fast-function method)
196 (sb-pcl::method-function method))))
197 t)
198 (t (print-simple-source-info fun)))))))
199
200 ;;; Patch suggested by Richard Harris <rharris@chestnut.com>
201
202 ;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object. It
203 ;;; returns a pathname for the file the function was defined in. If it was
204 ;;; not defined in some file, then nil is returned.
205 ;;;
206 ;;; FUN-DEFINED-FROM-PATHNAME is from hemlock/rompsite.lisp (cmucl17f),
207 ;;; with added read-time conditionalization to work in older versions
208 ;;; of cmucl. It may need a little bit more conditionalization for
209 ;;; some older versions of cmucl.
210
211 (defun fun-defined-from-pathname (function)
212 "Returns the file where FUNCTION is defined in (if the file can be found).
213 Takes a symbol or function and returns the pathname for the file the
214 function was defined in. If it was not defined in some file, nil is
215 returned."
216 (flet ((frob (code)
217 (let ((info (sb-kernel:%code-debug-info code)))
218 (when info
219 (let ((sources (sb-c::debug-info-source info)))
220 (when sources
221 (let ((source (car sources)))
222 (when (eq (sb-c::debug-source-from source) :file)
223 (sb-c::debug-source-name source)))))))))
224 (typecase function
225 (symbol (fun-defined-from-pathname (fdefinition function)))
226 ;; <2>
227 (#.(the-symbol-if-defined ((#:byte-function :sb-kernel) ()))
228 "Byte compiled function or macro, no arglist available.")
229 (#.(the-symbol-if-defined ((#:byte-closure :sb-kernel) ()))
230 "Byte compiled closure, no arglist available.")
231 (#.(the-symbol-if-defined ((#:byte-closure :sb-kernel) ()))
232 (fun-defined-from-pathname
233 (the-function-if-defined ((#:byte-closure-function :sb-kernel) ()
234 :function-binding-p t)
235 (funcall the-function function))))
236 (#.(the-symbol-if-defined ((#:byte-function :sb-kernel) ()))
237 (the-function-if-defined ((#:byte-function-component :sb-c) ()
238 :function-binding-p t)
239 (frob (funcall the-function function))))
240 (function
241 ;; <3>
242 (frob (the-function-if-defined ((#:fun-code-header :sb-kernel)
243 (#:function-code-header :sb-kernel))
244 (the-function-if-defined
245 ((#:%simple-fun-self :sb-kernel)
246 (#:%function-self :sb-kernel))
247 function))))
248 (t nil))))
249
250
251 ;;; print-simple-source-info --
252 ;;; Patches suggested by Larry Hunter <hunter@work.nlm.nih.gov> and
253 ;;; Richard Harris <rharris@chestnut.com>
254 ;;; Nov 21, 1994.
255
256 (defun print-simple-source-info (fun)
257 (let ((path (fun-defined-from-pathname fun)))
258 (when (and path (probe-file path))
259 (print (namestring (truename path)))
260 t)))
261
262
263139 (defun sbcl-trace (symbol package breakp)
264140 "Trace SYMBOL in PACKAGE."
265141 (ilisp-errors