/[slime]/slime/swank-cmucl.lisp
ViewVC logotype

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.161 - (hide annotations)
Wed Aug 9 17:01:13 2006 UTC (7 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.160: +1 -1 lines
(inspect-for-emacs): Don't use defimplementation for real generics.
1 lgorrie 1.103 ;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;+" -*-
2     ;;;
3 heller 1.108 ;;; License: Public Domain
4     ;;;
5 lgorrie 1.103 ;;;; Introduction
6     ;;;
7     ;;; This is the CMUCL implementation of the `swank-backend' package.
8 dbarlow 1.1
9 heller 1.80 (in-package :swank-backend)
10 dbarlow 1.1
11 heller 1.119 (import-swank-mop-symbols :pcl '(:slot-definition-documentation))
12    
13     (defun swank-mop:slot-definition-documentation (slot)
14     (documentation slot t))
15    
16 lgorrie 1.103 ;;;; "Hot fixes"
17     ;;;
18 heller 1.147 ;;; Here are necessary bugfixes to the oldest supported version of
19 lgorrie 1.103 ;;; CMUCL (currently 18e). Any fixes placed here should also be
20     ;;; submitted to the `cmucl-imp' mailing list and confirmed as
21     ;;; good. When a new release is made that includes the fixes we should
22     ;;; promptly delete them from here. It is enough to be compatible with
23     ;;; the latest release.
24    
25 heller 1.67 (in-package :lisp)
26    
27 lgorrie 1.103 ;;; `READ-SEQUENCE' with large sequences has problems in 18e. This new
28     ;;; definition works better.
29    
30 heller 1.131 #-cmu19
31 heller 1.67 (progn
32     (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
33     (when s
34     (setf (symbol-value s) nil)))
35    
36     (defun read-into-simple-string (s stream start end)
37     (declare (type simple-string s))
38     (declare (type stream stream))
39     (declare (type index start end))
40     (unless (subtypep (stream-element-type stream) 'character)
41     (error 'type-error
42     :datum (read-char stream nil #\Null)
43     :expected-type (stream-element-type stream)
44     :format-control "Trying to read characters from a binary stream."))
45     ;; Let's go as low level as it seems reasonable.
46     (let* ((numbytes (- end start))
47 heller 1.79 (total-bytes 0))
48     ;; read-n-bytes may return fewer bytes than requested, so we need
49     ;; to keep trying.
50     (loop while (plusp numbytes) do
51     (let ((bytes-read (system:read-n-bytes stream s start numbytes nil)))
52     (when (zerop bytes-read)
53     (return-from read-into-simple-string total-bytes))
54     (incf total-bytes bytes-read)
55     (incf start bytes-read)
56     (decf numbytes bytes-read)))
57     total-bytes))
58 heller 1.67
59     (let ((s (find-symbol (string :*enable-package-locked-errors*) :lisp)))
60     (when s
61     (setf (symbol-value s) t)))
62    
63     )
64    
65 heller 1.80 (in-package :swank-backend)
66 heller 1.67
67 lgorrie 1.25
68 lgorrie 1.103 ;;;; TCP server
69     ;;;
70     ;;; In CMUCL we support all communication styles. By default we use
71     ;;; `:SIGIO' because it is the most responsive, but it's somewhat
72     ;;; dangerous: CMUCL is not in general "signal safe", and you don't
73     ;;; know for sure what you'll be interrupting. Both `:FD-HANDLER' and
74     ;;; `:SPAWN' are reasonable alternatives.
75 lgorrie 1.25
76 heller 1.80 (defimplementation preferred-communication-style ()
77     :sigio)
78 heller 1.48
79 heller 1.133 #-(or ppc mips)
80 heller 1.63 (defimplementation create-socket (host port)
81 heller 1.136 (let* ((addr (resolve-hostname host))
82     (addr (if (not (find-symbol "SOCKET-ERROR" :ext))
83     (ext:htonl addr)
84     addr)))
85     (ext:create-inet-listener port :stream :reuse-address t :host addr)))
86 heller 1.133
87     ;; There seems to be a bug in create-inet-listener on Mac/OSX and Irix.
88     #+(or ppc mips)
89     (defimplementation create-socket (host port)
90     (declare (ignore host))
91     (ext:create-inet-listener port :stream :reuse-address t))
92 heller 1.47
93 lgorrie 1.56 (defimplementation local-port (socket)
94 heller 1.47 (nth-value 1 (ext::get-socket-host-and-port (socket-fd socket))))
95    
96 lgorrie 1.56 (defimplementation close-socket (socket)
97 heller 1.157 (let ((fd (socket-fd socket)))
98     (sys:invalidate-descriptor fd)
99     (ext:close-socket fd)))
100 heller 1.47
101 heller 1.157 (defimplementation accept-connection (socket &key
102     (external-format :iso-latin-1-unix)
103 dcrosher 1.160 (buffering :full)
104     timeout)
105     (declare (ignore timeout))
106 heller 1.159 (unless (eq external-format ':iso-latin-1-unix)
107     (remove-fd-handlers socket)
108     (remove-sigio-handlers socket)
109     (assert (eq external-format ':iso-latin-1-unix)))
110 heller 1.157 (make-socket-io-stream (ext:accept-tcp-connection socket) buffering))
111 heller 1.47
112 lgorrie 1.103 ;;;;; Sockets
113    
114     (defun socket-fd (socket)
115     "Return the filedescriptor for the socket represented by SOCKET."
116     (etypecase socket
117     (fixnum socket)
118     (sys:fd-stream (sys:fd-stream-fd socket))))
119    
120     (defun resolve-hostname (hostname)
121 heller 1.136 "Return the IP address of HOSTNAME as an integer (in host byte-order)."
122     (let ((hostent (ext:lookup-host-entry hostname)))
123     (car (ext:host-entry-addr-list hostent))))
124 lgorrie 1.103
125 heller 1.157 (defun make-socket-io-stream (fd buffering)
126 lgorrie 1.103 "Create a new input/output fd-stream for FD."
127 heller 1.157 (sys:make-fd-stream fd :input t :output t :element-type 'base-char
128     :buffering buffering))
129 lgorrie 1.103
130     ;;;;; Signal-driven I/O
131    
132 heller 1.59 (defvar *sigio-handlers* '()
133 lgorrie 1.103 "List of (key . function) pairs.
134     All functions are called on SIGIO, and the key is used for removing
135     specific functions.")
136 heller 1.59
137     (defun set-sigio-handler ()
138 heller 1.101 (sys:enable-interrupt :sigio (lambda (signal code scp)
139     (sigio-handler signal code scp))))
140 heller 1.59
141 lgorrie 1.103 (defun sigio-handler (signal code scp)
142     (declare (ignore signal code scp))
143     (mapc #'funcall (mapcar #'cdr *sigio-handlers*)))
144    
145 heller 1.68 (defun fcntl (fd command arg)
146 lgorrie 1.103 "fcntl(2) - manipulate a file descriptor."
147 heller 1.68 (multiple-value-bind (ok error) (unix:unix-fcntl fd command arg)
148 lgorrie 1.103 (unless ok (error "fcntl: ~A" (unix:get-unix-error-msg error)))))
149 heller 1.68
150     (defimplementation add-sigio-handler (socket fn)
151     (set-sigio-handler)
152 heller 1.59 (let ((fd (socket-fd socket)))
153 heller 1.68 (fcntl fd unix:f-setown (unix:unix-getpid))
154 heller 1.92 (fcntl fd unix:f-setfl unix:fasync)
155 heller 1.68 (push (cons fd fn) *sigio-handlers*)))
156 lgorrie 1.45
157 heller 1.68 (defimplementation remove-sigio-handlers (socket)
158 heller 1.59 (let ((fd (socket-fd socket)))
159 lgorrie 1.103 (setf *sigio-handlers* (remove fd *sigio-handlers* :key #'car))
160 heller 1.159 (sys:invalidate-descriptor fd)))
161 heller 1.50
162 lgorrie 1.103 ;;;;; SERVE-EVENT
163    
164 heller 1.68 (defimplementation add-fd-handler (socket fn)
165     (let ((fd (socket-fd socket)))
166 heller 1.154 (sys:add-fd-handler fd :input (lambda (_) _ (funcall fn)))))
167 heller 1.68
168     (defimplementation remove-fd-handlers (socket)
169     (sys:invalidate-descriptor (socket-fd socket)))
170    
171 lgorrie 1.103
172     ;;;; Stream handling
173     ;;; XXX: How come we don't use Gray streams in CMUCL too? -luke (15/May/2004)
174    
175 lgorrie 1.56 (defimplementation make-fn-streams (input-fn output-fn)
176 lgorrie 1.45 (let* ((output (make-slime-output-stream output-fn))
177     (input (make-slime-input-stream input-fn output)))
178     (values input output)))
179 lgorrie 1.25
180 dbarlow 1.1 (defstruct (slime-output-stream
181 lgorrie 1.45 (:include lisp::lisp-stream
182     (lisp::misc #'sos/misc)
183     (lisp::out #'sos/out)
184     (lisp::sout #'sos/sout))
185     (:conc-name sos.)
186     (:print-function %print-slime-output-stream)
187     (:constructor make-slime-output-stream (output-fn)))
188     (output-fn nil :type function)
189 heller 1.154 (buffer (make-string 8000) :type string)
190 heller 1.16 (index 0 :type kernel:index)
191 heller 1.154 (column 0 :type kernel:index)
192 heller 1.155 (last-flush-time (get-internal-real-time) :type unsigned-byte))
193 heller 1.16
194 heller 1.17 (defun %print-slime-output-stream (s stream d)
195     (declare (ignore d))
196     (print-unreadable-object (s stream :type t :identity t)))
197    
198 heller 1.16 (defun sos/out (stream char)
199 heller 1.157 (system:without-interrupts
200     (let ((buffer (sos.buffer stream))
201     (index (sos.index stream)))
202     (setf (schar buffer index) char)
203     (setf (sos.index stream) (1+ index))
204     (incf (sos.column stream))
205     (when (char= #\newline char)
206     (setf (sos.column stream) 0)
207     (force-output stream))
208     (when (= index (1- (length buffer)))
209     (finish-output stream)))
210     char))
211 heller 1.16
212     (defun sos/sout (stream string start end)
213 heller 1.157 (system:without-interrupts
214     (loop for i from start below end
215     do (sos/out stream (aref string i)))))
216 lgorrie 1.45
217 heller 1.154 (defun log-stream-op (stream operation)
218     stream operation
219     #+(or)
220     (progn
221     (format sys:*tty* "~S @ ~D ~A~%" operation
222     (sos.index stream)
223     (/ (- (get-internal-real-time) (sos.last-flush-time stream))
224     (coerce internal-time-units-per-second 'double-float)))
225     (finish-output sys:*tty*)))
226    
227 heller 1.16 (defun sos/misc (stream operation &optional arg1 arg2)
228     (declare (ignore arg1 arg2))
229 dbarlow 1.1 (case operation
230 heller 1.154 (:finish-output
231     (log-stream-op stream operation)
232 heller 1.157 (system:without-interrupts
233     (let ((end (sos.index stream)))
234     (unless (zerop end)
235     (let ((s (subseq (sos.buffer stream) 0 end)))
236     (setf (sos.index stream) 0)
237     (funcall (sos.output-fn stream) s))
238     (setf (sos.last-flush-time stream) (get-internal-real-time)))))
239 heller 1.154 nil)
240     (:force-output
241     (log-stream-op stream operation)
242 heller 1.156 (sos/misc-force-output stream)
243 heller 1.154 nil)
244 heller 1.16 (:charpos (sos.column stream))
245     (:line-length 75)
246 dbarlow 1.1 (:file-position nil)
247 heller 1.16 (:element-type 'base-char)
248     (:get-command nil)
249 heller 1.22 (:close nil)
250 heller 1.16 (t (format *terminal-io* "~&~Astream: ~S~%" stream operation))))
251 dbarlow 1.1
252 heller 1.156 (defun sos/misc-force-output (stream)
253 heller 1.157 (system:without-interrupts
254     (unless (or (zerop (sos.index stream))
255     (loop with buffer = (sos.buffer stream)
256     for i from 0 below (sos.index stream)
257     always (char= (aref buffer i) #\newline)))
258     (let ((last (sos.last-flush-time stream))
259     (now (get-internal-real-time)))
260     (when (> (/ (- now last)
261     (coerce internal-time-units-per-second 'double-float))
262     0.1)
263     (finish-output stream))))))
264 heller 1.156
265 heller 1.9 (defstruct (slime-input-stream
266 lgorrie 1.45 (:include string-stream
267     (lisp::in #'sis/in)
268     (lisp::misc #'sis/misc))
269     (:conc-name sis.)
270     (:print-function %print-slime-output-stream)
271     (:constructor make-slime-input-stream (input-fn sos)))
272     (input-fn nil :type function)
273     ;; We know our sibling output stream, so that we can force it before
274     ;; requesting input.
275     (sos nil :type slime-output-stream)
276     (buffer "" :type string)
277     (index 0 :type kernel:index))
278 heller 1.16
279     (defun sis/in (stream eof-errorp eof-value)
280 heller 1.156 (finish-output (sis.sos stream))
281 heller 1.16 (let ((index (sis.index stream))
282     (buffer (sis.buffer stream)))
283     (when (= index (length buffer))
284 heller 1.119 (let ((string (funcall (sis.input-fn stream))))
285     (cond ((zerop (length string))
286     (return-from sis/in
287     (if eof-errorp
288     (error (make-condition 'end-of-file :stream stream))
289     eof-value)))
290     (t
291     (setf buffer string)
292     (setf (sis.buffer stream) buffer)
293     (setf index 0)))))
294 heller 1.16 (prog1 (aref buffer index)
295     (setf (sis.index stream) (1+ index)))))
296 heller 1.9
297 heller 1.16 (defun sis/misc (stream operation &optional arg1 arg2)
298 heller 1.14 (declare (ignore arg2))
299 heller 1.15 (ecase operation
300     (:file-position nil)
301 heller 1.16 (:file-length nil)
302     (:unread (setf (aref (sis.buffer stream)
303     (decf (sis.index stream)))
304     arg1))
305 heller 1.57 (:clear-input
306     (setf (sis.index stream) 0
307 heller 1.16 (sis.buffer stream) ""))
308     (:listen (< (sis.index stream) (length (sis.buffer stream))))
309     (:charpos nil)
310     (:line-length nil)
311     (:get-command nil)
312 heller 1.22 (:element-type 'base-char)
313 heller 1.149 (:close nil)
314     (:interactive-p t)))
315 heller 1.16
316 lgorrie 1.25
317 dbarlow 1.1 ;;;; Compilation Commands
318    
319 lgorrie 1.24 (defvar *previous-compiler-condition* nil
320     "Used to detect duplicates.")
321    
322     (defvar *previous-context* nil
323     "Previous compiler error context.")
324    
325 lgorrie 1.103 (defvar *buffer-name* nil
326     "The name of the Emacs buffer we are compiling from.
327     NIL if we aren't compiling from a buffer.")
328    
329 heller 1.30 (defvar *buffer-start-position* nil)
330     (defvar *buffer-substring* nil)
331    
332 lgorrie 1.103 (defimplementation call-with-compilation-hooks (function)
333     (let ((*previous-compiler-condition* nil)
334     (*previous-context* nil)
335     (*print-readably* nil))
336     (handler-bind ((c::compiler-error #'handle-notification-condition)
337     (c::style-warning #'handle-notification-condition)
338     (c::warning #'handle-notification-condition))
339     (funcall function))))
340    
341 heller 1.150 (defimplementation swank-compile-file (filename load-p
342     &optional external-format)
343     (declare (ignore external-format))
344 lgorrie 1.103 (clear-xref-info filename)
345     (with-compilation-hooks ()
346 heller 1.127 (let ((*buffer-name* nil)
347     (ext:*ignore-extra-close-parentheses* nil))
348 lgorrie 1.103 (multiple-value-bind (output-file warnings-p failure-p)
349 heller 1.125 (compile-file filename)
350 lgorrie 1.103 (unless failure-p
351     ;; Cache the latest source file for definition-finding.
352 heller 1.125 (source-cache-get filename (file-write-date filename))
353 heller 1.130 (when load-p (load output-file)))
354 lgorrie 1.103 (values output-file warnings-p failure-p)))))
355    
356 pseibel 1.113 (defimplementation swank-compile-string (string &key buffer position directory)
357     (declare (ignore directory))
358 lgorrie 1.103 (with-compilation-hooks ()
359     (let ((*buffer-name* buffer)
360     (*buffer-start-position* position)
361     (*buffer-substring* string))
362     (with-input-from-string (stream string)
363     (ext:compile-from-stream
364     stream
365     :source-info `(:emacs-buffer ,buffer
366     :emacs-buffer-offset ,position
367     :emacs-buffer-string ,string))))))
368    
369 lgorrie 1.25
370 lgorrie 1.24 ;;;;; Trapping notes
371 lgorrie 1.103 ;;;
372     ;;; We intercept conditions from the compiler and resignal them as
373     ;;; `SWANK:COMPILER-CONDITION's.
374 lgorrie 1.24
375     (defun handle-notification-condition (condition)
376 lgorrie 1.103 "Handle a condition caused by a compiler warning."
377 dbarlow 1.1 (unless (eq condition *previous-compiler-condition*)
378 heller 1.65 (let ((context (c::find-error-context nil)))
379 dbarlow 1.1 (setq *previous-compiler-condition* condition)
380     (setq *previous-context* context)
381 lgorrie 1.24 (signal-compiler-condition condition context))))
382    
383     (defun signal-compiler-condition (condition context)
384     (signal (make-condition
385     'compiler-condition
386     :original-condition condition
387     :severity (severity-for-emacs condition)
388 heller 1.65 :short-message (brief-compiler-message-for-emacs condition)
389     :message (long-compiler-message-for-emacs condition context)
390 heller 1.127 :location (if (read-error-p condition)
391 heller 1.125 (read-error-location condition)
392     (compiler-note-location context)))))
393 lgorrie 1.24
394     (defun severity-for-emacs (condition)
395     "Return the severity of CONDITION."
396     (etypecase condition
397 heller 1.127 ((satisfies read-error-p) :read-error)
398 lgorrie 1.24 (c::compiler-error :error)
399     (c::style-warning :note)
400     (c::warning :warning)))
401    
402 heller 1.127 (defun read-error-p (condition)
403     (eq (type-of condition) 'c::compiler-read-error))
404    
405 heller 1.65 (defun brief-compiler-message-for-emacs (condition)
406 lgorrie 1.24 "Briefly describe a compiler error for Emacs.
407     When Emacs presents the message it already has the source popped up
408     and the source form highlighted. This makes much of the information in
409     the error-context redundant."
410 heller 1.65 (princ-to-string condition))
411    
412     (defun long-compiler-message-for-emacs (condition error-context)
413     "Describe a compiler error for Emacs including context information."
414 lgorrie 1.24 (declare (type (or c::compiler-error-context null) error-context))
415 heller 1.30 (multiple-value-bind (enclosing source)
416     (if error-context
417     (values (c::compiler-error-context-enclosing-source error-context)
418     (c::compiler-error-context-source error-context)))
419     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~^~%~}~]~A"
420     enclosing source condition)))
421 heller 1.125
422     (defun read-error-location (condition)
423     (let* ((finfo (car (c::source-info-current-file c::*source-info*)))
424     (file (c::file-info-name finfo))
425     (pos (c::compiler-read-error-position condition)))
426     (cond ((and (eq file :stream) *buffer-name*)
427     (make-location (list :buffer *buffer-name*)
428 heller 1.127 (list :position (+ *buffer-start-position* pos))))
429 heller 1.125 ((and (pathnamep file) (not *buffer-name*))
430     (make-location (list :file (unix-truename file))
431 heller 1.127 (list :position (1+ pos))))
432 heller 1.125 (t (break)))))
433 heller 1.30
434     (defun compiler-note-location (context)
435 lgorrie 1.103 "Derive the location of a complier message from its context.
436     Return a `location' record, or (:error REASON) on failure."
437     (if (null context)
438     (note-error-location)
439     (let ((file (c::compiler-error-context-file-name context))
440     (source (c::compiler-error-context-original-source context))
441     (path
442     (reverse (c::compiler-error-context-original-source-path context))))
443     (or (locate-compiler-note file source path)
444     (note-error-location)))))
445    
446     (defun note-error-location ()
447     "Pseudo-location for notes that can't be located."
448     (list :error "No error location available."))
449    
450     (defun locate-compiler-note (file source source-path)
451     (cond ((and (eq file :stream) *buffer-name*)
452     ;; Compiling from a buffer
453     (let ((position (+ *buffer-start-position*
454     (source-path-string-position
455     source-path *buffer-substring*))))
456     (make-location (list :buffer *buffer-name*)
457     (list :position position))))
458     ((and (pathnamep file) (null *buffer-name*))
459     ;; Compiling from a file
460     (make-location (list :file (unix-truename file))
461     (list :position
462     (1+ (source-path-file-position
463     source-path file)))))
464     ((and (eq file :lisp) (stringp source))
465     ;; No location known, but we have the source form.
466 heller 1.112 ;; XXX How is this case triggered? -luke (16/May/2004)
467     ;; This can happen if the compiler needs to expand a macro
468     ;; but the macro-expander is not yet compiled. Calling the
469     ;; (interpreted) macro-expander triggers IR1 conversion of
470     ;; the lambda expression for the expander and invokes the
471     ;; compiler recursively.
472 lgorrie 1.103 (make-location (list :source-form source)
473     (list :position 1)))))
474 heller 1.30
475 lgorrie 1.103 (defun unix-truename (pathname)
476     (ext:unix-namestring (truename pathname)))
477 dbarlow 1.1
478 lgorrie 1.25
479     ;;;; XREF
480 lgorrie 1.103 ;;;
481     ;;; Cross-reference support is based on the standard CMUCL `XREF'
482     ;;; package. This package has some caveats: XREF information is
483     ;;; recorded during compilation and not preserved in fasl files, and
484     ;;; XREF recording is disabled by default. Redefining functions can
485     ;;; also cause duplicate references to accumulate, but
486     ;;; `swank-compile-file' will automatically clear out any old records
487     ;;; from the same filename.
488     ;;;
489     ;;; To enable XREF recording, set `c:*record-xref-info*' to true. To
490     ;;; clear out the XREF database call `xref:init-xref-database'.
491 dbarlow 1.1
492 heller 1.81 (defmacro defxref (name function)
493     `(defimplementation ,name (name)
494 heller 1.82 (xref-results (,function name))))
495 heller 1.81
496     (defxref who-calls xref:who-calls)
497     (defxref who-references xref:who-references)
498     (defxref who-binds xref:who-binds)
499     (defxref who-sets xref:who-sets)
500 dbarlow 1.1
501 lgorrie 1.103 ;;; More types of XREF information were added since 18e:
502     ;;;
503 lgorrie 1.10 #+cmu19
504 heller 1.32 (progn
505 heller 1.81 (defxref who-macroexpands xref:who-macroexpands)
506     ;; XXX
507     (defimplementation who-specializes (symbol)
508     (let* ((methods (xref::who-specializes (find-class symbol)))
509 heller 1.86 (locations (mapcar #'method-location methods)))
510 heller 1.81 (mapcar #'list methods locations))))
511    
512     (defun xref-results (contexts)
513     (mapcar (lambda (xref)
514     (list (xref:xref-context-name xref)
515     (resolve-xref-location xref)))
516     contexts))
517 heller 1.30
518     (defun resolve-xref-location (xref)
519     (let ((name (xref:xref-context-name xref))
520     (file (xref:xref-context-file xref))
521     (source-path (xref:xref-context-source-path xref)))
522     (cond ((and file source-path)
523     (let ((position (source-path-file-position source-path file)))
524     (make-location (list :file (unix-truename file))
525     (list :position (1+ position)))))
526     (file
527     (make-location (list :file (unix-truename file))
528     (list :function-name (string name))))
529     (t
530 lgorrie 1.99 `(:error ,(format nil "Unknown source location: ~S ~S ~S "
531 heller 1.30 name file source-path))))))
532    
533 lgorrie 1.25 (defun clear-xref-info (namestring)
534 heller 1.66 "Clear XREF notes pertaining to NAMESTRING.
535 lgorrie 1.25 This is a workaround for a CMUCL bug: XREF records are cumulative."
536 heller 1.65 (when c:*record-xref-info*
537 heller 1.66 (let ((filename (truename namestring)))
538 lgorrie 1.25 (dolist (db (list xref::*who-calls*
539     #+cmu19 xref::*who-is-called*
540     #+cmu19 xref::*who-macroexpands*
541     xref::*who-references*
542     xref::*who-binds*
543     xref::*who-sets*))
544     (maphash (lambda (target contexts)
545 heller 1.66 ;; XXX update during traversal?
546 lgorrie 1.25 (setf (gethash target db)
547 heller 1.66 (delete filename contexts
548     :key #'xref:xref-context-file
549     :test #'equalp)))
550 lgorrie 1.25 db)))))
551    
552    
553     ;;;; Find callers and callees
554 lgorrie 1.103 ;;;
555 dbarlow 1.1 ;;; Find callers and callees by looking at the constant pool of
556     ;;; compiled code objects. We assume every fdefn object in the
557     ;;; constant pool corresponds to a call to that function. A better
558     ;;; strategy would be to use the disassembler to find actual
559     ;;; call-sites.
560    
561     (declaim (inline map-code-constants))
562     (defun map-code-constants (code fn)
563     "Call FN for each constant in CODE's constant pool."
564     (check-type code kernel:code-component)
565     (loop for i from vm:code-constants-offset below (kernel:get-header-data code)
566     do (funcall fn (kernel:code-header-ref code i))))
567    
568     (defun function-callees (function)
569 heller 1.30 "Return FUNCTION's callees as a list of functions."
570 dbarlow 1.1 (let ((callees '()))
571     (map-code-constants
572     (vm::find-code-object function)
573     (lambda (obj)
574     (when (kernel:fdefn-p obj)
575 heller 1.30 (push (kernel:fdefn-function obj) callees))))
576 dbarlow 1.1 callees))
577    
578 heller 1.19 (declaim (ext:maybe-inline map-allocated-code-components))
579 dbarlow 1.1 (defun map-allocated-code-components (spaces fn)
580     "Call FN for each allocated code component in one of SPACES. FN
581 heller 1.19 receives the object as argument. SPACES should be a list of the
582     symbols :dynamic, :static, or :read-only."
583 dbarlow 1.1 (dolist (space spaces)
584 heller 1.119 (declare (inline vm::map-allocated-objects)
585     (optimize (ext:inhibit-warnings 3)))
586 dbarlow 1.1 (vm::map-allocated-objects
587     (lambda (obj header size)
588 heller 1.19 (declare (type fixnum size) (ignore size))
589 dbarlow 1.1 (when (= vm:code-header-type header)
590 heller 1.19 (funcall fn obj)))
591 dbarlow 1.1 space)))
592    
593 heller 1.19 (declaim (ext:maybe-inline map-caller-code-components))
594 dbarlow 1.1 (defun map-caller-code-components (function spaces fn)
595     "Call FN for each code component with a fdefn for FUNCTION in its
596     constant pool."
597     (let ((function (coerce function 'function)))
598 heller 1.19 (declare (inline map-allocated-code-components))
599 dbarlow 1.1 (map-allocated-code-components
600     spaces
601 heller 1.19 (lambda (obj)
602 dbarlow 1.1 (map-code-constants
603     obj
604     (lambda (constant)
605     (when (and (kernel:fdefn-p constant)
606     (eq (kernel:fdefn-function constant)
607     function))
608     (funcall fn obj))))))))
609    
610     (defun function-callers (function &optional (spaces '(:read-only :static
611     :dynamic)))
612 heller 1.30 "Return FUNCTION's callers. The result is a list of code-objects."
613 dbarlow 1.1 (let ((referrers '()))
614 heller 1.19 (declare (inline map-caller-code-components))
615 heller 1.108 ;;(ext:gc :full t)
616 heller 1.30 (map-caller-code-components function spaces
617     (lambda (code) (push code referrers)))
618 dbarlow 1.1 referrers))
619 heller 1.80
620 heller 1.30 (defun debug-info-definitions (debug-info)
621     "Return the defintions for a debug-info. This should only be used
622     for code-object without entry points, i.e., byte compiled
623     code (are theree others?)"
624     ;; This mess has only been tested with #'ext::skip-whitespace, a
625     ;; byte-compiled caller of #'read-char .
626     (check-type debug-info (and (not c::compiled-debug-info) c::debug-info))
627     (let ((name (c::debug-info-name debug-info))
628     (source (c::debug-info-source debug-info)))
629     (destructuring-bind (first) source
630     (ecase (c::debug-source-from first)
631     (:file
632 heller 1.80 (list (list name
633     (make-location
634     (list :file (unix-truename (c::debug-source-name first)))
635 heller 1.119 (list :function-name (string name))))))))))
636 heller 1.30
637     (defun code-component-entry-points (code)
638 heller 1.80 "Return a list ((NAME LOCATION) ...) of function definitons for
639 heller 1.30 the code omponent CODE."
640 heller 1.122 (let ((names '()))
641     (do ((f (kernel:%code-entry-points code) (kernel::%function-next f)))
642     ((not f))
643     (let ((name (kernel:%function-name f)))
644     (when (ext:valid-function-name-p name)
645     (push (list name (function-location f)) names))))
646     names))
647 dbarlow 1.1
648 heller 1.80 (defimplementation list-callers (symbol)
649     "Return a list ((NAME LOCATION) ...) of callers."
650     (let ((components (function-callers symbol))
651 heller 1.30 (xrefs '()))
652     (dolist (code components)
653     (let* ((entry (kernel:%code-entry-points code))
654     (defs (if entry
655     (code-component-entry-points code)
656     ;; byte compiled stuff
657     (debug-info-definitions
658     (kernel:%code-debug-info code)))))
659     (setq xrefs (nconc defs xrefs))))
660 heller 1.80 xrefs))
661 dbarlow 1.1
662 heller 1.80 (defimplementation list-callees (symbol)
663     (let ((fns (function-callees symbol)))
664     (mapcar (lambda (fn)
665     (list (kernel:%function-name fn)
666 heller 1.86 (function-location fn)))
667 heller 1.80 fns)))
668 dbarlow 1.1
669 lgorrie 1.42
670 lgorrie 1.103 ;;;; Resolving source locations
671     ;;;
672     ;;; Our mission here is to "resolve" references to code locations into
673     ;;; actual file/buffer names and character positions. The references
674     ;;; we work from come out of the compiler's statically-generated debug
675     ;;; information, such as `code-location''s and `debug-source''s. For
676     ;;; more details, see the "Debugger Programmer's Interface" section of
677     ;;; the CMUCL manual.
678     ;;;
679     ;;; The first step is usually to find the corresponding "source-path"
680     ;;; for the location. Once we have the source-path we can pull up the
681     ;;; source file and `READ' our way through to the right position. The
682     ;;; main source-code groveling work is done in
683     ;;; `swank-source-path-parser.lisp'.
684 dbarlow 1.1
685 lgorrie 1.35 (defvar *debug-definition-finding* nil
686 dbarlow 1.1 "When true don't handle errors while looking for definitions.
687     This is useful when debugging the definition-finding code.")
688    
689 lgorrie 1.99 (defvar *source-snippet-size* 256
690     "Maximum number of characters in a snippet of source code.
691     Snippets at the beginning of definitions are used to tell Emacs what
692     the definitions looks like, so that it can accurately find them by
693     text search.")
694    
695 lgorrie 1.103 (defmacro safe-definition-finding (&body body)
696     "Execute BODY and return the source-location it returns.
697     If an error occurs and `*debug-definition-finding*' is false, then
698     return an error pseudo-location.
699    
700     The second return value is NIL if no error occurs, otherwise it is the
701     condition object."
702     `(flet ((body () ,@body))
703     (if *debug-definition-finding*
704     (body)
705     (handler-case (values (progn ,@body) nil)
706     (error (c) (values (list :error (princ-to-string c)) c))))))
707    
708     (defun code-location-source-location (code-location)
709     "Safe wrapper around `code-location-from-source-location'."
710     (safe-definition-finding
711     (source-location-from-code-location code-location)))
712    
713     (defun source-location-from-code-location (code-location)
714     "Return the source location for CODE-LOCATION."
715     (let ((debug-fun (di:code-location-debug-function code-location)))
716     (when (di::bogus-debug-function-p debug-fun)
717     ;; Those lousy cheapskates! They've put in a bogus debug source
718     ;; because the code was compiled at a low debug setting.
719     (error "Bogus debug function: ~A" debug-fun)))
720     (let* ((debug-source (di:code-location-debug-source code-location))
721     (from (di:debug-source-from debug-source))
722     (name (di:debug-source-name debug-source)))
723     (ecase from
724     (:file
725     (location-in-file name code-location debug-source))
726     (:stream
727     (location-in-stream code-location debug-source))
728     (:lisp
729     ;; The location comes from a form passed to `compile'.
730     ;; The best we can do is return the form itself for printing.
731     (make-location
732     (list :source-form (with-output-to-string (*standard-output*)
733     (debug::print-code-location-source-form
734     code-location 100 t)))
735     (list :position 1))))))
736    
737     (defun location-in-file (filename code-location debug-source)
738     "Resolve the source location for CODE-LOCATION in FILENAME."
739     (let* ((code-date (di:debug-source-created debug-source))
740 lgorrie 1.141 (source-code (get-source-code filename code-date)))
741 lgorrie 1.103 (with-input-from-string (s source-code)
742     (make-location (list :file (unix-truename filename))
743 heller 1.142 (list :position (1+ (code-location-stream-position
744     code-location s)))
745 lgorrie 1.103 `(:snippet ,(read-snippet s))))))
746    
747     (defun location-in-stream (code-location debug-source)
748     "Resolve the source location for a CODE-LOCATION from a stream.
749     This only succeeds if the code was compiled from an Emacs buffer."
750     (unless (debug-source-info-from-emacs-buffer-p debug-source)
751     (error "The code is compiled from a non-SLIME stream."))
752     (let* ((info (c::debug-source-info debug-source))
753     (string (getf info :emacs-buffer-string))
754     (position (code-location-string-offset
755     code-location
756     string)))
757     (make-location
758     (list :buffer (getf info :emacs-buffer))
759     (list :position (+ (getf info :emacs-buffer-offset) position))
760     (list :snippet (with-input-from-string (s string)
761     (file-position s position)
762     (read-snippet s))))))
763    
764     ;;;;; Function-name locations
765     ;;;
766     (defun debug-info-function-name-location (debug-info)
767     "Return a function-name source-location for DEBUG-INFO.
768     Function-name source-locations are a fallback for when precise
769     positions aren't available."
770     (with-struct (c::debug-info- (fname name) source) debug-info
771     (with-struct (c::debug-source- info from name) (car source)
772     (ecase from
773     (:file
774     (make-location (list :file (namestring (truename name)))
775 heller 1.119 (list :function-name (string fname))))
776 lgorrie 1.103 (:stream
777     (assert (debug-source-info-from-emacs-buffer-p (car source)))
778     (make-location (list :buffer (getf info :emacs-buffer))
779 heller 1.119 (list :function-name (string fname))))
780 lgorrie 1.103 (:lisp
781     (make-location (list :source-form (princ-to-string (aref name 0)))
782     (list :position 1)))))))
783    
784     (defun debug-source-info-from-emacs-buffer-p (debug-source)
785     "Does the `info' slot of DEBUG-SOURCE contain an Emacs buffer location?
786     This is true for functions that were compiled directly from buffers."
787     (info-from-emacs-buffer-p (c::debug-source-info debug-source)))
788    
789     (defun info-from-emacs-buffer-p (info)
790     (and info
791     (consp info)
792     (eq :emacs-buffer (car info))))
793    
794    
795     ;;;;; Groveling source-code for positions
796    
797     (defun code-location-stream-position (code-location stream)
798     "Return the byte offset of CODE-LOCATION in STREAM. Extract the
799     toplevel-form-number and form-number from CODE-LOCATION and use that
800     to find the position of the corresponding form.
801    
802     Finish with STREAM positioned at the start of the code location."
803     (let* ((location (debug::maybe-block-start-location code-location))
804     (tlf-offset (di:code-location-top-level-form-offset location))
805     (form-number (di:code-location-form-number location)))
806     (let ((pos (form-number-stream-position tlf-offset form-number stream)))
807     (file-position stream pos)
808     pos)))
809    
810     (defun form-number-stream-position (tlf-number form-number stream)
811     "Return the starting character position of a form in STREAM.
812     TLF-NUMBER is the top-level-form number.
813     FORM-NUMBER is an index into a source-path table for the TLF."
814 heller 1.135 (multiple-value-bind (tlf position-map) (read-source-form tlf-number stream)
815     (let* ((path-table (di:form-number-translations tlf 0))
816     (source-path
817     (if (<= (length path-table) form-number) ; source out of sync?
818     (list 0) ; should probably signal a condition
819     (reverse (cdr (aref path-table form-number))))))
820     (source-path-source-position source-path tlf position-map))))
821 lgorrie 1.103
822     (defun code-location-string-offset (code-location string)
823     "Return the byte offset of CODE-LOCATION in STRING.
824     See CODE-LOCATION-STREAM-POSITION."
825     (with-input-from-string (s string)
826     (code-location-stream-position code-location s)))
827 lgorrie 1.110
828 lgorrie 1.103
829     ;;;; Finding definitions
830    
831     ;;; There are a great many different types of definition for us to
832     ;;; find. We search for definitions of every kind and return them in a
833     ;;; list.
834    
835     (defimplementation find-definitions (name)
836     (append (function-definitions name)
837     (setf-definitions name)
838     (variable-definitions name)
839     (class-definitions name)
840     (type-definitions name)
841     (compiler-macro-definitions name)
842     (source-transform-definitions name)
843     (function-info-definitions name)
844     (ir1-translator-definitions name)))
845    
846     ;;;;; Functions, macros, generic functions, methods
847     ;;;
848     ;;; We make extensive use of the compile-time debug information that
849     ;;; CMUCL records, in particular "debug functions" and "code
850     ;;; locations." Refer to the "Debugger Programmer's Interface" section
851     ;;; of the CMUCL manual for more details.
852    
853     (defun function-definitions (name)
854     "Return definitions for NAME in the \"function namespace\", i.e.,
855     regular functions, generic functions, methods and macros.
856     NAME can any valid function name (e.g, (setf car))."
857     (let ((macro? (and (symbolp name) (macro-function name)))
858     (special? (and (symbolp name) (special-operator-p name)))
859     (function? (and (ext:valid-function-name-p name)
860 heller 1.140 (ext:info :function :definition name)
861     (if (symbolp name) (fboundp name) t))))
862 lgorrie 1.103 (cond (macro?
863     (list `((defmacro ,name)
864     ,(function-location (macro-function name)))))
865     (special?
866     (list `((:special-operator ,name)
867     (:error ,(format nil "Special operator: ~S" name)))))
868     (function?
869     (let ((function (fdefinition name)))
870     (if (genericp function)
871     (generic-function-definitions name function)
872     (list (list `(function ,name)
873     (function-location function)))))))))
874    
875     ;;;;;; Ordinary (non-generic/macro/special) functions
876     ;;;
877     ;;; First we test if FUNCTION is a closure created by defstruct, and
878     ;;; if so extract the defstruct-description (`dd') from the closure
879     ;;; and find the constructor for the struct. Defstruct creates a
880     ;;; defun for the default constructor and we use that as an
881     ;;; approximation to the source location of the defstruct.
882     ;;;
883     ;;; For an ordinary function we return the source location of the
884     ;;; first code-location we find.
885     ;;;
886     (defun function-location (function)
887     "Return the source location for FUNCTION."
888     (cond ((struct-closure-p function)
889     (struct-closure-location function))
890     ((c::byte-function-or-closure-p function)
891     (byte-function-location function))
892     (t
893     (compiled-function-location function))))
894 lgorrie 1.100
895 lgorrie 1.103 (defun compiled-function-location (function)
896     "Return the location of a regular compiled function."
897     (multiple-value-bind (code-location error)
898     (safe-definition-finding (function-first-code-location function))
899     (cond (error (list :error (princ-to-string error)))
900     (t (code-location-source-location code-location)))))
901 heller 1.88
902 dbarlow 1.1 (defun function-first-code-location (function)
903 lgorrie 1.103 "Return the first code-location we can find for FUNCTION."
904 dbarlow 1.1 (and (function-has-debug-function-p function)
905     (di:debug-function-start-location
906     (di:function-debug-function function))))
907    
908     (defun function-has-debug-function-p (function)
909     (di:function-debug-function function))
910    
911     (defun function-code-object= (closure function)
912     (and (eq (vm::find-code-object closure)
913     (vm::find-code-object function))
914     (not (eq closure function))))
915    
916 lgorrie 1.103
917     (defun byte-function-location (fn)
918     "Return the location of the byte-compiled function FN."
919     (etypecase fn
920     ((or c::hairy-byte-function c::simple-byte-function)
921     (let* ((component (c::byte-function-component fn))
922     (debug-info (kernel:%code-debug-info component)))
923     (debug-info-function-name-location debug-info)))
924     (c::byte-closure
925     (byte-function-location (c::byte-closure-function fn)))))
926    
927     ;;; Here we deal with structure accessors. Note that `dd' is a
928     ;;; "defstruct descriptor" structure in CMUCL. A `dd' describes a
929     ;;; `defstruct''d structure.
930 heller 1.83
931 heller 1.4 (defun struct-closure-p (function)
932 lgorrie 1.103 "Is FUNCTION a closure created by defstruct?"
933 heller 1.4 (or (function-code-object= function #'kernel::structure-slot-accessor)
934     (function-code-object= function #'kernel::structure-slot-setter)
935     (function-code-object= function #'kernel::%defstruct)))
936 dbarlow 1.1
937 lgorrie 1.103 (defun struct-closure-location (function)
938     "Return the location of the structure that FUNCTION belongs to."
939     (assert (struct-closure-p function))
940     (safe-definition-finding
941     (dd-location (struct-closure-dd function))))
942    
943 heller 1.4 (defun struct-closure-dd (function)
944 lgorrie 1.103 "Return the defstruct-definition (dd) of FUNCTION."
945 dbarlow 1.1 (assert (= (kernel:get-type function) vm:closure-header-type))
946 heller 1.4 (flet ((find-layout (function)
947     (sys:find-if-in-closure
948     (lambda (x)
949 heller 1.18 (let ((value (if (di::indirect-value-cell-p x)
950     (c:value-cell-ref x)
951     x)))
952     (when (kernel::layout-p value)
953     (return-from find-layout value))))
954 heller 1.4 function)))
955     (kernel:layout-info (find-layout function))))
956 lgorrie 1.103
957 heller 1.86 (defun dd-location (dd)
958 lgorrie 1.103 "Return the location of a `defstruct'."
959     ;; Find the location in a constructor.
960     (function-location (struct-constructor dd)))
961    
962     (defun struct-constructor (dd)
963     "Return a constructor function from a defstruct definition.
964     Signal an error if no constructor can be found."
965 dbarlow 1.1 (let ((constructor (or (kernel:dd-default-constructor dd)
966 heller 1.32 (car (kernel::dd-constructors dd)))))
967 lgorrie 1.103 (when (or (null constructor)
968     (and (consp constructor) (null (car constructor))))
969     (error "Cannot find structure's constructor: ~S"
970 heller 1.32 (kernel::dd-name dd)))
971 lgorrie 1.103 (coerce (if (consp constructor) (first constructor) constructor)
972     'function)))
973    
974     ;;;;;; Generic functions and methods
975 dbarlow 1.1
976 lgorrie 1.103 (defun generic-function-definitions (name function)
977     "Return the definitions of a generic function and its methods."
978     (cons (list `(defgeneric ,name) (gf-location function))
979     (gf-method-definitions function)))
980    
981     (defun gf-location (gf)
982     "Return the location of the generic function GF."
983     (definition-source-location gf (pcl::generic-function-name gf)))
984 heller 1.101
985 lgorrie 1.103 (defun gf-method-definitions (gf)
986     "Return the locations of all methods of the generic function GF."
987     (mapcar #'method-definition (pcl::generic-function-methods gf)))
988 heller 1.83
989 lgorrie 1.103 (defun method-definition (method)
990     (list (method-dspec method)
991     (method-location method)))
992 heller 1.83
993     (defun method-dspec (method)
994 lgorrie 1.103 "Return a human-readable \"definition specifier\" for METHOD."
995 heller 1.83 (let* ((gf (pcl:method-generic-function method))
996     (name (pcl:generic-function-name gf))
997 heller 1.92 (specializers (pcl:method-specializers method))
998     (qualifiers (pcl:method-qualifiers method)))
999     `(method ,name ,@qualifiers ,(pcl::unparse-specializers specializers))))
1000 heller 1.83
1001 lgorrie 1.103 ;; XXX maybe special case setters/getters
1002     (defun method-location (method)
1003     (function-location (or (pcl::method-fast-function method)
1004     (pcl:method-function method))))
1005 heller 1.83
1006 lgorrie 1.103 (defun genericp (fn)
1007     (typep fn 'generic-function))
1008 dbarlow 1.1
1009 lgorrie 1.105 ;;;;;; Types and classes
1010    
1011     (defun type-definitions (name)
1012     "Return `deftype' locations for type NAME."
1013     (maybe-make-definition (ext:info :type :expander name) 'deftype name))
1014    
1015 heller 1.88 (defun maybe-make-definition (function kind name)
1016 lgorrie 1.105 "If FUNCTION is non-nil then return its definition location."
1017 heller 1.87 (if function
1018 heller 1.88 (list (list `(,kind ,name) (function-location function)))))
1019 heller 1.87
1020 lgorrie 1.105 (defun class-definitions (name)
1021     "Return the definition locations for the class called NAME."
1022     (if (symbolp name)
1023     (let ((class (kernel::find-class name nil)))
1024     (etypecase class
1025     (null '())
1026     (kernel::structure-class
1027     (list (list `(defstruct ,name) (dd-location (find-dd name)))))
1028     #+(or)
1029     (conditions::condition-class
1030     (list (list `(define-condition ,name)
1031     (condition-class-location class))))
1032     (kernel::standard-class
1033     (list (list `(defclass ,name)
1034     (class-location (find-class name)))))
1035     ((or kernel::built-in-class
1036     conditions::condition-class
1037     kernel:funcallable-structure-class)
1038     (list (list `(kernel::define-type-class ,name)
1039     `(:error
1040     ,(format nil "No source info for ~A" name)))))))))
1041    
1042     (defun class-location (class)
1043     "Return the `defclass' location for CLASS."
1044     (definition-source-location class (pcl:class-name class)))
1045 heller 1.86
1046     (defun find-dd (name)
1047 lgorrie 1.105 "Find the defstruct-definition by the name of its structure-class."
1048 heller 1.86 (let ((layout (ext:info :type :compiler-layout name)))
1049     (if layout
1050     (kernel:layout-info layout))))
1051    
1052 heller 1.92 (defun condition-class-location (class)
1053     (let ((slots (conditions::condition-class-slots class))
1054     (name (conditions::condition-class-name class)))
1055     (cond ((null slots)
1056     `(:error ,(format nil "No location info for condition: ~A" name)))
1057     (t
1058 lgorrie 1.105 ;; Find the class via one of its slot-reader methods.
1059 heller 1.92 (let* ((slot (first slots))
1060     (gf (fdefinition
1061     (first (conditions::condition-slot-readers slot)))))
1062     (method-location
1063     (first
1064     (pcl:compute-applicable-methods-using-classes
1065     gf (list (find-class name))))))))))
1066    
1067 heller 1.93 (defun make-name-in-file-location (file string)
1068     (multiple-value-bind (filename c)
1069     (ignore-errors
1070     (unix-truename (merge-pathnames (make-pathname :type "lisp")
1071     file)))
1072     (cond (filename (make-location `(:file ,filename)
1073 heller 1.119 `(:function-name ,(string string))))
1074 heller 1.93 (t (list :error (princ-to-string c))))))
1075 heller 1.92
1076 heller 1.95 (defun source-location-form-numbers (location)
1077     (c::decode-form-numbers (c::form-numbers-form-numbers location)))
1078    
1079     (defun source-location-tlf-number (location)
1080     (nth-value 0 (source-location-form-numbers location)))
1081    
1082     (defun source-location-form-number (location)
1083     (nth-value 1 (source-location-form-numbers location)))
1084    
1085 heller 1.93 (defun resolve-file-source-location (location)
1086     (let ((filename (c::file-source-location-pathname location))
1087 heller 1.95 (tlf-number (source-location-tlf-number location))
1088     (form-number (source-location-form-number location)))
1089 heller 1.93 (with-open-file (s filename)
1090     (let ((pos (form-number-stream-position tlf-number form-number s)))
1091     (make-location `(:file ,(unix-truename filename))
1092     `(:position ,(1+ pos)))))))
1093    
1094 heller 1.95 (defun resolve-stream-source-location (location)
1095     (let ((info (c::stream-source-location-user-info location))
1096     (tlf-number (source-location-tlf-number location))
1097     (form-number (source-location-form-number location)))
1098 heller 1.93 ;; XXX duplication in frame-source-location
1099     (assert (info-from-emacs-buffer-p info))
1100     (destructuring-bind (&key emacs-buffer emacs-buffer-string
1101     emacs-buffer-offset) info
1102     (with-input-from-string (s emacs-buffer-string)
1103     (let ((pos (form-number-stream-position tlf-number form-number s)))
1104     (make-location `(:buffer ,emacs-buffer)
1105     `(:position ,(+ emacs-buffer-offset pos))))))))
1106    
1107 heller 1.102 ;; XXX predicates for 18e backward compatibilty. Remove them when
1108     ;; we're 19a only.
1109 heller 1.96 (defun file-source-location-p (object)
1110     (when (fboundp 'c::file-source-location-p)
1111     (c::file-source-location-p object)))
1112    
1113     (defun stream-source-location-p (object)
1114     (when (fboundp 'c::stream-source-location-p)
1115     (c::stream-source-location-p object)))
1116    
1117 heller 1.102 (defun source-location-p (object)
1118     (or (file-source-location-p object)
1119     (stream-source-location-p object)))
1120    
1121     (defun resolve-source-location (location)
1122     (etypecase location
1123     ((satisfies file-source-location-p)
1124     (resolve-file-source-location location))
1125     ((satisfies stream-source-location-p)
1126     (resolve-stream-source-location location))))
1127    
1128 heller 1.93 (defun definition-source-location (object name)
1129     (let ((source (pcl::definition-source object)))
1130     (etypecase source
1131     (null
1132     `(:error ,(format nil "No source info for: ~A" object)))
1133 heller 1.102 ((satisfies source-location-p)
1134     (resolve-source-location source))
1135 heller 1.93 (pathname
1136     (make-name-in-file-location source name))
1137     (cons
1138     (destructuring-bind ((dg name) pathname) source
1139     (declare (ignore dg))
1140     (etypecase pathname
1141     (pathname (make-name-in-file-location pathname (string name)))
1142     (null `(:error ,(format nil "Cannot resolve: ~S" source)))))))))
1143 heller 1.86
1144 heller 1.88 (defun setf-definitions (name)
1145     (let ((function (or (ext:info :setf :inverse name)
1146     (ext:info :setf :expander name))))
1147 heller 1.87 (if function
1148 heller 1.88 (list (list `(setf ,name)
1149 heller 1.87 (function-location (coerce function 'function)))))))
1150    
1151 heller 1.102
1152     (defun variable-location (symbol)
1153     (multiple-value-bind (location foundp)
1154     ;; XXX for 18e compatibilty. rewrite this when we drop 18e
1155     ;; support.
1156     (ignore-errors (eval `(ext:info :source-location :defvar ',symbol)))
1157     (if (and foundp location)
1158     (resolve-source-location location)
1159     `(:error ,(format nil "No source info for variable ~S" symbol)))))
1160    
1161     (defun variable-definitions (name)
1162     (if (symbolp name)
1163     (multiple-value-bind (kind recorded-p) (ext:info :variable :kind name)
1164     (if recorded-p
1165     (list (list `(variable ,kind ,name)
1166     (variable-location name)))))))
1167    
1168 heller 1.87 (defun compiler-macro-definitions (symbol)
1169     (maybe-make-definition (compiler-macro-function symbol)
1170     'define-compiler-macro
1171     symbol))
1172    
1173 heller 1.88 (defun source-transform-definitions (name)
1174     (maybe-make-definition (ext:info :function :source-transform name)
1175 heller 1.87 'c:def-source-transform
1176 heller 1.88 name))
1177 heller 1.87
1178 heller 1.88 (defun function-info-definitions (name)
1179     (let ((info (ext:info :function :info name)))
1180 heller 1.87 (if info
1181     (append (loop for transform in (c::function-info-transforms info)
1182 heller 1.88 collect (list `(c:deftransform ,name
1183 heller 1.87 ,(c::type-specifier
1184     (c::transform-type transform)))
1185     (function-location (c::transform-function
1186     transform))))
1187     (maybe-make-definition (c::function-info-derive-type info)
1188 heller 1.88 'c::derive-type name)
1189 heller 1.87 (maybe-make-definition (c::function-info-optimizer info)
1190 heller 1.88 'c::optimizer name)
1191 heller 1.87 (maybe-make-definition (c::function-info-ltn-annotate info)
1192 heller 1.88 'c::ltn-annotate name)
1193 heller 1.87 (maybe-make-definition (c::function-info-ir2-convert info)
1194 heller 1.88 'c::ir2-convert name)
1195 heller 1.87 (loop for template in (c::function-info-templates info)
1196     collect (list `(c::vop ,(c::template-name template))
1197     (function-location
1198     (c::vop-info-generator-function
1199     template))))))))
1200    
1201 heller 1.88 (defun ir1-translator-definitions (name)
1202     (maybe-make-definition (ext:info :function :ir1-convert name)
1203     'c:def-ir1-translator name))
1204    
1205 lgorrie 1.25
1206     ;;;; Documentation.
1207 dbarlow 1.1
1208 lgorrie 1.56 (defimplementation describe-symbol-for-emacs (symbol)
1209 dbarlow 1.1 (let ((result '()))
1210 lgorrie 1.24 (flet ((doc (kind)
1211     (or (documentation symbol kind) :not-documented))
1212     (maybe-push (property value)
1213     (when value
1214     (setf result (list* property value result)))))
1215 dbarlow 1.1 (maybe-push
1216     :variable (multiple-value-bind (kind recorded-p)
1217     (ext:info variable kind symbol)
1218     (declare (ignore kind))
1219     (if (or (boundp symbol) recorded-p)
1220     (doc 'variable))))
1221 heller 1.148 (when (fboundp symbol)
1222     (maybe-push
1223     (cond ((macro-function symbol) :macro)
1224     ((special-operator-p symbol) :special-operator)
1225     ((genericp (fdefinition symbol)) :generic-function)
1226     (t :function))
1227     (doc 'function)))
1228 dbarlow 1.1 (maybe-push
1229     :setf (if (or (ext:info setf inverse symbol)
1230     (ext:info setf expander symbol))
1231     (doc 'setf)))
1232     (maybe-push
1233     :type (if (ext:info type kind symbol)
1234     (doc 'type)))
1235     (maybe-push
1236     :class (if (find-class symbol nil)
1237     (doc 'class)))
1238 heller 1.18 (maybe-push
1239     :alien-type (if (not (eq (ext:info alien-type kind symbol) :unknown))
1240     (doc 'alien-type)))
1241     (maybe-push
1242     :alien-struct (if (ext:info alien-type struct symbol)
1243     (doc nil)))
1244     (maybe-push
1245     :alien-union (if (ext:info alien-type union symbol)
1246     (doc nil)))
1247     (maybe-push
1248     :alien-enum (if (ext:info alien-type enum symbol)
1249     (doc nil)))
1250 lgorrie 1.24 result)))
1251 dbarlow 1.1
1252 heller 1.80 (defimplementation describe-definition (symbol namespace)
1253 lgorrie 1.103 (describe (ecase namespace
1254     (:variable
1255     symbol)
1256     ((:function :generic-function)
1257     (symbol-function symbol))
1258     (:setf
1259     (or (ext:info setf inverse symbol)
1260     (ext:info setf expander symbol)))
1261     (:type
1262     (kernel:values-specifier-type symbol))
1263     (:class
1264     (find-class symbol))
1265     (:alien-struct
1266     (ext:info :alien-type :struct symbol))
1267     (:alien-union
1268     (ext:info :alien-type :union symbol))
1269     (:alien-enum
1270     (ext:info :alien-type :enum symbol))
1271     (:alien-type
1272     (ecase (ext:info :alien-type :kind symbol)
1273     (:primitive
1274     (let ((alien::*values-type-okay* t))
1275 heller 1.80 (funcall (ext:info :alien-type :translator symbol)
1276 lgorrie 1.103 (list symbol))))
1277     ((:defined)
1278     (ext:info :alien-type :definition symbol))
1279     (:unknown
1280     (return-from describe-definition
1281     (format nil "Unknown alien type: ~S" symbol))))))))
1282    
1283     ;;;;; Argument lists
1284    
1285 mbaringer 1.115 (defimplementation arglist ((name symbol))
1286 heller 1.120 (arglist (or (macro-function name)
1287 heller 1.119 (symbol-function name))))
1288 mbaringer 1.115
1289     (defimplementation arglist ((fun function))
1290 heller 1.140 (function-arglist fun))
1291    
1292     (defun function-arglist (fun)
1293 mbaringer 1.115 (let ((arglist
1294     (cond ((eval:interpreted-function-p fun)
1295     (eval:interpreted-function-arglist fun))
1296     ((pcl::generic-function-p fun)
1297     (pcl:generic-function-lambda-list fun))
1298     ((c::byte-function-or-closure-p fun)
1299     (byte-code-function-arglist fun))
1300     ((kernel:%function-arglist (kernel:%function-self fun))
1301     (handler-case (read-arglist fun)
1302     (error () :not-available)))
1303     ;; this should work both for compiled-debug-function
1304     ;; and for interpreted-debug-function
1305     (t
1306     (handler-case (debug-function-arglist
1307     (di::function-debug-function fun))
1308     (di:unhandled-condition () :not-available))))))
1309 lgorrie 1.103 (check-type arglist (or list (member :not-available)))
1310     arglist))
1311 mbaringer 1.115
1312     (defimplementation function-name (function)
1313     (cond ((eval:interpreted-function-p function)
1314     (eval:interpreted-function-name function))
1315     ((pcl::generic-function-p function)
1316     (pcl::generic-function-name function))
1317     ((c::byte-function-or-closure-p function)
1318     (c::byte-function-name function))
1319     (t (kernel:%function-name (kernel:%function-self function)))))
1320 heller 1.18
1321 lgorrie 1.103 ;;; A simple case: the arglist is available as a string that we can
1322     ;;; `read'.
1323    
1324     (defun read-arglist (fn)
1325     "Parse the arglist-string of the function object FN."
1326     (let ((string (kernel:%function-arglist
1327     (kernel:%function-self fn)))
1328     (package (find-package
1329     (c::compiled-debug-info-package
1330     (kernel:%code-debug-info
1331     (vm::find-code-object fn))))))
1332     (with-standard-io-syntax
1333     (let ((*package* (or package *package*)))
1334     (read-from-string string)))))
1335    
1336     ;;; A harder case: an approximate arglist is derived from available
1337     ;;; debugging information.
1338 heller 1.93
1339 heller 1.92 (defun debug-function-arglist (debug-function)
1340 lgorrie 1.103 "Derive the argument list of DEBUG-FUNCTION from debug info."
1341 heller 1.92 (let ((args (di::debug-function-lambda-list debug-function))
1342     (required '())
1343     (optional '())
1344     (rest '())
1345     (key '()))
1346     ;; collect the names of debug-vars
1347 heller 1.91 (dolist (arg args)
1348     (etypecase arg
1349     (di::debug-variable
1350 heller 1.93 (push (di::debug-variable-symbol arg) required))
1351 lgorrie 1.103 ((member :deleted)
1352 heller 1.93 (push ':deleted required))
1353 heller 1.91 (cons
1354     (ecase (car arg)
1355 heller 1.92 (:keyword
1356     (push (second arg) key))
1357     (:optional
1358 heller 1.93 (push (debug-variable-symbol-or-deleted (second arg)) optional))
1359 heller 1.92 (:rest
1360 heller 1.93 (push (debug-variable-symbol-or-deleted (second arg)) rest))))))
1361 heller 1.92 ;; intersperse lambda keywords as needed
1362     (append (nreverse required)
1363     (if optional (cons '&optional (nreverse optional)))
1364     (if rest (cons '&rest (nreverse rest)))
1365     (if key (cons '&key (nreverse key))))))
1366    
1367 lgorrie 1.103 (defun debug-variable-symbol-or-deleted (var)
1368     (etypecase var
1369     (di:debug-variable
1370     (di::debug-variable-symbol var))
1371     ((member :deleted)
1372     '#:deleted)))
1373    
1374 heller 1.92 (defun symbol-debug-function-arglist (fname)
1375     "Return FNAME's debug-function-arglist and %function-arglist.
1376     A utility for debugging DEBUG-FUNCTION-ARGLIST."
1377     (let ((fn (fdefinition fname)))
1378     (values (debug-function-arglist (di::function-debug-function fn))
1379     (kernel:%function-arglist (kernel:%function-self fn)))))
1380 heller 1.91
1381 lgorrie 1.103 ;;; Deriving arglists for byte-compiled functions:
1382     ;;;
1383     (defun byte-code-function-arglist (fn)
1384     ;; There doesn't seem to be much arglist information around for
1385     ;; byte-code functions. Use the arg-count and return something like
1386     ;; (arg0 arg1 ...)
1387     (etypecase fn
1388     (c::simple-byte-function
1389     (loop for i from 0 below (c::simple-byte-function-num-args fn)
1390     collect (make-arg-symbol i)))
1391     (c::hairy-byte-function
1392     (hairy-byte-function-arglist fn))
1393     (c::byte-closure
1394     (byte-code-function-arglist (c::byte-closure-function fn)))))
1395 heller 1.97
1396 heller 1.101 (defun make-arg-symbol (i)
1397     (make-symbol (format nil "~A~D" (string 'arg) i)))
1398    
1399 lgorrie 1.103 ;;; A "hairy" byte-function is one that takes a variable number of
1400     ;;; arguments. `hairy-byte-function' is a type from the bytecode
1401     ;;; interpreter.
1402     ;;;
1403 heller 1.101 (defun hairy-byte-function-arglist (fn)
1404     (let ((counter -1))
1405     (flet ((next-arg () (make-arg-symbol (incf counter))))
1406     (with-struct (c::hairy-byte-function- min-args max-args rest-arg-p
1407     keywords-p keywords) fn
1408     (let ((arglist '())
1409     (optional (- max-args min-args)))
1410     ;; XXX isn't there a better way to write this?
1411 lgorrie 1.103 ;; (Looks fine to me. -luke)
1412 heller 1.101 (dotimes (i min-args)
1413     (push (next-arg) arglist))
1414     (when (plusp optional)
1415     (push '&optional arglist)
1416     (dotimes (i optional)
1417     (push (next-arg) arglist)))
1418     (when rest-arg-p
1419     (push '&rest arglist)
1420     (push (next-arg) arglist))
1421     (when keywords-p
1422     (push '&key arglist)
1423     (loop for (key _ __) in keywords
1424     do (push key arglist))
1425     (when (eq keywords-p :allow-others)
1426     (push '&allow-other-keys arglist)))
1427     (nreverse arglist))))))
1428 lgorrie 1.25
1429    
1430     ;;;; Miscellaneous.
1431 dbarlow 1.1
1432 lgorrie 1.56 (defimplementation macroexpand-all (form)
1433 lgorrie 1.24 (walker:macroexpand-all form))
1434 dbarlow 1.1
1435 heller 1.158 (defimplementation compiler-macroexpand-1 (form &optional env)
1436     (ext:compiler-macroexpand-1 form env))
1437    
1438     (defimplementation compiler-macroexpand (form &optional env)
1439     (ext:compiler-macroexpand form env))
1440    
1441 mbaringer 1.90 (defimplementation set-default-directory (directory)
1442 lgorrie 1.25 (setf (ext:default-directory) (namestring directory))
1443     ;; Setting *default-pathname-defaults* to an absolute directory
1444     ;; makes the behavior of MERGE-PATHNAMES a bit more intuitive.
1445     (setf *default-pathname-defaults* (pathname (ext:default-directory)))
1446 heller 1.107 (default-directory))
1447    
1448     (defimplementation default-directory ()
1449 lgorrie 1.25 (namestring (ext:default-directory)))
1450    
1451 lgorrie 1.103 (defimplementation call-without-interrupts (fn)
1452     (sys:without-interrupts (funcall fn)))
1453 heller 1.19
1454 lgorrie 1.103 (defimplementation getpid ()
1455     (unix:unix-getpid))
1456 lgorrie 1.99
1457 lgorrie 1.103 (defimplementation lisp-implementation-type-name ()
1458     "cmucl")
1459 heller 1.92
1460 lgorrie 1.103 (defimplementation quit-lisp ()
1461     (ext::quit))
1462 heller 1.19
1463 lgorrie 1.103 ;;; source-path-{stream,file,string,etc}-position moved into
1464     ;;; swank-source-path-parser
1465 dbarlow 1.1
1466    
1467 lgorrie 1.25 ;;;; Debugging
1468 dbarlow 1.1
1469     (defvar *sldb-stack-top*)
1470    
1471 lgorrie 1.56 (defimplementation call-with-debugging-environment (debugger-loop-fn)
1472 dbarlow 1.1 (unix:unix-sigsetmask 0)
1473 lgorrie 1.25 (let* ((*sldb-stack-top* (or debug:*stack-top-hint* (di:top-frame)))
1474 heller 1.142 (debug:*stack-top-hint* nil)
1475     (kernel:*current-level* 0))
1476 heller 1.112 (handler-bind ((di::unhandled-condition
1477 dbarlow 1.1 (lambda (condition)
1478 heller 1.112 (error (make-condition
1479     'sldb-condition
1480     :original-condition condition)))))
1481 lgorrie 1.25 (funcall debugger-loop-fn))))
1482 dbarlow 1.1
1483 heller 1.112 (defun frame-down (frame)
1484     (handler-case (di:frame-down frame)
1485     (di:no-debug-info () nil)))
1486    
1487 dbarlow 1.1 (defun nth-frame (index)
1488 heller 1.112 (do ((frame *sldb-stack-top* (frame-down frame))
1489 dbarlow 1.1 (i index (1- i)))
1490     ((zerop i) frame)))
1491    
1492 heller 1.80 (defimplementation compute-backtrace (start end)
1493 dbarlow 1.1 (let ((end (or end most-positive-fixnum)))
1494 heller 1.112 (loop for f = (nth-frame start) then (frame-down f)
1495 dbarlow 1.1 for i from start below end
1496     while f
1497 heller 1.80 collect f)))
1498 dbarlow 1.1
1499 heller 1.80 (defimplementation print-frame (frame stream)
1500     (let ((*standard-output* stream))
1501 heller 1.114 (handler-case
1502     (debug::print-frame-call frame :verbosity 1 :number nil)
1503     (error (e)
1504     (ignore-errors (princ e stream))))))
1505 dbarlow 1.1
1506 lgorrie 1.56 (defimplementation frame-source-location-for-emacs (index)
1507 heller 1.29 (code-location-source-location (di:frame-code-location (nth-frame index))))
1508 dbarlow 1.1
1509 lgorrie 1.56 (defimplementation eval-in-frame (form index)
1510 lgorrie 1.26 (di:eval-in-frame (nth-frame index) form))
1511 heller 1.19
1512 heller 1.108 (defun frame-debug-vars (frame)
1513     "Return a vector of debug-variables in frame."
1514     (di::debug-function-debug-variables (di:frame-debug-function frame)))
1515    
1516     (defun debug-var-value (var frame location)
1517 heller 1.130 (let ((validity (di:debug-variable-validity var location)))
1518     (ecase validity
1519     (:valid (di:debug-variable-value var frame))
1520     ((:invalid :unknown) (make-symbol (string validity))))))
1521 heller 1.108
1522 lgorrie 1.56 (defimplementation frame-locals (index)
1523 dbarlow 1.1 (let* ((frame (nth-frame index))
1524 heller 1.108 (loc (di:frame-code-location frame))
1525     (vars (frame-debug-vars frame)))
1526     (loop for v across vars collect
1527 heller 1.80 (list :name (di:debug-variable-symbol v)
1528 heller 1.43 :id (di:debug-variable-id v)
1529 heller 1.108 :value (debug-var-value v frame loc)))))
1530    
1531     (defimplementation frame-var-value (frame var)
1532     (let* ((frame (nth-frame frame))
1533     (dvar (aref (frame-debug-vars frame) var)))
1534     (debug-var-value dvar frame (di:frame-code-location frame))))
1535 dbarlow 1.1
1536 lgorrie 1.56 (defimplementation frame-catch-tags (index)
1537 heller 1.80 (mapcar #'car (di:frame-catches (nth-frame index))))
1538 heller 1.33
1539 heller 1.123 (defimplementation return-from-frame (index form)
1540     (let ((sym (find-symbol (string 'find-debug-tag-for-frame)
1541     :debug-internals)))
1542     (if sym
1543     (let* ((frame (nth-frame index))
1544     (probe (funcall sym frame)))
1545     (cond (probe (throw (car probe) (eval-in-frame form index)))
1546     (t (format nil "Cannot return from frame: ~S" frame))))
1547     "return-from-frame is not implemented in this version of CMUCL.")))
1548    
1549 heller 1.126 (defimplementation activate-stepping (frame)
1550     (set-step-breakpoints (nth-frame frame)))
1551 heller 1.119
1552     (defimplementation sldb-break-on-return (frame)
1553     (break-on-return (nth-frame frame)))
1554    
1555 heller 1.133 ;;; We set the breakpoint in the caller which might be a bit confusing.
1556 heller 1.119 ;;;
1557     (defun break-on-return (frame)
1558     (let* ((caller (di:frame-down frame))
1559     (cl (di:frame-code-location caller)))
1560     (flet ((hook (frame bp)
1561     (when (frame-pointer= frame caller)
1562     (di:delete-breakpoint bp)
1563     (signal-breakpoint bp frame))))
1564     (let* ((info (ecase (di:code-location-kind cl)
1565     ((:single-value-return :unknown-return) nil)
1566     (:known-return (debug-function-returns
1567     (di:frame-debug-function frame)))))
1568     (bp (di:make-breakpoint #'hook cl :kind :code-location
1569     :info info)))
1570     (di:activate-breakpoint bp)
1571     `(:ok ,(format nil "Set breakpoint in ~A" caller))))))
1572    
1573     (defun frame-pointer= (frame1 frame2)
1574     "Return true if the frame pointers of FRAME1 and FRAME2 are the same."
1575     (sys:sap= (di::frame-pointer frame1) (di::frame-pointer frame2)))
1576    
1577 heller 1.126 ;;; The PC in escaped frames at a single-return-value point is
1578     ;;; actually vm:single-value-return-byte-offset bytes after the
1579     ;;; position given in the debug info. Here we try to recognize such
1580     ;;; cases.
1581     ;;;
1582     (defun next-code-locations (frame code-location)
1583     "Like `debug::next-code-locations' but be careful in escaped frames."
1584     (let ((next (debug::next-code-locations code-location)))
1585     (flet ((adjust-pc ()
1586     (let ((cl (di::copy-compiled-code-location code-location)))
1587     (incf (di::compiled-code-location-pc cl)
1588     vm:single-value-return-byte-offset)
1589     cl)))
1590     (cond ((and (di::compiled-frame-escaped frame)
1591     (eq (di:code-location-kind code-location)
1592     :single-value-return)
1593     (= (length next) 1)
1594     (di:code-location= (car next) (adjust-pc)))
1595     (debug::next-code-locations (car next)))
1596     (t
1597     next)))))
1598    
1599 heller 1.119 (defun set-step-breakpoints (frame)
1600     (let ((cl (di:frame-code-location frame)))
1601     (when (di:debug-block-elsewhere-p (di:code-location-debug-block cl))
1602     (error "Cannot step in elsewhere code"))
1603 heller 1.126 (let* ((debug::*bad-code-location-types*
1604 heller 1.119 (remove :call-site debug::*bad-code-location-types*))
1605 heller 1.126 (next (next-code-locations frame cl)))
1606 heller 1.119 (cond (next
1607     (let ((steppoints '()))
1608     (flet ((hook (bp-frame bp)
1609 heller 1.126 (signal-breakpoint bp bp-frame)
1610     (mapc #'di:delete-breakpoint steppoints)))
1611 heller 1.119 (dolist (code-location next)
1612     (let ((bp (di:make-breakpoint #'hook code-location
1613     :kind :code-location)))
1614     (di:activate-breakpoint bp)
1615     (push bp steppoints))))))
1616     (t
1617     (break-on-return frame))))))
1618    
1619    
1620     ;; XXX the return values at return breakpoints should be passed to the
1621     ;; user hooks. debug-int.lisp should be changed to do this cleanly.
1622    
1623     ;;; The sigcontext and the PC for a breakpoint invocation are not
1624     ;;; passed to user hook functions, but we need them to extract return
1625     ;;; values. So we advice di::handle-breakpoint and bind the values to
1626     ;;; special variables.
1627     ;;;
1628     (defvar *breakpoint-sigcontext*)
1629     (defvar *breakpoint-pc*)
1630    
1631     ;; XXX don't break old versions without fwrappers. Remove this one day.
1632     #+#.(cl:if (cl:find-package :fwrappers) '(and) '(or))
1633     (progn
1634     (fwrappers:define-fwrapper bind-breakpoint-sigcontext (offset c sigcontext)
1635     (let ((*breakpoint-sigcontext* sigcontext)
1636     (*breakpoint-pc* offset))
1637     (fwrappers:call-next-function)))
1638     (fwrappers:set-fwrappers 'di::handle-breakpoint '())
1639     (fwrappers:fwrap 'di::handle-breakpoint #'bind-breakpoint-sigcontext))
1640    
1641     (defun sigcontext-object (sc index)
1642     "Extract the lisp object in sigcontext SC at offset INDEX."
1643     (kernel:make-lisp-obj (vm:sigcontext-register sc index)))
1644    
1645     (defun known-return-point-values (sigcontext sc-offsets)
1646     (let ((fp (system:int-sap (vm:sigcontext-register sigcontext
1647     vm::cfp-offset))))
1648     (system:without-gcing
1649     (loop for sc-offset across sc-offsets
1650     collect (di::sub-access-debug-var-slot fp sc-offset sigcontext)))))
1651    
1652     ;;; CMUCL returns the first few values in registers and the rest on
1653     ;;; the stack. In the multiple value case, the number of values is
1654     ;;; stored in a dedicated register. The values of the registers can be
1655     ;;; accessed in the sigcontext for the breakpoint. There are 3 kinds
1656     ;;; of return conventions: :single-value-return, :unknown-return, and
1657     ;;; :known-return.
1658     ;;;
1659     ;;; The :single-value-return convention returns the value in a
1660     ;;; register without setting the nargs registers.
1661     ;;;
1662     ;;; The :unknown-return variant is used for multiple values. A
1663     ;;; :unknown-return point consists actually of 2 breakpoints: one for
1664     ;;; the single value case and one for the general case. The single
1665     ;;; value breakpoint comes vm:single-value-return-byte-offset after
1666     ;;; the multiple value breakpoint.
1667     ;;;
1668     ;;; The :known-return convention is used by local functions.
1669     ;;; :known-return is currently not supported because we don't know
1670     ;;; where the values are passed.
1671     ;;;
1672     (defun breakpoint-values (breakpoint)
1673     "Return the list of return values for a return point."
1674     (flet ((1st (sc) (sigcontext-object sc (car vm::register-arg-offsets))))
1675     (let ((sc (locally (declare (optimize (ext:inhibit-warnings 3)))
1676     (alien:sap-alien *breakpoint-sigcontext* (* unix:sigcontext))))
1677     (cl (di:breakpoint-what breakpoint)))
1678     (ecase (di:code-location-kind cl)
1679     (:single-value-return
1680     (list (1st sc)))
1681     (:known-return
1682     (let ((info (di:breakpoint-info breakpoint)))
1683     (if (vectorp info)
1684     (known-return-point-values sc info)
1685 heller 1.142 (progn
1686     ;;(break)
1687     (list "<<known-return convention not supported>>" info)))))
1688 heller 1.119 (:unknown-return
1689     (let ((mv-return-pc (di::compiled-code-location-pc cl)))
1690     (if (= mv-return-pc *breakpoint-pc*)
1691 heller 1.143 (mv-function-end-breakpoint-values sc)
1692 heller 1.119 (list (1st sc)))))))))
1693 heller 1.143
1694     ;; XXX: di::get-function-end-breakpoint-values takes 2 arguments in
1695     ;; newer versions of CMUCL (after ~March 2005).
1696     (defun mv-function-end-breakpoint-values (sigcontext)
1697     (let ((sym (find-symbol "FUNCTION-END-BREAKPOINT-VALUES/STANDARD" :di)))
1698     (cond (sym (funcall sym sigcontext))
1699     (t (di::get-function-end-breakpoint-values sigcontext)))))
1700 heller 1.119
1701     (defun debug-function-returns (debug-fun)
1702     "Return the return style of DEBUG-FUN."
1703     (let* ((cdfun (di::compiled-debug-function-compiler-debug-fun debug-fun)))
1704     (c::compiled-debug-function-returns cdfun)))
1705    
1706     (define-condition breakpoint (simple-condition)
1707 heller 1.137 ((message :initarg :message :reader breakpoint.message)
1708     (values :initarg :values :reader breakpoint.values))
1709 heller 1.119 (:report (lambda (c stream) (princ (breakpoint.message c) stream))))
1710    
1711     (defimplementation condition-extras ((c breakpoint))
1712     ;; simply pop up the source buffer
1713     `((:short-frame-source 0)))
1714    
1715     (defun signal-breakpoint (breakpoint frame)
1716     "Signal a breakpoint condition for BREAKPOINT in FRAME.
1717     Try to create a informative message."
1718 heller 1.137 (flet ((brk (values fstring &rest args)
1719 heller 1.119 (let ((msg (apply #'format nil fstring args))
1720     (debug:*stack-top-hint* frame))
1721 heller 1.137 (break 'breakpoint :message msg :values values))))
1722     (with-struct (di::breakpoint- kind what) breakpoint
1723     (case kind
1724     (:code-location
1725     (case (di:code-location-kind what)
1726     ((:single-value-return :known-return :unknown-return)
1727     (let ((values (breakpoint-values breakpoint)))
1728     (brk values "Return value: ~{~S ~}" values)))
1729     (t
1730 heller 1.140 #+(or)
1731     (when (eq (di:code-location-kind what) :call-site)
1732     (call-site-function breakpoint frame))
1733 heller 1.137 (brk nil "Breakpoint: ~S ~S"
1734     (di:code-location-kind what)
1735     (di::compiled-code-location-pc what)))))
1736     (:function-start
1737     (brk nil "Function start breakpoint"))
1738     (t (brk nil "Breakpoint: ~A in ~A" breakpoint frame))))))
1739 heller 1.119
1740     (defimplementation sldb-break-at-start (fname)
1741     (let ((debug-fun (di:function-debug-function (coerce fname 'function))))
1742     (cond ((not debug-fun)
1743     `(:error ,(format nil "~S has no debug-function" fname)))
1744     (t
1745     (flet ((hook (frame bp &optional args cookie)
1746     (declare (ignore args cookie))
1747     (signal-breakpoint bp frame)))
1748     (let ((bp (di:make-breakpoint #'hook debug-fun
1749     :kind :function-start)))
1750     (di:activate-breakpoint bp)
1751     `(:ok ,(format nil "Set breakpoint in ~S" fname))))))))
1752 dbarlow 1.1
1753 heller 1.58 (defun frame-cfp (frame)
1754     "Return the Control-Stack-Frame-Pointer for FRAME."
1755     (etypecase frame
1756     (di::compiled-frame (di::frame-pointer frame))
1757     ((or di::interpreted-frame null) -1)))
1758    
1759     (defun frame-ip (frame)
1760     "Return the (absolute) instruction pointer and the relative pc of FRAME."
1761     (if (not frame)
1762     -1
1763     (let ((debug-fun (di::frame-debug-function frame)))
1764     (etypecase debug-fun
1765     (di::compiled-debug-function
1766     (let* ((code-loc (di:frame-code-location frame))
1767     (component (di::compiled-debug-function-component debug-fun))
1768     (pc (di::compiled-code-location-pc code-loc))
1769     (ip (sys:without-gcing
1770     (sys:sap-int
1771     (sys:sap+ (kernel:code-instructions component) pc)))))
1772     (values ip pc)))
1773     ((or di::bogus-debug-function di::interpreted-debug-function)
1774     -1)))))
1775    
1776     (defun frame-registers (frame)
1777     "Return the lisp registers CSP, CFP, IP, OCFP, LRA for FRAME-NUMBER."
1778     (let* ((cfp (frame-cfp frame))
1779     (csp (frame-cfp (di::frame-up frame)))
1780     (ip (frame-ip frame))
1781     (ocfp (frame-cfp (di::frame-down frame)))
1782     (lra (frame-ip (di::frame-down frame))))
1783     (values csp cfp ip ocfp lra)))
1784    
1785     (defun print-frame-registers (frame-number)
1786     (let ((frame (di::frame-real-frame (nth-frame frame-number))))
1787     (flet ((fixnum (p) (etypecase p
1788     (integer p)
1789     (sys:system-area-pointer (sys:sap-int p)))))
1790     (apply #'format t "~
1791     CSP = ~X
1792     CFP = ~X
1793     IP = ~X
1794     OCFP = ~X
1795     LRA = ~X~%" (mapcar #'fixnum
1796     (multiple-value-list (frame-registers frame)))))))
1797    
1798 heller 1.82
1799 heller 1.81 (defimplementation disassemble-frame (frame-number)
1800     "Return a string with the disassembly of frames code."
1801     (print-frame-registers frame-number)
1802     (terpri)
1803     (let* ((frame (di::frame-real-frame (nth-frame frame-number)))
1804     (debug-fun (di::frame-debug-function frame)))
1805     (etypecase debug-fun
1806     (di::compiled-debug-function
1807     (let* ((component (di::compiled-debug-function-component debug-fun))
1808     (fun (di:debug-function-function debug-fun)))
1809     (if fun
1810     (disassemble fun)
1811     (disassem:disassemble-code-component component))))
1812     (di::bogus-debug-function
1813     (format t "~%[Disassembling bogus frames not implemented]")))))
1814 heller 1.58
1815 dbarlow 1.1
1816 lgorrie 1.25 ;;;; Inspecting
1817 dbarlow 1.1
1818 mbaringer 1.116 (defclass cmucl-inspector (inspector)
1819     ())
1820    
1821     (defimplementation make-default-inspector ()
1822     (make-instance 'cmucl-inspector))
1823    
1824 dbarlow 1.1 (defconstant +lowtag-symbols+
1825     '(vm:even-fixnum-type
1826     vm:function-pointer-type
1827     vm:other-immediate-0-type
1828     vm:list-pointer-type
1829     vm:odd-fixnum-type
1830     vm:instance-pointer-type
1831     vm:other-immediate-1-type
1832 lgorrie 1.103 vm:other-pointer-type)
1833     "Names of the constants that specify type tags.
1834     The `symbol-value' of each element is a type tag.")
1835 dbarlow 1.1
1836     (defconstant +header-type-symbols+
1837 heller 1.144 (labels ((suffixp (suffix string)
1838     (and (>= (length string) (length suffix))
1839     (string= string suffix :start1 (- (length string)
1840     (length suffix)))))
1841     (header-type-symbol-p (x)
1842     (and (suffixp "-TYPE" (symbol-name x))
1843     (not (member x +lowtag-symbols+))
1844     (boundp x)
1845     (typep (symbol-value x) 'fixnum))))
1846     (remove-if-not #'header-type-symbol-p
1847     (append (apropos-list "-TYPE" "VM")
1848     (apropos-list "-TYPE" "BIGNUM"))))
1849 heller 1.102 "A list of names of the type codes in boxed objects.")
1850 heller 1.62
1851     (defimplementation describe-primitive-type (object)
1852 dbarlow 1.1 (with-output-to-string (*standard-output*)
1853     (let* ((lowtag (kernel:get-lowtag object))
1854     (lowtag-symbol (find lowtag +lowtag-symbols+ :key #'symbol-value)))
1855 heller 1.76 (format t "lowtag: ~A" lowtag-symbol)
1856     (when (member lowtag (list vm:other-pointer-type
1857     vm:function-pointer-type
1858     vm:other-immediate-0-type
1859     vm:other-immediate-1-type
1860     ))
1861     (let* ((type (kernel:get-type object))
1862     (type-symbol (find type +header-type-symbols+
1863     :key #'symbol-value)))
1864     (format t ", type: ~A" type-symbol))))))
1865 dbarlow 1.1
1866 heller 1.161 (defmethod inspect-for-emacs ((o t) (inspector cmucl-inspector))
1867 dbarlow 1.1 (cond ((di::indirect-value-cell-p o)
1868 heller 1.121 (values (format nil "~A is a value cell." o)
1869 mbaringer 1.116 `("Value: " (:value ,(c:value-cell-ref o)))))
1870 heller 1.130 ((alien::alien-value-p o)
1871     (inspect-alien-value o))
1872 dbarlow 1.1 (t
1873 heller 1.130 (cmucl-inspect o))))
1874    
1875     (defun cmucl-inspect (o)
1876     (destructuring-bind (text labeledp . parts) (inspect::describe-parts o)
1877     (values (format nil "~A~%" text)
1878     (if labeledp
1879     (loop for (label . value) in parts
1880     append (label-value-line label value))
1881     (loop for value in parts for i from 0
1882     append (label-value-line i value))))))
1883 heller 1.55
1884 heller 1.157 (defmethod inspect-for-emacs ((o function) (inspector cmucl-inspector))
1885 mbaringer 1.116 (declare (ignore inspector))
1886 heller 1.126 (let ((header (kernel:get-type o)))
1887     (cond ((= header vm:function-header-type)
1888     (values (format nil "~A is a function." o)
1889     (append (label-value-line*
1890     ("Self" (kernel:%function-self o))
1891     ("Next" (kernel:%function-next o))
1892     ("Name" (kernel:%function-name o))
1893     ("Arglist" (kernel:%function-arglist o))
1894     ("Type" (kernel:%function-type o))
1895     ("Code" (kernel:function-code-header o)))
1896     (list
1897     (with-output-to-string (s)
1898     (disassem:disassemble-function o :stream s))))))
1899     ((= header vm:closure-header-type)
1900     (values (format nil "~A is a closure" o)
1901     (append
1902     (label-value-line "Function" (kernel:%closure-function o))
1903     `("Environment:" (:newline))
1904     (loop for i from 0 below (1- (kernel:get-closure-length o))
1905     append (label-value-line
1906     i (kernel:%closure-index-ref o i))))))
1907 heller 1.142 ((eval::interpreted-function-p o)
1908     (cmucl-inspect o))
1909     (t
1910 heller 1.126 (call-next-method)))))
1911    
1912 heller 1.158 (defmethod inspect-for-emacs ((o kernel:funcallable-instance)
1913     (i cmucl-inspector))
1914     (declare (ignore i))
1915     (values
1916     (format nil "~A is a funcallable-instance." o)
1917     (append (label-value-line*
1918     (:function (kernel:%funcallable-instance-function o))
1919     (:lexenv (kernel:%funcallable-instance-lexenv o))
1920     (:layout (kernel:%funcallable-instance-layout o)))
1921     (nth-value 1 (cmucl-inspect o)))))
1922 dbarlow 1.1
1923 heller 1.121 (defmethod inspect-for-emacs ((o kernel:code-component) (_ cmucl-inspector))
1924     (declare (ignore _))
1925     (values (format nil "~A is a code data-block." o)
1926     (append
1927     (label-value-line*
1928     ("code-size" (kernel:%code-code-size o))
1929     ("entry-points" (kernel:%code-entry-points o))
1930     ("debug-info" (kernel:%code-debug-info o))
1931     ("trace-table-offset" (kernel:code-header-ref
1932     o vm:code-trace-table-offset-slot)))
1933     `("Constants:" (:newline))
1934     (loop for i from vm:code-constants-offset
1935     below (kernel:get-header-data o)
1936     append (label-value-line i (kernel:code-header-ref o i)))
1937     `("Code:" (:newline)
1938     , (with-output-to-string (s)
1939 heller 1.123 (cond ((kernel:%code-debug-info o)
1940     (disassem:disassemble-code-component o :stream s))
1941     (t
1942     (disassem:disassemble-memory
1943     (disassem::align
1944     (+ (logandc2 (kernel:get-lisp-obj-address o)
1945     vm:lowtag-mask)
1946     (* vm:code-constants-offset vm:word-bytes))
1947     (ash 1 vm:lowtag-bits))
1948     (ash (kernel:%code-code-size o) vm:word-shift)
1949     :stream s))))))))
1950 mbaringer 1.116
1951     (defmethod inspect-for-emacs ((o kernel:fdefn) (inspector cmucl-inspector))
1952     (declare (ignore inspector))
1953 heller 1.121 (values (format nil "~A is a fdenf object." o)
1954     (label-value-line*
1955     ("name" (kernel:fdefn-name o))
1956     ("function" (kernel:fdefn-function o))
1957     ("raw-addr" (sys:sap-ref-32
1958     (sys:int-sap (kernel:get-lisp-obj-address o))
1959     (* vm:fdefn-raw-addr-slot vm:word-bytes))))))
1960 heller 1.58
1961 heller 1.129 (defmethod inspect-for-emacs ((o array) (inspector cmucl-inspector))
1962     inspector
1963     (values (format nil "~A is an array." o)
1964     (label-value-line*
1965     (:header (describe-primitive-type o))
1966     (:rank (array-rank o))
1967     (:fill-pointer (kernel:%array-fill-pointer o))
1968     (:fill-pointer-p (kernel:%array-fill-pointer-p o))
1969     (:elements (kernel:%array-available-elements o))
1970     (:data (kernel:%array-data-vector o))
1971     (:displacement (kernel:%array-displacement o))
1972     (:displaced-p (kernel:%array-displaced-p o))
1973     (:dimensions (array-dimensions o)))))
1974    
1975 heller 1.157 (defmethod inspect-for-emacs ((o simple-vector) (inspector cmucl-inspector))
1976 heller 1.129 inspector
1977     (values (format nil "~A is a vector." o)
1978     (append
1979     (label-value-line*
1980     (:header (describe-primitive-type o))
1981     (:length (c::vector-length o)))
1982     (loop for i below (length o)
1983     append (label-value-line i (aref o i))))))
1984    
1985 heller 1.130 (defun inspect-alien-record (alien)
1986     (values
1987     (format nil "~A is an alien value." alien)
1988     (with-struct (alien::alien-value- sap type) alien
1989     (with-struct (alien::alien-record-type- kind name fields) type
1990     (append
1991     (label-value-line*
1992     (:sap sap)
1993     (:kind kind)
1994     (:name name))
1995     (loop for field in fields
1996     append (let ((slot (alien::alien-record-field-name field)))
1997     (label-value-line slot (alien:slot alien slot)))))))))
1998    
1999     (defun inspect-alien-pointer (alien)
2000     (values
2001     (format nil "~A is an alien value." alien)
2002     (with-struct (alien::alien-value- sap type) alien
2003     (label-value-line*
2004     (:sap sap)
2005     (:type type)
2006     (:to (alien::deref alien))))))
2007    
2008     (defun inspect-alien-value (alien)
2009     (typecase (alien::alien-value-type alien)
2010     (alien::alien-record-type (inspect-alien-record alien))
2011     (alien::alien-pointer-type (inspect-alien-pointer alien))
2012     (t (cmucl-inspect alien))))
2013 heller 1.58
2014     ;;;; Profiling
2015     (defimplementation profile (fname)
2016     (eval `(profile:profile ,fname)))
2017    
2018     (defimplementation unprofile (fname)
2019     (eval `(profile:unprofile ,fname)))
2020    
2021     (defimplementation unprofile-all ()
2022 heller 1.126 (eval `(profile:unprofile))
2023 heller 1.58 "All functions unprofiled.")
2024    
2025     (defimplementation profile-report ()
2026 heller 1.126 (eval `(profile:report-time)))
2027 heller 1.58
2028     (defimplementation profile-reset ()
2029 heller 1.126 (eval `(profile:reset-time))
2030 heller 1.58 "Reset profiling counters.")
2031    
2032     (defimplementation profiled-functions ()
2033     profile:*timed-functions*)
2034    
2035     (defimplementation profile-package (package callers methods)
2036 heller 1.80 (profile:profile-all :package package
2037 heller 1.58 :callers-p callers
2038 lgorrie 1.105 #-cmu18e :methods #-cmu18e methods))
2039 dbarlow 1.1
2040 lgorrie 1.42
2041     ;;;; Multiprocessing
2042    
2043 heller 1.91 #+mp
2044 lgorrie 1.42 (progn
2045 heller 1.155 (defimplementation initialize-multiprocessing ()
2046     (mp::init-multi-processing))
2047    
2048     (defimplementation startup-idle-and-top-level-loops ()
2049 lgorrie 1.49 ;; Threads magic: this never returns! But top-level becomes
2050     ;; available again.
2051 lgorrie 1.42 (mp::startup-idle-and-top-level-loops))
2052 heller 1.54
2053 heller 1.59 (defimplementation spawn (fn &key (name "Anonymous"))
2054 heller 1.54 (mp:make-process fn :name name))
2055 lgorrie 1.42
2056 heller 1.109 (defvar *thread-id-counter* 0)
2057    
2058     (defimplementation thread-id (thread)
2059     (or (getf (mp:process-property-list thread) 'id)
2060     (setf (getf (mp:process-property-list thread) 'id)
2061     (incf *thread-id-counter*))))
2062    
2063     (defimplementation find-thread (id)
2064     (find id (all-threads)
2065     :key (lambda (p) (getf (mp:process-property-list p) 'id))))
2066    
2067 heller 1.61 (defimplementation thread-name (thread)
2068     (mp:process-name thread))
2069 lgorrie 1.42
2070 heller 1.61 (defimplementation thread-status (thread)
2071     (mp:process-whostate thread))
2072 lgorrie 1.42
2073 heller 1.61 (defimplementation current-thread ()
2074     mp:*current-process*)
2075 lgorrie 1.42
2076 heller 1.61 (defimplementation all-threads ()
2077