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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5