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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.248 - (hide annotations)
Mon Aug 10 19:30:22 2009 UTC (4 years, 8 months ago) by heller
Branch: MAIN
Changes since 1.247: +6 -6 lines
Separate context info from compiler message text.

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

  ViewVC Help
Powered by ViewVC 1.1.5