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

Contents of /slime/swank-sbcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5