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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5