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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.91 - (hide annotations)
Sun Jun 20 21:37:05 2004 UTC (9 years, 9 months ago) by heller
Branch: MAIN
Changes since 1.90: +25 -10 lines
(*trap-load-time-warnings*): New variable.  If it is true, conditions,
most notably redefinition warnings, signalled at load time are not
trapped.

(swank-compile-file, swank-compile-string): Use it.
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 dbarlow 1.30 ;;; This is a Slime backend for SBCL. Requires SBCL 0.8.5 or later
11     ;;; for the SB-INTROSPECT contrib
12 dbarlow 1.1
13    
14     ;;; Administrivia
15    
16     (eval-when (:compile-toplevel :load-toplevel :execute)
17     (require 'sb-bsd-sockets)
18 heller 1.59 (require 'sb-introspect)
19 heller 1.60 (require 'sb-posix)
20 heller 1.59 )
21 dbarlow 1.1
22     (declaim (optimize (debug 3)))
23 heller 1.74 (in-package :swank-backend)
24 dbarlow 1.1
25 heller 1.23 (import
26     '(sb-gray:fundamental-character-output-stream
27     sb-gray:stream-write-char
28     sb-gray:stream-line-length
29     sb-gray:stream-force-output
30     sb-gray:fundamental-character-input-stream
31     sb-gray:stream-read-char
32     sb-gray:stream-listen
33     sb-gray:stream-unread-char
34     sb-gray:stream-clear-input
35     sb-gray:stream-line-column
36     sb-gray:stream-line-length))
37    
38 dbarlow 1.1 ;;; TCP Server
39    
40 heller 1.74 (defimplementation preferred-communication-style ()
41 heller 1.82 (cond ((and (sb-int:featurep :sb-thread)
42     (sb-int:featurep :sb-futex))
43     :spawn)
44     ((fboundp 'sb-posix::fcntl)
45     :sigio)
46     (t
47     :fd-handler)))
48    
49 heller 1.65 (defun resolve-hostname (name)
50     (car (sb-bsd-sockets:host-ent-addresses
51     (sb-bsd-sockets:get-host-by-name name))))
52    
53     (defimplementation create-socket (host port)
54 dbarlow 1.6 (let ((socket (make-instance 'sb-bsd-sockets:inet-socket
55     :type :stream
56     :protocol :tcp)))
57 heller 1.48 (setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
58 heller 1.65 (sb-bsd-sockets:socket-bind socket (resolve-hostname host) port)
59 dbarlow 1.6 (sb-bsd-sockets:socket-listen socket 5)
60 heller 1.29 socket))
61    
62 lgorrie 1.54 (defimplementation local-port (socket)
63 lgorrie 1.46 (nth-value 1 (sb-bsd-sockets:socket-name socket)))
64    
65 lgorrie 1.54 (defimplementation close-socket (socket)
66 lgorrie 1.86 (sb-sys:invalidate-descriptor (socket-fd socket))
67 heller 1.48 (sb-bsd-sockets:socket-close socket))
68    
69 lgorrie 1.54 (defimplementation accept-connection (socket)
70 heller 1.48 (make-socket-io-stream (accept socket)))
71    
72 heller 1.59 (defvar *sigio-handlers* '()
73     "List of (key . fn) pairs to be called on SIGIO.")
74    
75     (defun sigio-handler (signal code scp)
76 heller 1.60 (declare (ignore signal code scp))
77     (mapc (lambda (handler)
78     (funcall (the function (cdr handler))))
79     *sigio-handlers*))
80 heller 1.59
81     (defun set-sigio-handler ()
82 heller 1.82 (sb-sys:enable-interrupt sb-unix:sigio (lambda (signal code scp)
83 heller 1.59 (sigio-handler signal code scp))))
84    
85 heller 1.62 (defun enable-sigio-on-fd (fd)
86 heller 1.82 (sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
87     (sb-posix::fcntl fd sb-posix::f-setown (getpid)))
88 heller 1.62
89 heller 1.67 (defimplementation add-sigio-handler (socket fn)
90 heller 1.62 (set-sigio-handler)
91     (let ((fd (socket-fd socket)))
92     (format *debug-io* "Adding sigio handler: ~S ~%" fd)
93     (enable-sigio-on-fd fd)
94     (push (cons fd fn) *sigio-handlers*)))
95    
96 heller 1.67 (defimplementation remove-sigio-handlers (socket)
97 heller 1.59 (let ((fd (socket-fd socket)))
98     (setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
99     (sb-sys:invalidate-descriptor fd))
100 heller 1.51 (close socket))
101 heller 1.67
102     (defimplementation add-fd-handler (socket fn)
103     (declare (type function fn))
104     (let ((fd (socket-fd socket)))
105     (format *debug-io* "; Adding fd handler: ~S ~%" fd)
106     (sb-sys:add-fd-handler fd :input (lambda (_)
107     _
108     (funcall fn)))))
109    
110     (defimplementation remove-fd-handlers (socket)
111     (sb-sys:invalidate-descriptor (socket-fd socket)))
112 heller 1.51
113 heller 1.48 (defun socket-fd (socket)
114     (etypecase socket
115     (fixnum socket)
116     (sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
117     (file-stream (sb-sys:fd-stream-fd socket))))
118    
119 lgorrie 1.46 (defun make-socket-io-stream (socket)
120     (sb-bsd-sockets:socket-make-stream socket
121     :output t
122     :input t
123     :element-type 'base-char))
124    
125 heller 1.29 (defun accept (socket)
126     "Like socket-accept, but retry on EAGAIN."
127     (loop (handler-case
128     (return (sb-bsd-sockets:socket-accept socket))
129     (sb-bsd-sockets:interrupted-error ()))))
130 dbarlow 1.6
131 heller 1.91 (defimplementation emacs-connected (stream)
132     (declare (ignore stream))
133     (setq sb-ext:*invoke-debugger-hook*
134     (find-symbol (string :swank-debugger-hook) (find-package :swank))))
135    
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.85 (defimplementation quit-lisp ()
147     (sb-ext:quit))
148    
149 dbarlow 1.1 ;;; Utilities
150    
151 dbarlow 1.4 (defvar *swank-debugger-stack-frame*)
152 dbarlow 1.1
153 heller 1.74 (defimplementation arglist (fname)
154     (sb-introspect:function-arglist fname))
155 dbarlow 1.1
156 dbarlow 1.42 (defvar *buffer-name* nil)
157 dbarlow 1.1 (defvar *buffer-offset*)
158 heller 1.70 (defvar *buffer-substring* nil)
159 dbarlow 1.1
160 lgorrie 1.24 (defvar *previous-compiler-condition* nil
161     "Used to detect duplicates.")
162    
163 dbarlow 1.1 (defun handle-notification-condition (condition)
164     "Handle a condition caused by a compiler warning.
165     This traps all compiler conditions at a lower-level than using
166     C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
167     craft our own error messages, which can omit a lot of redundant
168     information."
169     (let ((context (sb-c::find-error-context nil)))
170 heller 1.36 (unless (eq condition *previous-compiler-condition*)
171 dbarlow 1.1 (setq *previous-compiler-condition* condition)
172 lgorrie 1.24 (signal-compiler-condition condition context))))
173    
174     (defun signal-compiler-condition (condition context)
175     (signal (make-condition
176     'compiler-condition
177     :original-condition condition
178     :severity (etypecase condition
179     (sb-c:compiler-error :error)
180     (sb-ext:compiler-note :note)
181     (style-warning :style-warning)
182     (warning :warning))
183 heller 1.66 :short-message (brief-compiler-message-for-emacs condition)
184     :message (long-compiler-message-for-emacs condition context)
185 lgorrie 1.24 :location (compiler-note-location context))))
186    
187 dbarlow 1.44
188    
189 lgorrie 1.24 (defun compiler-note-location (context)
190 dbarlow 1.42 (cond (context
191     (resolve-note-location
192     *buffer-name*
193     (sb-c::compiler-error-context-file-name context)
194     (sb-c::compiler-error-context-file-position context)
195     (current-compiler-error-source-path context)
196     (sb-c::compiler-error-context-original-source context)))
197     (t
198     (resolve-note-location *buffer-name* nil nil nil nil))))
199    
200     (defgeneric resolve-note-location (buffer file-name file-position
201     source-path source))
202    
203     (defmethod resolve-note-location ((b (eql nil)) (f pathname) pos path source)
204     (make-location
205 dbarlow 1.43 `(:file ,(namestring (truename f)))
206 dbarlow 1.42 `(:position ,(1+ (source-path-file-position path f)))))
207    
208 heller 1.85 #+(or)
209 dbarlow 1.42 (defmethod resolve-note-location ((b string) (f (eql :stream)) pos path source)
210     (make-location
211     `(:buffer ,b)
212     `(:position ,(+ *buffer-offset*
213     (source-path-string-position path *buffer-substring*)))))
214    
215 heller 1.85 ;; SBCL doesn't have compile-from-stream, so C-c C-c ends up here
216     (defmethod resolve-note-location ((b string) (f (eql :lisp)) pos path source)
217 heller 1.88 ;; Remove the surrounding lambda from the path (was added by
218 heller 1.85 ;; swank-compile-string)
219     (destructuring-bind (_ form &rest rest) path
220     (declare (ignore _))
221     (make-location
222     `(:buffer ,b)
223     `(:position ,(+ *buffer-offset*
224     (source-path-string-position (list* (- form 2) rest)
225     *buffer-substring*))))))
226    
227 dbarlow 1.42 (defmethod resolve-note-location (b (f (eql :lisp)) pos path (source string))
228     (make-location
229     `(:source-form ,source)
230     `(:position 1)))
231    
232     (defmethod resolve-note-location (buffer
233     (file (eql nil))
234     (pos (eql nil))
235     (path (eql nil))
236     (source (eql nil)))
237 heller 1.82 (list :error "No error location available"))
238 dbarlow 1.42
239 heller 1.66 (defun brief-compiler-message-for-emacs (condition)
240 dbarlow 1.1 "Briefly describe a compiler error for Emacs.
241     When Emacs presents the message it already has the source popped up
242     and the source form highlighted. This makes much of the information in
243     the error-context redundant."
244 heller 1.66 (princ-to-string condition))
245    
246     (defun long-compiler-message-for-emacs (condition error-context)
247     "Describe a compiler error for Emacs including context information."
248 heller 1.45 (declare (type (or sb-c::compiler-error-context null) error-context))
249 heller 1.66 (multiple-value-bind (enclosing source)
250     (if error-context
251     (values (sb-c::compiler-error-context-enclosing-source error-context)
252     (sb-c::compiler-error-context-source error-context)))
253 heller 1.85 (format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]~A"
254 heller 1.66 enclosing source condition)))
255 dbarlow 1.1
256     (defun current-compiler-error-source-path (context)
257     "Return the source-path for the current compiler error.
258     Returns NIL if this cannot be determined by examining internal
259     compiler state."
260     (cond ((sb-c::node-p context)
261     (reverse
262     (sb-c::source-path-original-source
263     (sb-c::node-source-path context))))
264     ((sb-c::compiler-error-context-p context)
265     (reverse
266     (sb-c::compiler-error-context-original-source-path context)))))
267    
268 lgorrie 1.54 (defimplementation call-with-compilation-hooks (function)
269 heller 1.58 (declare (type function function))
270 dbarlow 1.41 (handler-bind ((sb-c:compiler-error #'handle-notification-condition)
271     (sb-ext:compiler-note #'handle-notification-condition)
272     (style-warning #'handle-notification-condition)
273     (warning #'handle-notification-condition))
274     (funcall function)))
275 lgorrie 1.24
276 heller 1.91 (defvar *trap-load-time-warnings* nil)
277    
278 heller 1.74 (defimplementation swank-compile-file (filename load-p)
279 heller 1.91 (flet ((loadit (fasl-file) (when (and load-p fasl-file) (load fasl-file))))
280     (cond (*trap-load-time-warnings*
281     (with-compilation-hooks ()
282     (loadit (compile-file filename))))
283     (t
284     (loadit (with-compilation-hooks ()
285     (compile-file filename)))))))
286 lgorrie 1.24
287 heller 1.74 (defimplementation swank-compile-string (string &key buffer position)
288 heller 1.91 (let ((form (read-from-string (format nil "(~S () ~A)" 'lambda string))))
289     (flet ((compileit (cont)
290     (with-compilation-hooks ()
291     (let ((*buffer-name* buffer)
292     (*buffer-offset* position)
293     (*buffer-substring* string))
294     (funcall cont (compile nil form))))))
295     (cond (*trap-load-time-warnings*
296     (compileit #'funcall))
297     (t
298     (funcall (compileit #'identity)))))))
299 dbarlow 1.1
300     ;;;; Definitions
301    
302     (defvar *debug-definition-finding* nil
303     "When true don't handle errors while looking for definitions.
304     This is useful when debugging the definition-finding code.")
305    
306     ;;; FIXME we don't handle the compiled-interactively case yet. That
307     ;;; should have NIL :filename & :position, and non-NIL :source-form
308 heller 1.36 (defun function-source-location (function &optional name)
309 dbarlow 1.1 "Try to find the canonical source location of FUNCTION."
310     (let* ((def (sb-introspect:find-definition-source function))
311     (pathname (sb-introspect:definition-source-pathname def))
312 heller 1.32 (path (sb-introspect:definition-source-form-path def))
313     (position (sb-introspect:definition-source-character-offset def)))
314     (unless pathname
315     (return-from function-source-location
316 heller 1.36 (list :error (format nil "No filename for: ~S" function))))
317 heller 1.32 (multiple-value-bind (truename condition)
318     (ignore-errors (truename pathname))
319     (when condition
320     (return-from function-source-location
321     (list :error (format nil "~A" condition))))
322     (make-location
323     (list :file (namestring truename))
324     ;; source-paths depend on the file having been compiled with
325     ;; lotsa debugging. If not present, return the function name
326     ;; for emacs to attempt to find with a regex
327     (cond (path (list :source-path path position))
328 heller 1.36 (t (list :function-name
329     (or (and name (string name))
330 heller 1.74 (string (sb-kernel:%fun-name function))))))))))
331    
332     (defun safe-function-source-location (fun name)
333     (if *debug-definition-finding*
334     (function-source-location fun name)
335     (handler-case (function-source-location fun name)
336     (error (e)
337     (list (list :error (format nil "Error: ~A" e)))))))
338    
339     (defun method-definitions (gf)
340     (let ((methods (sb-mop:generic-function-methods gf))
341     (name (sb-mop:generic-function-name gf)))
342     (loop for method in methods
343 heller 1.75 collect (list `(method ,name ,(sb-pcl::unparse-specializers method))
344 heller 1.74 (safe-function-source-location method name)))))
345    
346 heller 1.81 (defun function-definitions (name)
347     (flet ((loc (fn name) (safe-function-source-location fn name)))
348     (cond ((and (symbolp name) (macro-function name))
349     (list (list `(defmacro ,name)
350     (loc (macro-function name) name))))
351     ((fboundp name)
352     (let ((fn (fdefinition name)))
353     (typecase fn
354     (generic-function
355     (cons (list `(defgeneric ,name) (loc fn name))
356     (method-definitions fn)))
357     (t
358     (list (list `(function ,name) (loc fn name))))))))))
359 heller 1.74
360 heller 1.81 (defimplementation find-definitions (name)
361     (function-definitions name))
362 lgorrie 1.24
363 lgorrie 1.54 (defimplementation describe-symbol-for-emacs (symbol)
364 dbarlow 1.1 "Return a plist describing SYMBOL.
365     Return NIL if the symbol is unbound."
366     (let ((result '()))
367 lgorrie 1.24 (labels ((doc (kind)
368     (or (documentation symbol kind) :not-documented))
369 dbarlow 1.1 (maybe-push (property value)
370     (when value
371     (setf result (list* property value result)))))
372     (maybe-push
373     :variable (multiple-value-bind (kind recorded-p)
374     (sb-int:info :variable :kind symbol)
375     (declare (ignore kind))
376     (if (or (boundp symbol) recorded-p)
377     (doc 'variable))))
378     (maybe-push
379     :function (if (fboundp symbol)
380     (doc 'function)))
381     (maybe-push
382     :setf (if (or (sb-int:info :setf :inverse symbol)
383     (sb-int:info :setf :expander symbol))
384     (doc 'setf)))
385     (maybe-push
386     :type (if (sb-int:info :type :kind symbol)
387     (doc 'type)))
388 lgorrie 1.24 result)))
389 dbarlow 1.1
390 heller 1.74 (defimplementation describe-definition (symbol type)
391 lgorrie 1.54 (case type
392     (:variable
393 heller 1.74 (describe symbol))
394     (:function
395     (describe (symbol-function symbol)))
396 lgorrie 1.54 (:setf
397 heller 1.74 (describe (or (sb-int:info :setf :inverse symbol)
398     (sb-int:info :setf :expander symbol))))
399 lgorrie 1.54 (:class
400 heller 1.74 (describe (find-class symbol)))
401 lgorrie 1.54 (:type
402 heller 1.74 (describe (sb-kernel:values-specifier-type symbol)))))
403 dbarlow 1.1
404 dbarlow 1.4 ;;; macroexpansion
405 dbarlow 1.1
406 lgorrie 1.54 (defimplementation macroexpand-all (form)
407 heller 1.21 (let ((sb-walker:*walk-form-expand-macros-p* t))
408     (sb-walker:walk-form form)))
409 lgorrie 1.25
410 dbarlow 1.1
411     ;;; Debugging
412    
413     (defvar *sldb-stack-top*)
414    
415 lgorrie 1.54 (defimplementation call-with-debugging-environment (debugger-loop-fn)
416 heller 1.58 (declare (type function debugger-loop-fn))
417 lgorrie 1.25 (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
418 heller 1.71 (sb-debug:*stack-top-hint* nil))
419 dbarlow 1.1 (handler-bind ((sb-di:debug-condition
420     (lambda (condition)
421 lgorrie 1.25 (signal (make-condition
422     'sldb-condition
423     :original-condition condition)))))
424     (funcall debugger-loop-fn))))
425 dbarlow 1.1
426     (defun nth-frame (index)
427     (do ((frame *sldb-stack-top* (sb-di:frame-down frame))
428     (i index (1- i)))
429     ((zerop i) frame)))
430    
431 heller 1.74 (defimplementation compute-backtrace (start end)
432 dbarlow 1.1 "Return a list of frames starting with frame number START and
433     continuing to frame number END or, if END is nil, the last frame on the
434     stack."
435     (let ((end (or end most-positive-fixnum)))
436 heller 1.45 (loop for f = (nth-frame start) then (sb-di:frame-down f)
437     for i from start below end
438     while f
439 heller 1.74 collect f)))
440 dbarlow 1.1
441 heller 1.74 (defimplementation print-frame (frame stream)
442     (let ((*standard-output* stream))
443     (sb-debug::print-frame-call frame :verbosity 1 :number nil)))
444 dbarlow 1.1
445     (defun code-location-source-path (code-location)
446     (let* ((location (sb-debug::maybe-block-start-location code-location))
447     (form-num (sb-di:code-location-form-number location)))
448     (let ((translations (sb-debug::get-toplevel-form location)))
449     (unless (< form-num (length translations))
450     (error "Source path no longer exists."))
451     (reverse (cdr (svref translations form-num))))))
452    
453     (defun code-location-file-position (code-location)
454     (let* ((debug-source (sb-di:code-location-debug-source code-location))
455     (filename (sb-di:debug-source-name debug-source))
456     (path (code-location-source-path code-location)))
457     (source-path-file-position path filename)))
458    
459 dbarlow 1.44 ;;; source-path-file-position and friends are in swank-source-path-parser
460 dbarlow 1.1
461     (defun debug-source-info-from-emacs-buffer-p (debug-source)
462     (let ((info (sb-c::debug-source-info debug-source)))
463     (and info
464     (consp info)
465     (eq :emacs-buffer (car info)))))
466    
467     (defun source-location-for-emacs (code-location)
468     (let* ((debug-source (sb-di:code-location-debug-source code-location))
469     (from (sb-di:debug-source-from debug-source))
470     (name (sb-di:debug-source-name debug-source)))
471 heller 1.32 (ecase from
472     (:file
473 heller 1.36 (let ((source-path (ignore-errors
474     (code-location-source-path code-location))))
475     (cond (source-path
476     ;; XXX: code-location-source-path reads the source !!
477     (let ((position (code-location-file-position code-location)))
478     (make-location
479     (list :file (namestring (truename name)))
480     (list :source-path source-path position))))
481     (t
482     (let* ((dfn (sb-di:code-location-debug-fun code-location))
483     (fn (sb-di:debug-fun-fun dfn)))
484     (unless fn
485     (error "Cannot find source location for: ~A "
486     code-location))
487     (function-source-location
488     fn (sb-di:debug-fun-name dfn)))))))
489    
490 heller 1.32 (:lisp
491     (make-location
492     (list :source-form (with-output-to-string (*standard-output*)
493     (sb-debug::print-code-location-source-form
494     code-location 100)))
495     (list :position 0))))))
496 dbarlow 1.1
497     (defun safe-source-location-for-emacs (code-location)
498     (handler-case (source-location-for-emacs code-location)
499 heller 1.36 (error (c) (list :error (format nil "~A" c)))))
500    
501 lgorrie 1.54 (defimplementation frame-source-location-for-emacs (index)
502 heller 1.22 (safe-source-location-for-emacs
503     (sb-di:frame-code-location (nth-frame index))))
504 dbarlow 1.1
505 lgorrie 1.54 (defimplementation frame-locals (index)
506 dbarlow 1.1 (let* ((frame (nth-frame index))
507     (location (sb-di:frame-code-location frame))
508     (debug-function (sb-di:frame-debug-fun frame))
509     (debug-variables (sb-di::debug-fun-debug-vars debug-function)))
510 heller 1.58 (declare (type (or null simple-vector) debug-variables))
511 dbarlow 1.1 (loop for v across debug-variables
512     collect (list
513 mbaringer 1.73 :name (sb-di:debug-var-symbol v)
514 dbarlow 1.1 :id (sb-di:debug-var-id v)
515 mbaringer 1.73 :value (if (eq (sb-di:debug-var-validity v location)
516     :valid)
517     (sb-di:debug-var-value v frame)
518 heller 1.74 '#:<not-available>)))))
519 dbarlow 1.1
520 lgorrie 1.54 (defimplementation frame-catch-tags (index)
521 heller 1.74 (mapcar #'car (sb-di:frame-catches (nth-frame index))))
522 lgorrie 1.50
523 heller 1.56 (defimplementation eval-in-frame (form index)
524     (let ((frame (nth-frame index)))
525 heller 1.58 (funcall (the function
526     (sb-di:preprocess-for-eval form
527     (sb-di:frame-code-location frame)))
528 heller 1.56 frame)))
529    
530     (defun sb-debug-catch-tag-p (tag)
531     (and (symbolp tag)
532     (not (symbol-package tag))
533     (string= tag :sb-debug-catch-tag)))
534    
535     (defimplementation return-from-frame (index form)
536     (let* ((frame (nth-frame index))
537     (probe (assoc-if #'sb-debug-catch-tag-p
538     (sb-di::frame-catches frame))))
539     (cond (probe (throw (car probe) (eval-in-frame form index)))
540     (t (format nil "Cannot return from frame: ~S" frame)))))
541    
542 lgorrie 1.87 ;;;;; reference-conditions
543    
544     (defimplementation format-sldb-condition (condition)
545     (let ((sb-int:*print-condition-references* nil))
546     (princ-to-string condition)))
547    
548     (defimplementation condition-references (condition)
549     (if (typep condition 'sb-int:reference-condition)
550     (sb-int:reference-condition-references condition)
551     '()))
552    
553 heller 1.57
554     ;;;; Profiling
555    
556     (defimplementation profile (fname)
557     (when fname (eval `(sb-profile:profile ,fname))))
558    
559     (defimplementation unprofile (fname)
560     (when fname (eval `(sb-profile:unprofile ,fname))))
561    
562     (defimplementation unprofile-all ()
563     (sb-profile:unprofile)
564     "All functions unprofiled.")
565    
566     (defimplementation profile-report ()
567     (sb-profile:report))
568    
569     (defimplementation profile-reset ()
570     (sb-profile:reset)
571     "Reset profiling counters.")
572    
573     (defimplementation profiled-functions ()
574     (sb-profile:profile))
575    
576    
577 heller 1.64 ;;;; Inspector
578 heller 1.63
579 heller 1.64 (defmethod inspected-parts (o)
580     (cond ((sb-di::indirect-value-cell-p o)
581     (inspected-parts-of-value-cell o))
582     (t
583     (multiple-value-bind (text labeledp parts)
584     (sb-impl::inspected-parts o)
585     (let ((parts (if labeledp
586     (loop for (label . value) in parts
587     collect (cons (string label) value))
588     (loop for value in parts
589     for i from 0
590     collect (cons (format nil "~D" i) value)))))
591     (values text parts))))))
592    
593     (defun inspected-parts-of-value-cell (o)
594     (values (format nil "~A~% is a value cell." o)
595     (list (cons "Value" (sb-kernel:value-cell-ref o)))))
596    
597     (defmethod inspected-parts ((o function))
598     (let ((header (sb-kernel:widetag-of o)))
599     (cond ((= header sb-vm:simple-fun-header-widetag)
600     (values
601     (format nil "~A~% is a simple-fun." o)
602     (list (cons "Self" (sb-kernel:%simple-fun-self o))
603     (cons "Next" (sb-kernel:%simple-fun-next o))
604     (cons "Name" (sb-kernel:%simple-fun-name o))
605     (cons "Arglist" (sb-kernel:%simple-fun-arglist o))
606     (cons "Type" (sb-kernel:%simple-fun-type o))
607     (cons "Code Object" (sb-kernel:fun-code-header o)))))
608     ((= header sb-vm:closure-header-widetag)
609     (values (format nil "~A~% is a closure." o)
610     (list*
611     (cons "Function" (sb-kernel:%closure-fun o))
612     (loop for i from 0
613     below (- (sb-kernel:get-closure-length o)
614     (1- sb-vm:closure-info-offset))
615     collect (cons (format nil "~D" i)
616     (sb-kernel:%closure-index-ref o i))))))
617     (t (call-next-method o)))))
618    
619     (defmethod inspected-parts ((o sb-kernel:code-component))
620     (values (format nil "~A~% is a code data-block." o)
621     `(("First entry point" . ,(sb-kernel:%code-entry-points o))
622     ,@(loop for i from sb-vm:code-constants-offset
623     below (sb-kernel:get-header-data o)
624     collect (cons (format nil "Constant#~D" i)
625     (sb-kernel:code-header-ref o i)))
626     ("Debug info" . ,(sb-kernel:%code-debug-info o))
627     ("Instructions" . ,(sb-kernel:code-instructions o)))))
628    
629     (defmethod inspected-parts ((o sb-kernel:fdefn))
630     (values (format nil "~A~% is a fdefn object." o)
631     `(("Name" . ,(sb-kernel:fdefn-name o))
632     ("Function" . ,(sb-kernel:fdefn-fun o)))))
633    
634    
635     (defmethod inspected-parts ((o generic-function))
636     (values (format nil "~A~% is a generic function." o)
637     (list
638     (cons "Method-Class" (sb-pcl:generic-function-method-class o))
639     (cons "Methods" (sb-pcl:generic-function-methods o))
640     (cons "Name" (sb-pcl:generic-function-name o))
641     (cons "Declarations" (sb-pcl:generic-function-declarations o))
642     (cons "Method-Combination"
643     (sb-pcl:generic-function-method-combination o))
644     (cons "Lambda-List" (sb-pcl:generic-function-lambda-list o))
645     (cons "Precedence-Order"
646     (sb-pcl:generic-function-argument-precedence-order o))
647     (cons "Pretty-Arglist"
648     (sb-pcl::generic-function-pretty-arglist o))
649     (cons "Initial-Methods"
650     (sb-pcl::generic-function-initial-methods o)))))
651 heller 1.88
652    
653     ;;;; Support for SBCL syntax
654    
655     (defun feature-in-list-p (feature list)
656     (etypecase feature
657     (symbol (member feature list :test #'eq))
658     (cons (flet ((subfeature-in-list-p (subfeature)
659     (feature-in-list-p subfeature list)))
660     (ecase (first feature)
661     (:or (some #'subfeature-in-list-p (rest feature)))
662     (:and (every #'subfeature-in-list-p (rest feature)))
663     (:not (let ((rest (cdr feature)))
664     (if (or (null (car rest)) (cdr rest))
665     (error "wrong number of terms in compound feature ~S"
666     feature)
667     (not (subfeature-in-list-p (second feature)))))))))))
668    
669     (defun shebang-reader (stream sub-character infix-parameter)
670     (declare (ignore sub-character))
671     (when infix-parameter
672     (error "illegal read syntax: #~D!" infix-parameter))
673     (let ((next-char (read-char stream)))
674     (unless (find next-char "+-")
675     (error "illegal read syntax: #!~C" next-char))
676     ;; When test is not satisfied
677     ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
678     ;; would become "unless test is satisfied"..
679     (when (let* ((*package* (find-package "KEYWORD"))
680     (*read-suppress* nil)
681     (not-p (char= next-char #\-))
682     (feature (read stream)))
683     (if (feature-in-list-p feature *features*)
684     not-p
685     (not not-p)))
686     ;; Read (and discard) a form from input.
687     (let ((*read-suppress* t))
688     (read stream t nil t))))
689     (values))
690    
691     (defvar *shebang-readtable*
692     (let ((*readtable* (copy-readtable nil)))
693     (set-dispatch-macro-character #\# #\!
694     (lambda (s c n) (shebang-reader s c n))
695     *readtable*)
696     *readtable*))
697    
698     (defun shebang-readtable ()
699     *shebang-readtable*)
700    
701     (defun sbcl-package-p (package)
702     (let ((name (package-name package)))
703     (eql (mismatch "SB-" name) 3)))
704    
705     (defvar *debootstrap-packages* t)
706    
707     (defimplementation call-with-syntax-hooks (fn)
708 heller 1.89 (cond ((and *debootstrap-packages*
709 heller 1.88 (sbcl-package-p *package*))
710     (handler-bind ((sb-int:bootstrap-package-not-found
711     #'sb-int:debootstrap-package))
712     (funcall fn)))
713     (t
714     (funcall fn))))
715 heller 1.63
716 heller 1.90 (defimplementation default-readtable-alist ()
717     (let ((readtable (shebang-readtable)))
718     (loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
719     collect (cons (package-name p) readtable))))
720    
721 heller 1.63
722 lgorrie 1.50 ;;;; Multiprocessing
723    
724 heller 1.81 #+sb-thread
725 lgorrie 1.50 (progn
726 lgorrie 1.54 (defimplementation spawn (fn &key name)
727 lgorrie 1.50 (declare (ignore name))
728     (sb-thread:make-thread fn))
729    
730 heller 1.85 (defimplementation startup-multiprocessing ())
731 lgorrie 1.50
732 heller 1.63 (defimplementation thread-name (thread)
733     (format nil "Thread ~D" thread))
734 lgorrie 1.50
735 heller 1.63 (defimplementation thread-status (thread)
736     (declare (ignore thread))
737     "???")
738 lgorrie 1.50
739 lgorrie 1.54 (defimplementation make-lock (&key name)
740 lgorrie 1.50 (sb-thread:make-mutex :name name))
741    
742 lgorrie 1.54 (defimplementation call-with-lock-held (lock function)
743 heller 1.58 (declare (type function function))
744 lgorrie 1.50 (sb-thread:with-mutex (lock) (funcall function)))
745 heller 1.59
746     (defimplementation current-thread ()
747     (sb-thread:current-thread-id))
748    
749 heller 1.63 (defimplementation all-threads ()
750 heller 1.59 (sb-thread::mapcar-threads
751     (lambda (sap)
752     (sb-sys:sap-ref-32 sap (* sb-vm:n-word-bytes
753     sb-vm::thread-pid-slot)))))
754    
755     (defimplementation interrupt-thread (thread fn)
756     (sb-thread:interrupt-thread thread fn))
757    
758 heller 1.70 (defimplementation kill-thread (thread)
759     (sb-thread:terminate-thread thread))
760    
761     ;; XXX there is some deadlock / race condition here (with old 2.4 kernels)
762 heller 1.59
763     (defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
764     (defvar *mailboxes* (list))
765 heller 1.60 (declaim (type list *mailboxes*))
766 heller 1.59
767     (defstruct (mailbox (:conc-name mailbox.))
768     thread
769     (mutex (sb-thread:make-mutex))
770     (waitqueue (sb-thread:make-waitqueue))
771     (queue '() :type list))
772    
773     (defun mailbox (thread)
774     "Return THREAD's mailbox."
775     (sb-thread:with-mutex (*mailbox-lock*)
776     (or (find thread *mailboxes* :key #'mailbox.thread)
777     (let ((mb (make-mailbox :thread thread)))
778     (push mb *mailboxes*)
779     mb))))
780    
781     (defimplementation send (thread message)
782     (let* ((mbox (mailbox thread))
783     (mutex (mailbox.mutex mbox)))
784     (sb-thread:with-mutex (mutex)
785     (setf (mailbox.queue mbox)
786     (nconc (mailbox.queue mbox) (list message)))
787     (sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
788    
789     (defimplementation receive ()
790     (let* ((mbox (mailbox (sb-thread:current-thread-id)))
791     (mutex (mailbox.mutex mbox)))
792     (sb-thread:with-mutex (mutex)
793     (loop
794     (let ((q (mailbox.queue mbox)))
795     (cond (q (return (pop (mailbox.queue mbox))))
796     (t (sb-thread:condition-wait (mailbox.waitqueue mbox)
797     mutex))))))))
798    
799     )

  ViewVC Help
Powered by ViewVC 1.1.5