1
0
Fork 0
mirror of synced 2024-12-27 00:53:20 -05:00
ultimate-vim/sources_non_forked/slimv/slime/swank/sbcl.lisp
2022-06-05 18:14:25 +08:00

2036 lines
79 KiB
Common Lisp
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;;;; -*- indent-tabs-mode: nil -*-
;;;
;;; swank-sbcl.lisp --- SLIME backend for SBCL.
;;;
;;; Created 2003, Daniel Barlow <dan@metacircles.com>
;;;
;;; This code has been placed in the Public Domain. All warranties are
;;; disclaimed.
;;; Requires the SB-INTROSPECT contrib.
;;; Administrivia
(defpackage swank/sbcl
(:use cl swank/backend swank/source-path-parser swank/source-file-cache))
(in-package swank/sbcl)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'sb-bsd-sockets)
(require 'sb-introspect)
(require 'sb-posix)
(require 'sb-cltl2))
(declaim (optimize (debug 2)
(sb-c::insert-step-conditions 0)
(sb-c::insert-debug-catch 0)))
;;; backwards compability tests
(eval-when (:compile-toplevel :load-toplevel :execute)
;; Generate a form suitable for testing for stepper support (0.9.17)
;; with #+.
(defun sbcl-with-new-stepper-p ()
(with-symbol 'enable-stepping 'sb-impl))
;; Ditto for weak hash-tables
(defun sbcl-with-weak-hash-tables ()
(with-symbol 'hash-table-weakness 'sb-ext))
;; And for xref support (1.0.1)
(defun sbcl-with-xref-p ()
(with-symbol 'who-calls 'sb-introspect))
;; ... for restart-frame support (1.0.2)
(defun sbcl-with-restart-frame ()
(with-symbol 'frame-has-debug-tag-p 'sb-debug))
;; ... for :setf :inverse info (1.1.17)
(defun sbcl-with-setf-inverse-meta-info ()
(boolean-to-feature-expression
;; going through FIND-SYMBOL since META-INFO was renamed from
;; TYPE-INFO in 1.2.10.
(let ((sym (find-symbol "META-INFO" "SB-C")))
(and sym
(fboundp sym)
(funcall sym :setf :inverse ()))))))
;;; swank-mop
(import-swank-mop-symbols :sb-mop '(:slot-definition-documentation))
(defun swank-mop:slot-definition-documentation (slot)
(sb-pcl::documentation slot t))
;; stream support
(defimplementation gray-package-name ()
"SB-GRAY")
;; Pretty printer calls this, apparently
(defmethod sb-gray:stream-line-length
((s sb-gray:fundamental-character-input-stream))
nil)
;;; Connection info
(defimplementation lisp-implementation-type-name ()
"sbcl")
;; Declare return type explicitly to shut up STYLE-WARNINGS about
;; %SAP-ALIEN in ENABLE-SIGIO-ON-FD below.
(declaim (ftype (function () (values (signed-byte 32) &optional)) getpid))
(defimplementation getpid ()
(sb-posix:getpid))
;;; UTF8
(defimplementation string-to-utf8 (string)
(sb-ext:string-to-octets string :external-format '(:utf8 :replacement
#+sb-unicode #\Replacement_Character
#-sb-unicode #\? )))
(defimplementation utf8-to-string (octets)
(sb-ext:octets-to-string octets :external-format '(:utf8 :replacement
#+sb-unicode #\Replacement_Character
#-sb-unicode #\? )))
;;; TCP Server
(defimplementation preferred-communication-style ()
(cond
;; fixme: when SBCL/win32 gains better select() support, remove
;; this.
((member :sb-thread *features*) :spawn)
((member :win32 *features*) nil)
(t :fd-handler)))
(defun resolve-hostname (host)
"Returns valid IPv4 or IPv6 address for the host."
;; get all IPv4 and IPv6 addresses as a list
(let* ((host-ents (multiple-value-list (sb-bsd-sockets:get-host-by-name host)))
;; remove protocols for which we don't have an address
(addresses (remove-if-not #'sb-bsd-sockets:host-ent-address host-ents)))
;; Return the first one or nil,
;; but actually, it shouln't return nil, because
;; get-host-by-name will signal NAME-SERVICE-ERROR condition
;; if there isn't any address for the host.
(first addresses)))
(defimplementation create-socket (host port &key backlog)
(let* ((host-ent (resolve-hostname host))
(socket (make-instance (cond #+#.(swank/backend:with-symbol 'inet6-socket 'sb-bsd-sockets)
((eql (sb-bsd-sockets:host-ent-address-type host-ent) 10)
'sb-bsd-sockets:inet6-socket)
(t
'sb-bsd-sockets:inet-socket))
:type :stream
:protocol :tcp)))
(setf (sb-bsd-sockets:sockopt-reuse-address socket) t)
(sb-bsd-sockets:socket-bind socket (sb-bsd-sockets:host-ent-address host-ent) port)
(sb-bsd-sockets:socket-listen socket (or backlog 5))
socket))
(defimplementation local-port (socket)
(nth-value 1 (sb-bsd-sockets:socket-name socket)))
(defimplementation close-socket (socket)
(sb-sys:invalidate-descriptor (socket-fd socket))
(sb-bsd-sockets:socket-close socket))
(defimplementation accept-connection (socket &key
external-format
buffering timeout)
(declare (ignore timeout))
(make-socket-io-stream (accept socket) external-format
(ecase buffering
((t :full) :full)
((nil :none) :none)
((:line) :line))))
;; The SIGIO stuff should probably be removed as it's unlikey that
;; anybody uses it.
#-win32
(progn
(defimplementation install-sigint-handler (function)
(sb-sys:enable-interrupt sb-unix:sigint
(lambda (&rest args)
(declare (ignore args))
(sb-sys:invoke-interruption
(lambda ()
(sb-sys:with-interrupts
(funcall function)))))))
(defvar *sigio-handlers* '()
"List of (key . fn) pairs to be called on SIGIO.")
(defun sigio-handler (signal code scp)
(declare (ignore signal code scp))
(sb-sys:with-interrupts
(mapc (lambda (handler)
(funcall (the function (cdr handler))))
*sigio-handlers*)))
(defun set-sigio-handler ()
(sb-sys:enable-interrupt sb-unix:sigio #'sigio-handler))
(defun enable-sigio-on-fd (fd)
(sb-posix::fcntl fd sb-posix::f-setfl sb-posix::o-async)
(sb-posix::fcntl fd sb-posix::f-setown (getpid))
(values))
(defimplementation add-sigio-handler (socket fn)
(set-sigio-handler)
(let ((fd (socket-fd socket)))
(enable-sigio-on-fd fd)
(push (cons fd fn) *sigio-handlers*)))
(defimplementation remove-sigio-handlers (socket)
(let ((fd (socket-fd socket)))
(setf *sigio-handlers* (delete fd *sigio-handlers* :key #'car))
(sb-sys:invalidate-descriptor fd))
(close socket)))
(defimplementation add-fd-handler (socket fun)
(let ((fd (socket-fd socket))
(handler nil))
(labels ((add ()
(setq handler (sb-sys:add-fd-handler fd :input #'run)))
(run (fd)
(sb-sys:remove-fd-handler handler) ; prevent recursion
(unwind-protect
(funcall fun)
(when (sb-unix:unix-fstat fd) ; still open?
(add)))))
(add))))
(defimplementation remove-fd-handlers (socket)
(sb-sys:invalidate-descriptor (socket-fd socket)))
(defimplementation socket-fd (socket)
(etypecase socket
(fixnum socket)
(sb-bsd-sockets:socket (sb-bsd-sockets:socket-file-descriptor socket))
(file-stream (sb-sys:fd-stream-fd socket))))
(defimplementation command-line-args ()
sb-ext:*posix-argv*)
(defimplementation dup (fd)
(sb-posix:dup fd))
(defvar *wait-for-input-called*)
(defimplementation wait-for-input (streams &optional timeout)
(assert (member timeout '(nil t)))
(when (boundp '*wait-for-input-called*)
(setq *wait-for-input-called* t))
(let ((*wait-for-input-called* nil))
(loop
(let ((ready (remove-if-not #'input-ready-p streams)))
(when ready (return ready)))
(when (check-slime-interrupts)
(return :interrupt))
(when *wait-for-input-called*
(return :interrupt))
(when timeout
(return nil))
(sleep 0.1))))
(defun fd-stream-input-buffer-empty-p (stream)
(let ((buffer (sb-impl::fd-stream-ibuf stream)))
(or (not buffer)
(= (sb-impl::buffer-head buffer)
(sb-impl::buffer-tail buffer)))))
#-win32
(defun input-ready-p (stream)
(or (not (fd-stream-input-buffer-empty-p stream))
#+#.(swank/backend:with-symbol 'fd-stream-fd-type 'sb-impl)
(eq :regular (sb-impl::fd-stream-fd-type stream))
(not (sb-impl::sysread-may-block-p stream))))
#+win32
(progn
(defun input-ready-p (stream)
(or (not (fd-stream-input-buffer-empty-p stream))
(handle-listen (sockint::fd->handle (sb-impl::fd-stream-fd stream)))))
(sb-alien:define-alien-routine ("WSACreateEvent" wsa-create-event)
sb-win32:handle)
(sb-alien:define-alien-routine ("WSACloseEvent" wsa-close-event)
sb-alien:int
(event sb-win32:handle))
(defconstant +fd-read+ #.(ash 1 0))
(defconstant +fd-close+ #.(ash 1 5))
(sb-alien:define-alien-routine ("WSAEventSelect" wsa-event-select)
sb-alien:int
(fd sb-alien:int)
(handle sb-win32:handle)
(mask sb-alien:long))
(sb-alien:load-shared-object "kernel32.dll")
(sb-alien:define-alien-routine ("WaitForSingleObjectEx"
wait-for-single-object-ex)
sb-alien:int
(event sb-win32:handle)
(milliseconds sb-alien:long)
(alertable sb-alien:int))
;; see SB-WIN32:HANDLE-LISTEN
(defun handle-listen (handle)
(sb-alien:with-alien ((avail sb-win32:dword)
(buf (array char #.sb-win32::input-record-size)))
(unless (zerop (sb-win32:peek-named-pipe handle nil 0 nil
(sb-alien:alien-sap
(sb-alien:addr avail))
nil))
(return-from handle-listen (plusp avail)))
(unless (zerop (sb-win32:peek-console-input handle
(sb-alien:alien-sap buf)
sb-win32::input-record-size
(sb-alien:alien-sap
(sb-alien:addr avail))))
(return-from handle-listen (plusp avail))))
(let ((event (wsa-create-event)))
(wsa-event-select handle event (logior +fd-read+ +fd-close+))
(let ((val (wait-for-single-object-ex event 0 0)))
(wsa-close-event event)
(unless (= val -1)
(return-from handle-listen (zerop val)))))
nil)
)
(defvar *external-format-to-coding-system*
'((:iso-8859-1
"latin-1" "latin-1-unix" "iso-latin-1-unix"
"iso-8859-1" "iso-8859-1-unix")
(:utf-8 "utf-8" "utf-8-unix")
(:euc-jp "euc-jp" "euc-jp-unix")
(:us-ascii "us-ascii" "us-ascii-unix")))
;; C.f. R.M.Kreuter in <20536.1219412774@progn.net> on sbcl-general,
;; 2008-08-22.
(defvar *physical-pathname-host* (pathname-host (user-homedir-pathname)))
(defimplementation filename-to-pathname (filename)
(sb-ext:parse-native-namestring filename *physical-pathname-host*))
(defimplementation find-external-format (coding-system)
(car (rassoc-if (lambda (x) (member coding-system x :test #'equal))
*external-format-to-coding-system*)))
(defimplementation set-default-directory (directory)
(let ((directory (truename (merge-pathnames directory))))
(sb-posix:chdir directory)
(setf *default-pathname-defaults* directory)
(default-directory)))
(defun make-socket-io-stream (socket external-format buffering)
(let ((args `(:output t
:input t
:element-type ,(if external-format
'character
'(unsigned-byte 8))
:buffering ,buffering
,@(cond ((and external-format (sb-int:featurep :sb-unicode))
`(:external-format ,external-format))
(t '()))
:serve-events ,(eq :fd-handler swank:*communication-style*)
;; SBCL < 1.0.42.43 doesn't support :SERVE-EVENTS
;; argument.
:allow-other-keys t)))
(apply #'sb-bsd-sockets:socket-make-stream socket args)))
(defun accept (socket)
"Like socket-accept, but retry on EAGAIN."
(loop (handler-case
(return (sb-bsd-sockets:socket-accept socket))
(sb-bsd-sockets:interrupted-error ()))))
;;;; Support for SBCL syntax
;;; SBCL's source code is riddled with #! reader macros. Also symbols
;;; containing `!' have special meaning. We have to work long and
;;; hard to be able to read the source. To deal with #! reader
;;; macros, we use a special readtable. The special symbols are
;;; converted by a condition handler.
(defun feature-in-list-p (feature list)
(etypecase feature
(symbol (member feature list :test #'eq))
(cons (flet ((subfeature-in-list-p (subfeature)
(feature-in-list-p subfeature list)))
;; Don't use ECASE since SBCL also has :host-feature,
;; don't need to handle it or anything else appearing in
;; the future or in erronous code.
(case (first feature)
(:or (some #'subfeature-in-list-p (rest feature)))
(:and (every #'subfeature-in-list-p (rest feature)))
(:not (destructuring-bind (e) (cdr feature)
(not (subfeature-in-list-p e)))))))))
(defun shebang-reader (stream sub-character infix-parameter)
(declare (ignore sub-character))
(when infix-parameter
(error "illegal read syntax: #~D!" infix-parameter))
(let ((next-char (read-char stream)))
(unless (find next-char "+-")
(error "illegal read syntax: #!~C" next-char))
;; When test is not satisfied
;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
;; would become "unless test is satisfied"..
(when (let* ((*package* (find-package "KEYWORD"))
(*read-suppress* nil)
(not-p (char= next-char #\-))
(feature (read stream)))
(if (feature-in-list-p feature *features*)
not-p
(not not-p)))
;; Read (and discard) a form from input.
(let ((*read-suppress* t))
(read stream t nil t))))
(values))
(defvar *shebang-readtable*
(let ((*readtable* (copy-readtable nil)))
(set-dispatch-macro-character #\# #\!
(lambda (s c n) (shebang-reader s c n))
*readtable*)
*readtable*))
(defun shebang-readtable ()
*shebang-readtable*)
(defun sbcl-package-p (package)
(let ((name (package-name package)))
(eql (mismatch "SB-" name) 3)))
(defun sbcl-source-file-p (filename)
(when filename
(loop for (nil pattern) in (logical-pathname-translations "SYS")
thereis (pathname-match-p filename pattern))))
(defun guess-readtable-for-filename (filename)
(if (sbcl-source-file-p filename)
(shebang-readtable)
*readtable*))
(defvar *debootstrap-packages* t)
(defun call-with-debootstrapping (fun)
(handler-bind ((sb-int:bootstrap-package-not-found
#'sb-int:debootstrap-package))
(funcall fun)))
(defmacro with-debootstrapping (&body body)
`(call-with-debootstrapping (lambda () ,@body)))
(defimplementation call-with-syntax-hooks (fn)
(cond ((and *debootstrap-packages*
(sbcl-package-p *package*))
(with-debootstrapping (funcall fn)))
(t
(funcall fn))))
(defimplementation default-readtable-alist ()
(let ((readtable (shebang-readtable)))
(loop for p in (remove-if-not #'sbcl-package-p (list-all-packages))
collect (cons (package-name p) readtable))))
;;; Packages
#+#.(swank/backend:with-symbol 'package-local-nicknames 'sb-ext)
(defimplementation package-local-nicknames (package)
(sb-ext:package-local-nicknames package))
;;; Utilities
#+#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect)
(defimplementation arglist (fname)
(sb-introspect:function-lambda-list fname))
#-#.(swank/backend:with-symbol 'function-lambda-list 'sb-introspect)
(defimplementation arglist (fname)
(sb-introspect:function-arglist fname))
(defimplementation function-name (f)
(check-type f function)
(sb-impl::%fun-name f))
(defmethod declaration-arglist ((decl-identifier (eql 'optimize)))
(flet ((ensure-list (thing) (if (listp thing) thing (list thing))))
(let* ((flags (sb-cltl2:declaration-information decl-identifier)))
(if flags
;; Symbols aren't printed with package qualifiers, but the
;; FLAGS would have to be fully qualified when used inside a
;; declaration. So we strip those as long as there's no
;; better way. (FIXME)
`(&any ,@(remove-if-not
#'(lambda (qualifier)
(find-symbol (symbol-name (first qualifier)) :cl))
flags :key #'ensure-list))
(call-next-method)))))
#+#.(swank/backend:with-symbol 'deftype-lambda-list 'sb-introspect)
(defmethod type-specifier-arglist :around (typespec-operator)
(multiple-value-bind (arglist foundp)
(sb-introspect:deftype-lambda-list typespec-operator)
(if foundp arglist (call-next-method))))
(defimplementation type-specifier-p (symbol)
(or (sb-ext:valid-type-specifier-p symbol)
(not (eq (type-specifier-arglist symbol) :not-available))))
(defvar *buffer-name* nil)
(defvar *buffer-tmpfile* nil)
(defvar *buffer-offset*)
(defvar *buffer-substring* nil)
(defvar *previous-compiler-condition* nil
"Used to detect duplicates.")
(defun handle-notification-condition (condition)
"Handle a condition caused by a compiler warning.
This traps all compiler conditions at a lower-level than using
C:*COMPILER-NOTIFICATION-FUNCTION*. The advantage is that we get to
craft our own error messages, which can omit a lot of redundant
information."
(unless (or (eq condition *previous-compiler-condition*))
;; First resignal warnings, so that outer handlers -- which may choose to
;; muffle this -- get a chance to run.
(when (typep condition 'warning)
(signal condition))
(setq *previous-compiler-condition* condition)
(signal-compiler-condition (real-condition condition)
(sb-c::find-error-context nil))))
(defun signal-compiler-condition (condition context)
(signal 'compiler-condition
:original-condition condition
:severity (etypecase condition
(sb-ext:compiler-note :note)
(sb-c:compiler-error :error)
(reader-error :read-error)
(error :error)
#+#.(swank/backend:with-symbol early-deprecation-warning sb-ext)
(sb-ext::early-deprecation-warning :early-deprecation-warning)
#+#.(swank/backend:with-symbol late-deprecation-warning sb-ext)
(sb-ext::late-deprecation-warning :late-deprecation-warning)
#+#.(swank/backend:with-symbol final-deprecation-warning sb-ext)
(sb-ext::final-deprecation-warning :final-deprecation-warning)
#+#.(swank/backend:with-symbol redefinition-warning
sb-kernel)
(sb-kernel:redefinition-warning
:redefinition)
(style-warning :style-warning)
(warning :warning))
:references (condition-references condition)
:message (brief-compiler-message-for-emacs condition)
:source-context (compiler-error-context context)
:location (compiler-note-location condition context)))
(defun real-condition (condition)
"Return the encapsulated condition or CONDITION itself."
(typecase condition
(sb-int:encapsulated-condition (sb-int:encapsulated-condition condition))
(t condition)))
(defun condition-references (condition)
(if (typep condition 'sb-int:reference-condition)
(externalize-reference
(sb-int:reference-condition-references condition))))
(defun compiler-note-location (condition context)
(flet ((bailout ()
(return-from compiler-note-location
(make-error-location "No error location available"))))
(cond (context
(locate-compiler-note
(sb-c::compiler-error-context-file-name context)
(compiler-source-path context)
(sb-c::compiler-error-context-original-source context)))
((typep condition 'reader-error)
(let* ((stream (stream-error-stream condition))
;; If STREAM is, for example, a STRING-INPUT-STREAM,
;; an error will be signaled since PATHNAME only
;; accepts a "stream associated with a file" which
;; is a complicated predicate and hard to test
;; portably.
(file (ignore-errors (pathname stream))))
(unless (and file (open-stream-p stream))
(bailout))
(if (compiling-from-buffer-p file)
;; The stream position for e.g. "comma not inside
;; backquote" is at the character following the
;; comma, :offset is 0-based, hence the 1-.
(make-location (list :buffer *buffer-name*)
(list :offset *buffer-offset*
(1- (file-position stream))))
(progn
(assert (compiling-from-file-p file))
;; No 1- because :position is 1-based.
(make-location (list :file (namestring file))
(list :position (file-position stream)))))))
(t (bailout)))))
(defun compiling-from-buffer-p (filename)
(and *buffer-name*
;; The following is to trigger COMPILING-FROM-GENERATED-CODE-P
;; in LOCATE-COMPILER-NOTE, and allows handling nested
;; compilation from eg. hitting C-C on (eval-when ... (require ..))).
;;
;; PROBE-FILE to handle tempfile directory being a symlink.
(pathnamep filename)
(let ((true1 (probe-file filename))
(true2 (probe-file *buffer-tmpfile*)))
(and true1 (equal true1 true2)))))
(defun compiling-from-file-p (filename)
(and (pathnamep filename)
(or (null *buffer-name*)
(null *buffer-tmpfile*)
(let ((true1 (probe-file filename))
(true2 (probe-file *buffer-tmpfile*)))
(not (and true1 (equal true1 true2)))))))
(defun compiling-from-generated-code-p (filename source)
(and (eq filename :lisp) (stringp source)))
(defun locate-compiler-note (file source-path source)
(cond ((compiling-from-buffer-p file)
(make-location (list :buffer *buffer-name*)
(list :offset *buffer-offset*
(source-path-string-position
source-path *buffer-substring*))))
((compiling-from-file-p file)
(let ((position (source-path-file-position source-path file)))
(make-location (list :file (namestring file))
(list :position (and position
(1+ position))))))
((compiling-from-generated-code-p file source)
(make-location (list :source-form source)
(list :position 1)))
(t
(error "unhandled case in compiler note ~S ~S ~S"
file source-path source))))
(defun brief-compiler-message-for-emacs (condition)
"Briefly describe a compiler error for Emacs.
When Emacs presents the message it already has the source popped up
and the source form highlighted. This makes much of the information in
the error-context redundant."
(let ((sb-int:*print-condition-references* nil))
(princ-to-string condition)))
(defun compiler-error-context (error-context)
"Describe a compiler error for Emacs including context information."
(declare (type (or sb-c::compiler-error-context null) error-context))
(multiple-value-bind (enclosing source)
(if error-context
(values (sb-c::compiler-error-context-enclosing-source error-context)
(sb-c::compiler-error-context-source error-context)))
(and (or enclosing source)
(format nil "~@[--> ~{~<~%--> ~1:;~A~> ~}~%~]~@[~{==>~%~A~%~}~]"
enclosing source))))
(defun compiler-source-path (context)
"Return the source-path for the current compiler error.
Returns NIL if this cannot be determined by examining internal
compiler state."
(cond ((sb-c::node-p context)
(reverse
(sb-c::source-path-original-source
(sb-c::node-source-path context))))
((sb-c::compiler-error-context-p context)
(reverse
(sb-c::compiler-error-context-original-source-path context)))))
(defimplementation call-with-compilation-hooks (function)
(declare (type function function))
(handler-bind
;; N.B. Even though these handlers are called HANDLE-FOO they
;; actually decline, i.e. the signalling of the original
;; condition continues upward.
((sb-c:fatal-compiler-error #'handle-notification-condition)
(sb-c:compiler-error #'handle-notification-condition)
(sb-ext:compiler-note #'handle-notification-condition)
(error #'handle-notification-condition)
(warning #'handle-notification-condition))
(funcall function)))
;;; HACK: SBCL 1.2.12 shipped with a bug where
;;; SB-EXT:RESTRICT-COMPILER-POLICY would signal an error when there
;;; were no policy restrictions in place. This workaround ensures the
;;; existence of at least one dummy restriction.
(handler-case (sb-ext:restrict-compiler-policy)
(error () (sb-ext:restrict-compiler-policy 'debug)))
(defun compiler-policy (qualities)
"Return compiler policy qualities present in the QUALITIES alist.
QUALITIES is an alist with (quality . value)"
#+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext)
(loop with policy = (sb-ext:restrict-compiler-policy)
for (quality) in qualities
collect (cons quality
(or (cdr (assoc quality policy))
0))))
(defun (setf compiler-policy) (policy)
(declare (ignorable policy))
#+#.(swank/backend:with-symbol 'restrict-compiler-policy 'sb-ext)
(loop for (qual . value) in policy
do (sb-ext:restrict-compiler-policy qual value)))
(defmacro with-compiler-policy (policy &body body)
(let ((current-policy (gensym)))
`(let ((,current-policy (compiler-policy ,policy)))
(setf (compiler-policy) ,policy)
(unwind-protect (progn ,@body)
(setf (compiler-policy) ,current-policy)))))
(defimplementation swank-compile-file (input-file output-file
load-p external-format
&key policy)
(multiple-value-bind (output-file warnings-p failure-p)
(with-compiler-policy policy
(with-compilation-hooks ()
(compile-file input-file :output-file output-file
:external-format external-format)))
(values output-file warnings-p
(or failure-p
(when load-p
;; Cache the latest source file for definition-finding.
(source-cache-get input-file
(file-write-date input-file))
(not (load output-file)))))))
;;;; compile-string
;;; We copy the string to a temporary file in order to get adequate
;;; semantics for :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL EVAL-WHEN forms
;;; which the previous approach using
;;; (compile nil `(lambda () ,(read-from-string string)))
;;; did not provide.
(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
(sb-alien:define-alien-routine (#-win32 "tempnam" #+win32 "_tempnam" tempnam)
sb-alien:c-string
(dir sb-alien:c-string)
(prefix sb-alien:c-string)))
(defun temp-file-name ()
"Return a temporary file name to compile strings into."
(tempnam nil "slime"))
(defvar *trap-load-time-warnings* t)
(defimplementation swank-compile-string (string &key buffer position filename
line column policy)
(declare (ignore line column))
(let ((*buffer-name* buffer)
(*buffer-offset* position)
(*buffer-substring* string)
(*buffer-tmpfile* (temp-file-name)))
(labels ((load-it (filename)
(cond (*trap-load-time-warnings*
(with-compilation-hooks () (load filename)))
(t (load filename))))
(cf ()
(with-compiler-policy policy
(with-compilation-unit
(:source-plist (list :emacs-buffer buffer
:emacs-filename filename
:emacs-package (package-name *package*)
:emacs-position position
:emacs-string string)
:source-namestring filename
:allow-other-keys t)
(compile-file *buffer-tmpfile* :external-format :utf-8)))))
(with-open-file (s *buffer-tmpfile* :direction :output :if-exists :error
:external-format :utf-8)
(write-string string s))
(unwind-protect
(multiple-value-bind (output-file warningsp failurep)
(with-compilation-hooks () (cf))
(declare (ignore warningsp))
(when output-file
(load-it output-file))
(not failurep))
(ignore-errors
(delete-file *buffer-tmpfile*)
(delete-file (compile-file-pathname *buffer-tmpfile*)))))))
;;;; Definitions
(defparameter *definition-types*
'(:variable defvar
:constant defconstant
:type deftype
:symbol-macro define-symbol-macro
:macro defmacro
:compiler-macro define-compiler-macro
:function defun
:generic-function defgeneric
:method defmethod
:setf-expander define-setf-expander
:structure defstruct
:condition define-condition
:class defclass
:method-combination define-method-combination
:package defpackage
:transform :deftransform
:optimizer :defoptimizer
:vop :define-vop
:source-transform :define-source-transform
:ir1-convert :def-ir1-translator
:declaration declaim
:alien-type :define-alien-type)
"Map SB-INTROSPECT definition type names to Slime-friendly forms")
(defun definition-specifier (type)
"Return a pretty specifier for NAME representing a definition of type TYPE."
(getf *definition-types* type))
(defun make-dspec (type name source-location)
(list* (definition-specifier type)
name
(sb-introspect::definition-source-description source-location)))
(defimplementation find-definitions (name)
(loop for type in *definition-types* by #'cddr
for defsrcs = (sb-introspect:find-definition-sources-by-name name type)
for filtered-defsrcs = (if (eq type :generic-function)
(remove :invalid defsrcs
:key #'categorize-definition-source)
defsrcs)
append (loop for defsrc in filtered-defsrcs collect
(list (make-dspec type name defsrc)
(converting-errors-to-error-location
(definition-source-for-emacs defsrc
type name))))))
(defimplementation find-source-location (obj)
(flet ((general-type-of (obj)
(typecase obj
(method :method)
(generic-function :generic-function)
(function :function)
(structure-class :structure-class)
(class :class)
(method-combination :method-combination)
(package :package)
(condition :condition)
(structure-object :structure-object)
(standard-object :standard-object)
(t :thing)))
(to-string (obj)
(typecase obj
;; Packages are possibly named entities.
(package (princ-to-string obj))
((or structure-object standard-object condition)
(with-output-to-string (s)
(print-unreadable-object (obj s :type t :identity t))))
(t (princ-to-string obj)))))
(converting-errors-to-error-location
(let ((defsrc (sb-introspect:find-definition-source obj)))
(definition-source-for-emacs defsrc
(general-type-of obj)
(to-string obj))))))
(defmacro with-definition-source ((&rest names) obj &body body)
"Like with-slots but works only for structs."
(flet ((reader (slot)
;; Use read-from-string instead of intern so that
;; conc-name can be a string such as ext:struct- and not
;; cause errors and not force interning ext::struct-
(read-from-string
(concatenate 'string "sb-introspect:definition-source-"
(string slot)))))
(let ((tmp (gensym "OO-")))
` (let ((,tmp ,obj))
(symbol-macrolet
,(loop for name in names collect
(typecase name
(symbol `(,name (,(reader name) ,tmp)))
(cons `(,(first name) (,(reader (second name)) ,tmp)))
(t (error "Malformed syntax in WITH-STRUCT: ~A" name))))
,@body)))))
(defun categorize-definition-source (definition-source)
(with-definition-source (pathname form-path character-offset plist)
definition-source
(let ((file-p (and pathname (probe-file pathname)
(or form-path character-offset))))
(cond ((and (getf plist :emacs-buffer) file-p) :buffer-and-file)
((getf plist :emacs-buffer) :buffer)
(file-p :file)
(pathname :file-without-position)
(t :invalid)))))
#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
(defun form-number-position (definition-source stream)
(let* ((tlf-number (car (sb-introspect:definition-source-form-path definition-source)))
(form-number (sb-introspect:definition-source-form-number definition-source)))
(multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
(let* ((path-table (sb-di::form-number-translations tlf 0))
(path (cond ((<= (length path-table) form-number)
(warn "inconsistent form-number-translations")
(list 0))
(t
(reverse (cdr (aref path-table form-number)))))))
(source-path-source-position path tlf pos-map)))))
#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
(defun file-form-number-position (definition-source)
(let* ((code-date (sb-introspect:definition-source-file-write-date definition-source))
(filename (sb-introspect:definition-source-pathname definition-source))
(*readtable* (guess-readtable-for-filename filename))
(source-code (get-source-code filename code-date)))
(with-debootstrapping
(with-input-from-string (s source-code)
(form-number-position definition-source s)))))
#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
(defun string-form-number-position (definition-source string)
(with-input-from-string (s string)
(form-number-position definition-source s)))
(defun definition-source-buffer-location (definition-source)
(with-definition-source (form-path character-offset plist) definition-source
(destructuring-bind (&key emacs-buffer emacs-position emacs-directory
emacs-string &allow-other-keys)
plist
(let ((*readtable* (guess-readtable-for-filename emacs-directory))
start
end)
(with-debootstrapping
(or
(and form-path
(or
#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
(setf (values start end)
(and (sb-introspect:definition-source-form-number definition-source)
(string-form-number-position definition-source emacs-string)))
(setf (values start end)
(source-path-string-position form-path emacs-string))))
(setf start character-offset
end most-positive-fixnum)))
(make-location
`(:buffer ,emacs-buffer)
`(:offset ,emacs-position ,start)
`(:snippet
,(subseq emacs-string
start
(min end (+ start *source-snippet-size*)))))))))
(defun definition-source-file-location (definition-source)
(with-definition-source (pathname form-path character-offset plist
file-write-date) definition-source
(let* ((namestring (namestring (translate-logical-pathname pathname)))
(pos (or (and form-path
(or
#+#.(swank/backend:with-symbol 'definition-source-form-number 'sb-introspect)
(and (sb-introspect:definition-source-form-number definition-source)
(ignore-errors (file-form-number-position definition-source)))
(ignore-errors
(source-file-position namestring file-write-date
form-path))))
character-offset))
(snippet (source-hint-snippet namestring file-write-date pos)))
(make-location `(:file ,namestring)
;; /file positions/ in Common Lisp start from
;; 0, buffer positions in Emacs start from 1.
`(:position ,(1+ pos))
`(:snippet ,snippet)))))
(defun definition-source-buffer-and-file-location (definition-source)
(let ((buffer (definition-source-buffer-location definition-source)))
(make-location (list :buffer-and-file
(cadr (location-buffer buffer))
(namestring (sb-introspect:definition-source-pathname
definition-source)))
(location-position buffer)
(location-hints buffer))))
(defun definition-source-for-emacs (definition-source type name)
(with-definition-source (pathname form-path character-offset plist
file-write-date)
definition-source
(ecase (categorize-definition-source definition-source)
(:buffer-and-file
(definition-source-buffer-and-file-location definition-source))
(:buffer
(definition-source-buffer-location definition-source))
(:file
(definition-source-file-location definition-source))
(:file-without-position
(make-location `(:file ,(namestring
(translate-logical-pathname pathname)))
'(:position 1)
(when (eql type :function)
`(:snippet ,(format nil "(defun ~a "
(symbol-name name))))))
(:invalid
(error "DEFINITION-SOURCE of ~(~A~) ~A did not contain ~
meaningful information."
type name)))))
(defun source-file-position (filename write-date form-path)
(let ((source (get-source-code filename write-date))
(*readtable* (guess-readtable-for-filename filename)))
(with-debootstrapping
(source-path-string-position form-path source))))
(defun source-hint-snippet (filename write-date position)
(read-snippet-from-string (get-source-code filename write-date) position))
(defun function-source-location (function &optional name)
(declare (type function function))
(definition-source-for-emacs (sb-introspect:find-definition-source function)
:function
(or name (function-name function))))
(defun setf-expander (symbol)
(or
#+#.(swank/sbcl::sbcl-with-setf-inverse-meta-info)
(sb-int:info :setf :inverse symbol)
(sb-int:info :setf :expander symbol)))
(defimplementation describe-symbol-for-emacs (symbol)
"Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
(let ((result '()))
(flet ((doc (kind)
(or (documentation symbol kind) :not-documented))
(maybe-push (property value)
(when value
(setf result (list* property value result)))))
(maybe-push
:variable (multiple-value-bind (kind recorded-p)
(sb-int:info :variable :kind symbol)
(declare (ignore kind))
(if (or (boundp symbol) recorded-p)
(doc 'variable))))
(when (fboundp symbol)
(maybe-push
(cond ((macro-function symbol) :macro)
((special-operator-p symbol) :special-operator)
((typep (fdefinition symbol) 'generic-function)
:generic-function)
(t :function))
(doc 'function)))
(maybe-push
:setf (and (setf-expander symbol)
(doc 'setf)))
(maybe-push
:type (if (sb-int:info :type :kind symbol)
(doc 'type)))
result)))
(defimplementation describe-definition (symbol type)
(case type
(:variable
(describe symbol))
(:function
(describe (symbol-function symbol)))
(:setf
(describe (setf-expander symbol)))
(:class
(describe (find-class symbol)))
(:type
(describe (sb-kernel:values-specifier-type symbol)))))
#+#.(swank/sbcl::sbcl-with-xref-p)
(progn
(defmacro defxref (name &optional fn-name)
`(defimplementation ,name (what)
(sanitize-xrefs
(mapcar #'source-location-for-xref-data
(,(find-symbol (symbol-name (if fn-name
fn-name
name))
"SB-INTROSPECT")
what)))))
(defxref who-calls)
(defxref who-binds)
(defxref who-sets)
(defxref who-references)
(defxref who-macroexpands)
#+#.(swank/backend:with-symbol 'who-specializes-directly 'sb-introspect)
(defxref who-specializes who-specializes-directly))
(defun source-location-for-xref-data (xref-data)
(destructuring-bind (name . defsrc) xref-data
(list name (converting-errors-to-error-location
(definition-source-for-emacs defsrc 'function name)))))
(defimplementation list-callers (symbol)
(let ((fn (fdefinition symbol)))
(sanitize-xrefs
(mapcar #'function-dspec (sb-introspect:find-function-callers fn)))))
(defimplementation list-callees (symbol)
(let ((fn (fdefinition symbol)))
(sanitize-xrefs
(mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
(defun sanitize-xrefs (xrefs)
(remove-duplicates
(remove-if (lambda (f)
(member f (ignored-xref-function-names)))
(loop for entry in xrefs
for name = (car entry)
collect (if (and (consp name)
(member (car name)
'(sb-pcl::fast-method
sb-pcl::slow-method
sb-pcl::method)))
(cons (cons 'defmethod (cdr name))
(cdr entry))
entry))
:key #'car)
:test (lambda (a b)
(and (eq (first a) (first b))
(equal (second a) (second b))))))
(defun ignored-xref-function-names ()
#-#.(swank/sbcl::sbcl-with-new-stepper-p)
'(nil sb-c::step-form sb-c::step-values)
#+#.(swank/sbcl::sbcl-with-new-stepper-p)
'(nil))
(defun function-dspec (fn)
"Describe where the function FN was defined.
Return a list of the form (NAME LOCATION)."
(let ((name (function-name fn)))
(list name (converting-errors-to-error-location
(function-source-location fn name)))))
;;; macroexpansion
(defimplementation macroexpand-all (form &optional env)
(sb-cltl2:macroexpand-all form env))
(defimplementation collect-macro-forms (form &optional environment)
(let ((macro-forms '())
(compiler-macro-forms '())
(function-quoted-forms '()))
(sb-walker:walk-form
form environment
(lambda (form context environment)
(declare (ignore context))
(when (and (consp form)
(symbolp (car form)))
(cond ((eq (car form) 'function)
(push (cadr form) function-quoted-forms))
((member form function-quoted-forms)
nil)
((macro-function (car form) environment)
(push form macro-forms))
((not (eq form (compiler-macroexpand-1 form environment)))
(push form compiler-macro-forms))))
form))
(values macro-forms compiler-macro-forms)))
;;; Debugging
;;; Notice that SB-EXT:*INVOKE-DEBUGGER-HOOK* is slightly stronger
;;; than just a hook into BREAK. In particular, it'll make
;;; (LET ((*DEBUGGER-HOOK* NIL)) ..error..) drop into SLDB rather
;;; than the native debugger. That should probably be considered a
;;; feature.
(defun make-invoke-debugger-hook (hook)
(when hook
#'(sb-int:named-lambda swank-invoke-debugger-hook
(condition old-hook)
(if *debugger-hook*
nil ; decline, *DEBUGGER-HOOK* will be tried next.
(funcall hook condition old-hook)))))
(defun set-break-hook (hook)
(setq sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
(defun call-with-break-hook (hook continuation)
(let ((sb-ext:*invoke-debugger-hook* (make-invoke-debugger-hook hook)))
(funcall continuation)))
(defimplementation install-debugger-globally (function)
(setq *debugger-hook* function)
(set-break-hook function))
(defimplementation condition-extras (condition)
(cond #+#.(swank/sbcl::sbcl-with-new-stepper-p)
((typep condition 'sb-impl::step-form-condition)
`((:show-frame-source 0)))
((typep condition 'sb-int:reference-condition)
(let ((refs (sb-int:reference-condition-references condition)))
(if refs
`((:references ,(externalize-reference refs))))))))
(defun externalize-reference (ref)
(etypecase ref
(null nil)
(cons (cons (externalize-reference (car ref))
(externalize-reference (cdr ref))))
((or string number) ref)
(symbol
(cond ((eq (symbol-package ref) (symbol-package :test))
ref)
(t (symbol-name ref))))))
(defvar *sldb-stack-top*)
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(declare (type function debugger-loop-fn))
(let ((*sldb-stack-top*
(if (and (not *debug-swank-backend*)
sb-debug:*stack-top-hint*)
#+#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
(sb-debug::resolve-stack-top-hint)
#-#.(swank/backend:with-symbol 'resolve-stack-top-hint 'sb-debug)
sb-debug:*stack-top-hint*
(sb-di:top-frame)))
(sb-debug:*stack-top-hint* nil))
(handler-bind ((sb-di:debug-condition
(lambda (condition)
(signal 'sldb-condition
:original-condition condition))))
(funcall debugger-loop-fn))))
#+#.(swank/sbcl::sbcl-with-new-stepper-p)
(progn
(defimplementation activate-stepping (frame)
(declare (ignore frame))
(sb-impl::enable-stepping))
(defimplementation sldb-stepper-condition-p (condition)
(typep condition 'sb-ext:step-form-condition))
(defimplementation sldb-step-into ()
(invoke-restart 'sb-ext:step-into))
(defimplementation sldb-step-next ()
(invoke-restart 'sb-ext:step-next))
(defimplementation sldb-step-out ()
(invoke-restart 'sb-ext:step-out)))
(defimplementation call-with-debugger-hook (hook fun)
(let ((*debugger-hook* hook)
#+#.(swank/sbcl::sbcl-with-new-stepper-p)
(sb-ext:*stepper-hook*
(lambda (condition)
(typecase condition
(sb-ext:step-form-condition
(let ((sb-debug:*stack-top-hint* (sb-di::find-stepped-frame)))
(sb-impl::invoke-debugger condition)))))))
(handler-bind (#+#.(swank/sbcl::sbcl-with-new-stepper-p)
(sb-ext:step-condition #'sb-impl::invoke-stepper))
(call-with-break-hook hook fun))))
(defun nth-frame (index)
(do ((frame *sldb-stack-top* (sb-di:frame-down frame))
(i index (1- i)))
((zerop i) frame)))
(defimplementation compute-backtrace (start end)
"Return a list of frames starting with frame number START and
continuing to frame number END or, if END is nil, the last frame on the
stack."
(let ((end (or end most-positive-fixnum)))
(loop for f = (nth-frame start) then (sb-di:frame-down f)
for i from start below end
while f collect f)))
(defimplementation print-frame (frame stream)
(sb-debug::print-frame-call frame stream
:allow-other-keys t
:emergency-best-effort t))
(defimplementation frame-restartable-p (frame)
#+#.(swank/sbcl::sbcl-with-restart-frame)
(not (null (sb-debug:frame-has-debug-tag-p frame))))
(defimplementation frame-call (frame-number)
(multiple-value-bind (name args)
(sb-debug::frame-call (nth-frame frame-number))
(with-output-to-string (stream)
(locally (declare (sb-ext:muffle-conditions sb-ext:compiler-note))
(pprint-logical-block (stream nil :prefix "(" :suffix ")")
(locally (declare (sb-ext:unmuffle-conditions sb-ext:compiler-note))
(let ((*print-length* nil)
(*print-level* nil))
(prin1 (sb-debug::ensure-printable-object name) stream))
(let ((args (sb-debug::ensure-printable-object args)))
(if (listp args)
(format stream "~{ ~_~S~}" args)
(format stream " ~S" args)))))))))
;;;; Code-location -> source-location translation
;;; If debug-block info is avaibale, we determine the file position of
;;; the source-path for a code-location. If the code was compiled
;;; with C-c C-c, we have to search the position in the source string.
;;; If there's no debug-block info, we return the (less precise)
;;; source-location of the corresponding function.
(defun code-location-source-location (code-location)
(let* ((dsource (sb-di:code-location-debug-source code-location))
(plist (sb-c::debug-source-plist dsource))
(package (getf plist :emacs-package))
(*package* (or (and package
(find-package package))
*package*)))
(if (getf plist :emacs-buffer)
(emacs-buffer-source-location code-location plist)
#+#.(swank/backend:with-symbol 'debug-source-from 'sb-di)
(ecase (sb-di:debug-source-from dsource)
(:file (file-source-location code-location))
(:lisp (lisp-source-location code-location)))
#-#.(swank/backend:with-symbol 'debug-source-from 'sb-di)
(if (sb-di:debug-source-namestring dsource)
(file-source-location code-location)
(lisp-source-location code-location)))))
;;; FIXME: The naming policy of source-location functions is a bit
;;; fuzzy: we have FUNCTION-SOURCE-LOCATION which returns the
;;; source-location for a function, and we also have FILE-SOURCE-LOCATION &co
;;; which returns the source location for a _code-location_.
;;;
;;; Maybe these should be named code-location-file-source-location,
;;; etc, turned into generic functions, or something. In the very
;;; least the names should indicate the main entry point vs. helper
;;; status.
(defun file-source-location (code-location)
(if (code-location-has-debug-block-info-p code-location)
(source-file-source-location code-location)
(fallback-source-location code-location)))
(defun fallback-source-location (code-location)
(let ((fun (code-location-debug-fun-fun code-location)))
(cond (fun (function-source-location fun))
(t (error "Cannot find source location for: ~A " code-location)))))
(defun lisp-source-location (code-location)
(let ((source (prin1-to-string
(sb-debug::code-location-source-form code-location 100)))
(condition swank:*swank-debugger-condition*))
(if (and (typep condition 'sb-impl::step-form-condition)
(search "SB-IMPL::WITH-STEPPING-ENABLED" source
:test #'char-equal)
(search "SB-IMPL::STEP-FINISHED" source :test #'char-equal))
;; The initial form is utterly uninteresting -- and almost
;; certainly right there in the REPL.
(make-error-location "Stepping...")
(make-location `(:source-form ,source) '(:position 1)))))
(defun emacs-buffer-source-location (code-location plist)
(if (code-location-has-debug-block-info-p code-location)
(destructuring-bind (&key emacs-buffer emacs-position emacs-string
&allow-other-keys)
plist
(let* ((pos (string-source-position code-location emacs-string))
(snipped (read-snippet-from-string emacs-string pos)))
(make-location `(:buffer ,emacs-buffer)
`(:offset ,emacs-position ,pos)
`(:snippet ,snipped))))
(fallback-source-location code-location)))
(defun source-file-source-location (code-location)
(let* ((code-date (code-location-debug-source-created code-location))
(filename (code-location-debug-source-name code-location))
(*readtable* (guess-readtable-for-filename filename))
(source-code (get-source-code filename code-date)))
(with-debootstrapping
(with-input-from-string (s source-code)
(let* ((pos (stream-source-position code-location s))
(snippet (read-snippet s pos)))
(make-location `(:file ,filename)
`(:position ,pos)
`(:snippet ,snippet)))))))
(defun code-location-debug-source-name (code-location)
(namestring (truename (#.(swank/backend:choose-symbol
'sb-c 'debug-source-name
'sb-c 'debug-source-namestring)
(sb-di::code-location-debug-source code-location)))))
(defun code-location-debug-source-created (code-location)
(sb-c::debug-source-created
(sb-di::code-location-debug-source code-location)))
(defun code-location-debug-fun-fun (code-location)
(sb-di:debug-fun-fun (sb-di:code-location-debug-fun code-location)))
(defun code-location-has-debug-block-info-p (code-location)
(handler-case
(progn (sb-di:code-location-debug-block code-location)
t)
(sb-di:no-debug-blocks () nil)))
(defun stream-source-position (code-location stream)
(let* ((cloc (sb-debug::maybe-block-start-location code-location))
(tlf-number (sb-di::code-location-toplevel-form-offset cloc))
(form-number (sb-di::code-location-form-number cloc)))
(multiple-value-bind (tlf pos-map) (read-source-form tlf-number stream)
(let* ((path-table (sb-di::form-number-translations tlf 0))
(path (cond ((<= (length path-table) form-number)
(warn "inconsistent form-number-translations")
(list 0))
(t
(reverse (cdr (aref path-table form-number)))))))
(source-path-source-position path tlf pos-map)))))
(defun string-source-position (code-location string)
(with-input-from-string (s string)
(stream-source-position code-location s)))
;;; source-path-file-position and friends are in source-path-parser
(defimplementation frame-source-location (index)
(converting-errors-to-error-location
(code-location-source-location
(sb-di:frame-code-location (nth-frame index)))))
(defvar *keep-non-valid-locals* nil)
(defun frame-debug-vars (frame)
"Return a vector of debug-variables in frame."
(let* ((all-vars (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun frame)))
(loc (sb-di:frame-code-location frame))
(vars (if *keep-non-valid-locals*
all-vars
(remove-if (lambda (var)
(ecase (sb-di:debug-var-validity var loc)
(:valid nil)
((:invalid :unknown) t)))
all-vars)))
more-context
more-count)
(values (when vars
(loop for v across vars
unless
(case (debug-var-info v)
(:more-context
(setf more-context (debug-var-value v frame loc))
t)
(:more-count
(setf more-count (debug-var-value v frame loc))
t))
collect v))
more-context more-count)))
(defun debug-var-value (var frame location)
(ecase (sb-di:debug-var-validity var location)
(:valid (sb-di:debug-var-value var frame))
((:invalid :unknown) ':<not-available>)))
(defun debug-var-info (var)
;; Introduced by SBCL 1.0.49.76.
(let ((s (find-symbol "DEBUG-VAR-INFO" :sb-di)))
(when (and s (fboundp s))
(funcall s var))))
(defimplementation frame-locals (index)
(let* ((frame (nth-frame index))
(loc (sb-di:frame-code-location frame)))
(multiple-value-bind (vars more-context more-count)
(frame-debug-vars frame)
(let ((locals
(loop for v in vars
collect
(list :name (sb-di:debug-var-symbol v)
:id (sb-di:debug-var-id v)
:value (debug-var-value v frame loc)))))
(if (and more-context more-count)
(append locals
(list
(list :name
;; Since SBCL 1.0.49.76 PREPROCESS-FOR-EVAL understands SB-DEBUG::MORE
;; specially.
(or (find-symbol "MORE" :sb-debug) 'more)
:id 0
:value (multiple-value-list
(sb-c:%more-arg-values
more-context
0 more-count)))))
locals)))))
(defimplementation frame-var-value (frame var)
(let ((frame (nth-frame frame)))
(multiple-value-bind (vars more-context more-count)
(frame-debug-vars frame)
(let* ((loc (sb-di:frame-code-location frame))
(dvar (if (= var (length vars))
;; If VAR is out of bounds, it must be the fake var
;; we made up for &MORE.
(return-from frame-var-value
(multiple-value-list (sb-c:%more-arg-values
more-context
0 more-count)))
(nth var vars))))
(debug-var-value dvar frame loc)))))
(defimplementation frame-catch-tags (index)
(mapcar #'car (sb-di:frame-catches (nth-frame index))))
(defimplementation eval-in-frame (form index)
(let ((frame (nth-frame index)))
(funcall (the function
(sb-di:preprocess-for-eval form
(sb-di:frame-code-location frame)))
frame)))
(defimplementation frame-package (frame-number)
(let* ((frame (nth-frame frame-number))
(fun (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))))
(when fun
(let ((name (function-name fun)))
(typecase name
(null nil)
(symbol (symbol-package name))
((cons (eql setf) (cons symbol)) (symbol-package (cadr name))))))))
#+#.(swank/sbcl::sbcl-with-restart-frame)
(progn
(defimplementation return-from-frame (index form)
(let* ((frame (nth-frame index)))
(cond ((sb-debug:frame-has-debug-tag-p frame)
(let ((values (multiple-value-list (eval-in-frame form index))))
(sb-debug:unwind-to-frame-and-call frame
(lambda ()
(values-list values)))))
(t (format nil "Cannot return from frame: ~S" frame)))))
(defimplementation restart-frame (index)
(let ((frame (nth-frame index)))
(when (sb-debug:frame-has-debug-tag-p frame)
(multiple-value-bind (fname args) (sb-debug::frame-call frame)
(multiple-value-bind (fun arglist)
(if (and (sb-int:legal-fun-name-p fname) (fboundp fname))
(values (fdefinition fname) args)
(values (sb-di:debug-fun-fun (sb-di:frame-debug-fun frame))
(sb-debug::frame-args-as-list frame)))
(when (functionp fun)
(sb-debug:unwind-to-frame-and-call
frame
(lambda ()
;; Ensure TCO.
(declare (optimize (debug 0)))
(apply fun arglist)))))))
(format nil "Cannot restart frame: ~S" frame))))
;; FIXME: this implementation doesn't unwind the stack before
;; re-invoking the function, but it's better than no implementation at
;; all.
#-#.(swank/sbcl::sbcl-with-restart-frame)
(progn
(defun sb-debug-catch-tag-p (tag)
(and (symbolp tag)
(not (symbol-package tag))
(string= tag :sb-debug-catch-tag)))
(defimplementation return-from-frame (index form)
(let* ((frame (nth-frame index))
(probe (assoc-if #'sb-debug-catch-tag-p
(sb-di::frame-catches frame))))
(cond (probe (throw (car probe) (eval-in-frame form index)))
(t (format nil "Cannot return from frame: ~S" frame)))))
(defimplementation restart-frame (index)
(let ((frame (nth-frame index)))
(return-from-frame index (sb-debug::frame-call-as-list frame)))))
;;;;; reference-conditions
(defimplementation print-condition (condition stream)
(let ((sb-int:*print-condition-references* nil))
(princ condition stream)))
;;;; Profiling
(defimplementation profile (fname)
(when fname (eval `(sb-profile:profile ,fname))))
(defimplementation unprofile (fname)
(when fname (eval `(sb-profile:unprofile ,fname))))
(defimplementation unprofile-all ()
(sb-profile:unprofile)
"All functions unprofiled.")
(defimplementation profile-report ()
(sb-profile:report))
(defimplementation profile-reset ()
(sb-profile:reset)
"Reset profiling counters.")
(defimplementation profiled-functions ()
(sb-profile:profile))
(defimplementation profile-package (package callers methods)
(declare (ignore callers methods))
(eval `(sb-profile:profile ,(package-name (find-package package)))))
;;;; Inspector
(defmethod emacs-inspect ((o t))
(cond ((sb-di::indirect-value-cell-p o)
(label-value-line* (:value (sb-kernel:value-cell-ref o))))
(t
(multiple-value-bind (text label parts) (sb-impl::inspected-parts o)
(list* (string-right-trim '(#\Newline) text)
'(:newline)
(if label
(loop for (l . v) in parts
append (label-value-line l v))
(loop for value in parts
for i from 0
append (label-value-line i value))))))))
(defmethod emacs-inspect ((o function))
(cond ((sb-kernel:simple-fun-p o)
(label-value-line*
(:name (sb-kernel:%simple-fun-name o))
(:arglist (sb-kernel:%simple-fun-arglist o))
(:type (sb-kernel:%simple-fun-type o))
(:code (sb-kernel:fun-code-header o))))
((sb-kernel:closurep o)
(append
(label-value-line :function (sb-kernel:%closure-fun o))
`("Closed over values:" (:newline))
(loop for i below (1- (sb-kernel:get-closure-length o))
append (label-value-line
i (sb-kernel:%closure-index-ref o i)))))
(t (call-next-method o))))
(defmethod emacs-inspect ((o sb-kernel:code-component))
(append
(label-value-line*
(:code-size (sb-kernel:%code-code-size o))
(:debug-info (sb-kernel:%code-debug-info o)))
`("Constants:" (:newline))
(loop for i from sb-vm:code-constants-offset
below
(#.(swank/backend:choose-symbol 'sb-kernel 'code-header-words
'sb-kernel 'get-header-data)
o)
append (label-value-line i (sb-kernel:code-header-ref o i)))
`("Code:" (:newline)
,(with-output-to-string (s)
(sb-disassem:disassemble-code-component o :stream s)))))
(defmethod emacs-inspect ((o sb-ext:weak-pointer))
(label-value-line*
(:value (sb-ext:weak-pointer-value o))))
(defmethod emacs-inspect ((o sb-kernel:fdefn))
(label-value-line*
(:name (sb-kernel:fdefn-name o))
(:function (sb-kernel:fdefn-fun o))))
(defmethod emacs-inspect :around ((o generic-function))
(append
(call-next-method)
(label-value-line*
(:pretty-arglist (sb-pcl::generic-function-pretty-arglist o))
(:initial-methods (sb-pcl::generic-function-initial-methods o))
)))
;;;; Multiprocessing
#+(and sb-thread
#.(swank/backend:with-symbol "THREAD-NAME" "SB-THREAD"))
(progn
(defvar *thread-id-counter* 0)
(defvar *thread-id-counter-lock*
(sb-thread:make-mutex :name "thread id counter lock"))
(defun next-thread-id ()
(sb-thread:with-mutex (*thread-id-counter-lock*)
(incf *thread-id-counter*)))
(defparameter *thread-id-map* (make-hash-table))
;; This should be a thread -> id map but as weak keys are not
;; supported it is id -> map instead.
(defvar *thread-id-map-lock*
(sb-thread:make-mutex :name "thread id map lock"))
(defimplementation spawn (fn &key name)
(sb-thread:make-thread fn :name name))
(defimplementation thread-id (thread)
(block thread-id
(sb-thread:with-mutex (*thread-id-map-lock*)
(loop for id being the hash-key in *thread-id-map*
using (hash-value thread-pointer)
do
(let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
(cond ((null maybe-thread)
;; the value is gc'd, remove it manually
(remhash id *thread-id-map*))
((eq thread maybe-thread)
(return-from thread-id id)))))
;; lazy numbering
(let ((id (next-thread-id)))
(setf (gethash id *thread-id-map*) (sb-ext:make-weak-pointer thread))
id))))
(defimplementation find-thread (id)
(sb-thread:with-mutex (*thread-id-map-lock*)
(let ((thread-pointer (gethash id *thread-id-map*)))
(if thread-pointer
(let ((maybe-thread (sb-ext:weak-pointer-value thread-pointer)))
(if maybe-thread
maybe-thread
;; the value is gc'd, remove it manually
(progn
(remhash id *thread-id-map*)
nil)))
nil))))
(defimplementation thread-name (thread)
;; sometimes the name is not a string (e.g. NIL)
(princ-to-string (sb-thread:thread-name thread)))
(defimplementation thread-status (thread)
(if (sb-thread:thread-alive-p thread)
"Running"
"Stopped"))
(defimplementation make-lock (&key name)
(sb-thread:make-mutex :name name))
(defimplementation call-with-lock-held (lock function)
(declare (type function function))
(sb-thread:with-recursive-lock (lock) (funcall function)))
(defimplementation current-thread ()
sb-thread:*current-thread*)
(defimplementation all-threads ()
(sb-thread:list-all-threads))
(defimplementation interrupt-thread (thread fn)
(sb-thread:interrupt-thread thread fn))
(defimplementation kill-thread (thread)
(sb-thread:terminate-thread thread))
(defimplementation thread-alive-p (thread)
(sb-thread:thread-alive-p thread))
(defvar *mailbox-lock* (sb-thread:make-mutex :name "mailbox lock"))
(defvar *mailboxes* (list))
(declaim (type list *mailboxes*))
(defstruct (mailbox (:conc-name mailbox.))
thread
(mutex (sb-thread:make-mutex))
(waitqueue (sb-thread:make-waitqueue))
(queue '() :type list))
(defun mailbox (thread)
"Return THREAD's mailbox."
(sb-thread:with-mutex (*mailbox-lock*)
(or (find thread *mailboxes* :key #'mailbox.thread)
(let ((mb (make-mailbox :thread thread)))
(push mb *mailboxes*)
mb))))
(defimplementation wake-thread (thread)
(let* ((mbox (mailbox thread))
(mutex (mailbox.mutex mbox)))
(sb-thread:with-recursive-lock (mutex)
(sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
(defimplementation send (thread message)
(let* ((mbox (mailbox thread))
(mutex (mailbox.mutex mbox)))
(sb-thread:with-mutex (mutex)
(setf (mailbox.queue mbox)
(nconc (mailbox.queue mbox) (list message)))
(sb-thread:condition-broadcast (mailbox.waitqueue mbox)))))
(defimplementation receive-if (test &optional timeout)
(let* ((mbox (mailbox (current-thread)))
(mutex (mailbox.mutex mbox))
(waitq (mailbox.waitqueue mbox)))
(assert (or (not timeout) (eq timeout t)))
(loop
(check-slime-interrupts)
(sb-thread:with-mutex (mutex)
(let* ((q (mailbox.queue mbox))
(tail (member-if test q)))
(when tail
(setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
(return (car tail))))
(when (eq timeout t) (return (values nil t)))
(sb-thread:condition-wait waitq mutex)))))
(let ((alist '())
(mutex (sb-thread:make-mutex :name "register-thread")))
(defimplementation register-thread (name thread)
(declare (type symbol name))
(sb-thread:with-mutex (mutex)
(etypecase thread
(null
(setf alist (delete name alist :key #'car)))
(sb-thread:thread
(let ((probe (assoc name alist)))
(cond (probe (setf (cdr probe) thread))
(t (setf alist (acons name thread alist))))))))
nil)
(defimplementation find-registered (name)
(sb-thread:with-mutex (mutex)
(cdr (assoc name alist))))))
(defimplementation quit-lisp ()
#+#.(swank/backend:with-symbol 'exit 'sb-ext)
(sb-ext:exit)
#-#.(swank/backend:with-symbol 'exit 'sb-ext)
(progn
#+sb-thread
(dolist (thread (remove (current-thread) (all-threads)))
(ignore-errors (sb-thread:terminate-thread thread)))
(sb-ext:quit)))
;;Trace implementations
;;In SBCL, we have:
;; (trace <name>)
;; (trace :methods '<name>) ;to trace all methods of the gf <name>
;; (trace (method <name> <qualifier>? (<specializer>+)))
;; <name> can be a normal name or a (setf name)
(defun toggle-trace-aux (fspec &rest args)
(cond ((member fspec (eval '(trace)) :test #'equal)
(eval `(untrace ,fspec))
(format nil "~S is now untraced." fspec))
(t
(eval `(trace ,@(if args `(:encapsulate nil) (list)) ,fspec ,@args))
(format nil "~S is now traced." fspec))))
(defun process-fspec (fspec)
(cond ((consp fspec)
(ecase (first fspec)
((:defun :defgeneric) (second fspec))
((:defmethod) `(method ,@(rest fspec)))
((:labels) `(labels ,(process-fspec (second fspec)) ,(third fspec)))
((:flet) `(flet ,(process-fspec (second fspec)) ,(third fspec)))))
(t
fspec)))
(defimplementation toggle-trace (spec)
(ecase (car spec)
((setf)
(toggle-trace-aux spec))
((:defmethod)
(toggle-trace-aux `(sb-pcl::fast-method ,@(rest (process-fspec spec)))))
((:defgeneric)
(toggle-trace-aux (second spec) :methods t))
((:call)
(destructuring-bind (caller callee) (cdr spec)
(toggle-trace-aux callee :wherein (list (process-fspec caller)))))))
;;; Weak datastructures
(defimplementation make-weak-key-hash-table (&rest args)
#+#.(swank/sbcl::sbcl-with-weak-hash-tables)
(apply #'make-hash-table :weakness :key args)
#-#.(swank/sbcl::sbcl-with-weak-hash-tables)
(apply #'make-hash-table args))
(defimplementation make-weak-value-hash-table (&rest args)
#+#.(swank/sbcl::sbcl-with-weak-hash-tables)
(apply #'make-hash-table :weakness :value args)
#-#.(swank/sbcl::sbcl-with-weak-hash-tables)
(apply #'make-hash-table args))
(defimplementation hash-table-weakness (hashtable)
#+#.(swank/sbcl::sbcl-with-weak-hash-tables)
(sb-ext:hash-table-weakness hashtable))
;;; Floating point
(defimplementation float-nan-p (float)
(sb-ext:float-nan-p float))
(defimplementation float-infinity-p (float)
(sb-ext:float-infinity-p float))
#-win32
(defimplementation save-image (filename &optional restart-function)
(flet ((restart-sbcl ()
(sb-debug::enable-debugger)
(setf sb-impl::*descriptor-handlers* nil)
(funcall restart-function)))
(let ((pid (sb-posix:fork)))
(cond ((= pid 0)
(sb-debug::disable-debugger)
(apply #'sb-ext:save-lisp-and-die filename
(when restart-function
(list :toplevel #'restart-sbcl))))
(t
(multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
(assert (= pid rpid))
(assert (and (sb-posix:wifexited status)
(zerop (sb-posix:wexitstatus status))))))))))
#+unix
(progn
(sb-alien:define-alien-routine ("execv" sys-execv) sb-alien:int
(program sb-alien:c-string)
(argv (* sb-alien:c-string)))
(defun execv (program args)
"Replace current executable with another one."
(let ((a-args (sb-alien:make-alien sb-alien:c-string
(+ 1 (length args)))))
(unwind-protect
(progn
(loop for index from 0 by 1
and item in (append args '(nil))
do (setf (sb-alien:deref a-args index)
item))
(when (minusp
(sys-execv program a-args))
(error "execv(3) returned.")))
(sb-alien:free-alien a-args))))
(defun runtime-pathname ()
#+#.(swank/backend:with-symbol
'*runtime-pathname* 'sb-ext)
sb-ext:*runtime-pathname*
#-#.(swank/backend:with-symbol
'*runtime-pathname* 'sb-ext)
(car sb-ext:*posix-argv*))
(defimplementation exec-image (image-file args)
(loop with fd-arg =
(loop for arg in args
and key = "" then arg
when (string-equal key "--swank-fd")
return (parse-integer arg))
for my-fd from 3 to 1024
when (/= my-fd fd-arg)
do (ignore-errors (sb-posix:fcntl my-fd sb-posix:f-setfd 1)))
(let* ((self-string (pathname-to-filename (runtime-pathname))))
(execv
self-string
(apply 'list self-string "--core" image-file args)))))
(defimplementation make-fd-stream (fd external-format)
(sb-sys:make-fd-stream fd :input t :output t
:element-type 'character
:buffering :full
:dual-channel-p t
:external-format external-format))
#-win32
(defimplementation background-save-image (filename &key restart-function
completion-function)
(flet ((restart-sbcl ()
(sb-debug::enable-debugger)
(setf sb-impl::*descriptor-handlers* nil)
(funcall restart-function)))
(multiple-value-bind (pipe-in pipe-out) (sb-posix:pipe)
(let ((pid (sb-posix:fork)))
(cond ((= pid 0)
(sb-posix:close pipe-in)
(sb-debug::disable-debugger)
(apply #'sb-ext:save-lisp-and-die filename
(when restart-function
(list :toplevel #'restart-sbcl))))
(t
(sb-posix:close pipe-out)
(sb-sys:add-fd-handler
pipe-in :input
(lambda (fd)
(sb-sys:invalidate-descriptor fd)
(sb-posix:close fd)
(multiple-value-bind (rpid status) (sb-posix:waitpid pid 0)
(assert (= pid rpid))
(assert (sb-posix:wifexited status))
(funcall completion-function
(zerop (sb-posix:wexitstatus status))))))))))))
(pushnew 'deinit-log-output sb-ext:*save-hooks*)
;;;; wrap interface implementation
(defun sbcl-version>= (&rest subversions)
#+#.(swank/backend:with-symbol 'assert-version->= 'sb-ext)
(values (ignore-errors (apply #'sb-ext:assert-version->= subversions) t))
#-#.(swank/backend:with-symbol 'assert-version->= 'sb-ext)
nil)
(defimplementation wrap (spec indicator &key before after replace)
(when (wrapped-p spec indicator)
(warn "~a already wrapped with indicator ~a, unwrapping first"
spec indicator)
(sb-int:unencapsulate spec indicator))
(sb-int:encapsulate spec indicator
#-#.(swank/backend:with-symbol 'arg-list 'sb-int)
(lambda (function &rest args)
(sbcl-wrap spec before after replace function args))
#+#.(swank/backend:with-symbol 'arg-list 'sb-int)
(if (sbcl-version>= 1 1 16)
(lambda ()
(sbcl-wrap spec before after replace
(symbol-value 'sb-int:basic-definition)
(symbol-value 'sb-int:arg-list)))
`(sbcl-wrap ',spec ,before ,after ,replace
(symbol-value 'sb-int:basic-definition)
(symbol-value 'sb-int:arg-list)))))
(defimplementation unwrap (spec indicator)
(sb-int:unencapsulate spec indicator))
(defimplementation wrapped-p (spec indicator)
(sb-int:encapsulated-p spec indicator))
(defun sbcl-wrap (spec before after replace function args)
(declare (ignore spec))
(let (retlist completed)
(unwind-protect
(progn
(when before
(funcall before args))
(setq retlist (multiple-value-list (if replace
(funcall replace
args)
(apply function args))))
(setq completed t)
(values-list retlist))
(when after
(funcall after (if completed retlist :exited-non-locally))))))
#+#.(swank/backend:with-symbol 'comma-expr 'sb-impl)
(progn
(defmethod sexp-in-bounds-p ((s sb-impl::comma) i)
(sexp-in-bounds-p (sb-impl::comma-expr s) i))
(defmethod sexp-ref ((s sb-impl::comma) i)
(sexp-ref (sb-impl::comma-expr s) i)))