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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.286 - (hide annotations)
Tue Aug 9 10:27:25 2011 UTC (2 years, 8 months ago) by nsiivola
Branch: MAIN
Changes since 1.285: +2 -1 lines
sbcl: use explicit :SERVE-EVENTS T with sockets when necessary

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

  ViewVC Help
Powered by ViewVC 1.1.5