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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.305 - (hide annotations)
Fri Mar 30 14:54:46 2012 UTC (2 years ago) by nsiivola
Branch: MAIN
Changes since 1.304: +4 -2 lines
sbcl: fix bug introduced two commits ago

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

  ViewVC Help
Powered by ViewVC 1.1.5