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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.294 - (hide annotations)
Sun Nov 27 21:47:15 2011 UTC (2 years, 4 months ago) by heller
Branch: MAIN
Changes since 1.293: +2 -2 lines
* swank.lisp (create-server): Add a :backlog argument.
(setup-server): Pass it along.

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

  ViewVC Help
Powered by ViewVC 1.1.5