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

Contents of /slime/swank-cmucl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.226 - (hide annotations)
Fri Aug 13 07:25:23 2010 UTC (3 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.225: +13 -1 lines
Find definition for (def-vm-support-routine NAME ...)

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