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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5