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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.150 - (hide annotations)
Fri Nov 11 23:43:43 2005 UTC (8 years, 5 months ago) by heller
Branch: MAIN
Changes since 1.149: +6 -4 lines
(accept-connection): New argument: buffering.
1 heller 1.60 ;;;; -*- 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     ;;; This code has been placed in the Public Domain. All warranties are
8     ;;; 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 heller 1.129 (require 'sb-posix))
20 heller 1.107
21     (declaim (optimize (debug 2)))
22 dbarlow 1.1
23 heller 1.146 (import-from :sb-gray *gray-stream-symbols* :swank-backend)
24 heller 1.23
25 mbaringer 1.100 ;;; swank-mop
26    
27 heller 1.106 (import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
28 mbaringer 1.100
29 mbaringer 1.101 (defun swank-mop:slot-definition-documentation (slot)
30     (sb-pcl::documentation slot t))
31 mbaringer 1.100
32 dbarlow 1.1 ;;; TCP Server
33    
34 lgorrie 1.132 (defimplementation preferred-communication-style ()
35 lgorrie 1.131 (if (and (member :sb-thread *features*)
36 crhodes 1.140 #+linux
37 lgorrie 1.131 (not (sb-alien:extern-alien "linux_no_threads_p" sb-alien:boolean)))
38     :spawn
39     :fd-handler))
40 heller 1.82
41 heller 1.65 (defun resolve-hostname (name)
42     (car (sb-bsd-sockets:host-ent-addresses
43     (sb-bsd-sockets:get-host-by-name name))))
44    
45     (defimplementation create-socket (host port)
46 dbarlow 1.6 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
47     :type :stream
48     :protocol :tcp)))
49 heller 1.48 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
50 heller 1.65 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
51 dbarlow 1.6 (sb-bsd-sockets:socket-listen socket 5)
52 heller 1.29 socket))
53    
54 lgorrie 1.54 (defimplementation local-port (socket)
55 lgorrie 1.46 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
56    
57 lgorrie 1.54 (defimplementation close-socket (socket)
58 lgorrie 1.86 (sb-sys:invalidate-descriptor (socket-fd socket))
59 heller 1.48 (sb-bsd-sockets:socket-close socket))
60    
61 heller 1.150 (defimplementation accept-connection (socket &key
62     (external-format :iso-latin-1-unix)
63     (buffering :full))
64     (make-socket-io-stream (accept socket) external-format buffering))
65 heller 1.48
66 heller 1.59 (defvar *sigio-handlers* '()
67     "List of (key . fn) pairs to be called on SIGIO.")
68    
69     (defun sigio-handler (signal code scp)
70 heller 1.60 (declare (ignore signal code scp))
71     (mapc (lambda (handler)
72     (funcall (the function (cdr handler))))
73     *sigio-handlers*))
74 heller 1.59
75     (defun set-sigio-handler ()
76 heller 1.82 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
77 heller 1.59 (sigio-handler signal code scp))))
78    
79 heller 1.62 (defun enable-sigio-on-fd (fd)
80 heller 1.82 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
81     (sb-posix::fcntl fd sb-posix::f-setown (getpid)))
82 heller 1.62
83 heller 1.67 (defimplementation add-sigio-handler (socket fn)
84 heller 1.62 (set-sigio-handler)
85     (let ((fd (socket-fd socket)))
86     (format *debug-io* "Adding sigio handler: ~S ~%" fd)
87     (enable-sigio-on-fd fd)
88     (push (cons fd fn) *sigio-handlers*)))
89    
90 heller 1.67 (defimplementation remove-sigio-handlers (socket)
91 heller 1.59 (let ((fd (socket-fd socket)))
92     (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
93     (sb-sys:invalidate-descriptor fd))
94 heller 1.51 (close socket))
95 heller 1.67
96     (defimplementation add-fd-handler (socket fn)
97     (declare (type function fn))
98     (let ((fd (socket-fd socket)))
99     (format *debug-io* "; Adding fd handler: ~S ~%" fd)
100     (sb-sys:add-fd-handler fd :input (lambda (_)
101     _
102     (funcall fn)))))
103    
104     (defimplementation remove-fd-handlers (socket)
105     (sb-sys:invalidate-descriptor (socket-fd socket)))
106 heller 1.51
107 heller 1.48 (defun socket-fd (socket)
108     (etypecase socket
109     (fixnum socket)
110     (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
111     (file-stream (sb-sys:fd-stream-fd socket))))
112    
113 heller 1.137 (defun find-external-format (coding-system)
114     (ecase coding-system
115     (:iso-latin-1-unix :iso-8859-1)
116 heller 1.144 (:utf-8-unix :utf-8)
117     (:euc-jp-unix :euc-jp)))
118 heller 1.137
119 heller 1.150 (defun make-socket-io-stream (socket external-format buffering)
120 heller 1.137 (let ((ef (find-external-format external-format)))
121 heller 1.110 (sb-bsd-sockets:socket-make-stream socket
122     :output t
123     :input t
124     :element-type 'character
125 heller 1.150 :buffering buffering
126 heller 1.112 #+sb-unicode :external-format
127 heller 1.137 #+sb-unicode ef
128 heller 1.112 )))
129 lgorrie 1.46
130 heller 1.29 (defun accept (socket)
131     "Like socket-accept, but retry on EAGAIN."
132 heller 1.126 (loop (handler-case
133 heller 1.29 (return (sb-bsd-sockets:socket-accept socket))
134     (sb-bsd-sockets:interrupted-error ()))))
135 dbarlow 1.6
136 heller 1.52 (defmethod call-without-interrupts (fn)
137 heller 1.58 (declare (type function fn))
138 heller 1.52 (sb-sys:without-interrupts (funcall fn)))
139    
140 heller 1.81 (defimplementation getpid ()
141 lgorrie 1.80 (sb-posix:getpid))
142 heller 1.52
143 heller 1.68 (defimplementation lisp-implementation-type-name ()
144     "sbcl")
145    
146 heller 1.124
147     ;;;; Support for SBCL syntax
148    
149 heller 1.129 ;;; SBCL's source code is riddled with #! reader macros. Also symbols
150     ;;; containing `!' have special meaning. We have to work long and
151     ;;; hard to be able to read the source. To deal with #! reader
152     ;;; macros, we use a special readtable. The special symbols are
153     ;;; converted by a condition handler.
154    
155 heller 1.124 (defun feature-in-list-p (feature list)
156     (etypecase feature
157     (symbol (member feature list :test #'eq))
158     (cons (flet ((subfeature-in-list-p (subfeature)
159     (feature-in-list-p subfeature list)))
160     (ecase (first feature)
161     (:or (some #'subfeature-in-list-p (rest feature)))
162     (:and (every #'subfeature-in-list-p (rest feature)))
163     (:not (destructuring-bind (e) (cdr feature)
164     (not (subfeature-in-list-p e)))))))))
165    
166     (defun shebang-reader (stream sub-character infix-parameter)
167     (declare (ignore sub-character))
168     (when infix-parameter
169     (error "illegal read syntax: #~D!" infix-parameter))
170     (let ((next-char (read-char stream)))
171     (unless (find next-char "+-")
172     (error "illegal read syntax: #!~C" next-char))
173     ;; When test is not satisfied
174     ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
175     ;; would become "unless test is satisfied"..
176     (when (let* ((*package* (find-package "KEYWORD"))
177     (*read-suppress* nil)
178     (not-p (char= next-char #\-))
179     (feature (read stream)))
180     (if (feature-in-list-p feature *features*)
181     not-p
182     (not not-p)))
183     ;; Read (and discard) a form from input.
184     (let ((*read-suppress* t))
185     (read stream t nil t))))
186     (values))
187    
188     (defvar *shebang-readtable*
189     (let ((*readtable* (copy-readtable nil)))
190     (set-dispatch-macro-character #\# #\!
191     (lambda (s c n) (shebang-reader s c n))
192     *readtable*)
193     *readtable*))
194    
195     (defun shebang-readtable ()
196     *shebang-readtable*)
197    
198     (defun sbcl-package-p (package)
199     (let ((name (package-name package)))
200     (eql (mismatch "SB-" name) 3)))
201    
202 heller 1.126 (defun sbcl-source-file-p (filename)
203     (loop for (_ pattern) in (logical-pathname-translations "SYS")
204     thereis (pathname-match-p filename pattern)))
205    
206     (defun guess-readtable-for-filename (filename)
207     (if (sbcl-source-file-p filename)
208     (shebang-readtable)
209     *readtable*))
210    
211 heller 1.124 (defvar *debootstrap-packages* t)
212    
213 heller 1.126 (defun call-with-debootstrapping (fun)
214     (handler-bind ((sb-int:bootstrap-package-not-found
215     #'sb-int:debootstrap-package))
216     (funcall fun)))
217    
218 heller 1.124 (defmacro with-debootstrapping (&body body)
219 heller 1.126 `(call-with-debootstrapping (lambda () ,@body)))
220 heller 1.124
221     (defimplementation call-with-syntax-hooks (fn)
222     (cond ((and *debootstrap-packages*
223     (sbcl-package-p *package*))
224     (with-debootstrapping (funcall fn)))
225     (t
226     (funcall fn))))
227    
228     (defimplementation default-readtable-alist ()
229     (let ((readtable (shebang-readtable)))
230     (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
231     collect (cons (package-name p) readtable))))
232    
233 dbarlow 1.1 ;;; Utilities
234    
235 mbaringer 1.100 (defimplementation arglist ((fname t))
236 heller 1.74 (sb-introspect:function-arglist fname))
237 mbaringer 1.100
238     (defimplementation function-name ((f function))
239     (sb-impl::%fun-name f))
240 dbarlow 1.1
241 dbarlow 1.42 (defvar *buffer-name* nil)
242 dbarlow 1.1 (defvar *buffer-offset*)
243 heller 1.70 (defvar *buffer-substring* nil)
244 dbarlow 1.1
245 lgorrie 1.24 (defvar *previous-compiler-condition* nil
246     "Used to detect duplicates.")
247    
248 dbarlow 1.1 (defun handle-notification-condition (condition)
249     "Handle a condition caused by a compiler warning.
250     This traps all compiler conditions at a lower-level than using
251     C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
252     craft our own error messages, which can omit a lot of redundant
253     information."
254     (let ((context (sb-c::find-error-context nil)))
255 heller 1.36 (unless (eq condition *previous-compiler-condition*)
256 dbarlow 1.1 (setq *previous-compiler-condition* condition)
257 lgorrie 1.24 (signal-compiler-condition condition context))))
258    
259     (defun signal-compiler-condition (condition context)
260     (signal (make-condition
261     'compiler-condition
262     :original-condition condition
263     :severity (etypecase condition
264     (sb-c:compiler-error :error)
265     (sb-ext:compiler-note :note)
266     (style-warning :style-warning)
267 lgorrie 1.96 (warning :warning)
268     (error :error))
269 heller 1.66 :short-message (brief-compiler-message-for-emacs condition)
270 heller 1.107 :references (condition-references (real-condition condition))
271 heller 1.66 :message (long-compiler-message-for-emacs condition context)
272 lgorrie 1.24 :location (compiler-note-location context))))
273 heller 1.107
274     (defun real-condition (condition)
275     "Return the encapsulated condition or CONDITION itself."
276     (typecase condition
277     (sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
278     (t condition)))
279 lgorrie 1.24
280     (defun compiler-note-location (context)
281 heller 1.124 (if context
282 heller 1.127 (locate-compiler-note
283     (sb-c::compiler-error-context-file-name context)
284     (compiler-source-path context)
285     (sb-c::compiler-error-context-original-source context))
286 heller 1.124 (list :error "No error location available")))
287    
288 heller 1.127 (defun locate-compiler-note (file source-path source)
289 heller 1.139 (cond ((and (eq file :lisp)
290 nsiivola 1.134 *buffer-name*)
291 heller 1.124 ;; Compiling from a buffer
292     (let ((position (+ *buffer-offset*
293     (source-path-string-position
294 mbaringer 1.138 (cons 0 (nthcdr 2 source-path))
295     *buffer-substring*))))
296 heller 1.124 (make-location (list :buffer *buffer-name*)
297     (list :position position))))
298     ((and (pathnamep file) (null *buffer-name*))
299     ;; Compiling from a file
300     (make-location (list :file (namestring file))
301     (list :position
302     (1+ (source-path-file-position
303     source-path file)))))
304 heller 1.127 ((and (eq file :lisp) (stringp source))
305     ;; Compiling macro generated code
306     (make-location (list :source-form source)
307     (list :position 1)))
308 dbarlow 1.42 (t
309 heller 1.124 (error "unhandled case"))))
310 dbarlow 1.42
311 heller 1.66 (defun brief-compiler-message-for-emacs (condition)
312 dbarlow 1.1 "Briefly describe a compiler error for Emacs.
313     When Emacs presents the message it already has the source popped up
314     and the source form highlighted. This makes much of the information in
315     the error-context redundant."
316 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
317     (princ-to-string condition)))
318 heller 1.66
319     (defun long-compiler-message-for-emacs (condition error-context)
320     "Describe a compiler error for Emacs including context information."
321 heller 1.45 (declare (type (or sb-c::compiler-error-context null) error-context))
322 heller 1.66 (multiple-value-bind (enclosing source)
323     (if error-context
324     (values (sb-c::compiler-error-context-enclosing-source error-context)
325     (sb-c::compiler-error-context-source error-context)))
326 crhodes 1.95 (let ((sb-int:*print-condition-references* nil))
327     (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
328     enclosing source condition))))
329 dbarlow 1.1
330 heller 1.124 (defun compiler-source-path (context)
331 dbarlow 1.1 "Return the source-path for the current compiler error.
332     Returns NIL if this cannot be determined by examining internal
333     compiler state."
334     (cond ((sb-c::node-p context)
335     (reverse
336     (sb-c::source-path-original-source
337     (sb-c::node-source-path context))))
338     ((sb-c::compiler-error-context-p context)
339     (reverse
340     (sb-c::compiler-error-context-original-source-path context)))))
341    
342 lgorrie 1.54 (defimplementation call-with-compilation-hooks (function)
343 heller 1.58 (declare (type function function))
344 lgorrie 1.96 (handler-bind ((sb-c:fatal-compiler-error #'handle-file-compiler-termination)
345     (sb-c:compiler-error #'handle-notification-condition)
346 dbarlow 1.41 (sb-ext:compiler-note #'handle-notification-condition)
347     (style-warning #'handle-notification-condition)
348     (warning #'handle-notification-condition))
349     (funcall function)))
350 lgorrie 1.24
351 lgorrie 1.96 (defun handle-file-compiler-termination (condition)
352     "Handle a condition that caused the file compiler to terminate."
353     (handle-notification-condition
354     (sb-int:encapsulated-condition condition)))
355    
356 heller 1.91 (defvar *trap-load-time-warnings* nil)
357    
358 heller 1.137 (defimplementation swank-compile-file (filename load-p
359     &optional external-format)
360     (let ((ef (if external-format
361     (find-external-format external-format)
362     :default)))
363     (handler-case
364     (let ((output-file (with-compilation-hooks ()
365     (compile-file filename :external-format ef))))
366     (when output-file
367     ;; Cache the latest source file for definition-finding.
368     (source-cache-get filename (file-write-date filename))
369     (when load-p
370     (load output-file))))
371     (sb-c:fatal-compiler-error () nil))))
372 lgorrie 1.24
373 heller 1.124 ;;;; compile-string
374    
375 pseibel 1.98 (defimplementation swank-compile-string (string &key buffer position directory)
376     (declare (ignore directory))
377 heller 1.139 (flet ((compileit (cont)
378     (let ((*buffer-name* buffer)
379     (*buffer-offset* position)
380     (*buffer-substring* string))
381     (with-compilation-hooks ()
382     (with-compilation-unit (:source-plist
383     (list :emacs-buffer buffer
384     :emacs-string string
385     :emacs-position position))
386     (funcall cont (compile nil
387     `(lambda ()
388     ,(read-from-string string)))))))))
389     (if *trap-load-time-warnings*
390     (compileit #'funcall)
391     (funcall (compileit #'identity)))))
392    
393 dbarlow 1.1
394     ;;;; Definitions
395    
396     (defvar *debug-definition-finding* nil
397     "When true don't handle errors while looking for definitions.
398     This is useful when debugging the definition-finding code.")
399    
400 jsnellman 1.149 ;;; As of SBCL 0.9.7 most of the gritty details of source location handling
401     ;;; are supported reasonably well by SB-INTROSPECT.
402    
403     ;;; SBCL > 0.9.6
404     #+#.(cl:if (cl:find-symbol "FIND-DEFINITION-SOURCES-BY-NAME" "SB-INTROSPECT")
405     '(and)
406     '(or))
407     (progn
408    
409     (defparameter *definition-types*
410     '(:variable defvar
411     :constant defconstant
412     :type deftype
413     :symbol-macro define-symbol-macro
414     :macro defmacro
415     :compiler-macro define-compiler-macro
416     :function defun
417     :generic-function defgeneric
418     :method defmethod
419     :setf-expander define-setf-expander
420     :structure defstruct
421     :condition defcondition
422     :class defclass
423     :method-combination define-method-combination
424     :package defpackage
425     :transform :deftransform
426     :optimizer :defoptimizer
427     :vop :define-vop
428     :source-transform :define-source-transform)
429     "Map SB-INTROSPECT definition type names to Slime-friendly forms")
430    
431     (defimplementation find-definitions (name)
432     (loop for type in *definition-types* by #'cddr
433     for locations = (sb-introspect:find-definition-sources-by-name
434     name type)
435     append (loop for source-location in locations collect
436     (make-source-location-specification type name
437     source-location))))
438    
439     (defun make-source-location-specification (type name source-location)
440     (list (list* (getf *definition-types* type)
441     name
442     (sb-introspect::definition-source-description source-location))
443     (if *debug-definition-finding*
444     (make-definition-source-location source-location type name)
445     (handler-case (make-definition-source-location source-location
446     type name)
447     (error (e)
448     (list :error (format nil "Error: ~A" e)))))))
449    
450     (defun make-definition-source-location (definition-source type name)
451     (with-struct (sb-introspect::definition-source-
452     pathname form-path character-offset plist
453     file-write-date)
454     definition-source
455     (destructuring-bind (&key emacs-buffer emacs-position
456     emacs-string &allow-other-keys)
457     plist
458     (cond
459     (emacs-buffer
460     (let ((pos (if form-path
461     (with-debootstrapping
462     (source-path-string-position
463     form-path emacs-string))
464     character-offset)))
465     (make-location `(:buffer ,emacs-buffer)
466     `(:position ,(+ pos emacs-position))
467     `(:snippet ,emacs-string))))
468     ((not pathname)
469     `(:error ,(format nil "Source of ~A ~A not found"
470     (string-downcase type) name)))
471     (t
472     (let* ((namestring (namestring (translate-logical-pathname pathname)))
473     (*readtable* (guess-readtable-for-filename namestring))
474     (pos (1+ (with-debootstrapping
475     ;; Some internal functions have no source path
476     ;; or offset available, just the file (why?).
477     ;; In these cases we can at least try to open
478     ;; the right file.
479     (if form-path
480     (source-path-file-position form-path
481     pathname)
482     0))))
483     (snippet (source-hint-snippet namestring
484     file-write-date pos)))
485     (make-location `(:file ,namestring)
486     `(:position ,pos)
487     `(:snippet ,snippet))))))))
488    
489     (defun source-hint-snippet (filename write-date position)
490     (let ((source (get-source-code filename write-date)))
491     (with-input-from-string (s source)
492     (read-snippet s position))))
493    
494     ) ;; End >0.9.6
495    
496     ;;; Support for SBCL 0.9.6 and earlier. Feel free to delete this
497     ;;; after January 2006.
498     #-#.(cl:if (cl:find-symbol "FIND-DEFINITION-SOURCES-BY-NAME" "SB-INTROSPECT")
499     '(and)
500     '(or))
501     (progn
502 lgorrie 1.122 (defimplementation find-definitions (name)
503     (append (function-definitions name)
504     (compiler-definitions name)))
505    
506     ;;;;; Function definitions
507    
508     (defun function-definitions (name)
509     (flet ((loc (fn name) (safe-function-source-location fn name)))
510     (append
511     (cond ((and (symbolp name) (macro-function name))
512     (list (list `(defmacro ,name)
513     (loc (macro-function name) name))))
514     ((fboundp name)
515     (let ((fn (fdefinition name)))
516     (typecase fn
517     (generic-function
518     (cons (list `(defgeneric ,name) (loc fn name))
519     (method-definitions fn)))
520     (t
521     (list (list `(function ,name) (loc fn name))))))))
522     (when (compiler-macro-function name)
523     (list (list `(define-compiler-macro ,name)
524     (loc (compiler-macro-function name) name)))))))
525    
526 heller 1.129 ;;;; function -> soucre location translation
527    
528     ;;; Here we try to find the source locations for function objects. We
529     ;;; have to special case functions which were compiled with C-c C-c.
530     ;;; For the other functions we used the toplevel form number as
531     ;;; returned by the sb-introspect package to find the offset in the
532     ;;; source file. (If the function has debug-blocks, we should search
533     ;;; the position of the first code-location; for some reason, that
534     ;;; doesn't seem to work.)
535 lgorrie 1.122
536 nsiivola 1.134 (defun function-source-location (function &optional name)
537     "Try to find the canonical source location of FUNCTION."
538 crhodes 1.136 (declare (type function function)
539     (ignore name))
540 nsiivola 1.134 (find-function-source-location function))
541    
542 heller 1.129 (defun safe-function-source-location (fun name)
543     (if *debug-definition-finding*
544     (function-source-location fun name)
545     (handler-case (function-source-location fun name)
546     (error (e)
547     (list :error (format nil "Error: ~A" e))))))
548    
549 nsiivola 1.134 (defun find-function-source-location (function)
550     (with-struct (sb-introspect::definition-source- form-path character-offset plist)
551     (sb-introspect:find-definition-source function)
552     (destructuring-bind (&key emacs-buffer emacs-position emacs-string) plist
553     (if emacs-buffer
554     (let ((pos (if form-path
555     (with-debootstrapping
556     (source-path-string-position
557     form-path emacs-string))
558     character-offset)))
559     (make-location `(:buffer ,emacs-buffer)
560     `(:position ,(+ pos emacs-position))
561     `(:snippet ,emacs-string)))
562     (cond #+(or)
563     ;; doesn't work for unknown reasons
564     ((function-has-start-location-p function)
565     (code-location-source-location (function-start-location function)))
566     ((not (function-source-filename function))
567     (error "Source filename not recorded for ~A" function))
568     (t
569     (let* ((pos (function-source-position function))
570     (snippet (function-hint-snippet function pos)))
571     (make-location `(:file ,(function-source-filename function))
572     `(:position ,pos)
573     `(:snippet ,snippet)))))))))
574    
575 heller 1.126 (defun function-source-position (function)
576     ;; We only consider the toplevel form number here.
577     (let* ((tlf (function-toplevel-form-number function))
578     (filename (function-source-filename function))
579     (*readtable* (guess-readtable-for-filename filename)))
580     (with-debootstrapping
581     (source-path-file-position (list tlf) filename))))
582    
583     (defun function-source-filename (function)
584     (ignore-errors
585     (namestring
586     (truename
587     (sb-introspect:definition-source-pathname
588     (sb-introspect:find-definition-source function))))))
589    
590     (defun function-source-write-date (function)
591 nsiivola 1.134 (sb-introspect:definition-source-file-write-date
592     (sb-introspect:find-definition-source function)))
593 heller 1.126
594     (defun function-toplevel-form-number (function)
595     (car
596     (sb-introspect:definition-source-form-path
597     (sb-introspect:find-definition-source function))))
598    
599     (defun function-hint-snippet (function position)
600     (let ((source (get-source-code (function-source-filename function)
601     (function-source-write-date function))))
602     (with-input-from-string (s source)
603 heller 1.128 (read-snippet s position))))
604 heller 1.126
605     (defun function-has-start-location-p (function)
606     (ignore-errors (function-start-location function)))
607    
608     (defun function-start-location (function)
609     (let ((dfun (sb-di:fun-debug-fun function)))
610     (and dfun (sb-di:debug-fun-start-location dfun))))
611    
612 heller 1.74 (defun method-definitions (gf)
613     (let ((methods (sb-mop:generic-function-methods gf))
614     (name (sb-mop:generic-function-name gf)))
615     (loop for method in methods
616 crhodes 1.141 collect (list `(method ,name ,@(method-qualifiers method)
617     ,(sb-pcl::unparse-specializers method))
618 heller 1.126 (method-source-location method)))))
619 heller 1.74
620 heller 1.126 (defun method-source-location (method)
621     (safe-function-source-location (or (sb-pcl::method-fast-function method)
622     (sb-pcl:method-function method))
623     nil))
624    
625 lgorrie 1.122 ;;;;; Compiler definitions
626    
627     (defun compiler-definitions (name)
628     (let ((fun-info (sb-int:info :function :info name)))
629     (when fun-info
630     (append (transform-definitions fun-info name)
631     (optimizer-definitions fun-info name)))))
632 heller 1.105
633     (defun transform-definitions (fun-info name)
634     (loop for xform in (sb-c::fun-info-transforms fun-info)
635     for loc = (safe-function-source-location
636     (sb-c::transform-function xform) name)
637     for typespec = (sb-kernel:type-specifier (sb-c::transform-type xform))
638     for note = (sb-c::transform-note xform)
639     for spec = (if (consp typespec)
640     `(sb-c:deftransform ,(second typespec) ,note)
641     `(sb-c:deftransform ,note))
642     collect `(,spec ,loc)))
643    
644     (defun optimizer-definitions (fun-info fun-name)
645     (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
646     (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
647     (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
648     (sb-c::fun-info-optimizer . sb-c:optimizer))))
649     (loop for (reader . name) in otypes
650     for fn = (funcall reader fun-info)
651     when fn collect `((sb-c:defoptimizer ,name)
652     ,(safe-function-source-location fn fun-name)))))
653 jsnellman 1.149 ) ;; End SBCL <= 0.9.6 compability
654 heller 1.105
655 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
656 dbarlow 1.1 "Return a plist describing SYMBOL.
657     Return NIL if the symbol is unbound."
658     (let ((result '()))
659 heller 1.133 (flet ((doc (kind)
660     (or (documentation symbol kind) :not-documented))
661     (maybe-push (property value)
662     (when value
663     (setf result (list* property value result)))))
664 dbarlow 1.1 (maybe-push
665     :variable (multiple-value-bind (kind recorded-p)
666     (sb-int:info :variable :kind symbol)
667     (declare (ignore kind))
668     (if (or (boundp symbol) recorded-p)
669     (doc 'variable))))
670 heller 1.133 (when (fboundp symbol)
671     (maybe-push
672     (cond ((macro-function symbol) :macro)
673     ((special-operator-p symbol) :special-operator)
674     ((typep (fdefinition symbol) 'generic-function)
675     :generic-function)
676     (t :function))
677     (doc 'function)))
678 dbarlow 1.1 (maybe-push
679     :setf (if (or (sb-int:info :setf :inverse symbol)
680     (sb-int:info :setf :expander symbol))
681     (doc 'setf)))
682     (maybe-push
683     :type (if (sb-int:info :type :kind symbol)
684     (doc 'type)))
685 lgorrie 1.24 result)))
686 dbarlow 1.1
687 heller 1.74 (defimplementation describe-definition (symbol type)
688 lgorrie 1.54 (case type
689     (:variable
690 heller 1.74 (describe symbol))
691     (:function
692     (describe (symbol-function symbol)))
693 lgorrie 1.54 (:setf
694 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
695     (sb-int:info :setf :expander symbol))))
696 lgorrie 1.54 (:class
697 heller 1.74 (describe (find-class symbol)))
698 lgorrie 1.54 (:type
699 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
700 dbarlow 1.1
701 heller 1.97 (defimplementation list-callers (symbol)
702     (let ((fn (fdefinition symbol)))
703     (mapcar #'function-dspec (sb-introspect:find-function-callers fn))))
704    
705     (defimplementation list-callees (symbol)
706     (let ((fn (fdefinition symbol)))
707     (mapcar #'function-dspec (sb-introspect:find-function-callees fn))))
708    
709 lgorrie 1.122 (defun function-dspec (fn)
710     "Describe where the function FN was defined.
711     Return a list of the form (NAME LOCATION)."
712     (let ((name (sb-kernel:%fun-name fn)))
713     (list name (safe-function-source-location fn name))))
714    
715 dbarlow 1.4 ;;; macroexpansion
716 dbarlow 1.1
717 lgorrie 1.54 (defimplementation macroexpand-all (form)
718 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
719     (sb-walker:walk-form form)))
720 lgorrie 1.25
721 dbarlow 1.1
722     ;;; Debugging
723    
724     (defvar *sldb-stack-top*)
725    
726 heller 1.148 (defimplementation install-debugger-globally (function)
727     (setq sb-ext:*invoke-debugger-hook* function)
728     (setq *debugger-hook* function))
729    
730 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
731 heller 1.58 (declare (type function debugger-loop-fn))
732 lgorrie 1.25 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
733 heller 1.71 (sb-debug:*stack-top-hint* nil))
734 dbarlow 1.1 (handler-bind ((sb-di:debug-condition
735     (lambda (condition)
736 lgorrie 1.25 (signal (make-condition
737     'sldb-condition
738     :original-condition condition)))))
739     (funcall debugger-loop-fn))))
740 dbarlow 1.1
741 heller 1.118 (defimplementation call-with-debugger-hook (hook fun)
742     (let ((sb-ext:*invoke-debugger-hook* hook))
743     (funcall fun)))
744    
745 dbarlow 1.1 (defun nth-frame (index)
746     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
747     (i index (1- i)))
748     ((zerop i) frame)))
749    
750 heller 1.74 (defimplementation compute-backtrace (start end)
751 dbarlow 1.1 "Return a list of frames starting with frame number START and
752     continuing to frame number END or, if END is nil, the last frame on the
753     stack."
754     (let ((end (or end most-positive-fixnum)))
755 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
756     for i from start below end
757     while f
758 heller 1.74 collect f)))
759 dbarlow 1.1
760 heller 1.74 (defimplementation print-frame (frame stream)
761 nsiivola 1.134 (sb-debug::print-frame-call frame stream))
762 dbarlow 1.1
763 heller 1.124 ;;;; Code-location -> source-location translation
764    
765 heller 1.129 ;;; If debug-block info is avaibale, we determine the file position of
766     ;;; the source-path for a code-location. If the code was compiled
767     ;;; with C-c C-c, we have to search the position in the source string.
768     ;;; If there's no debug-block info, we return the (less precise)
769     ;;; source-location of the corresponding function.
770    
771 nsiivola 1.134 (defun code-location-source-location (code-location)
772     (let* ((dsource (sb-di:code-location-debug-source code-location))
773     (plist (sb-c::debug-source-plist dsource)))
774     (if (getf plist :emacs-buffer)
775     (emacs-buffer-source-location code-location plist)
776     (ecase (sb-di:debug-source-from dsource)
777     (:file (file-source-location code-location))
778     (:lisp (lisp-source-location code-location))))))
779    
780     ;;; FIXME: The naming policy of source-location functions is a bit
781     ;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
782     ;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
783     ;;; which returns the source location for a _code-location_.
784     ;;;
785     ;;; Maybe these should be named code-location-file-source-location,
786 heller 1.139 ;;; etc, turned into generic functions, or something. In the very
787     ;;; least the names should indicate the main entry point vs. helper
788     ;;; status.
789 heller 1.124
790 nsiivola 1.134 (defun file-source-location (code-location)
791     (if (code-location-has-debug-block-info-p code-location)
792     (source-file-source-location code-location)
793     (fallback-source-location code-location)))
794    
795     (defun fallback-source-location (code-location)
796     (let ((fun (code-location-debug-fun-fun code-location)))
797     (cond (fun (function-source-location fun))
798     (t (error "Cannot find source location for: ~A " code-location)))))
799    
800 heller 1.124 (defun lisp-source-location (code-location)
801 nsiivola 1.134 (let ((source (prin1-to-string
802     (sb-debug::code-location-source-form code-location 100))))
803 heller 1.124 (make-location `(:source-form ,source) '(:position 0))))
804    
805 nsiivola 1.134 (defun emacs-buffer-source-location (code-location plist)
806     (if (code-location-has-debug-block-info-p code-location)
807     (destructuring-bind (&key emacs-buffer emacs-position emacs-string) plist
808     (let* ((pos (string-source-position code-location emacs-string))
809     (snipped (with-input-from-string (s emacs-string)
810     (read-snippet s pos))))
811     (make-location `(:buffer ,emacs-buffer)
812     `(:position ,(+ emacs-position pos))
813     `(:snippet ,snipped))))
814     (fallback-source-location code-location)))
815    
816 heller 1.124 (defun source-file-source-location (code-location)
817     (let* ((code-date (code-location-debug-source-created code-location))
818     (filename (code-location-debug-source-name code-location))
819 heller 1.126 (source-code (get-source-code filename code-date)))
820 heller 1.124 (with-input-from-string (s source-code)
821 heller 1.128 (let* ((pos (stream-source-position code-location s))
822     (snippet (read-snippet s pos)))
823 heller 1.124 (make-location `(:file ,filename)
824 heller 1.128 `(:position ,(1+ pos))
825     `(:snippet ,snippet))))))
826 heller 1.124
827     (defun code-location-debug-source-name (code-location)
828     (sb-c::debug-source-name (sb-di::code-location-debug-source code-location)))
829    
830     (defun code-location-debug-source-created (code-location)
831     (sb-c::debug-source-created
832     (sb-di::code-location-debug-source code-location)))
833    
834     (defun code-location-debug-fun-fun (code-location)
835     (sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
836    
837     (defun code-location-has-debug-block-info-p (code-location)
838     (handler-case
839     (progn (sb-di:code-location-debug-block code-location)
840     t)
841     (sb-di:no-debug-blocks () nil)))
842    
843     (defun stream-source-position (code-location stream)
844     (let* ((cloc (sb-debug::maybe-block-start-location code-location))
845 heller 1.128 (tlf-number (sb-di::code-location-toplevel-form-offset cloc))
846 heller 1.124 (form-number (sb-di::code-location-form-number cloc)))
847     (multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
848     (let* ((path-table (sb-di::form-number-translations tlf 0))
849 heller 1.128 (path (cond ((<= (length path-table) form-number)
850 heller 1.129 (warn "inconsistent form-number-translations")
851 heller 1.128 (list 0))
852     (t
853     (reverse (cdr (aref path-table form-number)))))))
854     (source-path-source-position path tlf pos-map)))))
855    
856     (defun string-source-position (code-location string)
857     (with-input-from-string (s string)
858     (stream-source-position code-location s)))
859 dbarlow 1.1
860 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
861 lgorrie 1.121
862 dbarlow 1.1 (defun safe-source-location-for-emacs (code-location)
863 heller 1.126 (if *debug-definition-finding*
864     (code-location-source-location code-location)
865     (handler-case (code-location-source-location code-location)
866     (error (c) (list :error (format nil "~A" c))))))
867 heller 1.36
868 lgorrie 1.54 (defimplementation frame-source-location-for-emacs (index)
869 heller 1.22 (safe-source-location-for-emacs
870     (sb-di:frame-code-location (nth-frame index))))
871 dbarlow 1.1
872 heller 1.92 (defun frame-debug-vars (frame)
873     "Return a vector of debug-variables in frame."
874     (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
875    
876     (defun debug-var-value (var frame location)
877     (ecase (sb-di:debug-var-validity var location)
878     (:valid (sb-di:debug-var-value var frame))
879     ((:invalid :unknown) ':<not-available>)))
880    
881 lgorrie 1.54 (defimplementation frame-locals (index)
882 dbarlow 1.1 (let* ((frame (nth-frame index))
883 heller 1.92 (loc (sb-di:frame-code-location frame))
884     (vars (frame-debug-vars frame)))
885     (loop for v across vars collect
886     (list :name (sb-di:debug-var-symbol v)
887     :id (sb-di:debug-var-id v)
888     :value (debug-var-value v frame loc)))))
889    
890     (defimplementation frame-var-value (frame var)
891     (let* ((frame (nth-frame frame))
892     (dvar (aref (frame-debug-vars frame) var)))
893     (debug-var-value dvar frame (sb-di:frame-code-location frame))))
894 dbarlow 1.1
895 lgorrie 1.54 (defimplementation frame-catch-tags (index)
896 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
897 lgorrie 1.50
898 heller 1.56 (defimplementation eval-in-frame (form index)
899     (let ((frame (nth-frame index)))
900 heller 1.58 (funcall (the function
901     (sb-di:preprocess-for-eval form
902     (sb-di:frame-code-location frame)))
903 heller 1.56 frame)))
904    
905     (defun sb-debug-catch-tag-p (tag)
906     (and (symbolp tag)
907     (not (symbol-package tag))
908     (string= tag :sb-debug-catch-tag)))
909    
910     (defimplementation return-from-frame (index form)
911     (let* ((frame (nth-frame index))
912     (probe (assoc-if #'sb-debug-catch-tag-p
913     (sb-di::frame-catches frame))))
914     (cond (probe (throw (car probe) (eval-in-frame form index)))
915     (t (format nil "Cannot return from frame: ~S" frame)))))
916    
917 lgorrie 1.87 ;;;;; reference-conditions
918    
919     (defimplementation format-sldb-condition (condition)
920     (let ((sb-int:*print-condition-references* nil))
921     (princ-to-string condition)))
922    
923     (defimplementation condition-references (condition)
924     (if (typep condition 'sb-int:reference-condition)
925     (sb-int:reference-condition-references condition)
926     '()))
927    
928 heller 1.57
929     ;;;; Profiling
930    
931     (defimplementation profile (fname)
932     (when fname (eval `(sb-profile:profile ,fname))))
933    
934     (defimplementation unprofile (fname)
935     (when fname (eval `(sb-profile:unprofile ,fname))))
936    
937     (defimplementation unprofile-all ()
938     (sb-profile:unprofile)
939     "All functions unprofiled.")
940    
941     (defimplementation profile-report ()
942     (sb-profile:report))
943    
944     (defimplementation profile-reset ()
945     (sb-profile:reset)
946     "Reset profiling counters.")
947    
948     (defimplementation profiled-functions ()
949     (sb-profile:profile))
950    
951 heller 1.116 (defimplementation profile-package (package callers methods)
952     (declare (ignore callers methods))
953     (eval `(sb-profile:profile ,(package-name (find-package package)))))
954    
955 heller 1.57
956 heller 1.64 ;;;; Inspector
957 heller 1.63
958 mbaringer 1.102 (defclass sbcl-inspector (inspector)
959     ())
960    
961     (defimplementation make-default-inspector ()
962     (make-instance 'sbcl-inspector))
963    
964     (defmethod inspect-for-emacs ((o t) (inspector sbcl-inspector))
965     (declare (ignore inspector))
966 heller 1.64 (cond ((sb-di::indirect-value-cell-p o)
967 heller 1.126 (values "A value cell." (label-value-line*
968     (:value (sb-kernel:value-cell-ref o)))))
969 heller 1.64 (t
970 heller 1.126 (multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
971     (if label
972     (values text (loop for (l . v) in parts
973     append (label-value-line l v)))
974     (values text (loop for value in parts for i from 0
975     append (label-value-line i value))))))))
976 heller 1.64
977 mbaringer 1.102 (defmethod inspect-for-emacs ((o function) (inspector sbcl-inspector))
978     (declare (ignore inspector))
979 heller 1.64 (let ((header (sb-kernel:widetag-of o)))
980     (cond ((= header sb-vm:simple-fun-header-widetag)
981 heller 1.126 (values "A simple-fun."
982     (label-value-line*
983     (:name (sb-kernel:%simple-fun-name o))
984     (:arglist (sb-kernel:%simple-fun-arglist o))
985     (:self (sb-kernel:%simple-fun-self o))
986     (:next (sb-kernel:%simple-fun-next o))
987     (:type (sb-kernel:%simple-fun-type o))
988     (:code (sb-kernel:fun-code-header o)))))
989 heller 1.64 ((= header sb-vm:closure-header-widetag)
990 mbaringer 1.102 (values "A closure."
991 heller 1.126 (append
992     (label-value-line :function (sb-kernel:%closure-fun o))
993     `("Closed over values:" (:newline))
994     (loop for i below (1- (sb-kernel:get-closure-length o))
995     append (label-value-line
996     i (sb-kernel:%closure-index-ref o i))))))
997 heller 1.64 (t (call-next-method o)))))
998    
999 heller 1.113 (defmethod inspect-for-emacs ((o sb-kernel:code-component) (_ sbcl-inspector))
1000     (declare (ignore _))
1001     (values (format nil "~A is a code data-block." o)
1002     (append
1003     (label-value-line*
1004     (:code-size (sb-kernel:%code-code-size o))
1005     (:entry-points (sb-kernel:%code-entry-points o))
1006     (:debug-info (sb-kernel:%code-debug-info o))
1007     (:trace-table-offset (sb-kernel:code-header-ref
1008     o sb-vm:code-trace-table-offset-slot)))
1009     `("Constants:" (:newline))
1010     (loop for i from sb-vm:code-constants-offset
1011 mbaringer 1.102 below (sb-kernel:get-header-data o)
1012 heller 1.113 append (label-value-line i (sb-kernel:code-header-ref o i)))
1013     `("Code:" (:newline)
1014     , (with-output-to-string (s)
1015     (cond ((sb-kernel:%code-debug-info o)
1016     (sb-disassem:disassemble-code-component o :stream s))
1017     (t
1018     (sb-disassem:disassemble-memory
1019     (sb-disassem::align
1020     (+ (logandc2 (sb-kernel:get-lisp-obj-address o)
1021     sb-vm:lowtag-mask)
1022 heller 1.126 (* sb-vm:code-constants-offset
1023     sb-vm:n-word-bytes))
1024 heller 1.113 (ash 1 sb-vm:n-lowtag-bits))
1025     (ash (sb-kernel:%code-code-size o) sb-vm:word-shift)
1026     :stream s))))))))
1027 mbaringer 1.102
1028     (defmethod inspect-for-emacs ((o sb-kernel:fdefn) (inspector sbcl-inspector))
1029 mbaringer 1.104 (declare (ignore inspector))
1030 mbaringer 1.102 (values "A fdefn object."
1031 heller 1.126 (label-value-line*
1032     (:name (sb-kernel:fdefn-name o))
1033     (:function (sb-kernel:fdefn-fun o)))))
1034 mbaringer 1.102
1035 heller 1.126 (defmethod inspect-for-emacs :around ((o generic-function)
1036     (inspector sbcl-inspector))
1037 mbaringer 1.102 (declare (ignore inspector))
1038 heller 1.126 (multiple-value-bind (title contents) (call-next-method)
1039 mbaringer 1.102 (values title
1040 heller 1.126 (append
1041     contents
1042     (label-value-line*
1043     (:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
1044     (:initial-methods (sb-pcl::generic-function-initial-methods o))
1045     )))))
1046 heller 1.90
1047 heller 1.63
1048 lgorrie 1.50 ;;;; Multiprocessing
1049    
1050 crhodes 1.136 #+(and sb-thread
1051     #.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)))
1052     (progn
1053     (defvar *thread-id-counter* 0)
1054    
1055     (defvar *thread-id-counter-lock*
1056     (sb-thread:make-mutex :name "thread id counter lock"))
1057    
1058     (defun next-thread-id ()
1059     (sb-thread:with-mutex (*thread-id-counter-lock*)
1060     (incf *thread-id-counter*)))
1061    
1062     (defparameter *thread-id-map* (make-hash-table))
1063    
1064     ;; This should be a thread -> id map but as weak keys are not
1065     ;; supported it is id -> map instead.
1066     (defvar *thread-id-map-lock*
1067     (sb-thread:make-mutex :name "thread id map lock"))
1068    
1069     (defimplementation spawn (fn &key name)
1070     (sb-thread:make-thread fn :name name))
1071    
1072     (defimplementation startup-multiprocessing ())
1073    
1074     (defimplementation thread-id (thread)
1075     (sb-thread:with-mutex (*thread-id-map-lock*)
1076     (loop for id being the hash-key in *thread-id-map*
1077     using (hash-value thread-pointer)
1078     do
1079     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1080     (cond ((null maybe-thread)
1081     ;; the value is gc'd, remove it manually
1082     (remhash id *thread-id-map*))
1083     ((eq thread maybe-thread)
1084     (return-from thread-id id)))))
1085     ;; lazy numbering
1086     (let ((id (next-thread-id)))
1087     (setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
1088     id)))
1089    
1090     (defimplementation find-thread (id)
1091     (sb-thread:with-mutex (*thread-id-map-lock*)
1092     (let ((thread-pointer (gethash id *thread-id-map*)))
1093     (if thread-pointer
1094     (let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
1095     (if maybe-thread
1096     maybe-thread
1097     ;; the value is gc'd, remove it manually
1098     (progn
1099     (remhash id *thread-id-map*)
1100     nil)))
1101     nil))))
1102    
1103     (defimplementation thread-name (thread)
1104     ;; sometimes the name is not a string (e.g. NIL)
1105     (princ-to-string (sb-thread:thread-name thread)))
1106    
1107     (defimplementation thread-status (thread)
1108     (if (sb-thread:thread-alive-p thread)
1109     "RUNNING"
1110     "STOPPED"))
1111    
1112     (defimplementation make-lock (&key name)
1113     (sb-thread:make-mutex :name name))
1114    
1115     (defimplementation call-with-lock-held (lock function)
1116     (declare (type function function))
1117     (sb-thread:with-mutex (lock) (funcall function)))
1118    
1119     (defimplementation current-thread ()
1120     sb-thread:*current-thread*)
1121    
1122     (defimplementation all-threads ()
1123     (sb-thread:list-all-threads))
1124    
1125     (defimplementation interrupt-thread (thread fn)
1126     (sb-thread:interrupt-thread thread fn))
1127    
1128     (defimplementation kill-thread (thread)
1129     (sb-thread:terminate-thread thread))
1130    
1131     (defimplementation thread-alive-p (thread)
1132     (sb-thread:thread-alive-p thread))
1133    
1134     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
1135     (defvar *mailboxes* (list))
1136     (declaim (type list *mailboxes*))
1137    
1138     (defstruct (mailbox (:conc-name mailbox.))
1139     thread
1140     (mutex (sb-thread:make-mutex))
1141     (waitqueue (sb-thread:make-waitqueue))
1142     (queue '() :type list))
1143    
1144     (defun mailbox (thread)
1145     "Return THREAD's mailbox."
1146     (sb-thread:with-mutex (*mailbox-lock*)
1147     (or (find thread *mailboxes* :key #'mailbox.thread)
1148     (let ((mb (make-mailbox :thread thread)))
1149     (push mb *mailboxes*)
1150     mb))))
1151    
1152     (defimplementation send (thread message)
1153     (let* ((mbox (mailbox thread))
1154     (mutex (mailbox.mutex mbox)))
1155     (sb-thread:with-mutex (mutex)
1156     (setf (mailbox.queue mbox)
1157     (nconc (mailbox.queue mbox) (list message)))
1158     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
1159    
1160     (defimplementation receive ()
1161     (let* ((mbox (mailbox (current-thread)))
1162     (mutex (mailbox.mutex mbox)))
1163     (sb-thread:with-mutex (mutex)
1164     (loop
1165     (let ((q (mailbox.queue mbox)))
1166     (cond (q (return (pop (mailbox.queue mbox))))
1167     (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
1168     mutex))))))))
1169    
1170    
1171 heller 1.147 ;;; Auto-flush streams
1172 lgorrie 1.50
1173 heller 1.147 ;; XXX race conditions
1174     (defvar *auto-flush-streams* '())
1175 heller 1.114
1176 heller 1.147 (defvar *auto-flush-thread* nil)
1177 heller 1.59
1178 heller 1.147 (defimplementation make-stream-interactive (stream)
1179     (setq *auto-flush-streams* (adjoin stream *auto-flush-streams*))
1180     (unless *auto-flush-thread*
1181     (setq *auto-flush-thread*
1182     (sb-thread:make-thread #'flush-streams
1183     :name "auto-flush-thread"))))
1184    
1185     (defun flush-streams ()
1186     (loop
1187     (setq *auto-flush-streams*
1188     (remove-if (lambda (x)
1189     (not (and (open-stream-p x)
1190     (output-stream-p x))))
1191     *auto-flush-streams*))
1192     (mapc #'finish-output *auto-flush-streams*)
1193     (sleep 0.15)))
1194 heller 1.59
1195     )
1196 heller 1.126
1197     (defimplementation quit-lisp ()
1198     #+sb-thread
1199     (dolist (thread (remove (current-thread) (all-threads)))
1200 heller 1.133 (ignore-errors (sb-thread:interrupt-thread
1201     thread (lambda () (sb-ext:quit :recklessly-p t)))))
1202 heller 1.126 (sb-ext:quit))
1203 heller 1.133
1204 mbaringer 1.117
1205 heller 1.118
1206 mbaringer 1.117 ;;Trace implementations
1207     ;;In SBCL, we have:
1208     ;; (trace <name>)
1209 heller 1.118 ;; (trace :methods '<name>) ;to trace all methods of the gf <name>
1210 mbaringer 1.117 ;; (trace (method <name> <qualifier>? (<specializer>+)))
1211     ;; <name> can be a normal name or a (setf name)
1212    
1213 heller 1.119 (defun toggle-trace-aux (fspec &rest args)
1214 mbaringer 1.117 (cond ((member fspec (eval '(trace)) :test #'equal)
1215     (eval `(untrace ,fspec))
1216     (format nil "~S is now untraced." fspec))
1217     (t
1218     (eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
1219     (format nil "~S is now traced." fspec))))
1220    
1221     (defun process-fspec (fspec)
1222     (cond ((consp fspec)
1223     (ecase (first fspec)
1224     ((:defun :defgeneric) (second fspec))
1225     ((:defmethod) `(method ,@(rest fspec)))
1226     ((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
1227     ((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
1228     (t
1229     fspec)))
1230    
1231 heller 1.119 (defimplementation toggle-trace (spec)
1232     (ecase (car spec)
1233     ((setf)
1234     (toggle-trace-aux spec))
1235     ((:defmethod)
1236     (toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
1237     ((:defgeneric)
1238     (toggle-trace-aux (second spec) :methods t))
1239     ((:call)
1240     (destructuring-bind (caller callee) (cdr spec)
1241     (toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
1242 mkoeppe 1.142
1243     ;;; Weak datastructures
1244    
1245 jsnellman 1.143
1246     ;; SBCL doesn't actually implement weak hash-tables, the WEAK-P
1247     ;; keyword is just a decoy. Leave this here, but commented out,
1248     ;; so that no-one tries adding it back.
1249     #+(or)
1250 mkoeppe 1.142 (defimplementation make-weak-key-hash-table (&rest args)
1251     (apply #'make-hash-table :weak-p t args))
1252    

  ViewVC Help
Powered by ViewVC 1.1.5