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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.312 - (hide annotations)
Thu May 3 15:49:17 2012 UTC (23 months, 2 weeks ago) by sboukarev
Branch: MAIN
Changes since 1.311: +22 -5 lines
* slime.el (slime-goto-source-location): Allow for
:buffer-and-file locations, prefer buffer if the buffer exists.

* swank-sbcl.lisp (definition-source-for-emacs): Send
:buffer-and-file when both are available.
(quit-lisp): Use sb-ext:exit when it's present.
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 sboukarev 1.312 (let ((file-p (and pathname (probe-file pathname)
796     (or form-path character-offset))))
797     (cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file)
798     ((getf plist :emacs-buffer) :buffer)
799     (file-p :file)
800     (pathname :file-without-position)
801     (t :invalid)))))
802 trittweiler 1.261
803 sboukarev 1.310 (defun definition-source-buffer-location (definition-source)
804     (with-struct ("sb-introspect:definition-source-"
805     form-path character-offset plist)
806     definition-source
807     (destructuring-bind (&key emacs-buffer emacs-position emacs-directory
808     emacs-string &allow-other-keys)
809     plist
810     (let ((*readtable* (guess-readtable-for-filename emacs-directory)))
811     (multiple-value-bind (start end)
812     (if form-path
813     (with-debootstrapping
814     (source-path-string-position form-path
815     emacs-string))
816     (values character-offset
817     most-positive-fixnum))
818     (make-location
819     `(:buffer ,emacs-buffer)
820     `(:offset ,emacs-position ,start)
821     `(:snippet
822     ,(subseq emacs-string
823     start
824     (min end (+ start *source-snippet-size*))))))))))
825    
826     (defun definition-source-file-location (definition-source)
827     (with-struct ("sb-introspect:definition-source-"
828     pathname form-path character-offset plist
829     file-write-date) definition-source
830     (let* ((namestring (namestring (translate-logical-pathname pathname)))
831     (pos (if form-path
832     (source-file-position namestring file-write-date
833     form-path)
834     character-offset))
835     (snippet (source-hint-snippet namestring file-write-date pos)))
836     (make-location `(:file ,namestring)
837     ;; /file positions/ in Common Lisp start from
838     ;; 0, buffer positions in Emacs start from 1.
839     `(:position ,(1+ pos))
840     `(:snippet ,snippet)))))
841    
842 sboukarev 1.312 (defun definition-source-buffer-and-file-location (definition-source)
843     (let ((buffer (definition-source-buffer-location definition-source))
844     (file (definition-source-file-location definition-source)))
845     (make-location (list :buffer-and-file
846     (cadr (location-buffer buffer))
847     (cadr (location-buffer file)))
848     (list
849     :buffer-position (location-position buffer)
850     :file-position (location-position file))
851     (list
852     :buffer-hints (location-hints buffer)
853     :file-hints (location-hints file)))))
854    
855 trittweiler 1.261 (defun definition-source-for-emacs (definition-source type name)
856 sboukarev 1.310 (with-struct ("sb-introspect:definition-source-"
857     pathname form-path character-offset plist
858     file-write-date)
859     definition-source
860 trittweiler 1.261 (ecase (categorize-definition-source definition-source)
861 sboukarev 1.312 (:buffer-and-file
862     (definition-source-buffer-and-file-location definition-source))
863 trittweiler 1.261 (:buffer
864 sboukarev 1.310 (definition-source-buffer-location definition-source))
865 trittweiler 1.261 (:file
866 sboukarev 1.310 (definition-source-file-location definition-source))
867 sboukarev 1.269 (:file-without-position
868 heller 1.306 (make-location `(:file ,(namestring
869     (translate-logical-pathname pathname)))
870 sboukarev 1.269 '(:position 1)
871     (when (eql type :function)
872 heller 1.306 `(:snippet ,(format nil "(defun ~a "
873     (symbol-name name))))))
874 trittweiler 1.261 (:invalid
875 sboukarev 1.310 (error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~
876 trittweiler 1.261 meaningful information."
877 sboukarev 1.310 type name)))))
878 jsnellman 1.149
879 trittweiler 1.261 (defun source-file-position (filename write-date form-path)
880 jsnellman 1.172 (let ((source (get-source-code filename write-date))
881     (*readtable* (guess-readtable-for-filename filename)))
882 trittweiler 1.192 (with-debootstrapping
883 trittweiler 1.261 (source-path-string-position form-path source))))
884 jsnellman 1.172
885 jsnellman 1.149 (defun source-hint-snippet (filename write-date position)
886 trittweiler 1.241 (read-snippet-from-string (get-source-code filename write-date) position))
887 jsnellman 1.149
888 jsnellman 1.151 (defun function-source-location (function &optional name)
889     (declare (type function function))
890 trittweiler 1.261 (definition-source-for-emacs (sb-introspect:find-definition-source function)
891     :function
892     (or name (function-name function))))
893 jsnellman 1.151
894 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
895 dbarlow 1.1 "Return a plist describing SYMBOL.
896     Return NIL if the symbol is unbound."
897     (let ((result '()))
898 heller 1.133 (flet ((doc (kind)
899     (or (documentation symbol kind) :not-documented))
900     (maybe-push (property value)
901     (when value
902     (setf result (list* property value result)))))
903 dbarlow 1.1 (maybe-push
904     :variable (multiple-value-bind (kind recorded-p)
905     (sb-int:info :variable :kind symbol)
906     (declare (ignore kind))
907     (if (or (boundp symbol) recorded-p)
908     (doc 'variable))))
909 heller 1.133 (when (fboundp symbol)
910     (maybe-push
911     (cond ((macro-function symbol) :macro)
912     ((special-operator-p symbol) :special-operator)
913     ((typep (fdefinition symbol) 'generic-function)
914     :generic-function)
915     (t :function))
916     (doc 'function)))
917 dbarlow 1.1 (maybe-push
918     :setf (if (or (sb-int:info :setf :inverse symbol)
919     (sb-int:info :setf :expander symbol))
920     (doc 'setf)))
921     (maybe-push
922     :type (if (sb-int:info :type :kind symbol)
923     (doc 'type)))
924 lgorrie 1.24 result)))
925 dbarlow 1.1
926 heller 1.74 (defimplementation describe-definition (symbol type)
927 lgorrie 1.54 (case type
928     (:variable
929 heller 1.74 (describe symbol))
930     (:function
931     (describe (symbol-function symbol)))
932 lgorrie 1.54 (:setf
933 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
934     (sb-int:info :setf :expander symbol))))
935 lgorrie 1.54 (:class
936 heller 1.74 (describe (find-class symbol)))
937 lgorrie 1.54 (:type
938 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
939 jsnellman 1.172
940     #+#.(swank-backend::sbcl-with-xref-p)
941     (progn
942 trittweiler 1.255 (defmacro defxref (name &optional fn-name)
943 jsnellman 1.172 `(defimplementation ,name (what)
944     (sanitize-xrefs
945     (mapcar #'source-location-for-xref-data
946 trittweiler 1.255 (,(find-symbol (symbol-name (if fn-name
947     fn-name
948     name))
949     "SB-INTROSPECT")
950 jsnellman 1.172 what)))))
951     (defxref who-calls)
952     (defxref who-binds)
953     (defxref who-sets)
954     (defxref who-references)
955 trittweiler 1.222 (defxref who-macroexpands)
956 sboukarev 1.263 #+#.(swank-backend:with-symbol 'who-specializes-directly 'sb-introspect)
957 trittweiler 1.255 (defxref who-specializes who-specializes-directly))
958 jsnellman 1.172
959     (defun source-location-for-xref-data (xref-data)
960 trittweiler 1.261 (destructuring-bind (name . defsrc) xref-data
961 trittweiler 1.267 (list name (converting-errors-to-error-location
962 trittweiler 1.261 (definition-source-for-emacs defsrc 'function name)))))
963 dbarlow 1.1
964 heller 1.97 (defimplementation list-callers (symbol)
965     (let ((fn (fdefinition symbol)))
966 heller 1.168 (sanitize-xrefs
967     (mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
968 heller 1.97
969     (defimplementation list-callees (symbol)
970     (let ((fn (fdefinition symbol)))
971 heller 1.168 (sanitize-xrefs
972     (mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
973 heller 1.97
974 jsnellman 1.172 (defun sanitize-xrefs (xrefs)
975 heller 1.168 (remove-duplicates
976     (remove-if (lambda (f)
977     (member f (ignored-xref-function-names)))
978 jsnellman 1.172 (loop for entry in xrefs
979     for name = (car entry)
980     collect (if (and (consp name)
981     (member (car name)
982     '(sb-pcl::fast-method
983     sb-pcl::slow-method
984     sb-pcl::method)))
985     (cons (cons 'defmethod (cdr name))
986     (cdr entry))
987     entry))
988 heller 1.168 :key #'car)
989     :test (lambda (a b)
990     (and (eq (first a) (first b))
991     (equal (second a) (second b))))))
992    
993     (defun ignored-xref-function-names ()
994     #-#.(swank-backend::sbcl-with-new-stepper-p)
995     '(nil sb-c::step-form sb-c::step-values)
996     #+#.(swank-backend::sbcl-with-new-stepper-p)
997     '(nil))
998 jsnellman 1.166
999 lgorrie 1.122 (defun function-dspec (fn)
1000     "Describe where the function FN was defined.
1001     Return a list of the form (NAME LOCATION)."
1002 trittweiler 1.261 (let ((name (function-name fn)))
1003 trittweiler 1.267 (list name (converting-errors-to-error-location
1004 trittweiler 1.258 (function-source-location fn name)))))
1005 lgorrie 1.122
1006 dbarlow 1.4 ;;; macroexpansion
1007 dbarlow 1.1
1008 lgorrie 1.54 (defimplementation macroexpand-all (form)
1009 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
1010     (sb-walker:walk-form form)))
1011 lgorrie 1.25
1012 dbarlow 1.1
1013     ;;; Debugging
1014    
1015 trittweiler 1.257 ;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger
1016     ;;; than just a hook into BREAK. In particular, it'll make
1017     ;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather
1018     ;;; than the native debugger. That should probably be considered a
1019     ;;; feature.
1020 dbarlow 1.1
1021 trittweiler 1.194 (defun make-invoke-debugger-hook (hook)
1022 trittweiler 1.259 (when hook
1023     #'(sb-int:named-lambda swank-invoke-debugger-hook
1024     (condition old-hook)
1025     (if *debugger-hook*
1026     nil ; decline, *DEBUGGER-HOOK* will be tried next.
1027     (funcall hook condition old-hook)))))
1028 trittweiler 1.194
1029 trittweiler 1.257 (defun set-break-hook (hook)
1030     (setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1031    
1032     (defun call-with-break-hook (hook continuation)
1033     (let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
1034     (funcall continuation)))
1035    
1036 heller 1.148 (defimplementation install-debugger-globally (function)
1037 trittweiler 1.194 (setq *debugger-hook* function)
1038 trittweiler 1.257 (set-break-hook function))
1039 heller 1.148
1040 jsnellman 1.162 (defimplementation condition-extras (condition)
1041 heller 1.183 (cond #+#.(swank-backend::sbcl-with-new-stepper-p)
1042     ((typep condition 'sb-impl::step-form-condition)
1043     `((:show-frame-source 0)))
1044     ((typep condition 'sb-int:reference-condition)
1045     (let ((refs (sb-int:reference-condition-references condition)))
1046     (if refs
1047     `((:references ,(externalize-reference refs))))))))
1048    
1049     (defun externalize-reference (ref)
1050     (etypecase ref
1051     (null nil)
1052     (cons (cons (externalize-reference (car ref))
1053     (externalize-reference (cdr ref))))
1054     ((or string number) ref)
1055     (symbol
1056     (cond ((eq (symbol-package ref) (symbol-package :test))
1057     ref)
1058     (t (symbol-name ref))))))
1059 jsnellman 1.162
1060 trittweiler 1.257 (defvar *sldb-stack-top*)
1061    
1062 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
1063 heller 1.58 (declare (type function debugger-loop-fn))
1064 trittweiler 1.258 (let* ((*sldb-stack-top* (if *debug-swank-backend*
1065     (sb-di:top-frame)
1066 heller 1.306 (or sb-debug:*stack-top-hint*
1067     (sb-di:top-frame))))
1068 trittweiler 1.199 (sb-debug:*stack-top-hint* nil))
1069 jsnellman 1.158 (handler-bind ((sb-di:debug-condition
1070 dbarlow 1.1 (lambda (condition)
1071 lgorrie 1.25 (signal (make-condition
1072     'sldb-condition
1073     :original-condition condition)))))
1074     (funcall debugger-loop-fn))))
1075 dbarlow 1.1
1076 jsnellman 1.162 #+#.(swank-backend::sbcl-with-new-stepper-p)
1077     (progn
1078     (defimplementation activate-stepping (frame)
1079     (declare (ignore frame))
1080     (sb-impl::enable-stepping))
1081     (defimplementation sldb-stepper-condition-p (condition)
1082     (typep condition 'sb-ext:step-form-condition))
1083     (defimplementation sldb-step-into ()
1084     (invoke-restart 'sb-ext:step-into))
1085     (defimplementation sldb-step-next ()
1086     (invoke-restart 'sb-ext:step-next))
1087     (defimplementation sldb-step-out ()
1088     (invoke-restart 'sb-ext:step-out)))
1089    
1090 heller 1.118 (defimplementation call-with-debugger-hook (hook fun)
1091 trittweiler 1.259 (let ((*debugger-hook* hook)
1092     #+#.(swank-backend::sbcl-with-new-stepper-p)
1093 jsnellman 1.162 (sb-ext:*stepper-hook*
1094     (lambda (condition)
1095 jsnellman 1.164 (typecase condition
1096     (sb-ext:step-form-condition
1097     (let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
1098     (sb-impl::invoke-debugger condition)))))))
1099     (handler-bind (#+#.(swank-backend::sbcl-with-new-stepper-p)
1100     (sb-ext:step-condition #'sb-impl::invoke-stepper))
1101 trittweiler 1.257 (call-with-break-hook hook fun))))
1102 heller 1.118
1103 dbarlow 1.1 (defun nth-frame (index)
1104     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
1105     (i index (1- i)))
1106     ((zerop i) frame)))
1107    
1108 heller 1.74 (defimplementation compute-backtrace (start end)
1109 dbarlow 1.1 "Return a list of frames starting with frame number START and
1110     continuing to frame number END or, if END is nil, the last frame on the
1111     stack."
1112     (let ((end (or end most-positive-fixnum)))
1113 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
1114     for i from start below end
1115 heller 1.225 while f collect f)))
1116 trittweiler 1.218
1117 heller 1.225 (defimplementation print-frame (frame stream)
1118     (sb-debug::print-frame-call frame stream))
1119 trittweiler 1.218
1120 heller 1.225 (defimplementation frame-restartable-p (frame)
1121 trittweiler 1.218 #+#.(swank-backend::sbcl-with-restart-frame)
1122 heller 1.225 (not (null (sb-debug:frame-has-debug-tag-p frame))))
1123 dbarlow 1.1
1124 sboukarev 1.265 (defimplementation frame-call (frame-number)
1125     (multiple-value-bind (name args)
1126     (sb-debug::frame-call (nth-frame frame-number))
1127     (with-output-to-string (stream)
1128     (pprint-logical-block (stream nil :prefix "(" :suffix ")")
1129     (let ((*print-length* nil)
1130     (*print-level* nil))
1131     (prin1 (sb-debug::ensure-printable-object name) stream))
1132     (let ((args (sb-debug::ensure-printable-object args)))
1133     (if (listp args)
1134     (format stream "~{ ~_~S~}" args)
1135     (format stream " ~S" args)))))))
1136    
1137 heller 1.124 ;;;; Code-location -> source-location translation
1138    
1139 heller 1.129 ;;; If debug-block info is avaibale, we determine the file position of
1140     ;;; the source-path for a code-location. If the code was compiled
1141     ;;; with C-c C-c, we have to search the position in the source string.
1142     ;;; If there's no debug-block info, we return the (less precise)
1143     ;;; source-location of the corresponding function.
1144    
1145 nsiivola 1.134 (defun code-location-source-location (code-location)
1146     (let* ((dsource (sb-di:code-location-debug-source code-location))
1147     (plist (sb-c::debug-source-plist dsource)))
1148     (if (getf plist :emacs-buffer)
1149     (emacs-buffer-source-location code-location plist)
1150 sboukarev 1.263 #+#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1151 nsiivola 1.134 (ecase (sb-di:debug-source-from dsource)
1152     (:file (file-source-location code-location))
1153 trittweiler 1.197 (:lisp (lisp-source-location code-location)))
1154 sboukarev 1.263 #-#.(swank-backend:with-symbol 'debug-source-from 'sb-di)
1155 trittweiler 1.197 (if (sb-di:debug-source-namestring dsource)
1156     (file-source-location code-location)
1157     (lisp-source-location code-location)))))
1158 nsiivola 1.134
1159     ;;; FIXME: The naming policy of source-location functions is a bit
1160     ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
1161     ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
1162     ;;; which returns the source location for a _code-location_.
1163 jsnellman 1.158 ;;;
1164 nsiivola 1.134 ;;; Maybe these should be named code-location-file-source-location,
1165 heller 1.139 ;;; etc, turned into generic functions, or something. In the very
1166     ;;; least the names should indicate the main entry point vs. helper
1167     ;;; status.
1168 heller 1.124
1169 nsiivola 1.134 (defun file-source-location (code-location)
1170     (if (code-location-has-debug-block-info-p code-location)
1171     (source-file-source-location code-location)
1172     (fallback-source-location code-location)))
1173    
1174     (defun fallback-source-location (code-location)
1175     (let ((fun (code-location-debug-fun-fun code-location)))
1176     (cond (fun (function-source-location fun))
1177 heller 1.182 (t (error "Cannot find source location for: ~A " code-location)))))
1178 nsiivola 1.134
1179 heller 1.124 (defun lisp-source-location (code-location)
1180 jsnellman 1.158 (let ((source (prin1-to-string
1181 nsiivola 1.305 (sb-debug::code-location-source-form code-location 100)))
1182 nsiivola 1.307 (condition (swank-value '*swank-debugger-condition*)))
1183 nsiivola 1.309 (if (and (typep condition 'sb-impl::step-form-condition)
1184     (search "SB-IMPL::WITH-STEPPING-ENABLED" source
1185 nsiivola 1.307 :test #'char-equal)
1186     (search "SB-IMPL::STEP-FINISHED" source :test #'char-equal))
1187 heller 1.306 ;; The initial form is utterly uninteresting -- and almost
1188     ;; certainly right there in the REPL.
1189 nsiivola 1.304 (make-error-location "Stepping...")
1190     (make-location `(:source-form ,source) '(:position 1)))))
1191 heller 1.124
1192 nsiivola 1.134 (defun emacs-buffer-source-location (code-location plist)
1193     (if (code-location-has-debug-block-info-p code-location)
1194 nsiivola 1.177 (destructuring-bind (&key emacs-buffer emacs-position emacs-string
1195     &allow-other-keys)
1196     plist
1197 nsiivola 1.134 (let* ((pos (string-source-position code-location emacs-string))
1198 trittweiler 1.241 (snipped (read-snippet-from-string emacs-string pos)))
1199 jsnellman 1.158 (make-location `(:buffer ,emacs-buffer)
1200 heller 1.219 `(:offset ,emacs-position ,pos)
1201 nsiivola 1.134 `(:snippet ,snipped))))
1202     (fallback-source-location code-location)))
1203    
1204 heller 1.124 (defun source-file-source-location (code-location)
1205     (let* ((code-date (code-location-debug-source-created code-location))
1206     (filename (code-location-debug-source-name code-location))
1207 jsnellman 1.186 (*readtable* (guess-readtable-for-filename filename))
1208 heller 1.126 (source-code (get-source-code filename code-date)))
1209 jsnellman 1.186 (with-debootstrapping
1210     (with-input-from-string (s source-code)
1211     (let* ((pos (stream-source-position code-location s))
1212     (snippet (read-snippet s pos)))
1213     (make-location `(:file ,filename)
1214 heller 1.219 `(:position ,pos)
1215 jsnellman 1.186 `(:snippet ,snippet)))))))
1216 heller 1.124
1217     (defun code-location-debug-source-name (code-location)
1218 sboukarev 1.263 (namestring (truename (#+#.(swank-backend:with-symbol
1219 trittweiler 1.197 'debug-source-name 'sb-di)
1220     sb-c::debug-source-name
1221 sboukarev 1.263 #-#.(swank-backend:with-symbol
1222 trittweiler 1.197 'debug-source-name 'sb-di)
1223     sb-c::debug-source-namestring
1224 jsnellman 1.186 (sb-di::code-location-debug-source code-location)))))
1225 heller 1.124
1226     (defun code-location-debug-source-created (code-location)
1227 jsnellman 1.158 (sb-c::debug-source-created
1228 heller 1.124 (sb-di::code-location-debug-source code-location)))
1229    
1230     (defun code-location-debug-fun-fun (code-location)
1231     (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
1232    
1233     (defun code-location-has-debug-block-info-p (code-location)
1234 jsnellman 1.158 (handler-case
1235 heller 1.124 (progn (sb-di:code-location-debug-block code-location)
1236     t)
1237     (sb-di:no-debug-blocks () nil)))
1238    
1239     (defun stream-source-position (code-location stream)
1240     (let* ((cloc (sb-debug::maybe-block-start-location code-location))
1241 heller 1.128 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
1242 heller 1.124 (form-number (sb-di::code-location-form-number cloc)))
1243     (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
1244     (let* ((path-table (sb-di::form-number-translations tlf 0))
1245 heller 1.128 (path (cond ((<= (length path-table) form-number)
1246 heller 1.129 (warn "inconsistent form-number-translations")
1247 heller 1.128 (list 0))
1248     (t
1249     (reverse (cdr (aref path-table form-number)))))))
1250     (source-path-source-position path tlf pos-map)))))
1251    
1252     (defun string-source-position (code-location string)
1253     (with-input-from-string (s string)
1254     (stream-source-position code-location s)))
1255 dbarlow 1.1
1256 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
1257 lgorrie 1.121
1258 heller 1.243 (defimplementation frame-source-location (index)
1259 trittweiler 1.267 (converting-errors-to-error-location
1260 trittweiler 1.258 (code-location-source-location
1261     (sb-di:frame-code-location (nth-frame index)))))
1262 dbarlow 1.1
1263 heller 1.92 (defun frame-debug-vars (frame)
1264     "Return a vector of debug-variables in frame."
1265     (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
1266    
1267     (defun debug-var-value (var frame location)
1268     (ecase (sb-di:debug-var-validity var location)
1269     (:valid (sb-di:debug-var-value var frame))
1270     ((:invalid :unknown) ':<not-available>)))
1271    
1272 nsiivola 1.285 (defun debug-var-info (var)
1273     ;; Introduced by SBCL 1.0.49.76.
1274     (let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
1275     (when (and s (fboundp s))
1276     (funcall s var))))
1277    
1278 lgorrie 1.54 (defimplementation frame-locals (index)
1279 dbarlow 1.1 (let* ((frame (nth-frame index))
1280 heller 1.92 (loc (sb-di:frame-code-location frame))
1281 nsiivola 1.285 (vars (frame-debug-vars frame))
1282     ;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE
1283     ;; specially.
1284     (more-name (or (find-symbol "MORE" :sb-debug) 'more))
1285     (more-context nil)
1286     (more-count nil)
1287     (more-id 0))
1288 sboukarev 1.256 (when vars
1289 nsiivola 1.285 (let ((locals
1290     (loop for v across vars
1291     do (when (eq (sb-di:debug-var-symbol v) more-name)
1292     (incf more-id))
1293     (case (debug-var-info v)
1294     (:more-context
1295     (setf more-context (debug-var-value v frame loc)))
1296     (:more-count
1297     (setf more-count (debug-var-value v frame loc))))
1298     collect
1299     (list :name (sb-di:debug-var-symbol v)
1300     :id (sb-di:debug-var-id v)
1301     :value (debug-var-value v frame loc)))))
1302     (when (and more-context more-count)
1303     (setf locals (append locals
1304     (list
1305     (list :name more-name
1306     :id more-id
1307     :value (multiple-value-list
1308 heller 1.306 (sb-c:%more-arg-values
1309     more-context
1310     0 more-count)))))))
1311 nsiivola 1.285 locals))))
1312 heller 1.92
1313     (defimplementation frame-var-value (frame var)
1314     (let* ((frame (nth-frame frame))
1315 nsiivola 1.285 (vars (frame-debug-vars frame))
1316     (loc (sb-di:frame-code-location frame))
1317     (dvar (if (= var (length vars))
1318 heller 1.306 ;; If VAR is out of bounds, it must be the fake var
1319     ;; we made up for &MORE.
1320     (let* ((context-var (find :more-context vars
1321     :key #'debug-var-info))
1322     (more-context (debug-var-value context-var frame
1323     loc))
1324     (count-var (find :more-count vars
1325     :key #'debug-var-info))
1326 nsiivola 1.285 (more-count (debug-var-value count-var frame loc)))
1327     (return-from frame-var-value
1328 heller 1.306 (multiple-value-list (sb-c:%more-arg-values
1329     more-context
1330     0 more-count))))
1331 nsiivola 1.285 (aref vars var))))
1332     (debug-var-value dvar frame loc)))
1333 dbarlow 1.1
1334 lgorrie 1.54 (defimplementation frame-catch-tags (index)
1335 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
1336 lgorrie 1.50
1337 heller 1.56 (defimplementation eval-in-frame (form index)
1338     (let ((frame (nth-frame index)))
1339 heller 1.58 (funcall (the function
1340 jsnellman 1.158 (sb-di:preprocess-for-eval form
1341 heller 1.58 (sb-di:frame-code-location frame)))
1342 heller 1.56 frame)))
1343    
1344 jsnellman 1.174 #+#.(swank-backend::sbcl-with-restart-frame)
1345     (progn
1346     (defimplementation return-from-frame (index form)
1347     (let* ((frame (nth-frame index)))
1348     (cond ((sb-debug:frame-has-debug-tag-p frame)
1349     (let ((values (multiple-value-list (eval-in-frame form index))))
1350     (sb-debug:unwind-to-frame-and-call frame
1351     (lambda ()
1352     (values-list values)))))
1353     (t (format nil "Cannot return from frame: ~S" frame)))))
1354 nsiivola 1.293
1355 jsnellman 1.174 (defimplementation restart-frame (index)
1356 nsiivola 1.293 (let ((frame (nth-frame index)))
1357     (when (sb-debug:frame-has-debug-tag-p frame)
1358     (multiple-value-bind (fname args) (sb-debug::frame-call frame)
1359     (multiple-value-bind (fun arglist)
1360     (if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
1361     (values (fdefinition fname) args)
1362     (values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
1363     (sb-debug::frame-args-as-list frame)))
1364     (when (functionp fun)
1365 heller 1.306 (sb-debug:unwind-to-frame-and-call
1366     frame
1367     (lambda ()
1368     ;; Ensure TCO.
1369     (declare (optimize (debug 0)))
1370     (apply fun arglist)))))))
1371 nsiivola 1.293 (format nil "Cannot restart frame: ~S" frame))))
1372 heller 1.152
1373     ;; FIXME: this implementation doesn't unwind the stack before
1374     ;; re-invoking the function, but it's better than no implementation at
1375     ;; all.
1376 jsnellman 1.174 #-#.(swank-backend::sbcl-with-restart-frame)
1377     (progn
1378     (defun sb-debug-catch-tag-p (tag)
1379     (and (symbolp tag)
1380     (not (symbol-package tag))
1381     (string= tag :sb-debug-catch-tag)))
1382    
1383     (defimplementation return-from-frame (index form)
1384     (let* ((frame (nth-frame index))
1385     (probe (assoc-if #'sb-debug-catch-tag-p
1386     (sb-di::frame-catches frame))))
1387     (cond (probe (throw (car probe) (eval-in-frame form index)))
1388     (t (format nil "Cannot return from frame: ~S" frame)))))
1389    
1390     (defimplementation restart-frame (index)
1391     (let ((frame (nth-frame index)))
1392     (return-from-frame index (sb-debug::frame-call-as-list frame)))))
1393 jsnellman 1.158
1394 lgorrie 1.87 ;;;;; reference-conditions
1395    
1396     (defimplementation format-sldb-condition (condition)
1397     (let ((sb-int:*print-condition-references* nil))
1398     (princ-to-string condition)))
1399    
1400 heller 1.57
1401     ;;;; Profiling
1402    
1403     (defimplementation profile (fname)
1404     (when fname (eval `(sb-profile:profile ,fname))))
1405    
1406     (defimplementation unprofile (fname)
1407     (when fname (eval `(sb-profile:unprofile ,fname))))
1408    
1409     (defimplementation unprofile-all ()
1410     (sb-profile:unprofile)
1411     "All functions unprofiled.")
1412    
1413     (defimplementation profile-report ()
1414     (sb-profile:report))
1415    
1416     (defimplementation profile-reset ()
1417     (sb-profile:reset)
1418     "Reset profiling counters.")
1419    
1420     (defimplementation profiled-functions ()
1421     (sb-profile:profile))
1422    
1423 heller 1.116 (defimplementation profile-package (package callers methods)
1424     (declare (ignore callers methods))
1425     (eval `(sb-profile:profile ,(package-name (find-package package)))))
1426    
1427 heller 1.57
1428 heller 1.64 ;;;; Inspector
1429 heller 1.63
1430 heller 1.190 (defmethod emacs-inspect ((o t))
1431 heller 1.64 (cond ((sb-di::indirect-value-cell-p o)
1432 heller 1.191 (label-value-line* (:value (sb-kernel:value-cell-ref o))))
1433 heller 1.64 (t
1434 heller 1.126 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
1435 sboukarev 1.271 (list* (string-right-trim '(#\Newline) text)
1436     '(:newline)
1437 heller 1.191 (if label
1438     (loop for (l . v) in parts
1439     append (label-value-line l v))
1440 sboukarev 1.271 (loop for value in parts
1441     for i from 0
1442 heller 1.191 append (label-value-line i value))))))))
1443 heller 1.64
1444 heller 1.190 (defmethod emacs-inspect ((o function))
1445 heller 1.64 (let ((header (sb-kernel:widetag-of o)))
1446     (cond ((= header sb-vm:simple-fun-header-widetag)
1447 heller 1.126 (label-value-line*
1448     (:name (sb-kernel:%simple-fun-name o))
1449     (:arglist (sb-kernel:%simple-fun-arglist o))
1450     (:self (sb-kernel:%simple-fun-self o))
1451     (:next (sb-kernel:%simple-fun-next o))
1452     (:type (sb-kernel:%simple-fun-type o))
1453 heller 1.191 (:code (sb-kernel:fun-code-header o))))
1454 heller 1.64 ((= header sb-vm:closure-header-widetag)
1455 jsnellman 1.158 (append
1456 heller 1.126 (label-value-line :function (sb-kernel:%closure-fun o))
1457     `("Closed over values:" (:newline))
1458     (loop for i below (1- (sb-kernel:get-closure-length o))
1459 jsnellman 1.158 append (label-value-line
1460 heller 1.191 i (sb-kernel:%closure-index-ref o i)))))
1461 heller 1.64 (t (call-next-method o)))))
1462    
1463 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:code-component))
1464 jsnellman 1.158 (append
1465     (label-value-line*
1466 heller 1.113 (:code-size (sb-kernel:%code-code-size o))
1467     (:entry-points (sb-kernel:%code-entry-points o))
1468     (:debug-info (sb-kernel:%code-debug-info o))
1469 jsnellman 1.158 (:trace-table-offset (sb-kernel:code-header-ref
1470 heller 1.113 o sb-vm:code-trace-table-offset-slot)))
1471     `("Constants:" (:newline))
1472 jsnellman 1.158 (loop for i from sb-vm:code-constants-offset
1473 mbaringer 1.102 below (sb-kernel:get-header-data o)
1474 heller 1.113 append (label-value-line i (sb-kernel:code-header-ref o i)))
1475     `("Code:" (:newline)
1476     , (with-output-to-string (s)
1477     (cond ((sb-kernel:%code-debug-info o)
1478     (sb-disassem:disassemble-code-component o :stream s))
1479     (t
1480 jsnellman 1.158 (sb-disassem:disassemble-memory
1481     (sb-disassem::align
1482 heller 1.113 (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1483     sb-vm:lowtag-mask)
1484 heller 1.126 (* sb-vm:code-constants-offset
1485     sb-vm:n-word-bytes))
1486 heller 1.113 (ash 1 sb-vm:n-lowtag-bits))
1487     (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1488 heller 1.191 :stream s)))))))
1489 mbaringer 1.102
1490 heller 1.190 (defmethod emacs-inspect ((o sb-ext:weak-pointer))
1491 mbaringer 1.167 (label-value-line*
1492 heller 1.191 (:value (sb-ext:weak-pointer-value o))))
1493 mbaringer 1.167
1494 heller 1.190 (defmethod emacs-inspect ((o sb-kernel:fdefn))
1495 heller 1.126 (label-value-line*
1496     (:name (sb-kernel:fdefn-name o))
1497 heller 1.191 (:function (sb-kernel:fdefn-fun o))))
1498 mbaringer 1.102
1499 heller 1.190 (defmethod emacs-inspect :around ((o generic-function))
1500 jsnellman 1.158 (append
1501 heller 1.191 (call-next-method)
1502 heller 1.126 (label-value-line*
1503     (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1504     (:initial-methods (sb-pcl::generic-function-initial-methods o))
1505 heller 1.191 )))
1506 heller 1.90
1507 heller 1.63
1508 lgorrie 1.50 ;;;; Multiprocessing
1509    
1510 crhodes 1.136 #+(and sb-thread
1511 sboukarev 1.271 #.(swank-backend:with-symbol "THREAD-NAME" "SB-THREAD"))
1512 crhodes 1.136 (progn
1513     (defvar *thread-id-counter* 0)
1514 jsnellman 1.158
1515 crhodes 1.136 (defvar *thread-id-counter-lock*
1516     (sb-thread:make-mutex :name "thread id counter lock"))
1517    
1518     (defun next-thread-id ()
1519     (sb-thread:with-mutex (*thread-id-counter-lock*)
1520     (incf *thread-id-counter*)))
1521 jsnellman 1.158
1522 crhodes 1.136 (defparameter *thread-id-map* (make-hash-table))
1523    
1524     ;; This should be a thread -> id map but as weak keys are not
1525     ;; supported it is id -> map instead.
1526     (defvar *thread-id-map-lock*
1527     (sb-thread:make-mutex :name "thread id map lock"))
1528 jsnellman 1.158
1529 crhodes 1.136 (defimplementation spawn (fn &key name)
1530     (sb-thread:make-thread fn :name name))
1531    
1532     (defimplementation thread-id (thread)
1533 heller 1.160 (block thread-id
1534     (sb-thread:with-mutex (*thread-id-map-lock*)
1535     (loop for id being the hash-key in *thread-id-map*
1536     using (hash-value thread-pointer)
1537     do
1538     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1539     (cond ((null maybe-thread)
1540     ;; the value is gc'd, remove it manually
1541     (remhash id *thread-id-map*))
1542     ((eq thread maybe-thread)
1543     (return-from thread-id id)))))
1544     ;; lazy numbering
1545     (let ((id (next-thread-id)))
1546     (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1547     id))))
1548 crhodes 1.136
1549     (defimplementation find-thread (id)
1550     (sb-thread:with-mutex (*thread-id-map-lock*)
1551     (let ((thread-pointer (gethash id *thread-id-map*)))
1552     (if thread-pointer
1553     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1554     (if maybe-thread
1555     maybe-thread
1556     ;; the value is gc'd, remove it manually
1557     (progn
1558     (remhash id *thread-id-map*)
1559     nil)))
1560     nil))))
1561 jsnellman 1.158
1562 crhodes 1.136 (defimplementation thread-name (thread)
1563     ;; sometimes the name is not a string (e.g. NIL)
1564     (princ-to-string (sb-thread:thread-name thread)))
1565    
1566     (defimplementation thread-status (thread)
1567     (if (sb-thread:thread-alive-p thread)
1568 sboukarev 1.253 "Running"
1569     "Stopped"))
1570    
1571 crhodes 1.136 (defimplementation make-lock (&key name)
1572     (sb-thread:make-mutex :name name))
1573    
1574     (defimplementation call-with-lock-held (lock function)
1575     (declare (type function function))
1576 nsiivola 1.154 (sb-thread:with-recursive-lock (lock) (funcall function)))
1577    
1578 crhodes 1.136 (defimplementation current-thread ()
1579     sb-thread:*current-thread*)
1580    
1581     (defimplementation all-threads ()
1582     (sb-thread:list-all-threads))
1583 jsnellman 1.158
1584 crhodes 1.136 (defimplementation interrupt-thread (thread fn)
1585     (sb-thread:interrupt-thread thread fn))
1586    
1587     (defimplementation kill-thread (thread)
1588     (sb-thread:terminate-thread thread))
1589    
1590     (defimplementation thread-alive-p (thread)
1591     (sb-thread:thread-alive-p thread))
1592    
1593     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1594     (defvar *mailboxes* (list))
1595     (declaim (type list *mailboxes*))
1596    
1597 jsnellman 1.158 (defstruct (mailbox (:conc-name mailbox.))
1598 crhodes 1.136 thread
1599     (mutex (sb-thread:make-mutex))
1600     (waitqueue (sb-thread:make-waitqueue))
1601     (queue '() :type list))
1602    
1603     (defun mailbox (thread)
1604     "Return THREAD's mailbox."
1605     (sb-thread:with-mutex (*mailbox-lock*)
1606     (or (find thread *mailboxes* :key #'mailbox.thread)
1607     (let ((mb (make-mailbox :thread thread)))
1608     (push mb *mailboxes*)
1609     mb))))
1610    
1611     (defimplementation send (thread message)
1612     (let* ((mbox (mailbox thread))
1613     (mutex (mailbox.mutex mbox)))
1614     (sb-thread:with-mutex (mutex)
1615     (setf (mailbox.queue mbox)
1616     (nconc (mailbox.queue mbox) (list message)))
1617     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1618 trittweiler 1.270 #-sb-lutex
1619     (defun condition-timed-wait (waitqueue mutex timeout)
1620     (handler-case
1621     (let ((*break-on-signals* nil))
1622     (sb-sys:with-deadline (:seconds timeout :override t)
1623     (sb-thread:condition-wait waitqueue mutex) t))
1624     (sb-ext:timeout ()
1625     nil)))
1626    
1627     ;; FIXME: with-timeout doesn't work properly on Darwin
1628     #+sb-lutex
1629     (defun condition-timed-wait (waitqueue mutex timeout)
1630     (declare (ignore timeout))
1631     (sb-thread:condition-wait waitqueue mutex))
1632    
1633 heller 1.212 (defimplementation receive-if (test &optional timeout)
1634 heller 1.209 (let* ((mbox (mailbox (current-thread)))
1635 trittweiler 1.270 (mutex (mailbox.mutex mbox))
1636     (waitq (mailbox.waitqueue mbox)))
1637 heller 1.212 (assert (or (not timeout) (eq timeout t)))
1638 heller 1.207 (loop
1639     (check-slime-interrupts)
1640 heller 1.209 (sb-thread:with-mutex (mutex)
1641 heller 1.202 (let* ((q (mailbox.queue mbox))
1642     (tail (member-if test q)))
1643 heller 1.207 (when tail
1644     (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
1645     (return (car tail))))
1646 heller 1.212 (when (eq timeout t) (return (values nil t)))
1647 trittweiler 1.270 (condition-timed-wait waitq mutex 0.2)))))
1648 heller 1.301
1649     (let ((alist '())
1650     (mutex (sb-thread:make-mutex :name "register-thread")))
1651    
1652     (defimplementation register-thread (name thread)
1653     (declare (type symbol name))
1654     (sb-thread:with-mutex (mutex)
1655     (etypecase thread
1656     (null
1657     (setf alist (delete name alist :key #'car)))
1658     (sb-thread:thread
1659     (let ((probe (assoc name alist)))
1660     (cond (probe (setf (cdr probe) thread))
1661     (t (setf alist (acons name thread alist))))))))
1662     nil)
1663    
1664     (defimplementation find-registered (name)
1665     (sb-thread:with-mutex (mutex)
1666     (cdr (assoc name alist)))))
1667    
1668 nsiivola 1.308 ;; Workaround for deadlocks between the world-lock and auto-flush-thread
1669     ;; buffer write lock.
1670     ;;
1671     ;; Another alternative would be to grab the world-lock here, but that's less
1672     ;; future-proof, and could introduce other lock-ordering issues in the
1673     ;; future.
1674     ;;
1675     ;; In an ideal world we would just have an :AROUND method on
1676     ;; SLIME-OUTPUT-STREAM, and be done, but that class doesn't exist when this
1677     ;; file is loaded -- so first we need a dummy definition that will be
1678     ;; overridden by swank-gray.lisp.
1679     (defclass slime-output-stream (fundamental-character-output-stream)
1680     ())
1681     (defmethod stream-force-output :around ((stream slime-output-stream))
1682     (handler-case
1683     (sb-sys:with-deadline (:seconds 0.1)
1684     (call-next-method))
1685     (sb-sys:deadline-timeout ()
1686     nil)))
1687    
1688 heller 1.59 )
1689 heller 1.126
1690     (defimplementation quit-lisp ()
1691 sboukarev 1.311 #+#.(swank-backend:with-symbol 'exit 'sb-ext)
1692     (sb-ext:exit)
1693     #-#.(swank-backend:with-symbol 'exit 'sb-ext)
1694     (progn
1695     #+sb-thread
1696     (dolist (thread (remove (current-thread) (all-threads)))
1697     (ignore-errors (sb-thread:terminate-thread thread)))
1698     (sb-ext:quit)))
1699 heller 1.133
1700 mbaringer 1.117
1701 heller 1.118
1702 mbaringer 1.117 ;;Trace implementations
1703     ;;In SBCL, we have:
1704     ;; (trace <name>)
1705 heller 1.118 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1706 mbaringer 1.117 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1707     ;; <name> can be a normal name or a (setf name)
1708    
1709 heller 1.119 (defun toggle-trace-aux (fspec &rest args)
1710 mbaringer 1.117 (cond ((member fspec (eval '(trace)) :test #'equal)
1711     (eval `(untrace ,fspec))
1712     (format nil "~S is now untraced." fspec))
1713     (t
1714     (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1715     (format nil "~S is now traced." fspec))))
1716    
1717     (defun process-fspec (fspec)
1718     (cond ((consp fspec)
1719     (ecase (first fspec)
1720     ((:defun :defgeneric) (second fspec))
1721     ((:defmethod) `(method ,@(rest fspec)))
1722     ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1723     ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1724     (t
1725     fspec)))
1726    
1727 heller 1.119 (defimplementation toggle-trace (spec)
1728     (ecase (car spec)
1729 jsnellman 1.158 ((setf)
1730 heller 1.119 (toggle-trace-aux spec))
1731     ((:defmethod)
1732     (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1733     ((:defgeneric)
1734     (toggle-trace-aux (second spec) :methods t))
1735     ((:call)
1736     (destructuring-bind (caller callee) (cdr spec)
1737     (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1738 mkoeppe 1.142
1739     ;;; Weak datastructures
1740    
1741 nsiivola 1.170 (defimplementation make-weak-key-hash-table (&rest args)
1742     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1743     (apply #'make-hash-table :weakness :key args)
1744     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1745     (apply #'make-hash-table args))
1746 mkoeppe 1.142
1747 mbaringer 1.169 (defimplementation make-weak-value-hash-table (&rest args)
1748 nsiivola 1.170 #+#.(swank-backend::sbcl-with-weak-hash-tables)
1749     (apply #'make-hash-table :weakness :value args)
1750     #-#.(swank-backend::sbcl-with-weak-hash-tables)
1751     (apply #'make-hash-table args))
1752 alendvai 1.173
1753     (defimplementation hash-table-weakness (hashtable)
1754     #+#.(swank-backend::sbcl-with-weak-hash-tables)
1755     (sb-ext:hash-table-weakness hashtable))
1756 heller 1.214
1757     #-win32
1758     (defimplementation save-image (filename &optional restart-function)
1759 heller 1.274 (flet ((restart-sbcl ()
1760     (sb-debug::enable-debugger)
1761     (setf sb-impl::*descriptor-handlers* nil)
1762     (funcall restart-function)))
1763     (let ((pid (sb-posix:fork)))
1764     (cond ((= pid 0)
1765     (sb-debug::disable-debugger)
1766     (apply #'sb-ext:save-lisp-and-die filename
1767     (when restart-function
1768     (list :toplevel #'restart-sbcl))))
1769     (t
1770     (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1771     (assert (= pid rpid))
1772     (assert (and (sb-posix:wifexited status)
1773     (zerop (sb-posix:wexitstatus status))))))))))
1774    
1775     #+unix
1776     (progn
1777 nsiivola 1.281 (sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int
1778 heller 1.274 (program sb-alien:c-string)
1779     (argv (* sb-alien:c-string)))
1780 nsiivola 1.281
1781 heller 1.274 (defun execv (program args)
1782     "Replace current executable with another one."
1783     (let ((a-args (sb-alien:make-alien sb-alien:c-string
1784     (+ 1 (length args)))))
1785     (unwind-protect
1786     (progn
1787     (loop for index from 0 by 1
1788     and item in (append args '(nil))
1789     do (setf (sb-alien:deref a-args index)
1790     item))
1791     (when (minusp
1792     (sys-execv program a-args))
1793 nsiivola 1.281 (error "execv(3) returned.")))
1794 heller 1.274 (sb-alien:free-alien a-args))))
1795    
1796 sboukarev 1.275 (defun runtime-pathname ()
1797     #+#.(swank-backend:with-symbol
1798     '*runtime-pathname* 'sb-ext)
1799     sb-ext:*runtime-pathname*
1800     #-#.(swank-backend:with-symbol
1801     '*runtime-pathname* 'sb-ext)
1802     (car sb-ext:*posix-argv*))
1803    
1804 heller 1.274 (defimplementation exec-image (image-file args)
1805     (loop with fd-arg =
1806     (loop for arg in args
1807     and key = "" then arg
1808     when (string-equal key "--swank-fd")
1809 sboukarev 1.275 return (parse-integer arg))
1810 heller 1.274 for my-fd from 3 to 1024
1811     when (/= my-fd fd-arg)
1812 sboukarev 1.275 do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
1813     (let* ((self-string (pathname-to-filename (runtime-pathname))))
1814 heller 1.274 (execv
1815     self-string
1816     (apply 'list self-string "--core" image-file args)))))
1817    
1818     (defimplementation make-fd-stream (fd external-format)
1819     (sb-sys:make-fd-stream fd :input t :output t
1820     :element-type 'character
1821     :buffering :full
1822     :dual-channel-p t
1823     :external-format external-format))
1824    
1825 nsiivola 1.283 (defimplementation call-with-io-timeout (function &key seconds)
1826     (handler-case
1827     (sb-sys:with-deadline (:seconds seconds)
1828     (funcall function))
1829     (sb-sys:deadline-timeout ()
1830     nil)))
1831    
1832 sboukarev 1.277 #-win32
1833     (defimplementation background-save-image (filename &key restart-function
1834     completion-function)
1835 heller 1.274 (flet ((restart-sbcl ()
1836     (sb-debug::enable-debugger)
1837     (setf sb-impl::*descriptor-handlers* nil)
1838     (funcall restart-function)))
1839     (multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
1840     (let ((pid (sb-posix:fork)))
1841     (cond ((= pid 0)
1842     (sb-posix:close pipe-in)
1843     (sb-debug::disable-debugger)
1844     (apply #'sb-ext:save-lisp-and-die filename
1845     (when restart-function
1846     (list :toplevel #'restart-sbcl))))
1847     (t
1848     (sb-posix:close pipe-out)
1849     (sb-sys:add-fd-handler
1850     pipe-in :input
1851     (lambda (fd)
1852     (sb-sys:invalidate-descriptor fd)
1853     (sb-posix:close fd)
1854     (multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
1855     (assert (= pid rpid))
1856     (assert (sb-posix:wifexited status))
1857     (funcall completion-function
1858     (zerop (sb-posix:wexitstatus status))))))))))))
1859 nsiivola 1.278
1860     (defun deinit-log-output ()
1861     ;; Can't hang on to an fd-stream from a previous session.
1862 sboukarev 1.279 (setf (symbol-value (find-symbol "*LOG-OUTPUT*" 'swank))
1863     nil))
1864 nsiivola 1.278
1865     (pushnew 'deinit-log-output sb-ext:*save-hooks*)

  ViewVC Help
Powered by ViewVC 1.1.5