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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.282 - (hide annotations)
Tue Jun 14 14:00:37 2011 UTC (2 years, 10 months ago) by nsiivola
Branch: MAIN
Changes since 1.281: +13 -8 lines
sbcl: get compilation notes for recursive entry to compilation right

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

  ViewVC Help
Powered by ViewVC 1.1.5