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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.310 - (hide annotations)
Thu May 3 14:12:23 2012 UTC (23 months, 2 weeks ago) by sboukarev
Branch: MAIN
Changes since 1.309: +52 -37 lines
* swank-sbcl.lisp (definition-source-for-emacs): Prefer :file over
:buffer, because the buffer can be killed in the mean time and the
silly "No buffer named x.lisp" would be displayed.
1 trittweiler 1.246 ;;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
2 dbarlow 1.1 ;;;
3     ;;; swank-sbcl.lisp --- SLIME backend for SBCL.
4     ;;;
5     ;;; Created 2003, Daniel Barlow <dan@metacircles.com>
6     ;;;
7 jsnellman 1.158 ;;; This code has been placed in the Public Domain. All warranties are
8 dbarlow 1.1 ;;; disclaimed.
9    
10 heller 1.106 ;;; Requires the SB-INTROSPECT contrib.
11 dbarlow 1.1
12     ;;; Administrivia
13    
14 heller 1.146 (in-package :swank-backend)
15    
16 dbarlow 1.1 (eval-when (:compile-toplevel :load-toplevel :execute)
17     (require 'sb-bsd-sockets)
18 heller 1.59 (require 'sb-introspect)
19 trittweiler 1.179 (require 'sb-posix)
20 nsiivola 1.308 (require 'sb-cltl2)
21     (import-from :sb-gray *gray-stream-symbols* :swank-backend))
22 heller 1.107
23 heller 1.196 (declaim (optimize (debug 2)
24     (sb-c::insert-step-conditions 0)
25     (sb-c::insert-debug-catch 0)
26     (sb-c::merge-tail-calls 2)))
27 dbarlow 1.1
28 jsnellman 1.166 ;;; backwards compability tests
29    
30     (eval-when (:compile-toplevel :load-toplevel :execute)
31     ;; Generate a form suitable for testing for stepper support (0.9.17)
32     ;; with #+.
33     (defun sbcl-with-new-stepper-p ()
34 trittweiler 1.233 (with-symbol 'enable-stepping 'sb-impl))
35 nsiivola 1.170 ;; Ditto for weak hash-tables
36     (defun sbcl-with-weak-hash-tables ()
37 trittweiler 1.233 (with-symbol 'hash-table-weakness 'sb-ext))
38 jsnellman 1.172 ;; And for xref support (1.0.1)
39     (defun sbcl-with-xref-p ()
40 trittweiler 1.233 (with-symbol 'who-calls 'sb-introspect))
41 jsnellman 1.174 ;; ... for restart-frame support (1.0.2)
42     (defun sbcl-with-restart-frame ()
43 trittweiler 1.233 (with-symbol 'frame-has-debug-tag-p 'sb-debug)))
44 jsnellman 1.166
45 mbaringer 1.100 ;;; swank-mop
46    
47 heller 1.106 (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
48 mbaringer 1.100
49 mbaringer 1.101 (defun swank-mop:slot-definition-documentation (slot)
50 jsnellman 1.158 (sb-pcl::documentation slot t))
51 mbaringer 1.100
52 trittweiler 1.194 ;;; Connection info
53    
54     (defimplementation lisp-implementation-type-name ()
55     "sbcl")
56    
57     ;; Declare return type explicitly to shut up STYLE-WARNINGS about
58     ;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below.
59     (declaim (ftype (function () (values (signed-byte 32) &optional)) getpid))
60     (defimplementation getpid ()
61     (sb-posix:getpid))
62    
63 heller 1.290 ;;; UTF8
64    
65     (defimplementation string-to-utf8 (string)
66     (sb-ext:string-to-octets string :external-format :utf8))
67    
68     (defimplementation utf8-to-string (octets)
69     (sb-ext:octets-to-string octets :external-format :utf8))
70    
71 dbarlow 1.1 ;;; TCP Server
72    
73 lgorrie 1.132 (defimplementation preferred-communication-style ()
74 crhodes 1.155 (cond
75     ;; fixme: when SBCL/win32 gains better select() support, remove
76     ;; this.
77 sboukarev 1.289 ((member :sb-thread *features*) :spawn)
78 crhodes 1.155 ((member :win32 *features*) nil)
79     (t :fd-handler)))
80 jsnellman 1.158
81 heller 1.65 (defun resolve-hostname (name)
82     (car (sb-bsd-sockets:host-ent-addresses
83     (sb-bsd-sockets:get-host-by-name name))))
84    
85 heller 1.294 (defimplementation create-socket (host port &key backlog)
86 dbarlow 1.6 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
87     :type :stream
88     :protocol :tcp)))
89 heller 1.48 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
90 heller 1.65 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
91 heller 1.294 (sb-bsd-sockets:socket-listen socket (or backlog 5))
92 heller 1.29 socket))
93    
94 lgorrie 1.54 (defimplementation local-port (socket)
95 lgorrie 1.46 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
96    
97 lgorrie 1.54 (defimplementation close-socket (socket)
98 lgorrie 1.86 (sb-sys:invalidate-descriptor (socket-fd socket))
99 heller 1.48 (sb-bsd-sockets:socket-close socket))
100    
101 jsnellman 1.158 (defimplementation accept-connection (socket &key
102 heller 1.160 external-format
103     buffering timeout)
104 dcrosher 1.153 (declare (ignore timeout))
105 heller 1.291 (make-socket-io-stream (accept socket) external-format
106     (ecase buffering
107     ((t :full) :full)
108     ((nil :none) :none)
109     ((:line) :line))))
110 heller 1.48
111 heller 1.214 #-win32
112 heller 1.213 (defimplementation install-sigint-handler (function)
113     (sb-sys:enable-interrupt sb-unix:sigint
114     (lambda (&rest args)
115     (declare (ignore args))
116 heller 1.221 (sb-sys:invoke-interruption
117     (lambda ()
118     (sb-sys:with-interrupts
119     (funcall function)))))))
120 heller 1.213
121 heller 1.59 (defvar *sigio-handlers* '()
122     "List of (key . fn) pairs to be called on SIGIO.")
123    
124     (defun sigio-handler (signal code scp)
125 heller 1.60 (declare (ignore signal code scp))
126     (mapc (lambda (handler)
127     (funcall (the function (cdr handler))))
128     *sigio-handlers*))
129 heller 1.59
130     (defun set-sigio-handler ()
131 heller 1.82 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
132 heller 1.59 (sigio-handler signal code scp))))
133    
134 heller 1.62 (defun enable-sigio-on-fd (fd)
135 heller 1.82 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
136 trittweiler 1.194 (sb-posix::fcntl fd sb-posix::f-setown (getpid))
137     (values))
138 heller 1.62
139 heller 1.67 (defimplementation add-sigio-handler (socket fn)
140 heller 1.62 (set-sigio-handler)
141     (let ((fd (socket-fd socket)))
142     (enable-sigio-on-fd fd)
143     (push (cons fd fn) *sigio-handlers*)))
144    
145 heller 1.67 (defimplementation remove-sigio-handlers (socket)
146 heller 1.59 (let ((fd (socket-fd socket)))
147     (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
148 jsnellman 1.158 (sb-sys:invalidate-descriptor fd))
149 heller 1.51 (close socket))
150 heller 1.67
151 heller 1.244 (defimplementation add-fd-handler (socket fun)
152     (let ((fd (socket-fd socket))
153     (handler nil))
154     (labels ((add ()
155     (setq handler (sb-sys:add-fd-handler fd :input #'run)))
156     (run (fd)
157     (sb-sys:remove-fd-handler handler) ; prevent recursion
158     (unwind-protect
159     (funcall fun)
160     (when (sb-unix:unix-fstat fd) ; still open?
161     (add)))))
162     (add))))
163 heller 1.67
164     (defimplementation remove-fd-handlers (socket)
165     (sb-sys:invalidate-descriptor (socket-fd socket)))
166 heller 1.51
167 heller 1.274 (defimplementation socket-fd (socket)
168 heller 1.48 (etypecase socket
169     (fixnum socket)
170     (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
171     (file-stream (sb-sys:fd-stream-fd socket))))
172    
173 heller 1.274 (defimplementation command-line-args ()
174     sb-ext:*posix-argv*)
175    
176     (defimplementation dup (fd)
177     (sb-posix:dup fd))
178    
179 heller 1.221 (defvar *wait-for-input-called*)
180    
181     (defimplementation wait-for-input (streams &optional timeout)
182     (assert (member timeout '(nil t)))
183     (when (boundp '*wait-for-input-called*)
184     (setq *wait-for-input-called* t))
185     (let ((*wait-for-input-called* nil))
186     (loop
187 nsiivola 1.298 (let ((ready (remove-if-not #'input-ready-p streams)))
188     (when ready (return ready)))
189     (when (check-slime-interrupts)
190     (return :interrupt))
191     (when *wait-for-input-called*
192     (return :interrupt))
193     (when timeout
194     (return nil))
195     (sleep 0.1))))
196 heller 1.242
197 heller 1.302 (defun fd-stream-input-buffer-empty-p (stream)
198     (let ((buffer (sb-impl::fd-stream-ibuf stream)))
199     (or (not buffer)
200     (= (sb-impl::buffer-head buffer)
201     (sb-impl::buffer-tail buffer)))))
202    
203 nsiivola 1.298 #-win32
204     (defun input-ready-p (stream)
205 heller 1.302 (or (not (fd-stream-input-buffer-empty-p stream))
206 sboukarev 1.300 #+#.(swank-backend:with-symbol 'fd-stream-fd-type 'sb-impl)
207 nsiivola 1.298 (eq :regular (sb-impl::fd-stream-fd-type stream))
208     (not (sb-impl::sysread-may-block-p stream))))
209 heller 1.295
210 sboukarev 1.297 #+win32
211 heller 1.242 (progn
212     (defun input-ready-p (stream)
213 heller 1.295 (or (not (fd-stream-input-buffer-empty-p stream))
214     (handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream)))))
215 heller 1.242
216     (sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event)
217     sb-win32:handle)
218    
219     (sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event)
220     sb-alien:int
221     (event sb-win32:handle))
222    
223     (defconstant +fd-read+ #.(ash 1 0))
224     (defconstant +fd-close+ #.(ash 1 5))
225    
226     (sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
227     sb-alien:int
228     (fd sb-alien:int)
229     (handle sb-win32:handle)
230     (mask sb-alien:long))
231    
232     (sb-alien:load-shared-object "kernel32.dll")
233     (sb-alien:define-alien-routine ("WaitForSingleObjectEx"
234     wait-for-single-object-ex)
235     sb-alien:int
236     (event sb-win32:handle)
237     (milliseconds sb-alien:long)
238     (alertable sb-alien:int))
239    
240     ;; see SB-WIN32:HANDLE-LISTEN
241     (defun handle-listen (handle)
242     (sb-alien:with-alien ((avail sb-win32:dword)
243     (buf (array char #.sb-win32::input-record-size)))
244     (unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil
245     (sb-alien:alien-sap
246     (sb-alien:addr avail))
247     nil))
248     (return-from handle-listen (plusp avail)))
249    
250     (unless (zerop (sb-win32:peek-console-input handle
251     (sb-alien:alien-sap buf)
252     sb-win32::input-record-size
253     (sb-alien:alien-sap
254     (sb-alien:addr avail))))
255     (return-from handle-listen (plusp avail))))
256    
257     (let ((event (wsa-create-event)))
258     (wsa-event-select handle event (logior +fd-read+ +fd-close+))
259     (let ((val (wait-for-single-object-ex event 0 0)))
260     (wsa-close-event event)
261     (unless (= val -1)
262     (return-from handle-listen (zerop val)))))
263    
264     nil)
265    
266     )
267 heller 1.221
268 heller 1.171 (defvar *external-format-to-coding-system*
269     '((:iso-8859-1
270     "latin-1" "latin-1-unix" "iso-latin-1-unix"
271     "iso-8859-1" "iso-8859-1-unix")
272     (:utf-8 "utf-8" "utf-8-unix")
273     (:euc-jp "euc-jp" "euc-jp-unix")
274     (:us-ascii "us-ascii" "us-ascii-unix")))
275    
276 heller 1.306 ;; C.f. R.M.Kreuter in <20536.1219412774@progn.net> on sbcl-general,
277     ;; 2008-08-22.
278 trittweiler 1.216 (defvar *physical-pathname-host* (pathname-host (user-homedir-pathname)))
279    
280 heller 1.223 (defimplementation filename-to-pathname (filename)
281 trittweiler 1.216 (sb-ext:parse-native-namestring filename *physical-pathname-host*))
282    
283 heller 1.171 (defimplementation find-external-format (coding-system)
284     (car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
285     *external-format-to-coding-system*)))
286 heller 1.137
287 heller 1.150 (defun make-socket-io-stream (socket external-format buffering)
288 heller 1.291 (let ((args `(,@()
289     :output t
290     :input t
291     :element-type ,(if external-format
292     'character
293     '(unsigned-byte 8))
294     :buffering ,buffering
295     ,@(cond ((and external-format (sb-int:featurep :sb-unicode))
296     `(:external-format ,external-format))
297     (t '()))
298     :serve-events ,(eq :fd-handler
299 nsiivola 1.307 (swank-value '*communication-style* t))
300 heller 1.291 ;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS
301     ;; argument.
302     :allow-other-keys t)))
303     (apply #'sb-bsd-sockets:socket-make-stream socket args)))
304 lgorrie 1.46
305 heller 1.29 (defun accept (socket)
306     "Like socket-accept, but retry on EAGAIN."
307 jsnellman 1.158 (loop (handler-case
308 heller 1.29 (return (sb-bsd-sockets:socket-accept socket))
309     (sb-bsd-sockets:interrupted-error ()))))
310 dbarlow 1.6
311 heller 1.124
312     ;;;; Support for SBCL syntax
313    
314 heller 1.129 ;;; SBCL's source code is riddled with #! reader macros. Also symbols
315     ;;; containing `!' have special meaning. We have to work long and
316     ;;; hard to be able to read the source. To deal with #! reader
317     ;;; macros, we use a special readtable. The special symbols are
318     ;;; converted by a condition handler.
319    
320 heller 1.124 (defun feature-in-list-p (feature list)
321     (etypecase feature
322     (symbol (member feature list :test #'eq))
323     (cons (flet ((subfeature-in-list-p (subfeature)
324     (feature-in-list-p subfeature list)))
325     (ecase (first feature)
326     (:or (some #'subfeature-in-list-p (rest feature)))
327     (:and (every #'subfeature-in-list-p (rest feature)))
328     (:not (destructuring-bind (e) (cdr feature)
329     (not (subfeature-in-list-p e)))))))))
330    
331     (defun shebang-reader (stream sub-character infix-parameter)
332     (declare (ignore sub-character))
333     (when infix-parameter
334     (error "illegal read syntax: #~D!" infix-parameter))
335     (let ((next-char (read-char stream)))
336     (unless (find next-char "+-")
337     (error "illegal read syntax: #!~C" next-char))
338     ;; When test is not satisfied
339     ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
340     ;; would become "unless test is satisfied"..
341     (when (let* ((*package* (find-package "KEYWORD"))
342     (*read-suppress* nil)
343     (not-p (char= next-char #\-))
344     (feature (read stream)))
345     (if (feature-in-list-p feature *features*)
346     not-p
347     (not not-p)))
348     ;; Read (and discard) a form from input.
349     (let ((*read-suppress* t))
350     (read stream t nil t))))
351     (values))
352    
353 jsnellman 1.158 (defvar *shebang-readtable*
354 heller 1.124 (let ((*readtable* (copy-readtable nil)))
355 jsnellman 1.158 (set-dispatch-macro-character #\# #\!
356 heller 1.124 (lambda (s c n) (shebang-reader s c n))
357     *readtable*)
358     *readtable*))
359    
360     (defun shebang-readtable ()
361     *shebang-readtable*)
362    
363     (defun sbcl-package-p (package)
364     (let ((name (package-name package)))
365     (eql (mismatch "SB-" name) 3)))
366    
367 heller 1.126 (defun sbcl-source-file-p (filename)
368 nsiivola 1.187 (when filename
369 trittweiler 1.218 (loop for (nil pattern) in (logical-pathname-translations "SYS")
370 nsiivola 1.187 thereis (pathname-match-p filename pattern))))
371 heller 1.126
372     (defun guess-readtable-for-filename (filename)
373     (if (sbcl-source-file-p filename)
374     (shebang-readtable)
375     *readtable*))
376    
377 heller 1.124 (defvar *debootstrap-packages* t)
378    
379 heller 1.126 (defun call-with-debootstrapping (fun)
380 jsnellman 1.158 (handler-bind ((sb-int:bootstrap-package-not-found
381 heller 1.126 #'sb-int:debootstrap-package))
382     (funcall fun)))
383    
384 heller 1.124 (defmacro with-debootstrapping (&body body)
385 heller 1.126 `(call-with-debootstrapping (lambda () ,@body)))
386 heller 1.124
387     (defimplementation call-with-syntax-hooks (fn)
388 jsnellman 1.158 (cond ((and *debootstrap-packages*
389 heller 1.124 (sbcl-package-p *package*))
390     (with-debootstrapping (funcall fn)))
391     (t
392     (funcall fn))))
393    
394     (defimplementation default-readtable-alist ()
395     (let ((readtable (shebang-readtable)))
396     (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
397     collect (cons (package-name p) readtable))))
398    
399 dbarlow 1.1 ;;; Utilities
400    
401 nsiivola 1.307 (defun swank-value (name &optional errorp)
402     ;; Easy way to refer to symbol values in SWANK, which doesn't yet exist when
403     ;; this is file is loaded.
404     (let ((symbol (find-symbol (string name) :swank)))
405     (if (and symbol (or errorp (boundp symbol)))
406     (symbol-value symbol)
407     (when errorp
408     (error "~S does not exist in SWANK." name)))))
409    
410 sboukarev 1.263 #+#.(swank-backend:with-symbol 'function-lambda-list 'sb-introspect)
411 trittweiler 1.230 (defimplementation arglist (fname)
412     (sb-introspect:function-lambda-list fname))
413    
414 sboukarev 1.263 #-#.(swank-backend:with-symbol 'function-lambda-list 'sb-introspect)
415 heller 1.160 (defimplementation arglist (fname)
416 heller 1.74 (sb-introspect:function-arglist fname))
417 mbaringer 1.100
418 heller 1.160 (defimplementation function-name (f)
419     (check-type f function)
420 mbaringer 1.100 (sb-impl::%fun-name f))
421 dbarlow 1.1
422 trittweiler 1.179 (defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
423     (flet ((ensure-list (thing) (if (listp thing) thing (list thing))))
424     (let* ((flags (sb-cltl2:declaration-information decl-identifier)))
425     (if flags
426 heller 1.306 ;; Symbols aren't printed with package qualifiers, but the
427     ;; FLAGS would have to be fully qualified when used inside a
428     ;; declaration. So we strip those as long as there's no
429     ;; better way. (FIXME)
430     `(&any ,@(remove-if-not
431     #'(lambda (qualifier)
432     (find-symbol (symbol-name (first qualifier)) :cl))
433     flags :key #'ensure-list))
434 trittweiler 1.179 (call-next-method)))))
435    
436 sboukarev 1.263 #+#.(swank-backend:with-symbol 'deftype-lambda-list 'sb-introspect)
437 trittweiler 1.229 (defmethod type-specifier-arglist :around (typespec-operator)
438     (multiple-value-bind (arglist foundp)
439     (sb-introspect:deftype-lambda-list typespec-operator)
440     (if foundp arglist (call-next-method))))
441    
442 trittweiler 1.246
443 dbarlow 1.42 (defvar *buffer-name* nil)
444 nsiivola 1.282 (defvar *buffer-tmpfile* nil)
445 dbarlow 1.1 (defvar *buffer-offset*)
446 heller 1.70 (defvar *buffer-substring* nil)
447 dbarlow 1.1
448 lgorrie 1.24 (defvar *previous-compiler-condition* nil
449     "Used to detect duplicates.")
450    
451 dbarlow 1.1 (defun handle-notification-condition (condition)
452     "Handle a condition caused by a compiler warning.
453     This traps all compiler conditions at a lower-level than using
454     C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
455     craft our own error messages, which can omit a lot of redundant
456     information."
457 nsiivola 1.206 (unless (or (eq condition *previous-compiler-condition*))
458     ;; First resignal warnings, so that outer handlers -- which may choose to
459     ;; muffle this -- get a chance to run.
460     (when (typep condition 'warning)
461     (signal condition))
462     (setq *previous-compiler-condition* condition)
463 trittweiler 1.260 (signal-compiler-condition (real-condition condition)
464     (sb-c::find-error-context nil))))
465 lgorrie 1.24
466     (defun signal-compiler-condition (condition context)
467     (signal (make-condition
468     'compiler-condition
469     :original-condition condition
470     :severity (etypecase condition
471 trittweiler 1.264 (sb-ext:compiler-note :note)
472 lgorrie 1.24 (sb-c:compiler-error :error)
473 trittweiler 1.264 (reader-error :read-error)
474 trittweiler 1.260 (error :error)
475 heller 1.306 #+#.(swank-backend:with-symbol redefinition-warning
476     sb-kernel)
477 trittweiler 1.246 (sb-kernel:redefinition-warning
478     :redefinition)
479 lgorrie 1.24 (style-warning :style-warning)
480 trittweiler 1.260 (warning :warning))
481     :references (condition-references condition)
482 heller 1.248 :message (brief-compiler-message-for-emacs condition)
483     :source-context (compiler-error-context context)
484 trittweiler 1.235 :location (compiler-note-location condition context))))
485 heller 1.107
486     (defun real-condition (condition)
487     "Return the encapsulated condition or CONDITION itself."
488     (typecase condition
489     (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
490     (t condition)))
491 lgorrie 1.24
492 heller 1.184 (defun condition-references (condition)
493     (if (typep condition 'sb-int:reference-condition)
494     (externalize-reference
495     (sb-int:reference-condition-references condition))))
496    
497 trittweiler 1.235 (defun compiler-note-location (condition context)
498     (flet ((bailout ()
499 trittweiler 1.266 (return-from compiler-note-location
500     (make-error-location "No error location available"))))
501 trittweiler 1.235 (cond (context
502     (locate-compiler-note
503     (sb-c::compiler-error-context-file-name context)
504     (compiler-source-path context)
505     (sb-c::compiler-error-context-original-source context)))
506     ((typep condition 'reader-error)
507 trittweiler 1.236 (let* ((stream (stream-error-stream condition))
508     (file (pathname stream)))
509     (unless (open-stream-p stream)
510     (bailout))
511     (if (compiling-from-buffer-p file)
512 heller 1.306 ;; The stream position for e.g. "comma not inside
513     ;; backquote" is at the character following the
514     ;; comma, :offset is 0-based, hence the 1-.
515 trittweiler 1.236 (make-location (list :buffer *buffer-name*)
516     (list :offset *buffer-offset*
517 trittweiler 1.237 (1- (file-position stream))))
518 trittweiler 1.236 (progn
519     (assert (compiling-from-file-p file))
520 trittweiler 1.237 ;; No 1- because :position is 1-based.
521 trittweiler 1.236 (make-location (list :file (namestring file))
522     (list :position (file-position stream)))))))
523 trittweiler 1.235 (t (bailout)))))
524 heller 1.124
525 trittweiler 1.236 (defun compiling-from-buffer-p (filename)
526 trittweiler 1.266 (and *buffer-name*
527     ;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P
528 nsiivola 1.282 ;; in LOCATE-COMPILER-NOTE, and allows handling nested
529     ;; compilation from eg. hitting C-C on (eval-when ... (require ..))).
530 nsiivola 1.284 ;;
531     ;; PROBE-FILE to handle tempfile directory being a symlink.
532 nsiivola 1.282 (pathnamep filename)
533 nsiivola 1.284 (let ((true1 (probe-file filename))
534     (true2 (probe-file *buffer-tmpfile*)))
535     (and true1 (equal true1 true2)))))
536 trittweiler 1.236
537     (defun compiling-from-file-p (filename)
538 nsiivola 1.282 (and (pathnamep filename)
539     (or (null *buffer-name*)
540 nsiivola 1.284 (null *buffer-tmpfile*)
541     (let ((true1 (probe-file filename))
542     (true2 (probe-file *buffer-tmpfile*)))
543     (not (and true1 (equal true1 true2)))))))
544 trittweiler 1.236
545     (defun compiling-from-generated-code-p (filename source)
546     (and (eq filename :lisp) (stringp source)))
547    
548 heller 1.127 (defun locate-compiler-note (file source-path source)
549 trittweiler 1.236 (cond ((compiling-from-buffer-p file)
550 heller 1.219 (make-location (list :buffer *buffer-name*)
551     (list :offset *buffer-offset*
552     (source-path-string-position
553     source-path *buffer-substring*))))
554 trittweiler 1.236 ((compiling-from-file-p file)
555 heller 1.124 (make-location (list :file (namestring file))
556 heller 1.219 (list :position (1+ (source-path-file-position
557     source-path file)))))
558 trittweiler 1.236 ((compiling-from-generated-code-p file source)
559 heller 1.127 (make-location (list :source-form source)
560     (list :position 1)))
561 dbarlow 1.42 (t
562 heller 1.306 (error "unhandled case in compiler note ~S ~S ~S"
563     file source-path source))))
564 dbarlow 1.42
565 heller 1.66 (defun brief-compiler-message-for-emacs (condition)
566 dbarlow 1.1 "Briefly describe a compiler error for Emacs.
567     When Emacs presents the message it already has the source popped up
568     and the source form highlighted. This makes much of the information in
569     the error-context redundant."
570 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
571     (princ-to-string condition)))
572 heller 1.66
573 heller 1.248 (defun compiler-error-context (error-context)
574 heller 1.66 "Describe a compiler error for Emacs including context information."
575 heller 1.45 (declare (type (or sb-c::compiler-error-context null) error-context))
576 heller 1.66 (multiple-value-bind (enclosing source)
577     (if error-context
578     (values (sb-c::compiler-error-context-enclosing-source error-context)
579     (sb-c::compiler-error-context-source error-context)))
580 heller 1.248 (and (or enclosing source)
581     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]"
582     enclosing source))))
583 dbarlow 1.1
584 heller 1.124 (defun compiler-source-path (context)
585 dbarlow 1.1 "Return the source-path for the current compiler error.
586     Returns NIL if this cannot be determined by examining internal
587     compiler state."
588     (cond ((sb-c::node-p context)
589     (reverse
590     (sb-c::source-path-original-source
591     (sb-c::node-source-path context))))
592     ((sb-c::compiler-error-context-p context)
593     (reverse
594     (sb-c::compiler-error-context-original-source-path context)))))
595    
596 lgorrie 1.54 (defimplementation call-with-compilation-hooks (function)
597 heller 1.58 (declare (type function function))
598 trittweiler 1.238 (handler-bind
599     ;; N.B. Even though these handlers are called HANDLE-FOO they
600     ;; actually decline, i.e. the signalling of the original
601     ;; condition continues upward.
602 trittweiler 1.260 ((sb-c:fatal-compiler-error #'handle-notification-condition)
603     (sb-c:compiler-error #'handle-notification-condition)
604     (sb-ext:compiler-note #'handle-notification-condition)
605     (error #'handle-notification-condition)
606     (warning #'handle-notification-condition))
607 dbarlow 1.41 (funcall function)))
608 lgorrie 1.24
609 lgorrie 1.96
610 nsiivola 1.280 (defvar *trap-load-time-warnings* t)
611 heller 1.91
612 sboukarev 1.268 (defun compiler-policy (qualities)
613     "Return compiler policy qualities present in the QUALITIES alist.
614     QUALITIES is an alist with (quality . value)"
615     #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
616     (loop with policy = (sb-ext:restrict-compiler-policy)
617     for (quality) in qualities
618     collect (cons quality
619     (or (cdr (assoc quality policy))
620     0))))
621    
622     (defun (setf compiler-policy) (policy)
623     (declare (ignorable policy))
624     #+#.(swank-backend:with-symbol 'restrict-compiler-policy 'sb-ext)
625     (loop for (qual . value) in policy
626     do (sb-ext:restrict-compiler-policy qual value)))
627    
628     (defmacro with-compiler-policy (policy &body body)
629     (let ((current-policy (gensym)))
630     `(let ((,current-policy (compiler-policy ,policy)))
631     (setf (compiler-policy) ,policy)
632     (unwind-protect (progn ,@body)
633     (setf (compiler-policy) ,current-policy)))))
634    
635 heller 1.232 (defimplementation swank-compile-file (input-file output-file
636 sboukarev 1.268 load-p external-format
637     &key policy)
638 trittweiler 1.264 (multiple-value-bind (output-file warnings-p failure-p)
639 sboukarev 1.268 (with-compiler-policy policy
640     (with-compilation-hooks ()
641     (compile-file input-file :output-file output-file
642     :external-format external-format)))
643 trittweiler 1.264 (values output-file warnings-p
644     (or failure-p
645     (when load-p
646     ;; Cache the latest source file for definition-finding.
647     (source-cache-get input-file
648     (file-write-date input-file))
649     (not (load output-file)))))))
650 lgorrie 1.24
651 heller 1.124 ;;;; compile-string
652    
653 heller 1.156 ;;; We copy the string to a temporary file in order to get adequate
654     ;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
655     ;;; which the previous approach using
656     ;;; (compile nil `(lambda () ,(read-from-string string)))
657     ;;; did not provide.
658    
659 heller 1.245 (locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
660    
661 heller 1.242 (sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam)
662     sb-alien:c-string
663     (dir sb-alien:c-string)
664     (prefix sb-alien:c-string))
665 heller 1.156
666 heller 1.245 )
667    
668 heller 1.156 (defun temp-file-name ()
669     "Return a temporary file name to compile strings into."
670 heller 1.242 (tempnam nil nil))
671 heller 1.156
672 heller 1.231 (defimplementation swank-compile-string (string &key buffer position filename
673     policy)
674 heller 1.156 (let ((*buffer-name* buffer)
675     (*buffer-offset* position)
676     (*buffer-substring* string)
677 nsiivola 1.282 (*buffer-tmpfile* (temp-file-name)))
678 trittweiler 1.200 (flet ((load-it (filename)
679     (when filename (load filename)))
680     (compile-it (cont)
681 heller 1.139 (with-compilation-hooks ()
682 heller 1.156 (with-compilation-unit
683     (:source-plist (list :emacs-buffer buffer
684 heller 1.231 :emacs-filename filename
685 heller 1.156 :emacs-string string
686 nsiivola 1.280 :emacs-position position)
687     :source-namestring filename
688     :allow-other-keys t)
689 trittweiler 1.249 (multiple-value-bind (output-file warningsp failurep)
690 heller 1.303 (compile-file *buffer-tmpfile* :external-format :utf-8)
691 sboukarev 1.251 (declare (ignore warningsp))
692 trittweiler 1.249 (unless failurep
693     (funcall cont output-file)))))))
694 heller 1.303 (with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error
695     :external-format :utf-8)
696 heller 1.156 (write-string string s))
697     (unwind-protect
698 sboukarev 1.268 (with-compiler-policy policy
699     (if *trap-load-time-warnings*
700     (compile-it #'load-it)
701     (load-it (compile-it #'identity))))
702 heller 1.156 (ignore-errors
703 nsiivola 1.282 (delete-file *buffer-tmpfile*)
704     (delete-file (compile-file-pathname *buffer-tmpfile*)))))))
705 dbarlow 1.1
706     ;;;; Definitions
707    
708 jsnellman 1.149 (defparameter *definition-types*
709     '(:variable defvar
710     :constant defconstant
711     :type deftype
712     :symbol-macro define-symbol-macro
713     :macro defmacro
714     :compiler-macro define-compiler-macro
715     :function defun
716     :generic-function defgeneric
717     :method defmethod
718     :setf-expander define-setf-expander
719     :structure defstruct
720 jsnellman 1.159 :condition define-condition
721 jsnellman 1.149 :class defclass
722     :method-combination define-method-combination
723     :package defpackage
724     :transform :deftransform
725     :optimizer :defoptimizer
726     :vop :define-vop
727     :source-transform :define-source-transform)
728     "Map SB-INTROSPECT definition type names to Slime-friendly forms")
729    
730 trittweiler 1.234 (defun definition-specifier (type name)
731     "Return a pretty specifier for NAME representing a definition of type TYPE."
732     (if (and (symbolp name)
733     (eq type :function)
734     (sb-int:info :function :ir1-convert name))
735     :def-ir1-translator
736     (getf *definition-types* type)))
737    
738 trittweiler 1.258 (defun make-dspec (type name source-location)
739 nsiivola 1.276 (let ((spec (definition-specifier type name))
740     (desc (sb-introspect::definition-source-description source-location)))
741     (if (eq :define-vop spec)
742     ;; The first part of the VOP description is the name of the template
743     ;; -- which is actually good information and often long. So elide the
744     ;; original name in favor of making the interesting bit more visible.
745     ;;
746 heller 1.306 ;; The second part of the VOP description is the associated
747     ;; compiler note, or NIL -- which is quite uninteresting and
748     ;; confuses the eye when reading the actual name which usually
749     ;; has a worthwhile postfix. So drop the note.
750 nsiivola 1.276 (list spec (car desc))
751     (list* spec name desc))))
752 trittweiler 1.234
753 jsnellman 1.149 (defimplementation find-definitions (name)
754     (loop for type in *definition-types* by #'cddr
755 trittweiler 1.261 for defsrcs = (sb-introspect:find-definition-sources-by-name name type)
756     append (loop for defsrc in defsrcs collect
757     (list (make-dspec type name defsrc)
758 trittweiler 1.267 (converting-errors-to-error-location
759 heller 1.306 (definition-source-for-emacs defsrc
760     type name))))))
761 jsnellman 1.149
762 trittweiler 1.193 (defimplementation find-source-location (obj)
763     (flet ((general-type-of (obj)
764     (typecase obj
765     (method :method)
766     (generic-function :generic-function)
767     (function :function)
768     (structure-class :structure-class)
769     (class :class)
770     (method-combination :method-combination)
771 trittweiler 1.200 (package :package)
772 trittweiler 1.261 (condition :condition)
773 trittweiler 1.193 (structure-object :structure-object)
774     (standard-object :standard-object)
775     (t :thing)))
776     (to-string (obj)
777     (typecase obj
778 heller 1.306 ;; Packages are possibly named entities.
779     (package (princ-to-string obj))
780 trittweiler 1.193 ((or structure-object standard-object condition)
781     (with-output-to-string (s)
782     (print-unreadable-object (obj s :type t :identity t))))
783 trittweiler 1.200 (t (princ-to-string obj)))))
784 trittweiler 1.267 (converting-errors-to-error-location
785 trittweiler 1.261 (let ((defsrc (sb-introspect:find-definition-source obj)))
786     (definition-source-for-emacs defsrc
787     (general-type-of obj)
788     (to-string obj))))))
789 jsnellman 1.149
790 trittweiler 1.234
791 trittweiler 1.261 (defun categorize-definition-source (definition-source)
792 sboukarev 1.310 (with-struct ("sb-introspect:definition-source-"
793     pathname form-path character-offset plist)
794     definition-source
795 trittweiler 1.262 (cond ((getf plist :emacs-buffer) :buffer)
796 sboukarev 1.310 ((and pathname (or form-path character-offset)
797     (probe-file pathname)) :file)
798 sboukarev 1.269 (pathname :file-without-position)
799 trittweiler 1.262 (t :invalid))))
800 trittweiler 1.261
801 sboukarev 1.310 (defun definition-source-buffer-location (definition-source)
802     (with-struct ("sb-introspect:definition-source-"
803     form-path character-offset plist)
804     definition-source
805     (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
806     emacs-string &allow-other-keys)
807     plist
808     (let ((*readtable* (guess-readtable-for-filename emacs-directory)))
809     (multiple-value-bind (start end)
810     (if form-path
811     (with-debootstrapping
812     (source-path-string-position form-path
813     emacs-string))
814     (values character-offset
815     most-positive-fixnum))
816     (make-location
817     `(:buffer ,emacs-buffer)
818     `(:offset ,emacs-position ,start)
819     `(:snippet
820     ,(subseq emacs-string
821     start
822     (min end (+ start *source-snippet-size*))))))))))
823    
824     (defun definition-source-file-location (definition-source)
825     (with-struct ("sb-introspect:definition-source-"
826     pathname form-path character-offset plist
827     file-write-date) definition-source
828     (let* ((namestring (namestring (translate-logical-pathname pathname)))
829     (pos (if form-path
830     (source-file-position namestring file-write-date
831     form-path)
832     character-offset))
833     (snippet (source-hint-snippet namestring file-write-date pos)))
834     (make-location `(:file ,namestring)
835     ;; /file positions/ in Common Lisp start from
836     ;; 0, buffer positions in Emacs start from 1.
837     `(:position ,(1+ pos))
838     `(:snippet ,snippet)))))
839    
840 trittweiler 1.261 (defun definition-source-for-emacs (definition-source type name)
841 sboukarev 1.310 (with-struct ("sb-introspect:definition-source-"
842     pathname form-path character-offset plist
843     file-write-date)
844     definition-source
845 trittweiler 1.261 (ecase (categorize-definition-source definition-source)
846     (:buffer
847 sboukarev 1.310 (definition-source-buffer-location definition-source))
848 trittweiler 1.261 (:file
849 sboukarev 1.310 (definition-source-file-location definition-source))
850 sboukarev 1.269 (:file-without-position
851 heller 1.306 (make-location `(:file ,(namestring
852     (translate-logical-pathname pathname)))
853 sboukarev 1.269 '(:position 1)
854     (when (eql type :function)
855 heller 1.306 `(:snippet ,(format nil "(defun ~a "
856     (symbol-name name))))))
857 trittweiler 1.261 (:invalid
858 sboukarev 1.310 (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~
859 trittweiler 1.261 meaningful information."
860 sboukarev 1.310 type name)))))
861 jsnellman 1.149
862 trittweiler 1.261 (defun source-file-position (filename write-date form-path)
863 jsnellman 1.172 (let ((source (get-source-code filename write-date))
864     (*readtable* (guess-readtable-for-filename filename)))
865 trittweiler 1.192 (with-debootstrapping
866 trittweiler 1.261 (source-path-string-position form-path source))))
867 jsnellman 1.172
868 jsnellman 1.149 (defun source-hint-snippet (filename write-date position)
869 trittweiler 1.241 (read-snippet-from-string (get-source-code filename write-date) position))
870 jsnellman 1.149
871 jsnellman 1.151 (defun function-source-location (function &optional name)
872     (declare (type function function))
873 trittweiler 1.261 (definition-source-for-emacs (sb-introspect:find-definition-source function)
874     :function
875     (or name (function-name function))))
876 jsnellman 1.151
877 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
878 dbarlow 1.1 "Return a plist describing SYMBOL.
879     Return NIL if the symbol is unbound."
880     (let ((result '()))
881 heller 1.133 (flet ((doc (kind)
882     (or (documentation symbol kind) :not-documented))
883     (maybe-push (property value)
884     (when value
885     (setf result (list* property value result)))))
886 dbarlow 1.1 (maybe-push
887     :variable (multiple-value-bind (kind recorded-p)
888     (sb-int:info :variable :kind symbol)
889     (declare (ignore kind))
890     (if (or (boundp symbol) recorded-p)
891     (doc 'variable))))
892 heller 1.133 (when (fboundp symbol)
893     (maybe-push
894     (cond ((macro-function symbol) :macro)
895     ((special-operator-p symbol) :special-operator)
896     ((typep (fdefinition symbol) 'generic-function)
897     :generic-function)
898     (t :function))
899     (doc 'function)))
900 dbarlow 1.1 (maybe-push
901     :setf (if (or (sb-int:info :setf :inverse symbol)
902     (sb-int:info :setf :expander symbol))
903     (doc 'setf)))
904     (maybe-push
905     :type (if (sb-int:info :type :kind symbol)
906     (doc 'type)))
907 lgorrie 1.24 result)))
908 dbarlow 1.1
909 heller 1.74 (defimplementation describe-definition (symbol type)
910 lgorrie 1.54 (case type
911     (:variable
912 heller 1.74 (describe symbol))
913     (:function
914     (describe (symbol-function symbol)))
915 lgorrie 1.54 (:setf
916 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
917     (sb-int:info :setf :expander symbol))))
918 lgorrie 1.54 (:class
919 heller 1.74 (describe (find-class symbol)))
920 lgorrie 1.54 (:type
921 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
922 jsnellman 1.172
923     #+#.(swank-backend::sbcl-with-xref-p)
924     (progn
925 trittweiler 1.255 (defmacro defxref (name &optional fn-name)
926 jsnellman 1.172 `(defimplementation ,name (what)
927     (sanitize-xrefs
928     (mapcar #'source-location-for-xref-data
929 trittweiler 1.255 (,(find-symbol (symbol-name (if fn-name
930     fn-name
931     name))
932     "SB-INTROSPECT")
933 jsnellman 1.172 what)))))
934     (defxref who-calls)
935     (defxref who-binds)
936     (defxref who-sets)
937     (defxref who-references)
938 trittweiler 1.222 (defxref who-macroexpands)
939 sboukarev 1.263 #+#.(swank-backend:with-symbol 'who-specializes-directly 'sb-introspect)
940 trittweiler 1.255 (defxref who-specializes who-specializes-directly))
941 jsnellman 1.172
942     (defun source-location-for-xref-data (xref-data)
943 trittweiler 1.261 (destructuring-bind (name . defsrc) xref-data
944 trittweiler 1.267 (list name (converting-errors-to-error-location
945 trittweiler 1.261 (definition-source-for-emacs defsrc 'function name)))))
946 dbarlow 1.1
947 heller 1.97 (defimplementation list-callers (symbol)
948     (let ((fn (fdefinition symbol)))
949 heller 1.168 (sanitize-xrefs
950     (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
951 heller 1.97
952     (defimplementation list-callees (symbol)
953     (let ((fn (fdefinition symbol)))
954 heller 1.168 (sanitize-xrefs
955     (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
956 heller 1.97
957 jsnellman 1.172 (defun sanitize-xrefs (xrefs)
958 heller 1.168 (remove-duplicates
959     (remove-if (lambda (f)
960     (member f (ignored-xref-function-names)))
961 jsnellman 1.172 (loop for entry in xrefs
962     for name = (car entry)
963     collect (if (and (consp name)
964     (member (car name)
965     '(sb-pcl::fast-method
966     sb-pcl::slow-method
967     sb-pcl::method)))
968     (cons (cons 'defmethod (cdr name))
969     (cdr entry))
970     entry))
971 heller 1.168 :key #'car)
972     :test (lambda (a b)
973     (and (eq (first a) (first b))
974     (equal (second a) (second b))))))
975    
976     (defun ignored-xref-function-names ()
977     #-#.(swank-backend::sbcl-with-new-stepper-p)
978     '(nil sb-c::step-form sb-c::step-values)
979     #+#.(swank-backend::sbcl-with-new-stepper-p)
980     '(nil))
981 jsnellman 1.166
982 lgorrie 1.122 (defun function-dspec (fn)
983     "Describe where the function FN was defined.
984     Return a list of the form (NAME LOCATION)."
985 trittweiler 1.261 (let ((name (function-name fn)))
986 trittweiler 1.267 (list name (converting-errors-to-error-location
987 trittweiler 1.258 (function-source-location fn name)))))
988 lgorrie 1.122
989 dbarlow 1.4 ;;; macroexpansion
990 dbarlow 1.1
991 lgorrie 1.54 (defimplementation macroexpand-all (form)
992 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
993     (sb-walker:walk-form form)))
994 lgorrie 1.25
995 dbarlow 1.1
996     ;;; Debugging
997    
998 trittweiler 1.257 ;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger
999     ;;; than just a hook into BREAK. In particular, it'll make
1000     ;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather
1001     ;;; than the native debugger. That should probably be considered a
1002     ;;; feature.
1003 dbarlow 1.1
1004 trittweiler 1.194 (defun make-invoke-debugger-hook (hook)
1005 trittweiler 1.259 (when hook
1006     #'(sb-int:named-lambda swank-invoke-debugger-hook
1007     (condition old-hook)
1008     (if *debugger-hook*
1009     nil ; decline, *DEBUGGER-HOOK* will be tried next.
1010     (funcall hook condition old-hook)))))
1011 trittweiler 1.194
1012 trittweiler 1.257 (defun set-break-hook (hook)
1013     (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1014    
1015     (defun call-with-break-hook (hook continuation)
1016     (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1017     (funcall continuation)))
1018    
1019 heller 1.148 (defimplementation install-debugger-globally (function)
1020 trittweiler 1.194 (setq *debugger-hook* function)
1021 trittweiler 1.257 (set-break-hook function))
1022 heller 1.148
1023 jsnellman 1.162 (defimplementation condition-extras (condition)
1024 heller 1.183 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
1025     ((typep condition 'sb-impl::step-form-condition)
1026     `((:show-frame-source 0)))
1027     ((typep condition 'sb-int:reference-condition)
1028     (let ((refs (sb-int:reference-condition-references condition)))
1029     (if refs
1030     `((:references ,(externalize-reference refs))))))))
1031    
1032     (defun externalize-reference (ref)
1033     (etypecase ref
1034     (null nil)
1035     (cons (cons (externalize-reference (car ref))
1036     (externalize-reference (cdr ref))))
1037     ((or string number) ref)
1038     (symbol
1039     (cond ((eq (symbol-package ref) (symbol-package :test))
1040     ref)
1041     (t (symbol-name ref))))))
1042 jsnellman 1.162
1043 trittweiler 1.257 (defvar *sldb-stack-top*)
1044    
1045 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
1046 heller 1.58 (declare (type function debugger-loop-fn))
1047 trittweiler 1.258 (let* ((*sldb-stack-top* (if *debug-swank-backend*
1048     (sb-di:top-frame)
1049 heller 1.306 (or sb-debug:*stack-top-hint*
1050     (sb-di:top-frame))))
1051 trittweiler 1.199 (sb-debug:*stack-top-hint* nil))
1052 jsnellman 1.158 (handler-bind ((sb-di:debug-condition
1053 dbarlow 1.1 (lambda (condition)
1054 lgorrie 1.25 (signal (make-condition
1055     'sldb-condition
1056     :original-condition condition)))))
1057     (funcall debugger-loop-fn))))
1058 dbarlow 1.1
1059 jsnellman 1.162 #+#.(swank-backend::sbcl-with-new-stepper-p)
1060     (progn
1061     (defimplementation activate-stepping (frame)
1062     (declare (ignore frame))
1063     (sb-impl::enable-stepping))
1064     (defimplementation sldb-stepper-condition-p (condition)
1065     (typep condition 'sb-ext:step-form-condition))
1066     (defimplementation sldb-step-into ()
1067     (invoke-restart 'sb-ext:step-into))
1068     (defimplementation sldb-step-next ()
1069     (invoke-restart 'sb-ext:step-next))
1070     (defimplementation sldb-step-out ()
1071     (invoke-restart 'sb-ext:step-out)))
1072    
1073 heller 1.118 (defimplementation call-with-debugger-hook (hook fun)
1074 trittweiler 1.259 (let ((*debugger-hook* hook)
1075     #+#.(swank-backend::sbcl-with-new-stepper-p)
1076 jsnellman 1.162 (sb-ext:*stepper-hook*
1077     (lambda (condition)
1078 jsnellman 1.164 (typecase condition
1079     (sb-ext:step-form-condition
1080     (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
1081     (sb-impl::invoke-debugger condition)))))))
1082     (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
1083     (sb-ext:step-condition #'sb-impl::invoke-stepper))
1084 trittweiler 1.257 (call-with-break-hook hook fun))))
1085 heller 1.118
1086 dbarlow 1.1 (defun nth-frame (index)
1087     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
1088     (i index (1- i)))
1089     ((zerop i) frame)))
1090    
1091 heller 1.74 (defimplementation compute-backtrace (start end)
1092 dbarlow 1.1 "Return a list of frames starting with frame number START and
1093     continuing to frame number END or, if END is nil, the last frame on the
1094     stack."
1095     (let ((end (or end most-positive-fixnum)))
1096 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
1097     for i from start below end
1098 heller 1.225 while f collect f)))
1099 trittweiler 1.218
1100 heller 1.225 (defimplementation print-frame (frame stream)
1101     (sb-debug::print-frame-call frame stream))
1102 trittweiler 1.218
1103 heller 1.225 (defimplementation frame-restartable-p (frame)
1104 trittweiler 1.218 #+#.(swank-backend::sbcl-with-restart-frame)
1105 heller 1.225 (not (null (sb-debug:frame-has-debug-tag-p frame))))
1106 dbarlow 1.1
1107 sboukarev 1.265 (defimplementation frame-call (frame-number)
1108     (multiple-value-bind (name args)
1109     (sb-debug::frame-call (nth-frame frame-number))
1110     (with-output-to-string (stream)
1111     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
1112     (let ((*print-length* nil)
1113     (*print-level* nil))
1114     (prin1 (sb-debug::ensure-printable-object name) stream))
1115     (let ((args (sb-debug::ensure-printable-object args)))
1116     (if (listp args)
1117     (format stream "~{ ~_~S~}" args)
1118     (format stream " ~S" args)))))))
1119    
1120 heller 1.124 ;;;; Code-location -> source-location translation
1121    
1122 heller 1.129 ;;; If debug-block info is avaibale, we determine the file position of
1123     ;;; the source-path for a code-location. If the code was compiled
1124     ;;; with C-c C-c, we have to search the position in the source string.
1125     ;;; If there's no debug-block info, we return the (less precise)
1126     ;;; source-location of the corresponding function.
1127    
1128 nsiivola 1.134 (defun code-location-source-location (code-location)
1129     (let* ((dsource (sb-di:code-location-debug-source code-location))
1130     (plist (sb-c::debug-source-plist dsource)))
1131     (if (getf plist :emacs-buffer)
1132     (emacs-buffer-source-location code-location plist)
1133 sboukarev 1.263 #+#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1134 nsiivola 1.134 (ecase (sb-di:debug-source-from dsource)
1135     (:file (file-source-location code-location))
1136 trittweiler 1.197 (:lisp (lisp-source-location code-location)))
1137 sboukarev 1.263 #-#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1138 trittweiler 1.197 (if (sb-di:debug-source-namestring dsource)
1139     (file-source-location code-location)
1140     (lisp-source-location code-location)))))
1141 nsiivola 1.134
1142     ;;; FIXME: The naming policy of source-location functions is a bit
1143     ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
1144     ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
1145     ;;; which returns the source location for a _code-location_.
1146 jsnellman 1.158 ;;;
1147 nsiivola 1.134 ;;; Maybe these should be named code-location-file-source-location,
1148 heller 1.139 ;;; etc, turned into generic functions, or something. In the very
1149     ;;; least the names should indicate the main entry point vs. helper
1150     ;;; status.
1151 heller 1.124
1152 nsiivola 1.134 (defun file-source-location (code-location)
1153     (if (code-location-has-debug-block-info-p code-location)
1154     (source-file-source-location code-location)
1155     (fallback-source-location code-location)))
1156    
1157     (defun fallback-source-location (code-location)
1158     (let ((fun (code-location-debug-fun-fun code-location)))
1159     (cond (fun (function-source-location fun))
1160 heller 1.182 (t (error "Cannot find source location for: ~A " code-location)))))
1161 nsiivola 1.134
1162 heller 1.124 (defun lisp-source-location (code-location)
1163 jsnellman 1.158 (let ((source (prin1-to-string
1164 nsiivola 1.305 (sb-debug::code-location-source-form code-location 100)))
1165 nsiivola 1.307 (condition (swank-value '*swank-debugger-condition*)))
1166 nsiivola 1.309 (if (and (typep condition 'sb-impl::step-form-condition)
1167     (search "SB-IMPL::WITH-STEPPING-ENABLED" source
1168 nsiivola 1.307 :test #'char-equal)
1169     (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal))
1170 heller 1.306 ;; The initial form is utterly uninteresting -- and almost
1171     ;; certainly right there in the REPL.
1172 nsiivola 1.304 (make-error-location "Stepping...")
1173     (make-location `(:source-form ,source) '(:position 1)))))
1174 heller 1.124
1175 nsiivola 1.134 (defun emacs-buffer-source-location (code-location plist)
1176     (if (code-location-has-debug-block-info-p code-location)
1177 nsiivola 1.177 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
1178     &allow-other-keys)
1179     plist
1180 nsiivola 1.134 (let* ((pos (string-source-position code-location emacs-string))
1181 trittweiler 1.241 (snipped (read-snippet-from-string emacs-string pos)))
1182 jsnellman 1.158 (make-location `(:buffer ,emacs-buffer)
1183 heller 1.219 `(:offset ,emacs-position ,pos)
1184 nsiivola 1.134 `(:snippet ,snipped))))
1185     (fallback-source-location code-location)))
1186    
1187 heller 1.124 (defun source-file-source-location (code-location)
1188     (let* ((code-date (code-location-debug-source-created code-location))
1189     (filename (code-location-debug-source-name code-location))
1190 jsnellman 1.186 (*readtable* (guess-readtable-for-filename filename))
1191 heller 1.126 (source-code (get-source-code filename code-date)))
1192 jsnellman 1.186 (with-debootstrapping
1193     (with-input-from-string (s source-code)
1194     (let* ((pos (stream-source-position code-location s))
1195     (snippet (read-snippet s pos)))
1196     (make-location `(:file ,filename)
1197 heller 1.219 `(:position ,pos)
1198 jsnellman 1.186 `(:snippet ,snippet)))))))
1199 heller 1.124
1200     (defun code-location-debug-source-name (code-location)
1201 sboukarev 1.263 (namestring (truename (#+#.(swank-backend:with-symbol
1202 trittweiler 1.197 'debug-source-name 'sb-di)
1203     sb-c::debug-source-name
1204 sboukarev 1.263 #-#.(swank-backend:with-symbol
1205 trittweiler 1.197 'debug-source-name 'sb-di)
1206     sb-c::debug-source-namestring
1207 jsnellman 1.186 (sb-di::code-location-debug-source code-location)))))
1208 heller 1.124
1209     (defun code-location-debug-source-created (code-location)
1210 jsnellman 1.158 (sb-c::debug-source-created
1211 heller 1.124 (sb-di::code-location-debug-source code-location)))
1212    
1213     (defun code-location-debug-fun-fun (code-location)
1214     (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
1215    
1216     (defun code-location-has-debug-block-info-p (code-location)
1217 jsnellman 1.158 (handler-case
1218 heller 1.124 (progn (sb-di:code-location-debug-block code-location)
1219     t)
1220     (sb-di:no-debug-blocks () nil)))
1221    
1222     (defun stream-source-position (code-location stream)
1223     (let* ((cloc (sb-debug::maybe-block-start-location code-location))
1224 heller 1.128 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
1225 heller 1.124 (form-number (sb-di::code-location-form-number cloc)))
1226     (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
1227     (let* ((path-table (sb-di::form-number-translations tlf 0))
1228 heller 1.128 (path (cond ((<= (length path-table) form-number)
1229 heller 1.129 (warn "inconsistent form-number-translations")
1230 heller 1.128 (list 0))
1231     (t
1232     (reverse (cdr (aref path-table form-number)))))))
1233     (source-path-source-position path tlf pos-map)))))
1234    
1235     (defun string-source-position (code-location string)
1236     (with-input-from-string (s string)
1237     (stream-source-position code-location s)))
1238 dbarlow 1.1
1239 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
1240 lgorrie 1.121
1241 heller 1.243 (defimplementation frame-source-location (index)
1242 trittweiler 1.267 (converting-errors-to-error-location
1243 trittweiler 1.258 (code-location-source-location
1244     (sb-di:frame-code-location (nth-frame index)))))
1245 dbarlow 1.1
1246 heller 1.92 (defun frame-debug-vars (frame)
1247     "Return a vector of debug-variables in frame."
1248     (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
1249    
1250     (defun debug-var-value (var frame location)
1251     (ecase (sb-di:debug-var-validity var location)
1252     (:valid (sb-di:debug-var-value var frame))
1253     ((:invalid :unknown) ':<not-available>)))
1254    
1255 nsiivola 1.285 (defun debug-var-info (var)
1256     ;; Introduced by SBCL 1.0.49.76.
1257     (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
1258     (when (and s (fboundp s))
1259     (funcall s var))))
1260    
1261 lgorrie 1.54 (defimplementation frame-locals (index)
1262 dbarlow 1.1 (let* ((frame (nth-frame index))
1263 heller 1.92 (loc (sb-di:frame-code-location frame))
1264 nsiivola 1.285 (vars (frame-debug-vars frame))
1265     ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE
1266     ;; specially.
1267     (more-name (or (find-symbol "MORE" :sb-debug) 'more))
1268     (more-context nil)
1269     (more-count nil)
1270     (more-id 0))
1271 sboukarev 1.256 (when vars
1272 nsiivola 1.285 (let ((locals
1273     (loop for v across vars
1274     do (when (eq (sb-di:debug-var-symbol v) more-name)
1275     (incf more-id))
1276     (case (debug-var-info v)
1277     (:more-context
1278     (setf more-context (debug-var-value v frame loc)))
1279     (:more-count
1280     (setf more-count (debug-var-value v frame loc))))
1281     collect
1282     (list :name (sb-di:debug-var-symbol v)
1283     :id (sb-di:debug-var-id v)
1284     :value (debug-var-value v frame loc)))))
1285     (when (and more-context more-count)
1286     (setf locals (append locals
1287     (list
1288     (list :name more-name
1289     :id more-id
1290     :value (multiple-value-list
1291 heller 1.306 (sb-c:%more-arg-values
1292     more-context
1293     0 more-count)))))))
1294 nsiivola 1.285 locals))))
1295 heller 1.92
1296     (defimplementation frame-var-value (frame var)
1297     (let* ((frame (nth-frame frame))
1298 nsiivola 1.285 (vars (frame-debug-vars frame))
1299     (loc (sb-di:frame-code-location frame))
1300     (dvar (if (= var (length vars))
1301 heller 1.306 ;; If VAR is out of bounds, it must be the fake var
1302     ;; we made up for &MORE.
1303     (let* ((context-var (find :more-context vars
1304     :key #'debug-var-info))
1305     (more-context (debug-var-value context-var frame
1306     loc))
1307     (count-var (find :more-count vars
1308     :key #'debug-var-info))
1309 nsiivola 1.285 (more-count (debug-var-value count-var frame loc)))
1310     (return-from frame-var-value
1311 heller 1.306 (multiple-value-list (sb-c:%more-arg-values
1312     more-context
1313     0 more-count))))
1314 nsiivola 1.285 (aref vars var))))
1315     (debug-var-value dvar frame loc)))
1316 dbarlow 1.1
1317 lgorrie 1.54 (defimplementation frame-catch-tags (index)
1318 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
1319 lgorrie 1.50
1320 heller 1.56 (defimplementation eval-in-frame (form index)
1321     (let ((frame (nth-frame index)))
1322 heller 1.58 (funcall (the function
1323 jsnellman 1.158 (sb-di:preprocess-for-eval form
1324 heller 1.58 (sb-di:frame-code-location frame)))
1325 heller 1.56 frame)))
1326    
1327 jsnellman 1.174 #+#.(swank-backend::sbcl-with-restart-frame)
1328     (progn
1329     (defimplementation return-from-frame (index form)
1330     (let* ((frame (nth-frame index)))
1331     (cond ((sb-debug:frame-has-debug-tag-p frame)
1332     (let ((values (multiple-value-list (eval-in-frame form index))))
1333     (sb-debug:unwind-to-frame-and-call frame
1334     (lambda ()
1335     (values-list values)))))
1336     (t (format nil "Cannot return from frame: ~S" frame)))))
1337 nsiivola 1.293
1338 jsnellman 1.174 (defimplementation restart-frame (index)
1339 nsiivola 1.293 (let ((frame (nth-frame index)))
1340     (when (sb-debug:frame-has-debug-tag-p frame)
1341     (multiple-value-bind (fname args) (sb-debug::frame-call frame)
1342     (multiple-value-bind (fun arglist)
1343     (if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
1344     (values (fdefinition fname) args)
1345     (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
1346     (sb-debug::frame-args-as-list frame)))
1347     (when (functionp fun)
1348 heller 1.306 (sb-debug:unwind-to-frame-and-call
1349     frame
1350     (lambda ()
1351     ;; Ensure TCO.
1352     (declare (optimize (debug 0)))
1353     (apply fun arglist)))))))
1354 nsiivola 1.293 (format nil "Cannot restart frame: ~S" frame))))
1355 heller 1.152
1356     ;; FIXME: this implementation doesn't unwind the stack before
1357     ;; re-invoking the function, but it's better than no implementation at
1358     ;; all.
1359 jsnellman 1.174 #-#.(swank-backend::sbcl-with-restart-frame)
1360     (progn
1361     (defun sb-debug-catch-tag-p (tag)
1362     (and (symbolp tag)
1363     (not (symbol-package tag))
1364     (string= tag :sb-debug-catch-tag)))
1365    
1366     (defimplementation return-from-frame (index form)
1367     (let* ((frame (nth-frame index))
1368     (probe (assoc-if #'sb-debug-catch-tag-p
1369     (sb-di::frame-catches frame))))
1370     (cond (probe (throw (car probe) (eval-in-frame form index)))
1371     (t (format nil "Cannot return from frame: ~S" frame)))))
1372    
1373     (defimplementation restart-frame (index)
1374     (let ((frame (nth-frame index)))
1375     (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1376 jsnellman 1.158
1377 lgorrie 1.87 ;;;;; reference-conditions
1378    
1379     (defimplementation format-sldb-condition (condition)
1380     (let ((sb-int:*print-condition-references* nil))
1381     (princ-to-string condition)))
1382    
1383 heller 1.57
1384     ;;;; Profiling
1385    
1386     (defimplementation profile (fname)
1387     (when fname (eval `(sb-profile:profile ,fname))))
1388    
1389     (defimplementation unprofile (fname)
1390     (when fname (eval `(sb-profile:unprofile ,fname))))
1391    
1392     (defimplementation unprofile-all ()
1393     (sb-profile:unprofile)
1394     "All functions unprofiled.")
1395    
1396     (defimplementation profile-report ()
1397     (sb-profile:report))
1398    
1399     (defimplementation profile-reset ()
1400     (sb-profile:reset)
1401     "Reset profiling counters.")
1402    
1403     (defimplementation profiled-functions ()
1404     (sb-profile:profile))
1405    
1406 heller 1.116 (defimplementation profile-package (package callers methods)
1407     (declare (ignore callers methods))
1408     (eval `(sb-profile:profile ,(package-name (find-package package)))))
1409    
1410 heller 1.57
1411 heller 1.64 ;;;; Inspector
1412 heller 1.63
1413 heller 1.190 (defmethod emacs-inspect ((o t))
1414 heller 1.64 (cond ((sb-di::indirect-value-cell-p o)
1415 heller 1.191 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1416 heller 1.64 (t
1417 heller 1.126 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1418 sboukarev 1.271 (list* (string-right-trim '(#\Newline) text)
1419     '(:newline)
1420 heller 1.191 (if label
1421     (loop for (l . v) in parts
1422     append (label-value-line l v))
1423 sboukarev 1.271 (loop for value in parts
1424     for i from 0
1425 heller 1.191 append (label-value-line i value))))))))
1426 heller 1.64
1427 heller 1.190 (defmethod emacs-inspect ((o function))
1428 heller 1.64 (let ((header (sb-kernel:widetag-of o)))
1429     (cond ((= header sb-vm:simple-fun-header-widetag)
1430 heller 1.126 (label-value-line*
1431     (:name (sb-kernel:%simple-fun-name o))
1432     (:arglist (sb-kernel:%simple-fun-arglist o))
1433     (:self (sb-kernel:%simple-fun-self o))
1434     (:next (sb-kernel:%simple-fun-next o))
1435     (:type (sb-kernel:%simple-fun-type o))
1436 heller 1.191 (:code (sb-kernel:fun-code-header o))))
1437 heller 1.64 ((= header sb-vm:closure-header-widetag)
1438 jsnellman 1.158 (append
1439 heller 1.126 (label-value-line :function (sb-kernel:%closure-fun o))
1440     `("Closed over values:" (:newline))
1441     (loop for i below (1- (sb-kernel:get-closure-length o))
1442 jsnellman 1.158 append (label-value-line
1443 heller 1.191 i (sb-kernel:%closure-index-ref o i)))))
1444 heller 1.64 (t (call-next-method o)))))
1445    
1446 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:code-component))
1447 jsnellman 1.158 (append
1448     (label-value-line*
1449 heller 1.113 (:code-size (sb-kernel:%code-code-size o))
1450     (:entry-points (sb-kernel:%code-entry-points o))
1451     (:debug-info (sb-kernel:%code-debug-info o))
1452 jsnellman 1.158 (:trace-table-offset (sb-kernel:code-header-ref
1453 heller 1.113 o sb-vm:code-trace-table-offset-slot)))
1454     `("Constants:" (:newline))
1455 jsnellman 1.158 (loop for i from sb-vm:code-constants-offset
1456 mbaringer 1.102 below (sb-kernel:get-header-data o)
1457 heller 1.113 append (label-value-line i (sb-kernel:code-header-ref o i)))
1458     `("Code:" (:newline)
1459     , (with-output-to-string (s)
1460     (cond ((sb-kernel:%code-debug-info o)
1461     (sb-disassem:disassemble-code-component o :stream s))
1462     (t
1463 jsnellman 1.158 (sb-disassem:disassemble-memory
1464     (sb-disassem::align
1465 heller 1.113 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1466     sb-vm:lowtag-mask)
1467 heller 1.126 (* sb-vm:code-constants-offset
1468     sb-vm:n-word-bytes))
1469 heller 1.113 (ash 1 sb-vm:n-lowtag-bits))
1470     (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1471 heller 1.191 :stream s)))))))
1472 mbaringer 1.102
1473 heller 1.190 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1474 mbaringer 1.167 (label-value-line*
1475 heller 1.191 (:value (sb-ext:weak-pointer-value o))))
1476 mbaringer 1.167
1477 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1478 heller 1.126 (label-value-line*
1479     (:name (sb-kernel:fdefn-name o))
1480 heller 1.191 (:function (sb-kernel:fdefn-fun o))))
1481 mbaringer 1.102
1482 heller 1.190 (defmethod emacs-inspect :around ((o generic-function))
1483 jsnellman 1.158 (append
1484 heller 1.191 (call-next-method)
1485 heller 1.126 (label-value-line*
1486     (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1487     (:initial-methods (sb-pcl::generic-function-initial-methods o))
1488 heller 1.191 )))
1489 heller 1.90
1490 heller 1.63
1491 lgorrie 1.50 ;;;; Multiprocessing
1492    
1493 crhodes 1.136 #+(and sb-thread
1494 sboukarev 1.271 #.(swank-backend:with-symbol "THREAD-NAME" "SB-THREAD"))
1495 crhodes 1.136 (progn
1496     (defvar *thread-id-counter* 0)
1497 jsnellman 1.158
1498 crhodes 1.136 (defvar *thread-id-counter-lock*
1499     (sb-thread:make-mutex :name "thread id counter lock"))
1500    
1501     (defun next-thread-id ()
1502     (sb-thread:with-mutex (*thread-id-counter-lock*)
1503     (incf *thread-id-counter*)))
1504 jsnellman 1.158
1505 crhodes 1.136 (defparameter *thread-id-map* (make-hash-table))
1506    
1507     ;; This should be a thread -> id map but as weak keys are not
1508     ;; supported it is id -> map instead.
1509     (defvar *thread-id-map-lock*
1510     (sb-thread:make-mutex :name "thread id map lock"))
1511 jsnellman 1.158
1512 crhodes 1.136 (defimplementation spawn (fn &key name)
1513     (sb-thread:make-thread fn :name name))
1514    
1515     (defimplementation thread-id (thread)
1516 heller 1.160 (block thread-id
1517     (sb-thread:with-mutex (*thread-id-map-lock*)
1518     (loop for id being the hash-key in *thread-id-map*
1519     using (hash-value thread-pointer)
1520     do
1521     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1522     (cond ((null maybe-thread)
1523     ;; the value is gc'd, remove it manually
1524     (remhash id *thread-id-map*))
1525     ((eq thread maybe-thread)
1526     (return-from thread-id id)))))
1527     ;; lazy numbering
1528     (let ((id (next-thread-id)))
1529     (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1530     id))))
1531 crhodes 1.136
1532     (defimplementation find-thread (id)
1533     (sb-thread:with-mutex (*thread-id-map-lock*)
1534     (let ((thread-pointer (gethash id *thread-id-map*)))
1535     (if thread-pointer
1536     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1537     (if maybe-thread
1538     maybe-thread
1539     ;; the value is gc'd, remove it manually
1540     (progn
1541     (remhash id *thread-id-map*)
1542     nil)))
1543     nil))))
1544 jsnellman 1.158
1545 crhodes 1.136 (defimplementation thread-name (thread)
1546     ;; sometimes the name is not a string (e.g. NIL)
1547     (princ-to-string (sb-thread:thread-name thread)))
1548    
1549     (defimplementation thread-status (thread)
1550     (if (sb-thread:thread-alive-p thread)
1551 sboukarev 1.253 "Running"
1552     "Stopped"))
1553    
1554 crhodes 1.136 (defimplementation make-lock (&key name)
1555     (sb-thread:make-mutex :name name))
1556    
1557     (defimplementation call-with-lock-held (lock function)
1558     (declare (type function function))
1559 nsiivola 1.154 (sb-thread:with-recursive-lock (lock) (funcall function)))
1560    
1561 crhodes 1.136 (defimplementation current-thread ()
1562     sb-thread:*current-thread*)
1563    
1564     (defimplementation all-threads ()
1565     (sb-thread:list-all-threads))
1566 jsnellman 1.158
1567 crhodes 1.136 (defimplementation interrupt-thread (thread fn)
1568     (sb-thread:interrupt-thread thread fn))
1569    
1570     (defimplementation kill-thread (thread)
1571     (sb-thread:terminate-thread thread))
1572    
1573     (defimplementation thread-alive-p (thread)
1574     (sb-thread:thread-alive-p thread))
1575    
1576     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1577     (defvar *mailboxes* (list))
1578     (declaim (type list *mailboxes*))
1579    
1580 jsnellman 1.158 (defstruct (mailbox (:conc-name mailbox.))
1581 crhodes 1.136 thread
1582     (mutex (sb-thread:make-mutex))
1583     (waitqueue (sb-thread:make-waitqueue))
1584     (queue '() :type list))
1585    
1586     (defun mailbox (thread)
1587     "Return THREAD's mailbox."
1588     (sb-thread:with-mutex (*mailbox-lock*)
1589     (or (find thread *mailboxes* :key #'mailbox.thread)
1590     (let ((mb (make-mailbox :thread thread)))
1591     (push mb *mailboxes*)
1592     mb))))
1593    
1594     (defimplementation send (thread message)
1595     (let* ((mbox (mailbox thread))
1596     (mutex (mailbox.mutex mbox)))
1597     (sb-thread:with-mutex (mutex)
1598     (setf (mailbox.queue mbox)
1599     (nconc (mailbox.queue mbox) (list message)))
1600     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1601 trittweiler 1.270 #-sb-lutex
1602     (defun condition-timed-wait (waitqueue mutex timeout)
1603     (handler-case
1604     (let ((*break-on-signals* nil))
1605     (sb-sys:with-deadline (:seconds timeout :override t)
1606     (sb-thread:condition-wait waitqueue mutex) t))
1607     (sb-ext:timeout ()
1608     nil)))
1609    
1610     ;; FIXME: with-timeout doesn't work properly on Darwin
1611     #+sb-lutex
1612     (defun condition-timed-wait (waitqueue mutex timeout)
1613     (declare (ignore timeout))
1614     (sb-thread:condition-wait waitqueue mutex))
1615    
1616 heller 1.212 (defimplementation receive-if (test &optional timeout)
1617 heller 1.209 (let* ((mbox (mailbox (current-thread)))
1618 trittweiler 1.270 (mutex (mailbox.mutex mbox))
1619     (waitq (mailbox.waitqueue mbox)))
1620 heller 1.212 (assert (or (not timeout) (eq timeout t)))
1621 heller 1.207 (loop
1622     (check-slime-interrupts)
1623 heller 1.209 (sb-thread:with-mutex (mutex)
1624 heller 1.202 (let* ((q (mailbox.queue mbox))
1625     (tail (member-if test q)))
1626 heller 1.207 (when tail
1627     (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1628     (return (car tail))))
1629 heller 1.212 (when (eq timeout t) (return (values nil t)))
1630 trittweiler 1.270 (condition-timed-wait waitq mutex 0.2)))))
1631 heller 1.301
1632     (let ((alist '())
1633     (mutex (sb-thread:make-mutex :name "register-thread")))
1634    
1635     (defimplementation register-thread (name thread)
1636     (declare (type symbol name))
1637     (sb-thread:with-mutex (mutex)
1638     (etypecase thread
1639     (null
1640     (setf alist (delete name alist :key #'car)))
1641     (sb-thread:thread
1642     (let ((probe (assoc name alist)))
1643     (cond (probe (setf (cdr probe) thread))
1644     (t (setf alist (acons name thread alist))))))))
1645     nil)
1646    
1647     (defimplementation find-registered (name)
1648     (sb-thread:with-mutex (mutex)
1649     (cdr (assoc name alist)))))
1650    
1651 nsiivola 1.308 ;; Workaround for deadlocks between the world-lock and auto-flush-thread
1652     ;; buffer write lock.
1653     ;;
1654     ;; Another alternative would be to grab the world-lock here, but that's less
1655     ;; future-proof, and could introduce other lock-ordering issues in the
1656     ;; future.
1657     ;;
1658     ;; In an ideal world we would just have an :AROUND method on
1659     ;; SLIME-OUTPUT-STREAM, and be done, but that class doesn't exist when this
1660     ;; file is loaded -- so first we need a dummy definition that will be
1661     ;; overridden by swank-gray.lisp.
1662     (defclass slime-output-stream (fundamental-character-output-stream)
1663     ())
1664     (defmethod stream-force-output :around ((stream slime-output-stream))
1665     (handler-case
1666     (sb-sys:with-deadline (:seconds 0.1)
1667     (call-next-method))
1668     (sb-sys:deadline-timeout ()
1669     nil)))
1670    
1671 heller 1.59 )
1672 heller 1.126
1673     (defimplementation quit-lisp ()
1674     #+sb-thread
1675     (dolist (thread (remove (current-thread) (all-threads)))
1676 sboukarev 1.272 (ignore-errors (sb-thread:terminate-thread thread)))
1677 heller 1.126 (sb-ext:quit))
1678 heller 1.133
1679 mbaringer 1.117
1680 heller 1.118
1681 mbaringer 1.117 ;;Trace implementations
1682     ;;In SBCL, we have:
1683     ;; (trace <name>)
1684 heller 1.118 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1685 mbaringer 1.117 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1686     ;; <name> can be a normal name or a (setf name)
1687    
1688 heller 1.119 (defun toggle-trace-aux (fspec &rest args)
1689 mbaringer 1.117 (cond ((member fspec (eval '(trace)) :test #'equal)
1690     (eval `(untrace ,fspec))
1691     (format nil "~S is now untraced." fspec))
1692     (t
1693     (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1694     (format nil "~S is now traced." fspec))))
1695    
1696     (defun process-fspec (fspec)
1697     (cond ((consp fspec)
1698     (ecase (first fspec)
1699     ((:defun :defgeneric) (second fspec))
1700     ((:defmethod) `(method ,@(rest fspec)))
1701     ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1702     ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1703     (t
1704     fspec)))
1705    
1706 heller 1.119 (defimplementation toggle-trace (spec)
1707     (ecase (car spec)
1708 jsnellman 1.158 ((setf)
1709 heller 1.119 (toggle-trace-aux spec))
1710     ((:defmethod)
1711     (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1712     ((:defgeneric)
1713     (toggle-trace-aux (second spec) :methods t))
1714     ((:call)
1715     (destructuring-bind (caller callee) (cdr spec)
1716     (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1717 mkoeppe 1.142
1718     ;;; Weak datastructures
1719    
1720 nsiivola 1.170 (defimplementation make-weak-key-hash-table (&rest args)
1721     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1722     (apply #'make-hash-table :weakness :key args)
1723     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1724     (apply #'make-hash-table args))
1725 mkoeppe 1.142
1726 mbaringer 1.169 (defimplementation make-weak-value-hash-table (&rest args)
1727 nsiivola 1.170 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1728     (apply #'make-hash-table :weakness :value args)
1729     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1730     (apply #'make-hash-table args))
1731 alendvai 1.173
1732     (defimplementation hash-table-weakness (hashtable)
1733     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1734     (sb-ext:hash-table-weakness hashtable))
1735 heller 1.214
1736     #-win32
1737     (defimplementation save-image (filename &optional restart-function)
1738 heller 1.274 (flet ((restart-sbcl ()
1739     (sb-debug::enable-debugger)
1740     (setf sb-impl::*descriptor-handlers* nil)
1741     (funcall restart-function)))
1742     (let ((pid (sb-posix:fork)))
1743     (cond ((= pid 0)
1744     (sb-debug::disable-debugger)
1745     (apply #'sb-ext:save-lisp-and-die filename
1746     (when restart-function
1747     (list :toplevel #'restart-sbcl))))
1748     (t
1749     (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1750     (assert (= pid rpid))
1751     (assert (and (sb-posix:wifexited status)
1752     (zerop (sb-posix:wexitstatus status))))))))))
1753    
1754     #+unix
1755     (progn
1756 nsiivola 1.281 (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int
1757 heller 1.274 (program sb-alien:c-string)
1758     (argv (* sb-alien:c-string)))
1759 nsiivola 1.281
1760 heller 1.274 (defun execv (program args)
1761     "Replace current executable with another one."
1762     (let ((a-args (sb-alien:make-alien sb-alien:c-string
1763     (+ 1 (length args)))))
1764     (unwind-protect
1765     (progn
1766     (loop for index from 0 by 1
1767     and item in (append args '(nil))
1768     do (setf (sb-alien:deref a-args index)
1769     item))
1770     (when (minusp
1771     (sys-execv program a-args))
1772 nsiivola 1.281 (error "execv(3) returned.")))
1773 heller 1.274 (sb-alien:free-alien a-args))))
1774    
1775 sboukarev 1.275 (defun runtime-pathname ()
1776     #+#.(swank-backend:with-symbol
1777     '*runtime-pathname* 'sb-ext)
1778     sb-ext:*runtime-pathname*
1779     #-#.(swank-backend:with-symbol
1780     '*runtime-pathname* 'sb-ext)
1781     (car sb-ext:*posix-argv*))
1782    
1783 heller 1.274 (defimplementation exec-image (image-file args)
1784     (loop with fd-arg =
1785     (loop for arg in args
1786     and key = "" then arg
1787     when (string-equal key "--swank-fd")
1788 sboukarev 1.275 return (parse-integer arg))
1789 heller 1.274 for my-fd from 3 to 1024
1790     when (/= my-fd fd-arg)
1791 sboukarev 1.275 do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
1792     (let* ((self-string (pathname-to-filename (runtime-pathname))))
1793 heller 1.274 (execv
1794     self-string
1795     (apply 'list self-string "--core" image-file args)))))
1796    
1797     (defimplementation make-fd-stream (fd external-format)
1798     (sb-sys:make-fd-stream fd :input t :output t
1799     :element-type 'character
1800     :buffering :full
1801     :dual-channel-p t
1802     :external-format external-format))
1803    
1804 nsiivola 1.283 (defimplementation call-with-io-timeout (function &key seconds)
1805     (handler-case
1806     (sb-sys:with-deadline (:seconds seconds)
1807     (funcall function))
1808     (sb-sys:deadline-timeout ()
1809     nil)))
1810    
1811 sboukarev 1.277 #-win32
1812     (defimplementation background-save-image (filename &key restart-function
1813     completion-function)
1814 heller 1.274 (flet ((restart-sbcl ()
1815     (sb-debug::enable-debugger)
1816     (setf sb-impl::*descriptor-handlers* nil)
1817     (funcall restart-function)))
1818     (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
1819     (let ((pid (sb-posix:fork)))
1820     (cond ((= pid 0)
1821     (sb-posix:close pipe-in)
1822     (sb-debug::disable-debugger)
1823     (apply #'sb-ext:save-lisp-and-die filename
1824     (when restart-function
1825     (list :toplevel #'restart-sbcl))))
1826     (t
1827     (sb-posix:close pipe-out)
1828     (sb-sys:add-fd-handler
1829     pipe-in :input
1830     (lambda (fd)
1831     (sb-sys:invalidate-descriptor fd)
1832     (sb-posix:close fd)
1833     (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1834     (assert (= pid rpid))
1835     (assert (sb-posix:wifexited status))
1836     (funcall completion-function
1837     (zerop (sb-posix:wexitstatus status))))))))))))
1838 nsiivola 1.278
1839     (defun deinit-log-output ()
1840     ;; Can't hang on to an fd-stream from a previous session.
1841 sboukarev 1.279 (setf (symbol-value (find-symbol "*LOG-OUTPUT*" 'swank))
1842     nil))
1843 nsiivola 1.278
1844     (pushnew 'deinit-log-output sb-ext:*save-hooks*)

  ViewVC Help
Powered by ViewVC 1.1.5